more of module invoke

NOTES

@@ -468,3 +468,31 @@ the prompt splicing.
 ----------------------------------------------------------------------
 
 
+May 13,
+
+begin0 is still broken; I'm a bit unsatisfied with the way that it's
+coded, and I know it's not correct yet.
+
+The other thing that's I'm sure needs to be looked at again are the
+implementation of prompts.
+
+
+modules are almost in place.  Needs a mechanism for loading modules on
+the fly on the network, as well as some kind of predicable namespacing
+mechanism.  I think the compiler will need to include something like a
+
+    (current-module-name-canonizer)
+
+which takes module names (symbol, path-string) and systematically
+translates them to predictable identifiers.  Anything refering to a
+collection should be translated to
+
+    collects/...
+
+Anything outside that should be given a name relative to some root.
+One should be able to say:
+
+    root the translation at "/home/dyoo/work/js-sicp-5.5/examples"
+
+where all translated paths are either from collections, or reachable
+from the root.  That way, we get predictable paths.

assemble-helpers.rkt

@@ -56,6 +56,10 @@
      (assemble-primitive-kernel-value v)]
     [(ModuleEntry? v)
      (assemble-module-entry v)]
+    [(IsModuleInvoked? v)
+     (assemble-is-module-invoked v)]
+    [(IsModuleLinked? v)
+     (assemble-is-module-linked v)]
     [(VariableReference? v)
      (assemble-variable-reference v)]))
 
@@ -278,6 +282,18 @@
           (symbol->string (ModuleName-name (ModuleEntry-name entry)))))
 
 
+(: assemble-is-module-invoked (IsModuleInvoked -> String))
+(define (assemble-is-module-invoked entry)
+  (format "MACHINE.modules[~s].label"
+          (symbol->string (ModuleName-name (IsModuleInvoked-name entry)))))
+
+
+(: assemble-is-module-linked (IsModuleLinked -> String))
+(define (assemble-is-module-linked entry)
+  (format "(MACHINE.modules[~s] !== undefined)"
+          (symbol->string (ModuleName-name (IsModuleLinked-name entry)))))
+
+
 
 (: assemble-variable-reference (VariableReference -> String))
 (define (assemble-variable-reference varref)

assemble.rkt

@@ -204,6 +204,10 @@ EOF
                      (format "if (~a === false) { ~a }"
                              (assemble-oparg (TestFalse-operand test))
                              jump)]
+                    [(TestTrue? test)
+                     (format "if (~a !== false) { ~a }"
+                             (assemble-oparg (TestTrue-operand test))
+                             jump)]
                     [(TestOne? test)
                      (format "if (~a === 1) { ~a }"
                              (assemble-oparg (TestOne-operand test))

collect-jump-targets.rkt

@@ -96,6 +96,10 @@
     empty]
    [(ModuleEntry? an-input)
     empty]
+   [(IsModuleInvoked? an-input)
+    empty]
+   [(IsModuleLinked? an-input)
+    empty]
    [(VariableReference? an-input)
     empty]))
 

compiler.rkt

@@ -165,6 +165,50 @@
 
 
 
+
+(: end-with-linkage (Linkage CompileTimeEnvironment InstructionSequence -> InstructionSequence))
+;; Add linkage for expressions.
+(define (end-with-linkage linkage cenv instruction-sequence)
+  (append-instruction-sequences instruction-sequence
+                                (compile-linkage cenv linkage)))
+
+
+
+
+(: compile-linkage (CompileTimeEnvironment Linkage -> InstructionSequence))
+;; Generates the code necessary to drive the rest of the computation (represented as the linkage).
+(define (compile-linkage cenv linkage)
+  (cond
+    [(ReturnLinkage? linkage)
+     (cond
+       [(ReturnLinkage-tail? linkage)
+        ;; Under tail calls, clear the environment of the current stack frame (represented by cenv)
+        ;; and do the jump.
+        (make-instruction-sequence 
+         `(,(make-PopEnvironment (make-Const (length cenv)) 
+                                 (make-Const 0))
+           ,(make-AssignImmediateStatement 'proc (make-ControlStackLabel))
+           ,(make-PopControlFrame)
+           ,(make-GotoStatement (make-Reg 'proc))))]
+       [else
+        ;; Under non-tail calls, leave the stack as is and just do the jump.
+        (make-instruction-sequence
+         `(,(make-AssignImmediateStatement 'proc (make-ControlStackLabel))
+           ,(make-PopControlFrame)
+           ,(make-GotoStatement (make-Reg 'proc))))])]
+    
+    [(NextLinkage? linkage)
+     empty-instruction-sequence]
+ 
+    [(LabelLinkage? linkage)
+     (make-instruction-sequence 
+      `(,(make-GotoStatement (make-Label (LabelLinkage-label linkage)))))]))
+
+
+
+
+
+
 (: compile (Expression CompileTimeEnvironment Target Linkage -> InstructionSequence))
 ;; The main dispatching function for compilation.
 ;; Compiles an expression into an instruction sequence.
@@ -256,66 +300,82 @@
 (: 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)
+(define (compile-module mod 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))
+  (let*: ([after-module-body (make-label 'afterModuleBody)]
-                 (Prefix-names (Module-prefix top))])
+	  [module-entry (make-label 'module-entry)]
+	  [names : (Listof (U False Symbol GlobalBucket ModuleVariable))
+                 (Prefix-names (Module-prefix mod))]
+	  [module-cenv : CompileTimeEnvironment (list (Module-prefix mod))])
+
          (end-with-linkage 
           linkage cenv
           (append-instruction-sequences
-           (make-instruction-sequence 
+           (make-instruction-sequence
-            `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! names))))
+	    `(,(make-GotoStatement (make-Label after-module-body))))
-           (compile (Module-code top) 
+
-                    (cons (Module-prefix top) cenv)
+	   ;; Module body definition
+	   (apply append-instruction-sequences 
+		  (map compile-module-invoke (Module-requires mod)))
+
+	   (make-instruction-sequence 
+            `(,module-entry
+	      ,(make-PerformStatement (make-ExtendEnvironment/Prefix! names))))
+	   ;; TODO: we need to sequester the prefix of the module with the record.
+           (compile (Module-code mod) 
+                    (cons (Module-prefix mod) module-cenv)
                     target
                     next-linkage/drop-multiple)
+
+	   ;; Cleanup
            (make-instruction-sequence
             `(,(make-PopEnvironment (make-Const 1) 
-                                    (make-Const 0))))))))
+                                    (make-Const 0))
+	      ,(make-AssignImmediateStatement 'proc (make-ControlStackLabel))
+	      ,(make-PopControlFrame)
+	      ,(make-GotoStatement (make-Reg 'proc))))
+
+	   after-module-body))))
+
+
+(: compile-module-invoke (ModuleName -> InstructionSequence))
+;; Generates code that will invoke a module (if it hasn't been invoked yet)
+;; FIXME: assumes the module has already been linked.  We should error out
+;; if the module hasn't been linked yet.
+(define (compile-module-invoke a-module-name)
+  (let* ([linked (make-label 'linked)]
+	 [already-loaded (make-label 'alreadyLoaded)]
+	 [on-return-multiple (make-label 'onReturnMultiple)]
+	 [on-return (make-LinkedLabel (make-label 'onReturn)
+				     on-return-multiple)])
+  (make-instruction-sequence
+   `(,(make-TestAndBranchStatement (make-TestTrue
+				   (make-IsModuleLinked a-module-name))
+				  linked)
+     ;; TODO: raise an exception here that says that the module hasn't been
+     ;; linked yet.
+     ,(make-DebugPrint (make-Const 
+		        (format "DEBUG: the module ~a hasn't been linked in yet!"
+				(ModuleName-name a-module-name))))
+     ,linked
+     ,(make-TestAndBranchStatement (make-TestTrue 
+				    (make-IsModuleInvoked a-module-name))
+				   already-loaded)
+     ,(make-PushControlFrame/Call on-return)
+     ,(make-GotoStatement (make-ModuleEntry a-module-name))
+     ,on-return-multiple
+     ,(make-PopEnvironment (make-SubtractArg (make-Reg 'argcount)
+					     (make-Const 1))
+			   (make-Const 0))
+     ,on-return
+     ,already-loaded))))
 
 
 
 
 
-(: end-with-linkage (Linkage CompileTimeEnvironment InstructionSequence -> InstructionSequence))
-;; Add linkage for expressions.
-(define (end-with-linkage linkage cenv instruction-sequence)
-  (append-instruction-sequences instruction-sequence
-                                (compile-linkage cenv linkage)))
-
-
-
-
-(: compile-linkage (CompileTimeEnvironment Linkage -> InstructionSequence))
-;; Generates the code necessary to drive the rest of the computation (represented as the linkage).
-(define (compile-linkage cenv linkage)
-  (cond
-    [(ReturnLinkage? linkage)
-     (cond
-       [(ReturnLinkage-tail? linkage)
-        ;; Under tail calls, clear the environment of the current stack frame (represented by cenv)
-        ;; and do the jump.
-        (make-instruction-sequence 
-         `(,(make-PopEnvironment (make-Const (length cenv)) 
-                                 (make-Const 0))
-           ,(make-AssignImmediateStatement 'proc (make-ControlStackLabel))
-           ,(make-PopControlFrame)
-           ,(make-GotoStatement (make-Reg 'proc))))]
-       [else
-        ;; Under non-tail calls, leave the stack as is and just do the jump.
-        (make-instruction-sequence
-         `(,(make-AssignImmediateStatement 'proc (make-ControlStackLabel))
-           ,(make-PopControlFrame)
-           ,(make-GotoStatement (make-Reg 'proc))))])]
-    
-    [(NextLinkage? linkage)
-     empty-instruction-sequence]
- 
-    [(LabelLinkage? linkage)
-     (make-instruction-sequence 
-      `(,(make-GotoStatement (make-Label (LabelLinkage-label linkage)))))]))
 
 
 (: emit-singular-context (Linkage -> InstructionSequence))

il-structs.rkt

@@ -34,6 +34,8 @@
                       CompiledProcedureEntry
                       CompiledProcedureClosureReference
                       ModuleEntry
+                      IsModuleInvoked
+		      IsModuleLinked
                       PrimitiveKernelValue
                       VariableReference))
 
@@ -89,14 +91,22 @@
   #:transparent)
 
 
-
 (define-struct: PrimitivesReference ([name : Symbol])
   #:transparent)
 
-
+;; Produces the entry point of the module.
 (define-struct: ModuleEntry ([name : ModuleName])
   #:transparent)
 
+;; Produces true if the module has already been invoked
+(define-struct: IsModuleInvoked ([name : ModuleName])
+  #:transparent)
+
+;; Produces true if the module has been loaded into the machine
+(define-struct: IsModuleLinked ([name : ModuleName])
+  #:transparent)
+
+
 
 
 
@@ -288,12 +298,14 @@
 ;; Primitive tests (used with TestAndBranch)
 (define-type PrimitiveTest (U 
                             TestFalse
+                            TestTrue
                             TestOne
                             TestZero
                             TestPrimitiveProcedure
                             TestClosureArityMismatch
                             ))
 (define-struct: TestFalse ([operand : OpArg]) #:transparent)
+(define-struct: TestTrue ([operand : OpArg]) #:transparent)
 (define-struct: TestOne ([operand : OpArg]) #:transparent)
 (define-struct: TestZero ([operand : OpArg]) #:transparent)
 (define-struct: TestPrimitiveProcedure ([operand : OpArg]) #:transparent)

optimize-il.rkt

@@ -141,6 +141,10 @@
      oparg]
     [(ModuleEntry? oparg)
      oparg]
+    [(IsModuleInvoked? oparg)
+     oparg]
+    [(IsModuleLinked? oparg)
+     oparg]
     [(VariableReference? oparg)
      (let ([t (VariableReference-toplevel oparg)])
        (make-VariableReference 

simulator.rkt

@@ -207,25 +207,26 @@
 (: step-test-and-branch! (machine TestAndBranchStatement -> 'ok))
 (define (step-test-and-branch! m stmt)
   (let: ([test : PrimitiveTest (TestAndBranchStatement-op stmt)])
-        (if (let: ([v : Boolean (cond
+        (if (ann (cond
-                                  [(TestFalse? test)
+		  [(TestFalse? test)
-                                   (not (evaluate-oparg m (TestFalse-operand test)))]
+		   (not (evaluate-oparg m (TestFalse-operand test)))]
-                                  [(TestOne? test)
+		  [(TestTrue? test)
-                                   (= (ensure-natural (evaluate-oparg m (TestOne-operand test)))
+		   (and (evaluate-oparg m (TestTrue-operand test)) #t)]
-                                      1)]
+		  [(TestOne? test)
-				  [(TestZero? test)
+		   (= (ensure-natural (evaluate-oparg m (TestOne-operand test)))
-				   (= (ensure-natural (evaluate-oparg m (TestZero-operand test)))
+		      1)]
-                                      0)]
+		  [(TestZero? test)
-                                  [(TestPrimitiveProcedure? test)
+		   (= (ensure-natural (evaluate-oparg m (TestZero-operand test)))
-                                   (primitive-proc? (evaluate-oparg m (TestPrimitiveProcedure-operand test)))]
+		      0)]
-                                  [(TestClosureArityMismatch? test)
+		  [(TestPrimitiveProcedure? test)
-                                   (let ([proc (ensure-closure
+		   (primitive-proc? (evaluate-oparg m (TestPrimitiveProcedure-operand test)))]
-                                                (evaluate-oparg m (TestClosureArityMismatch-closure test)))]
+		  [(TestClosureArityMismatch? test)
-                                         [n (ensure-natural 
+		   (let ([proc (ensure-closure
-                                             (evaluate-oparg m (TestClosureArityMismatch-n test)))])
+				(evaluate-oparg m (TestClosureArityMismatch-closure test)))]
-                                     (not (arity-match? (closure-arity proc) n)))])])
+			 [n (ensure-natural 
-
+			     (evaluate-oparg m (TestClosureArityMismatch-n test)))])
-                  v)
+		     (not (arity-match? (closure-arity proc) n)))])
+		 Boolean)
             (jump! m (TestAndBranchStatement-label stmt))
             'ok)))
 
@@ -792,6 +793,15 @@
                                (ModuleName-name (ModuleEntry-name an-oparg)))])
        (module-record-label a-module))]
 
+    [(IsModuleInvoked? an-oparg)
+     (let ([a-module (hash-ref (machine-modules m) 
+                               (ModuleName-name (IsModuleInvoked-name an-oparg)))])
+       (module-record-invoked? a-module))]
+
+    [(IsModuleLinked? an-oparg)
+     (hash-has-key? (machine-modules m) 
+		    (ModuleName-name (IsModuleLinked-name an-oparg)))]
+
     [(VariableReference? an-oparg)
      (let ([t (VariableReference-toplevel an-oparg)])
        (make-ToplevelReference (ensure-toplevel (env-ref m (ToplevelRef-depth t)))