trying to introduce promises so I can pre-cache some of the compilations

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

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)
 

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))

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]))