getting into bad compilation times again. Trying to isolate

NOTES

@@ -463,3 +463,8 @@ Ok, I think I've been able to do this successfully.  I lifted out the
 code for emit-values-context-check-on-procedure-return so it's used
 for both the returns from procedure call, as well as the calls from
 the prompt splicing.
+
+
+----------------------------------------------------------------------
+
+

assemble-perform-statement.rkt

@@ -123,4 +123,9 @@
 
     [(RaiseOperatorApplicationError!? op)
      (format "RUNTIME.raiseOperatorApplicationError(MACHINE, ~a);"
-             (assemble-oparg (RaiseOperatorApplicationError!-operator op)))]))
+             (assemble-oparg (RaiseOperatorApplicationError!-operator op)))]
+    
+    [(InstallModuleEntry!? op)
+     (format "MACHINE.modules[~s]=new RUNTIME.ModuleRecord(~s, ~a);"
+             (symbol->string (ModuleName-name (InstallModuleEntry!-name op)))
+             (assemble-label (make-Label (InstallModuleEntry!-entry-point op))))]))

collect-jump-targets.rkt

@@ -154,7 +154,9 @@
    [(RaiseArityMismatchError!? op)
     empty]
    [(RaiseOperatorApplicationError!? op)
-    empty]))
+    empty]
+   [(InstallModuleEntry!? op)
+    (list (InstallModuleEntry!-entry-point op))]))
 
 
 

compiler.rkt

@@ -65,6 +65,8 @@
         (cond
           [(Top? exp)
            (loop (Top-code exp) (cons (Top-prefix exp) cenv))]
+          [(Module? exp)
+           (loop (Module-code exp) (cons (Module-prefix exp) cenv))]
           [(Constant? exp)
            '()]
           [(LocalRef? exp)
@@ -168,6 +170,8 @@
   (cond
     [(Top? exp)
      (compile-top exp cenv target linkage)]
+    [(Module? exp)
+     (compile-module exp cenv target linkage)]
     [(Constant? exp)
      (compile-constant exp cenv target linkage)]
     [(LocalRef? exp)
@@ -244,6 +248,33 @@
 
 
 
+
+(: compile-module (Module CompileTimeEnvironment Target Linkage -> InstructionSequence))
+;; Generates code to write out the top prefix, evaluate the rest of the body,
+;; and then pop the top prefix off.
+(define (compile-module top cenv target linkage)
+  ;; fixme: this is not right yet.  This should instead install a module record
+  ;; that has not yet been invoked.
+  ;; fixme: This also needs to generate code for the requires and provides.
+  (let*: ([names : (Listof (U False Symbol GlobalBucket ModuleVariable))
+                 (Prefix-names (Module-prefix top))])
+         (end-with-linkage 
+          linkage cenv
+          (append-instruction-sequences
+           (make-instruction-sequence 
+            `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! names))))
+           (compile (Module-code top) 
+                    (cons (Module-prefix top) cenv)
+                    target
+                    next-linkage/drop-multiple)
+           (make-instruction-sequence
+            `(,(make-PopEnvironment (make-Const 1) 
+                                    (make-Const 0))))))))
+
+
+
+
+
 (: end-with-linkage (Linkage CompileTimeEnvironment InstructionSequence -> InstructionSequence))
 ;; Add linkage for expressions.
 (define (end-with-linkage linkage cenv instruction-sequence)
@@ -815,7 +846,9 @@
              (default)]
             [(ModuleVariable? op-knowledge)
              (cond
-               [(symbol=? (ModuleVariable-module-path op-knowledge) '#%kernel)
+               [(symbol=? (ModuleName-name
+                           (ModuleVariable-module-name op-knowledge))
+                          '#%kernel)
                 (let ([op (ModuleVariable-name op-knowledge)])
                   (cond [(KernelPrimitiveName? op)
                          (compile-kernel-primitive-application 
@@ -1952,6 +1985,13 @@
      (make-Top (Top-prefix exp)
                (adjust-expression-depth (Top-code exp) n (add1 skip)))]
     
+    [(Module? exp)
+     (make-Module (Module-name exp)
+                  (Module-prefix exp)
+                  (Module-requires exp)
+                  (Module-provides exp)
+                  (adjust-expression-depth (Module-code exp) n (add1 skip)))]
+    
     [(Constant? exp)
      exp]
     

il-structs.rkt

@@ -196,6 +196,7 @@
 
 
 
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Primitive Operators
 
@@ -369,6 +370,13 @@
 ;; Adds a continuation mark into the current top control frame.
 (define-struct: InstallContinuationMarkEntry! () #:transparent)
 
+
+;; Installs a module record into the machine
+(define-struct: InstallModuleEntry! ([name : ModuleName]
+                                     [entry-point : Symbol])
+  #:transparent)
+
+
 (define-type PrimitiveCommand (U                                
                                CheckToplevelBound!
                                CheckClosureArity!
@@ -389,7 +397,10 @@
 			       RaiseOperatorApplicationError!
                                
                                RestoreEnvironment!
-                               RestoreControl!))
+                               RestoreControl!
+                               
+                               InstallModuleEntry!
+                               ))
 
 
 

parse.rkt

@@ -52,7 +52,7 @@
     [(current-language)
      => (lambda (lang)
           (if (member sym lang)
-              (make-ModuleVariable sym '#%kernel)
+              (make-ModuleVariable sym (make-ModuleName '#%kernel))
               #f))]
     [else
      #f]))

runtime.js

@@ -64,6 +64,7 @@
 	this.env = [];
 	this.control = [];     // Arrayof (U Frame CallFrame PromptFrame)
 	this.running = false;
+	this.modules = {};     // String -> ModuleRecord
 	this.params = { 'currentDisplayer': function(v) {},
 			
 			'currentOutputPort': new StandardOutputPort(),
@@ -92,6 +93,12 @@
 
 
 
+    var ModuleRecord = function(name, label) {
+	this.name = name;
+	this.label = label;
+	this.isInvoked = false;
+	this.exports = {};
+    };
 
 
 
@@ -1128,6 +1135,7 @@
     exports['CallFrame'] = CallFrame;
     exports['PromptFrame'] = PromptFrame;
     exports['Closure'] = Closure;
+    exports['ModuleRecord'] = ModuleRecord;
     exports['ContinuationPromptTag'] = ContinuationPromptTag;
     exports['DEFAULT_CONTINUATION_PROMPT_TAG'] = 
 	DEFAULT_CONTINUATION_PROMPT_TAG;
@@ -1162,4 +1170,6 @@
     exports['heir'] = heir;
     exports['makeClassPredicate'] = makeClassPredicate;
 
+
+
 }).call(this);

simulator-structs.rkt

@@ -48,6 +48,8 @@
                          [pc : Natural]                  ;; program counter
                          [text : (Vectorof Statement)]   ;; text of the program
 
+                         [modules : (HashTable Symbol module-record)]
+                         
                          ;; other metrics for debugging
                          [stack-size : Natural]
                          
@@ -58,6 +60,13 @@
   #:mutable)
 
 
+(define-struct: module-record ([name : ModuleName]
+                               [label : Symbol]
+                               [invoked? : Boolean]
+                               [exports : (HashTable Symbol PrimitiveValue)])
+  #:transparent
+  #:mutable)
+
 
 (define-type frame (U GenericFrame CallFrame PromptFrame))
 

simulator.rkt

@@ -57,6 +57,7 @@
                                               '()
                                               0 
                                               (list->vector program-text) 
+                                              ((inst make-hash Symbol module-record))
                                               0
                                               ((inst make-hash Symbol Natural)))])
                   (let: loop : Void ([i : Natural 0])
@@ -401,7 +402,17 @@
 
 	  [(RaiseOperatorApplicationError!? op)
 	   (error "expected procedure, given ~a"
-		  (evaluate-oparg m (RaiseOperatorApplicationError!-operator op)))])))
+		  (evaluate-oparg m (RaiseOperatorApplicationError!-operator op)))]
+          
+          
+          [(InstallModuleEntry!? op)
+           (hash-set! (machine-modules m)
+                      (ModuleName-name (InstallModuleEntry!-name op))
+                      (make-module-record (InstallModuleEntry!-name op)
+                                          (InstallModuleEntry!-entry-point op)
+                                          #f
+                                          (make-hash)))
+           'ok])))
 
 
 
@@ -879,7 +890,7 @@
 (define (current-instruction m)
   (match m
     [(struct machine (val proc argcount env control pc text
-                          stack-size jump-table))
+                          modules stack-size jump-table))
      (vector-ref text pc)]))
 
 
@@ -903,7 +914,7 @@
 (: env-push! (machine SlotValue -> 'ok))
 (define (env-push! m v)
   (match m
-    [(struct machine (val proc argcount env control pc text stack-size jump-table))
+    [(struct machine (val proc argcount env control pc text modules stack-size jump-table))
      (set-machine-env! m (cons v env))
      (set-machine-stack-size! m (add1 stack-size))
      'ok]))
@@ -911,7 +922,7 @@
 (: env-push-many! (machine (Listof SlotValue) -> 'ok))
 (define (env-push-many! m vs)
   (match m
-    [(struct machine (val proc argcount env control pc text stack-size jump-table))
+    [(struct machine (val proc argcount env control pc text modules stack-size jump-table))
      (set-machine-env! m (append vs env))
      (set-machine-stack-size! m (+ stack-size (length vs)))
      'ok]))
@@ -920,13 +931,13 @@
 (: env-ref (machine Natural -> SlotValue))
 (define (env-ref m i)  
   (match m
-    [(struct machine (val proc argcount env control pc text stack-size jump-table))
+    [(struct machine (val proc argcount env control pc text modules stack-size jump-table))
      (list-ref env i)]))
 
 (: env-mutate! (machine Natural SlotValue -> 'ok))
 (define (env-mutate! m i v)
   (match m
-    [(struct machine (val proc argcount env control pc text stack-size jump-table))
+    [(struct machine (val proc argcount env control pc text modules stack-size jump-table))
      (set-machine-env! m (list-replace env i v))
      'ok]))
 
@@ -944,7 +955,7 @@
 (: env-pop! (machine Natural Natural -> 'ok))
 (define (env-pop! m n skip)     
   (match m
-    [(struct machine (val proc argcount env control pc text stack-size jump-table))
+    [(struct machine (val proc argcount env control pc text modules stack-size jump-table))
      (set-machine-env! m (append (take env skip)
                                  (drop env (+ skip n))))
      (set-machine-stack-size! m (ensure-natural (- stack-size n)))
@@ -954,7 +965,7 @@
 (: control-push! (machine frame -> 'ok))
 (define (control-push! m a-frame)
   (match m
-    [(struct machine (val proc argcount env control pc text stack-size jump-table))
+    [(struct machine (val proc argcount env control pc text modules stack-size jump-table))
      (set-machine-control! m (cons a-frame control))
      'ok]))
 
@@ -962,14 +973,14 @@
 (: control-pop! (machine -> 'ok))
 (define (control-pop! m)
   (match m
-    [(struct machine (val proc argcount env control pc text stack-size jump-table))
+    [(struct machine (val proc argcount env control pc text modules stack-size jump-table))
      (set-machine-control! m (rest control))
      'ok]))
 
 (: control-top (machine -> frame))
 (define (control-top m)
   (match m
-    [(struct machine (val proc argcount env control pc text stack-size jump-table))
+    [(struct machine (val proc argcount env control pc text modules stack-size jump-table))
      (first control)]))
 
 
@@ -985,7 +996,7 @@
 ;; Jumps directly to the instruction at the given label.
 (define (jump! m l)
   (match m
-    [(struct machine (val proc argcount env control pc text stack-size jump-table))
+    [(struct machine (val proc argcount env control pc text modules stack-size jump-table))
      (set-machine-pc! m (hash-ref jump-table l))
      'ok]))
 

test-parse.rkt

@@ -208,7 +208,7 @@
                           'lamEntry2)))
 
 (test (parse '(+ x x))
-      (make-Top (make-Prefix `(,(make-ModuleVariable '+ '#%kernel) 
+      (make-Top (make-Prefix `(,(make-ModuleVariable '+ (make-ModuleName '#%kernel))
                                x))
                 (make-App (make-ToplevelRef 2 0)
                           (list (make-ToplevelRef 2 1)
@@ -216,7 +216,7 @@
   
 
 (test (parse '(lambda (x) (+ x x)))
-      (make-Top (make-Prefix `(,(make-ModuleVariable '+ '#%kernel)))
+      (make-Top (make-Prefix `(,(make-ModuleVariable '+ (make-ModuleName '#%kernel))))
                 (make-Lam 'unknown 1 #f
                           (make-App (make-ToplevelRef 2 0)
                                     (list (make-LocalRef 3 #f)
@@ -226,8 +226,8 @@
 
 (test (parse '(lambda (x) 
                 (+ (* x x) x)))
-      (make-Top (make-Prefix `(,(make-ModuleVariable '* '#%kernel)
+      (make-Top (make-Prefix `(,(make-ModuleVariable '* (make-ModuleName '#%kernel))
-                               ,(make-ModuleVariable '+ '#%kernel)))
+                               ,(make-ModuleVariable '+ (make-ModuleName '#%kernel))))
                 (make-Lam 'unknown 1 #f
                           ;; stack layout: [???, ???, prefix, x]
                           (make-App (make-ToplevelRef 2 1)
@@ -286,7 +286,7 @@
 (test (parse '(let* ([x 3]
                      [x (add1 x)])
                 (add1 x)))
-      (make-Top (make-Prefix `(,(make-ModuleVariable 'add1 '#%kernel)))
+      (make-Top (make-Prefix `(,(make-ModuleVariable 'add1 (make-ModuleName '#%kernel))))
                 
                 ;; stack layout: [prefix]
                 
@@ -415,7 +415,7 @@
 (test (parse '(let ([x 0])
                 (lambda ()
                   (set! x (add1 x)))))
-      (make-Top (make-Prefix `(,(make-ModuleVariable 'add1 '#%kernel)))
+      (make-Top (make-Prefix `(,(make-ModuleVariable 'add1 (make-ModuleName '#%kernel))))
                 (make-Let1 (make-Constant 0)
                            (make-BoxEnv 0
                                         (make-Lam 'unknown 0 #f
@@ -434,7 +434,7 @@
                     [y 1])
                 (lambda ()
                   (set! x (add1 x)))))
-      (make-Top (make-Prefix `(,(make-ModuleVariable 'add1 '#%kernel)))
+      (make-Top (make-Prefix `(,(make-ModuleVariable 'add1 (make-ModuleName '#%kernel))))
                 (make-LetVoid 2
                               (make-Seq (list
                                          (make-InstallValue 1 0 (make-Constant 0) #t)
@@ -462,7 +462,7 @@
                      (reset!)
                      (list a b)))
       (make-Top
-       (make-Prefix `(a b ,(make-ModuleVariable 'list '#%kernel) reset!))
+       (make-Prefix `(a b ,(make-ModuleVariable 'list (make-ModuleName '#%kernel)) reset!))
        (make-Splice
         (list
          (make-ToplevelSet 0 0 (make-Constant '(hello)))