Added unported files
This commit is contained in:
Jens Axel Søgaard
parent
f6ca5855e1
commit
9587a8aa10
135
whalesong/selfhost/js-assembler/check-valid-module-source.rkt
Normal file
135
whalesong/selfhost/js-assembler/check-valid-module-source.rkt
Normal file
|
|
@ -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))))
|
||||
|
|
@ -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]))))
|
||||
|
|
@ -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)
|
||||
string<?)))
|
||||
|
||||
;; ;; primitive-names: (listof symbol)
|
||||
;; (define js-vm-primitive-names
|
||||
;; (map string->symbol
|
||||
;; (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?)])
|
||||
110
whalesong/selfhost/js-assembler/get-runtime.rkt
Normal file
110
whalesong/selfhost/js-assembler/get-runtime.rkt
Normal file
|
|
@ -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)
|
||||
94
whalesong/selfhost/js-assembler/hash-cache.rkt
Normal file
94
whalesong/selfhost/js-assembler/hash-cache.rkt
Normal file
|
|
@ -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)]))
|
||||
19
whalesong/selfhost/js-assembler/module-knowledge.rkt
Normal file
19
whalesong/selfhost/js-assembler/module-knowledge.rkt
Normal file
|
|
@ -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))))
|
||||
|
||||
|
||||
788
whalesong/selfhost/js-assembler/package.rkt
Normal file
788
whalesong/selfhost/js-assembler/package.rkt
Normal file
|
|
@ -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
|
||||
#<<EOF
|
||||
<!DOCTYPE html>
|
||||
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en">
|
||||
<head>
|
||||
<meta name="viewport" content="initial-scale=1.0, width=device-width, height=device-height, minimum-scale=1.0, maximum-scale=1.0, user-scalable=no" />
|
||||
<meta charset="utf-8"/>
|
||||
<title></title>
|
||||
~a
|
||||
</head>
|
||||
<script>
|
||||
|
||||
EOF
|
||||
(append-text-files (current-header-scripts))))
|
||||
|
||||
|
||||
;; get-html-template: (listof string) (#:manifest path) -> string
|
||||
(define (get-html-template js-files
|
||||
#:manifest (manifest #f)
|
||||
#:with-legacy-ie-support? (with-legacy-ie-support? #t)
|
||||
#:title (title "")
|
||||
#:module-mappings (module-mappings (make-hash)))
|
||||
(format #<<EOF
|
||||
<!DOCTYPE html>
|
||||
<html ~a>
|
||||
<head>
|
||||
~a
|
||||
<meta name="viewport" content="initial-scale=1.0, width=device-width, height=device-height, minimum-scale=1.0, maximum-scale=1.0, user-scalable=no" />
|
||||
<meta name="apple-mobile-web-app-capable" content="yes" />
|
||||
<meta name="apple-mobile-web-app-status-bar-style" content="black" />
|
||||
<meta charset="utf-8"/>
|
||||
<title>~a</title>
|
||||
~a
|
||||
~a
|
||||
<script>
|
||||
plt.runtime.currentModuleLoader = plt.runtime.makeLocalFileModuleLoader(~a);
|
||||
</script>
|
||||
<script>
|
||||
~a
|
||||
</script>
|
||||
</head>
|
||||
<body>
|
||||
</body>
|
||||
</html>
|
||||
EOF
|
||||
(if manifest (format "manifest=~s" (path->string manifest)) "")
|
||||
(if with-legacy-ie-support?
|
||||
"<meta http-equiv='X-UA-Compatible' content='IE=7,chrome=1'><!--[if lt IE 9]><script src='excanvas.js' type='text/javascript'></script><script src='canvas.text.js'></script><script src='optimer-normal-normal.js'></script><![endif]-->"
|
||||
"")
|
||||
title
|
||||
(append-text-files (current-header-scripts))
|
||||
(string-join (map (lambda (js)
|
||||
(format " <script src='~a'></script>\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
|
||||
#<<EOF
|
||||
var invokeMainModule = function() {
|
||||
var M = plt.runtime.currentMachine;
|
||||
var startTime = new Date().valueOf();
|
||||
plt.runtime.invokeMains(
|
||||
M,
|
||||
function() {
|
||||
// On main module invokation success:
|
||||
var stopTime = new Date().valueOf();
|
||||
if (window.console && window.console.log) {
|
||||
window.console.log('evaluation took ' + (stopTime - startTime) + ' milliseconds');
|
||||
}
|
||||
},
|
||||
function(e) {
|
||||
var contMarkSet, context, i, appName, contextDiv, srclocProcedure;
|
||||
|
||||
var displayContext = function() {
|
||||
var subcontextDiv = $('<div/>').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])) {
|
||||
$('<div/>').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) {
|
||||
$('<div/>').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 = $('<div/>');
|
||||
|
||||
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)) {
|
||||
$('<div/>').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
|
||||
</script>
|
||||
<body></body>
|
||||
</html>
|
||||
EOF
|
||||
)
|
||||
Loading…
Reference in New Issue
Block a user