diff --git a/js-assembler/package.rkt b/js-assembler/package.rkt index 1acf9b4..2813c2e 100644 --- a/js-assembler/package.rkt +++ b/js-assembler/package.rkt @@ -10,6 +10,7 @@ "../parser/path-rewriter.rkt" "../parser/parse-bytecode.rkt" "../resource/structs.rkt" + "../promise.rkt" racket/match racket/list racket/promise @@ -283,7 +284,7 @@ M.modules[~s] = (fprintf op "(function(M) { ~a }(plt.runtime.currentMachine));" (UninterpretedSource-datum src))] [else (fprintf op "(") - (assemble/write-invoke stmts op) + (assemble/write-invoke (my-force stmts) op) (fprintf op ")(plt.runtime.currentMachine, function() { if (window.console && window.console.log) { @@ -361,7 +362,7 @@ M.modules[~s] = (lambda (src) #t) ;; on (lambda (src ast stmts) - (assemble/write-invoke stmts op) + (assemble/write-invoke (my-force stmts) op) (fprintf op "(M, function() { ")) ;; after diff --git a/make/make-structs.rkt b/make/make-structs.rkt index fa9d11f..fe76366 100644 --- a/make/make-structs.rkt +++ b/make/make-structs.rkt @@ -3,7 +3,8 @@ (require "../compiler/il-structs.rkt" "../compiler/bootstrapped-primitives.rkt" "../compiler/expression-structs.rkt" - "get-dependencies.rkt") + "get-dependencies.rkt" + "../promise.rkt") @@ -51,11 +52,11 @@ (define-struct: Configuration ([wrap-source : (Source -> Source)] [should-follow-children? : (Source -> Boolean)] - [on-module-statements : (Source - (U Expression #f) - (Listof Statement) - -> Void)] - [after-module-statements : (Source -> Void)] + [on-source : (Source + (U Expression #f) + (MyPromise (Listof Statement)) + -> Void)] + [after-source : (Source -> Void)] [after-last : (-> Void)]) #:mutable) diff --git a/make/make.rkt b/make/make.rkt index 3a9a243..b1998d6 100644 --- a/make/make.rkt +++ b/make/make.rkt @@ -10,7 +10,8 @@ "get-dependencies.rkt" "make-structs.rkt" racket/list - racket/match) + racket/match + "../promise.rkt") (require/typed "../logger.rkt" @@ -39,36 +40,41 @@ (: get-ast-and-statements (Source -> (values (U False Expression) - (Listof Statement)))) + (MyPromise (Listof Statement))))) (define (get-ast-and-statements a-source) (cond [(StatementsSource? a-source) - (values #f (StatementsSource-stmts a-source))] + (values #f (my-delay (StatementsSource-stmts a-source)))] [(UninterpretedSource? a-source) - (values #f '())] + (values #f (my-delay '()))] [(MainModuleSource? a-source) (let-values ([(ast stmts) (get-ast-and-statements (MainModuleSource-source a-source))]) - (let ([maybe-module-locator (find-module-locator ast)]) - (cond - [(ModuleLocator? maybe-module-locator) - (values ast (append stmts - ;; Set the main module name - (list (make-PerformStatement - (make-AliasModuleAsMain! - maybe-module-locator)))))] - [else - (values ast stmts)])))] - + (values ast + (my-delay + (let ([maybe-module-locator (find-module-locator ast)]) + (cond + [(ModuleLocator? maybe-module-locator) + (append (my-force stmts) + ;; Set the main module name + (list (make-PerformStatement + (make-AliasModuleAsMain! + maybe-module-locator))))] + [else + (my-force stmts)])))))] [else (let ([ast (get-ast a-source)]) - (define start-time (current-inexact-milliseconds)) - (define compiled-code (compile ast 'val next-linkage/drop-multiple)) - (define stop-time (current-inexact-milliseconds)) - (fprintf (current-timing-port) " compile ast: ~a milliseconds\n" (- stop-time start-time)) - (values ast compiled-code))])) + (values ast + (my-delay + (define start-time (current-inexact-milliseconds)) + (define compiled-code (compile ast 'val next-linkage/drop-multiple)) + (define stop-time (current-inexact-milliseconds)) + (fprintf (current-timing-port) + " compile ast: ~a milliseconds\n" + (- stop-time start-time)) + compiled-code)))])) @@ -122,7 +128,7 @@ (match config [(struct Configuration (wrap-source should-follow-children? - on-module-statements + on-source after-module-statements after-last)) @@ -177,7 +183,7 @@ [(ast stmts) (get-ast-and-statements this-source)]) (log-debug (format "visiting ~a\n" (source-name this-source))) - (on-module-statements this-source ast stmts) + ((Configuration-on-source config) this-source ast stmts) (define start-time (current-inexact-milliseconds)) (define new-dependencies (map wrap-source (collect-new-dependencies this-source ast))) (define end-time (current-inexact-milliseconds)) diff --git a/promise.rkt b/promise.rkt new file mode 100644 index 0000000..f124fab --- /dev/null +++ b/promise.rkt @@ -0,0 +1,39 @@ +#lang typed/racket/base +(require (for-syntax racket/base)) + +;; Working around what appears to be a bug in Typed Racket +;; by implementing my own promises. + +(provide my-delay my-force MyPromise) + + +(define-struct: Sentinel ()) + + +(define-struct: (a) MyPromise ([forced? : Boolean] + [thunk : (-> a)] + [val : (U Sentinel a)]) + #:mutable) + + +(define-syntax (my-delay stx) + (syntax-case stx () + [(_ expr ...) + (syntax/loc stx + (make-MyPromise #f + (lambda () expr ...) + (make-Sentinel)))])) + +(: my-force (All (a) (MyPromise a) -> a)) +(define (my-force a-promise) + (cond + [(MyPromise-forced? a-promise) + (define val (MyPromise-val a-promise)) + (if (Sentinel? val) + (error 'force "Impossible") + val)] + [else + (define val ((MyPromise-thunk a-promise))) + (set-MyPromise-val! a-promise val) + (set-MyPromise-forced?! a-promise #t) + val])) \ No newline at end of file