From 9587a8aa107c4ef34b6820f58c98db6ffe81b4c5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jens=20Axel=20S=C3=B8gaard?= Date: Tue, 21 Oct 2014 21:38:44 +0200 Subject: [PATCH] Added unported files --- .../check-valid-module-source.rkt | 135 +++ .../find-primitive-implemented.rkt | 51 ++ .../get-js-vm-implemented-primitives.rkt | 47 ++ .../selfhost/js-assembler/get-runtime.rkt | 110 +++ .../selfhost/js-assembler/hash-cache.rkt | 94 +++ .../js-assembler/module-knowledge.rkt | 19 + whalesong/selfhost/js-assembler/package.rkt | 788 ++++++++++++++++++ 7 files changed, 1244 insertions(+) create mode 100644 whalesong/selfhost/js-assembler/check-valid-module-source.rkt create mode 100644 whalesong/selfhost/js-assembler/find-primitive-implemented.rkt create mode 100644 whalesong/selfhost/js-assembler/get-js-vm-implemented-primitives.rkt create mode 100644 whalesong/selfhost/js-assembler/get-runtime.rkt create mode 100644 whalesong/selfhost/js-assembler/hash-cache.rkt create mode 100644 whalesong/selfhost/js-assembler/module-knowledge.rkt create mode 100644 whalesong/selfhost/js-assembler/package.rkt diff --git a/whalesong/selfhost/js-assembler/check-valid-module-source.rkt b/whalesong/selfhost/js-assembler/check-valid-module-source.rkt new file mode 100644 index 0000000..b5480e4 --- /dev/null +++ b/whalesong/selfhost/js-assembler/check-valid-module-source.rkt @@ -0,0 +1,135 @@ +#lang racket/base + +(provide check-valid-module-source + [struct-out exn:invalid-module-source]) + +(require syntax/kerncase + syntax/modresolve + racket/path + "../parameters.rkt" + "../parser/path-rewriter.rkt") + + +(struct exn:invalid-module-source exn:fail ()) + + +(define (abort-abort #:reason (reason "Invalid module source")) + (fprintf (current-report-port) "Aborting compilation.\n") + (raise (exn:invalid-module-source reason + (current-continuation-marks)))) + + +(define ns (make-base-namespace)) + + + + +(define (looks-like-old-moby-or-js-vm? module-source-path) + (or (call-with-input-file* module-source-path + (lambda (ip) (regexp-match #px"^\\s*#lang\\s+planet\\s+dyoo/moby" ip))) + (call-with-input-file* module-source-path + (lambda (ip) (regexp-match #px"^\\s*#lang\\s+planet\\s+dyoo/js-vm" ip))))) + + + + +(define (check-valid-module-source module-source-path) + ;; Check that the file exists. + (unless (file-exists? module-source-path) + (fprintf (current-report-port) "ERROR: Can't read a Racket module from ~e. The file does not appear to exist.\n" + module-source-path) + (abort-abort)) + + + ;; Is the file one that we know how to symbolically resolve? + (cond [(rewrite-path module-source-path) + (void)] + [else + (fprintf (current-report-port) + "ERROR: The file ~e appears to be outside the root package directory ~e. You may need to use --root-dir.\n" + module-source-path + (current-root-path)) + (abort-abort)]) + + + ;; Does it look like something out of moby or js-vm? Abort early, because if we don't do + ;; this up front, Racket will try to install the deprecated module, and that's bad. + (when (looks-like-old-moby-or-js-vm? module-source-path) + (fprintf (current-report-port) "ERROR: The program in ~e appears to be written using the deprecated project js-vm or Moby.\n\nPlease change the lang line to:\n\n #lang whalesong\n\ninstead.\n" + module-source-path) + (abort-abort)) + + + ;; Check that it looks like a module. + (define stx + (with-handlers ([exn:fail? + (lambda (exn) + ;; We can't even get the bytecode for the file. + ;; Fail immediately. + (fprintf (current-report-port) "ERROR: Can't read a Racket module from ~e. The file may be ill-formed or be written in a language that Whalesong doesn't recognize.\n" + module-source-path) + (fprintf (current-report-port) "\nFor reference, the error message produced when trying to read ~e is:\n\n" module-source-path) + (fprintf (current-report-port) "~a\n" (exn-message exn)) + (abort-abort))]) + (parameterize ([read-accept-reader #t] + [read-accept-lang #t]) + (call-with-input-file* module-source-path + (lambda (ip) + (port-count-lines! ip) + (read-syntax module-source-path ip)))))) + + (define relative-language-stx + (kernel-syntax-case stx #t + [(module name language body ...) + #'language] + [else + (fprintf (current-report-port) "ERROR: Can't read a Racket module from ~e. The file exists, but does not appear to be a Racket module.\n" + module-source-path) + (abort-abort)])) + + + ;; Check that the module is written in a language that we allow. + (define resolved-language-path + (resolve-module-path (syntax->datum relative-language-stx) + module-source-path)) + (cond + [(eq? resolved-language-path '#%kernel) + (void)] + [(path? resolved-language-path) + (define normalized-resolved-language-path + (normalize-path resolved-language-path)) + + (cond + [(within-root-path? normalized-resolved-language-path) + (void)] + + [(within-whalesong-path? normalized-resolved-language-path) + (void)] + + [else + ;; Something bad is about to happen, as the module is written + ;; in a language that we, most likely, can't compile. + ;; + ;; Let's see if we can provide a good error message here + (fprintf (current-report-port) "ERROR: The file ~e is a Racket module, but is written in the language ~a [~e], which Whalesong does not know how to compile.\n" + module-source-path + (syntax->datum relative-language-stx) + normalized-resolved-language-path) + (abort-abort)])]) + + + ;; Once we know that the module is in a language we allow, we + ;; check that the file compiles. + (with-handlers ([exn:fail? + (lambda (exn) + (fprintf (current-report-port) "ERROR: the racket module ~e raises a compile-time error during compilation." module-source-path) + (fprintf (current-report-port) "\n\nFor reference, the error message produced during compilation is the following:\n\n") + (fprintf (current-report-port) "~a\n" (exn-message exn)) + (newline (current-report-port)) + (abort-abort))]) + (parameterize ([current-namespace ns] + [current-load-relative-directory + (path-only module-source-path)] + [current-directory + (path-only module-source-path)]) + (compile stx)))) diff --git a/whalesong/selfhost/js-assembler/find-primitive-implemented.rkt b/whalesong/selfhost/js-assembler/find-primitive-implemented.rkt new file mode 100644 index 0000000..aeb8d28 --- /dev/null +++ b/whalesong/selfhost/js-assembler/find-primitive-implemented.rkt @@ -0,0 +1,51 @@ +#lang racket/base + +(require racket/runtime-path + racket/list + (for-syntax racket/base) + "../compiler/arity-structs.rkt") + +;; Provides a list of symbols of the function implemented primitively. Knowing +;; this allows us to do certain procedure applications more efficiently without +;; touching the stack so much. +(provide primitive-ids) + +(define a-regexp + #px"installPrimitiveProcedure\\s*\\(\\s*['\"]([^'\"]+)['\"]\\s*,\\s*([^\n]+)\n") + +(define-runtime-path baselib-primitives.js + (build-path "runtime-src" "baselib-primitives.js")) + +(define ip (open-input-file baselib-primitives.js)) + +(define (parse-arity-string s) + (define arity + (let loop ([s s]) + (let ([s (regexp-replace #px",\\s+$" s "")]) + (cond + [(regexp-match #px"^(\\d+)" s) + => + (lambda (m) (string->number (second m)))] + [(regexp-match #px"^makeList\\((.+)\\)" s) + => + (lambda (m) + (map string->number (regexp-split #px"\\s*,\\s*" (second m))))] + [(regexp-match #px"^baselib.arity.makeArityAtLeast\\((\\d+)\\)" s) + => + (lambda (m) + (ArityAtLeast (string->number (second m))))] + [else + (error 'parse-arity-string "How to parse? ~e" s)])))) + arity) + +(define primitive-ids + (let loop () + (let ([a-match (regexp-match a-regexp ip)]) + (cond + [a-match => (lambda (a-match) + (define name (second a-match)) + (define arity-string (bytes->string/utf-8 (third a-match))) + (define arity (parse-arity-string arity-string)) + (cons (cons (string->symbol (bytes->string/utf-8 name)) arity) + (loop)))] + [else empty])))) \ No newline at end of file diff --git a/whalesong/selfhost/js-assembler/get-js-vm-implemented-primitives.rkt b/whalesong/selfhost/js-assembler/get-js-vm-implemented-primitives.rkt new file mode 100644 index 0000000..7f13fbe --- /dev/null +++ b/whalesong/selfhost/js-assembler/get-js-vm-implemented-primitives.rkt @@ -0,0 +1,47 @@ +#lang racket/base + +(require racket/runtime-path + racket/file + racket/contract + racket/list) +;; Get the list of primitives implemented in js-vm-primitives.js + +;; (define-runtime-path js-vm-primitives.js "runtime-src/js-vm-primitives.js") + +(define-runtime-path whalesong-primitives.js "runtime-src/baselib-primitives.js") + +;; sort&unique: (listof string) -> (listof string) +(define (sort&unique names) + (let ([ht (make-hash)]) + (for ([name names]) + (hash-set! ht name #t)) + (sort (for/list ([name (in-hash-keys ht)]) + name) + stringsymbol +;; (sort&unique +;; (map (lambda (a-str) +;; (substring a-str +;; (string-length "PRIMITIVES['") +;; (- (string-length a-str) (string-length "']")))) +;; (let ([contents (file->string js-vm-primitives.js)]) +;; (regexp-match* #px"PRIMITIVES\\[('|\")[^\\]]*('|\")\\]" contents)))))) + + + +(define whalesong-primitive-names + (map string->symbol + (sort&unique + (map (lambda (a-str) + (let ([match (regexp-match + #px"installPrimitiveProcedure\\(\\s+('|\")([^\\]]*)('|\")" a-str)]) + (third match))) + (let ([contents (file->string whalesong-primitives.js)]) + (regexp-match* #px"installPrimitiveProcedure\\(\\s+('|\")[^\\']*('|\")" contents)))))) + + +(provide/contract ;[js-vm-primitive-names (listof symbol?)] + [whalesong-primitive-names (listof symbol?)]) \ No newline at end of file diff --git a/whalesong/selfhost/js-assembler/get-runtime.rkt b/whalesong/selfhost/js-assembler/get-runtime.rkt new file mode 100644 index 0000000..5296573 --- /dev/null +++ b/whalesong/selfhost/js-assembler/get-runtime.rkt @@ -0,0 +1,110 @@ +#lang racket/base + +;; Function to get the runtime library. +;; +;; The resulting Javascript will produce a file that loads: +;; +;; +;; jquery at the the toplevel +;; HashTable at the toplevel +;; jsnums at the toplevel +;; +;; followed by the base library +;; + + + +(require racket/contract + racket/runtime-path + racket/port) + + + +(provide/contract [get-runtime (-> string?)]) + + +(define-runtime-path base-path "runtime-src") + + +;; The order matters here. link needs to come near the top, because +;; the other modules below have some circular dependencies that are resolved +;; by link. +(define files '( + top.js + + ;; jquery is special: we need to make sure it's resilient against + ;; multiple invokation and inclusion. + jquery-protect-header.js + jquery.js + jquery-protect-footer.js + + js-numbers.js + base64.js + + baselib.js + baselib-dict.js + baselib-frames.js + + baselib-loadscript.js + + baselib-unionfind.js + baselib-equality.js + baselib-format.js + + baselib-constants.js + baselib-numbers.js + baselib-lists.js + baselib-vectors.js + baselib-chars.js + baselib-symbols.js + baselib-paramz.js + baselib-strings.js + baselib-bytes.js + + hashes-header.js + jshashtable-2.1_src.js + llrbtree.js + baselib-hashes.js + hashes-footer.js + + + baselib-regexps.js + baselib-paths.js + baselib-boxes.js + baselib-placeholders.js + baselib-keywords.js + baselib-structs.js + baselib-srclocs.js + baselib-ports.js + baselib-functions.js + baselib-modules.js + baselib-contmarks.js + + baselib-arity.js + baselib-inspectors.js + baselib-exceptions.js + baselib-readergraph.js + + ;; baselib-check has to come after the definitions of types, + ;; since it uses the type predicates immediately on init time. + baselib-check.js + + baselib-primitives.js + runtime.js)) + + + +(define (path->string p) + (call-with-input-file p + (lambda (ip) + (port->string ip)))) + + +(define text (apply string-append + (map (lambda (n) + (path->string + (build-path base-path (symbol->string n)))) + files))) + +(define (get-runtime) + text) diff --git a/whalesong/selfhost/js-assembler/hash-cache.rkt b/whalesong/selfhost/js-assembler/hash-cache.rkt new file mode 100644 index 0000000..663e832 --- /dev/null +++ b/whalesong/selfhost/js-assembler/hash-cache.rkt @@ -0,0 +1,94 @@ +#lang racket/base + +;; on-disk hashtable cache. + +(require (prefix-in whalesong: "../version.rkt") + racket/runtime-path + racket/file + file/md5) + + +(define cache-directory-path + (build-path (find-system-path 'pref-dir) + "whalesong")) + +(provide cached? save-in-cache!) + + +;; create-cache-directory!: -> void +(define (create-cache-directory!) + (unless (directory-exists? cache-directory-path) + (make-directory* cache-directory-path))) + + +;; clear-cache-files!: -> void +;; Remove all the cache files. +(define (clear-cache-files!) + (for ([file (directory-list cache-directory-path)]) + (when (file-exists? (build-path cache-directory-path file)) + (with-handlers ([exn:fail? void]) + (delete-file (build-path cache-directory-path file)))))) + + +(define whalesong-cache.scm + (build-path cache-directory-path + (format "whalesong-cache-~a.scm" + whalesong:version))) + + +(define (ensure-cache-db-structure!) + (when (not (file-exists? whalesong-cache.scm)) + ;; Clear existing cache files: they're obsolete. + (clear-cache-files!) + (call-with-output-file whalesong-cache.scm + (lambda (op) + (write (make-hash) op))))) + + + +(define (get-db) + (hash-copy (call-with-input-file whalesong-cache.scm read))) + + +(define (write-db! hash) + (call-with-output-file whalesong-cache.scm + (lambda (op) (write hash op)) + #:exists 'replace)) + + + + +(create-cache-directory!) +(ensure-cache-db-structure!) +(define db (get-db)) + + + + +;; cached?: path -> (U false bytes) +;; Returns a true value, (vector path md5-signature data), if we can +;; find an appropriate entry in the cache, and false otherwise. +(define (cached? path) + (cond + [(file-exists? path) + (hash-ref db + (list (path->string path) + (call-with-input-file* path md5)) + #f)] + [else + #f])) + + +;; save-in-cache!: path bytes -> void +;; Saves a record. +(define (save-in-cache! path data) + (cond + [(file-exists? path) + (define signature (call-with-input-file* path md5)) + (hash-set! db + (list (path->string path) + signature) + data) + (write-db! db)] + [else + (error 'save-in-cache! "File ~e does not exist" path)])) \ No newline at end of file diff --git a/whalesong/selfhost/js-assembler/module-knowledge.rkt b/whalesong/selfhost/js-assembler/module-knowledge.rkt new file mode 100644 index 0000000..9a93c87 --- /dev/null +++ b/whalesong/selfhost/js-assembler/module-knowledge.rkt @@ -0,0 +1,19 @@ +#lang racket/base + +;; Provides a mapping of the core bindings in kernel, so that we know statically +;; if something is implemented as a primitive or a closure. +(require syntax/modresolve) + +(provide bound-procedure-names) + + +(define ns (make-base-empty-namespace)) +(define bound-procedure-names + (let ([path (resolve-module-path 'whalesong/lang/kernel #f)]) + (parameterize ([current-namespace ns]) + (namespace-require path) + (for/list ([name (namespace-mapped-symbols)] + #:when (namespace-variable-value name #t (lambda () #f))) + name)))) + + diff --git a/whalesong/selfhost/js-assembler/package.rkt b/whalesong/selfhost/js-assembler/package.rkt new file mode 100644 index 0000000..a4c564f --- /dev/null +++ b/whalesong/selfhost/js-assembler/package.rkt @@ -0,0 +1,788 @@ +#lang racket/base + +(require "assemble.rkt" + "quote-cdata.rkt" + "../logger.rkt" + "../make/make.rkt" + "../make/make-structs.rkt" + "../parameters.rkt" + "../compiler/expression-structs.rkt" + "../parser/path-rewriter.rkt" + "../parser/parse-bytecode.rkt" + "../parser/modprovide.rkt" + "../resource/structs.rkt" + "../promise.rkt" + "check-valid-module-source.rkt" + "find-primitive-implemented.rkt" + (prefix-in hash-cache: "hash-cache.rkt") + racket/match + racket/list + racket/promise + racket/set + racket/path + racket/string + racket/port + syntax/modread + syntax/kerncase + syntax/modresolve + (prefix-in query: "../lang/js/query.rkt") + (prefix-in resource-query: "../resource/query.rkt") + (prefix-in runtime: "get-runtime.rkt") + (prefix-in racket: racket/base) + racket/runtime-path + json) + + + +;; There is a dynamic require for (planet dyoo/closure-compile) that's done +;; if compression is turned on. + + +;; TODO: put proper contracts here + + +(provide package + package-anonymous + package-standalone-xhtml + get-inert-code + get-standalone-code + write-standalone-code + get-runtime + write-runtime + current-on-resource + get-html-template) + + + +;; notify: string (listof any)* -> void +;; Print out log message during the build process. +(define (notify msg . args) + (displayln (apply format msg args))) + + + +(define primitive-identifiers-ht + (make-hash primitive-ids)) + +;; Sets up the compiler parameters we need to do javascript-specific compilation. +(define (with-compiler-params thunk) + (parameterize ([compile-context-preservation-enabled #t] + [current-primitive-identifier? + (lambda (a-name) + (hash-ref primitive-identifiers-ht a-name #f))]) + (thunk))) + + + + +(define current-on-resource + (make-parameter (lambda (r) + (log-debug "Resource ~s should be written" + (resource-path r)) + (void)))) + + +(define-struct cached-entry (real-path ;; path to a module. + whalesong-version ;; string + md5 ;; md5 of the original source in real-path + bytes) + #:transparent) ;; bytes + + + + +(define-struct js-impl (name ;; symbol + real-path ;; path + src ;; string + ) + #:transparent) + + +;; Packager: produce single .js files to be included to execute a +;; program. + + + +(define (package-anonymous source-code + #:should-follow-children? should-follow? + #:output-port op) + (fprintf op "(function() {\n") + (package source-code + #:should-follow-children? should-follow? + #:output-port op) + (fprintf op " return invoke; })\n")) + + + +;; check-valid-source: Source -> void +;; Check to see if the file, if a module, is a valid module file. +(define (check-valid-source src) + (cond + [(StatementsSource? src) + (void)] + [(MainModuleSource? src) + (check-valid-module-source (MainModuleSource-path src))] + [(ModuleSource? src) + (check-valid-module-source (ModuleSource-path src))] + [(SexpSource? src) + (void)] + [(UninterpretedSource? src) + (void)])) + + + +;; source-is-javascript-module?: Source -> boolean +;; Returns true if the source looks like a Javascript-implemented module. +(define (source-is-javascript-module? src) + (cond + [(StatementsSource? src) + #f] + [(MainModuleSource? src) + (query:has-javascript-implementation? + `(file ,(path->string (MainModuleSource-path src))))] + [(ModuleSource? src) + (query:has-javascript-implementation? + `(file ,(path->string (ModuleSource-path src))))] + [(SexpSource? src) + #f] + [(UninterpretedSource? src) + #f])) + +(define (source-resources src) + (cond + [(StatementsSource? src) + empty] + [(MainModuleSource? src) + (resource-query:query + `(file ,(path->string (MainModuleSource-path src))))] + [(ModuleSource? src) + (resource-query:query + `(file ,(path->string (ModuleSource-path src))))] + [(SexpSource? src) + empty] + [(UninterpretedSource? src) + empty])) + + + +;; get-javascript-implementation: source -> UninterpretedSource +(define (get-javascript-implementation src) + + (define (get-provided-name-code bytecode) + (apply string-append + (for/list ([modprovide (get-provided-names bytecode)] + [i (in-naturals)]) + (string-append + (format "ns.set(~s,exports[~s]);\n" + (symbol->string (ModuleProvide-internal-name modprovide)) + (symbol->string (ModuleProvide-external-name modprovide))) + (format "extNs.set(~s,exports[~s]);\n" + (symbol->string (ModuleProvide-external-name modprovide)) + (symbol->string (ModuleProvide-external-name modprovide))) + (format "modrec.prefix[~a]=exports[~s];\n" + i + (symbol->string (ModuleProvide-external-name modprovide))))))) + + (define (get-prefix-code bytecode) + (format "modrec.prefix=[~a];modrec.prefix.names=[~a];modrec.prefix.internalNames=[~a];" + (string-join (map (lambda (n) "void(0)") + (get-provided-names bytecode)) + ",") + (string-join (map (lambda (n) + (format "~s" (symbol->string + (ModuleProvide-internal-name n)))) + (get-provided-names bytecode)) + ",") + (string-join (map (lambda (n) + (format "~s" (symbol->string + (ModuleProvide-external-name n)))) + (get-provided-names bytecode)) + ","))) + + (define (get-implementation-from-path path) + (let* ([name (rewrite-path path)] + [paths (query:query `(file ,(path->string path)))] + [text (string-join + (map (lambda (p) + (call-with-input-file p port->string)) + paths) + "\n")] + [module-requires (query:lookup-module-requires path)] + [bytecode (parse-bytecode path)]) + (when (not (empty? module-requires)) + (log-debug "~a requires ~a" + path + module-requires)) + (let ([module-body-text + (format " + if(--M.cbt<0) { throw arguments.callee; } + var modrec = M.modules[~s]; + var ns = modrec.getExports(); + var extNs = modrec.getExternalExports(); + ~a + var exports = {}; + modrec.isInvoked = true; + (function(MACHINE, EXPORTS){~a})(M, exports); + ~a + modrec.privateExports = exports; + return M.c.pop().label(M);" + (symbol->string name) + (get-prefix-code bytecode) + text + (get-provided-name-code bytecode))]) + + (make-UninterpretedSource + path + (format " +M.installedModules[~s] = function() { + return new plt.runtime.ModuleRecord(~s, + function(M) { + ~a + }); + } +" + (symbol->string name) + (symbol->string name) + (assemble-modinvokes+body module-requires module-body-text)) + + (map (lambda (p) (make-ModuleSource (normalize-path p))) + module-requires))))) + + + + (cond + [(StatementsSource? src) + (error 'get-javascript-implementation src)] + [(MainModuleSource? src) + (get-implementation-from-path (MainModuleSource-path src))] + [(ModuleSource? src) + (get-implementation-from-path (ModuleSource-path src))] + + + [(SexpSource? src) + (error 'get-javascript-implementation)] + [(UninterpretedSource? src) + (error 'get-javascript-implementation)])) + + + +;; source-module-name: source -> (U symbol #f) +;; Given a source, return its module name if it's a module. +;; If not, return #f. +(define (source-module-name src) + (cond + [(StatementsSource? src) + #f] + [(MainModuleSource? src) + (rewrite-path (MainModuleSource-path src))] + [(ModuleSource? src) + (rewrite-path (ModuleSource-path src))] + [(SexpSource? src) + #f] + [(UninterpretedSource? src) + (rewrite-path (UninterpretedSource-path src))])) + + + +(define (assemble-modinvokes+body paths after) + (cond + [(empty? paths) + after] + [(empty? (rest paths)) + (assemble-modinvoke (first paths) after)] + [else + (assemble-modinvoke (first paths) + (assemble-modinvokes+body (rest paths) after))])) + + +(define (assemble-modinvoke path after) + (let ([name (rewrite-path (path->string path))] + [afterName (gensym 'afterName)]) + (format " + var ~a = function() { ~a }; + plt.runtime.PAUSE(function(restart) { + var modName = ~s; + plt.runtime.currentModuleLoader(M, + modName, + function() { + restart(function(M) { + M.modules[modName] = M.installedModules[modName](); + if (! M.modules[modName].isInvoked) { + M.modules[modName].internalInvoke(M, + ~a, + M.params.currentErrorHandler); + } else { + ~a(); + } + }) + }, + function() { + alert('Could not load ' + modName); + }) + }); " + afterName + after + (symbol->string name) + afterName + afterName))) + + + + +;; package: Source (path -> boolean) output-port -> void + +;; Compile package for the given source program. +;; +;; should-follow-children? indicates whether we should continue +;; following module paths of a source's dependencies. +;; +;; The generated output defines a function called 'invoke' with +;; four arguments (M, SUCCESS, FAIL, PARAMS). When called, it will +;; execute the code to either run standalone expressions or +;; load in modules. +(define (package source-code + #:should-follow-children? should-follow? + #:output-port op + #:next-file-path (next-file-path (lambda (module-name) (error 'package)))) + (define resources (set)) + + + ;; wrap-source: source -> source + ;; Translate all JavaScript-implemented sources into uninterpreted sources; + ;; we'll leave its interpretation to on-visit-src. + (define (wrap-source src) + (log-debug "Checking valid source") + (check-valid-source src) + + (log-debug "Checking if the source has a JavaScript implementation") + (cond + [(source-is-javascript-module? src) + (log-debug "Replacing implementation with JavaScript one.") + (get-javascript-implementation src)] + [else + src])) + + + ;; maybe-with-fresh-file: source (-> any) -> any + ;; Call thunk, perhaps in the dynamic extent where op is a new file. + (define (maybe-with-fresh-file src thunk) + (cond + [(current-one-module-per-file?) + (define old-port op) + (define temp-string (open-output-string)) + (set! op temp-string) + (thunk) + (set! op old-port) + (define fresh-name (next-file-path (source-module-name src))) + (call-with-output-file fresh-name + (lambda (op) + (display (compress (get-output-string temp-string)) op)) + #:exists 'replace)] + [else + (thunk)])) + + + (define (on-visit-src src ast stmts) + ;; Record the use of resources on source module visitation... + (set! resources (set-union resources (list->set (source-resources src)))) + + (maybe-with-fresh-file + src + (lambda () + (fprintf op "\n// ** Visiting ~a\n" (source-name src)) + (define start-time (current-inexact-milliseconds)) + (cond + [(UninterpretedSource? src) + (fprintf op "(function(M) {\n\"use strict\";\n ~a }(plt.runtime.currentMachine));" (UninterpretedSource-datum src))] + [else + (fprintf op "(") + (on-source src stmts op) + (fprintf op ")(plt.runtime.currentMachine, + function() { + if (window.console && window.console.log) { + window.console.log('loaded ' + ~s); + } + }, + function(M, err) { + if (window.console && window.console.log) { + window.console.log('error: unable to load ' + ~s); + if (err && err.stack) { console.log(err.stack); } + } + }, + {});" + (format "~a" (source-name src)) + (format "~a" (source-name src))) + (define stop-time (current-inexact-milliseconds)) + (fprintf (current-timing-port) " assembly: ~s milliseconds\n" (- stop-time start-time)) + (void)])))) + + + (define (after-visit-src src) + (void)) + + + (define (on-last-src) + (void)) + + + + (define packaging-configuration + (make-Configuration + wrap-source + + should-follow? + + ;; on + on-visit-src + + ;; after + after-visit-src + + ;; last + on-last-src)) + + (with-compiler-params + (lambda () (make (list source-code) packaging-configuration))) + + (for ([r resources]) + ((current-on-resource) r))) + + + +;; on-source: Source (Promise (Listof Statement)) OutputPort -> void +;; Generates the source for the statements here. +;; Optimization: if we've seen this source before, we may be able to pull +;; it from the cache. +(define (on-source src stmts op) + (define (on-path path) + (cond + [(current-with-cache?) + (cond + [(cached? path) + => + (lambda (bytes) + (display bytes op))] + [(cacheable? path) + (define string-op (open-output-bytes)) + (assemble/write-invoke (my-force stmts) string-op 'no-trampoline) + (save-in-cache! path (get-output-bytes string-op)) + (display (get-output-string string-op) op)] + [else + (assemble/write-invoke (my-force stmts) op 'no-trampoline)])] + [else + (assemble/write-invoke (my-force stmts) op 'no-trampoline)])) + (cond + [(ModuleSource? src) + (on-path (ModuleSource-path src))] + [(MainModuleSource? src) + (on-path (MainModuleSource-path src))] + [else + (assemble/write-invoke (my-force stmts) op 'without-preemption)])) + + +;; cached?: path -> (U false bytes) +;; Returns a true value (the cached bytes) if we've seen this path +;; and know its JavaScript-compiled bytes. +(define (cached? path) + (hash-cache:cached? path)) + + + +;; cacheable?: path -> boolean +;; Produces true if the file should be cached. +;; At the current time, only cache modules that are provided +;; by whalesong itself. +(define (cacheable? path) + (within-whalesong-path? path)) + + +;; save-in-cache!: path bytes -> void +;; Saves the bytes in the cache, associated with that path. +;; TODO: Needs to sign with the internal version of Whalesong, and +;; the md5sum of the path's content. +(define (save-in-cache! path bytes) + (hash-cache:save-in-cache! path bytes)) + + + + +;; package-standalone-xhtml: X output-port -> void +(define (package-standalone-xhtml source-code op) + (display (get-header) op) + (display (quote-cdata + (string-append (get-runtime) + (get-inert-code source-code + (lambda () (error 'package-standalone-xhtml))) + invoke-main-module-code)) op) + (display *footer* op)) + + + +;; write-runtime: output-port -> void +(define (write-runtime op) + + (define (wrap-source src) src) + (let ([packaging-configuration + (make-Configuration + + wrap-source + + ;; should-follow-children? + (lambda (src) #t) + ;; on + (lambda (src ast stmts) + (on-source src stmts op) + (fprintf op "(M, function() { ")) + + ;; after + (lambda (src) + (fprintf op " }, FAIL, PARAMS);")) + + ;; last + (lambda () + (fprintf op "SUCCESS();")))]) + + (display (runtime:get-runtime) op) + + (newline op) + (fprintf op "(function(M, SUCCESS, FAIL, PARAMS) {") + (with-compiler-params + (lambda () + (make (list (my-force only-bootstrapped-code)) packaging-configuration))) + (fprintf op "})(plt.runtime.currentMachine,\nfunction(){ plt.runtime.setReadyTrue(); },\nfunction(){},\n{});\n"))) + + +(define closure-compile-ns (make-base-namespace)) +(define (compress x) + (cond [(current-compress-javascript?) + (log-debug "compressing javascript...") + (parameterize ([current-namespace closure-compile-ns]) + (define closure-compile (dynamic-require '(planet dyoo/closure-compile) 'closure-compile)) + (closure-compile x))] + [else + (log-debug "not compressing javascript...") + x])) + + + +(define *the-runtime* + (delay (let ([buffer (open-output-string)]) + (write-runtime buffer) + (compress + (get-output-string buffer))))) + + +;; get-runtime: -> string +(define (get-runtime) + (force *the-runtime*)) + + +(define (append-text-files paths) + (string-join (map (λ (p) (if (file-exists? p) + (bytes->string/utf-8 (call-with-input-file p port->bytes)) + "")) + paths) + "\n")) + + + +;; get-header : -> string +(define (get-header) + (format + #< + + + + + + ~a + + + + + + + +EOF + (if manifest (format "manifest=~s" (path->string manifest)) "") + (if with-legacy-ie-support? + "" + "") + title + (append-text-files (current-header-scripts)) + (string-join (map (lambda (js) + (format " \n" js)) + js-files) + "") + (jsexpr->string module-mappings) + invoke-main-module-code)) + + +;; get-inert-code: source (-> path) -> string +(define (get-inert-code source-code next-file-path) + (let ([buffer (open-output-string)]) + (package source-code + #:should-follow-children? (lambda (src) #t) + #:output-port buffer + #:next-file-path next-file-path) + (compress + (get-output-string buffer)))) + + + +;; get-standalone-code: source -> string +(define (get-standalone-code source-code) + (let ([buffer (open-output-string)]) + (write-standalone-code source-code buffer) + (compress + (get-output-string buffer)))) + + +;; write-standalone-code: source output-port -> void +(define (write-standalone-code source-code op) + (package source-code + #:should-follow-children? (lambda (src) #t) + #:output-port op)) + + + + + + +(define invoke-main-module-code + #<').css('color', 'red'); + subcontextDiv.append("Stacktrace:\n"); + if (contMarkSet) { + context = contMarkSet.getContext(M); + for (i = 0; i < context.length; i++) { + if (plt.runtime.isVector(context[i])) { + $('
').text('at ' + context[i].elts[0] + + ', line ' + context[i].elts[2] + + ', column ' + context[i].elts[3]) + .addClass('stacktrace') + .css('margin-left', '10px') + .css('whitespace', 'pre') + .appendTo(subcontextDiv); + } else if (plt.runtime.isProcedure(context[i])) { + if (context[i].displayName) { + $('
').text('in ' + context[i].displayName) + .addClass('stacktrace') + .css('margin-left', '10px') + .css('whitespace', 'pre') + .appendTo(subcontextDiv); + } + } + } + } + contextDiv.append(subcontextDiv); + M.params.currentErrorDisplayer(M, contextDiv); + }; + + + // On main module invokation failure + if (window.console && window.console.log) { + window.console.log(e.stack || e); + } + + M.params.currentErrorDisplayer( + M, $(plt.baselib.format.toDomNode(e.stack || e)).css('color', 'red')); + + if (Object.hasOwnProperty.call(e,'racketError') && + plt.baselib.exceptions.isExn(e.racketError)) { + contMarkSet = plt.baselib.exceptions.exnContMarks(e.racketError); + contextDiv = $('
'); + + if (e.racketError.structType && + plt.baselib.structs.supportsStructureTypeProperty( + e.racketError.structType, + plt.baselib.structs.propExnSrcloc)) { + srclocProcedure = plt.baselib.functions.asJavaScriptFunction( + plt.baselib.structs.lookupStructureTypeProperty( + e.racketError.structType, + plt.baselib.structs.propExnSrcloc), + M); + srclocProcedure(function(v) { + if (plt.baselib.lists.isList(v)) { + while(v !== plt.baselib.lists.EMPTY) { + if (plt.baselib.srclocs.isSrcloc(v.first)) { + $('
').text('at ' + plt.baselib.srclocs.srclocSource(v.first) + + ', line ' + plt.baselib.srclocs.srclocLine(v.first) + + ', column ' + plt.baselib.srclocs.srclocColumn(v.first)) + .addClass('srcloc') + .css('margin-left', '10px') + .css('whitespace', 'pre') + .css('color', 'red') + .appendTo(contextDiv); + } + v = v.rest; + } + } + displayContext(); + }, + function(err) { + displayContext(); + }, + e.racketError); + } else { + displayContext(); + } + } + }); +}; + $(document).ready(invokeMainModule); +EOF + ) + +(define *footer* + #< + + +EOF + )