trying to get module invokation working under tests

compiler.rkt

@@ -382,7 +382,7 @@
 				    (make-IsModuleInvoked a-module-name))
 				   already-loaded)
      ,(make-PushControlFrame/Call on-return)
-     ,(make-GotoStatement (make-ModuleEntry a-module-name))
+     ,(make-GotoStatement (ModuleEntry a-module-name))
      ,on-return-multiple
      ,(make-PopEnvironment (make-SubtractArg (make-Reg 'argcount)
 					     (make-Const 1))

il-structs.rkt

@@ -204,7 +204,10 @@
 
 
 
-(define-struct: GotoStatement ([target : OpArg]) 
+(define-struct: GotoStatement ([target : (U Label 
+                                            Reg
+                                            ModuleEntry
+                                            CompiledProcedureEntry)]) 
   #:transparent)
 
 (define-struct: PerformStatement ([op : PrimitiveCommand])

kernel-primitives.rkt

@@ -59,6 +59,7 @@
 				    'values
 				    'call-with-values
                                     'apply
+                                    'printf
                                     ))
 (define-predicate KernelPrimitiveName? KernelPrimitiveName)
 

lang/kernel.rkt

@@ -63,12 +63,13 @@
 	 #%app
 	 #%top-interaction
 	 #%top
-	 define
+         module
+         define
 	 define-values
 	 let-values
 	 let*-values
 	 define-struct
-	 if
+         if
 	 cond
 	 else
 	 case

package.rkt

@@ -6,6 +6,7 @@
 	 "language-namespace.rkt"
          "il-structs.rkt"
          "bootstrapped-primitives.rkt"
+         "get-module-bytecode.rkt"
          "get-dependencies.rkt"
          "js-assembler/assemble.rkt"
          "js-assembler/get-runtime.rkt"
@@ -23,34 +24,21 @@
 (define-runtime-path kernel-language-path
   "lang/kernel.rkt")
 
-;; Use Racket's compiler, and then parse the resulting bytecode
-;; to our own AST structures.
-(define (parse stx)
-  (parameterize ([current-namespace (lookup-language-namespace 
-                                     `(file ,(path->string kernel-language-path))
-                                     #;'racket/base)]
-                 ;; We want to disable some optimizations for the moment.
-                 ;; See: http://docs.racket-lang.org/drracket/module.html
-                 [compile-context-preservation-enabled #t])
-
-    (let ([bc (racket:compile stx)]
-          [op (open-output-bytes)])
-      (write bc op)
-      (parse-bytecode 
-       (open-input-bytes (get-output-bytes op))))))
-
-
 
 
 ;; package: s-expression output-port -> void
 (define (package source-code op)  
-  (fprintf op "var invoke = ")
+  (let ([source-code-op (open-output-bytes)])
-  (assemble/write-invoke (append (get-bootstrapping-code)
+    (write source-code source-code-op)
-				 (compile (parse source-code)
+    (let ([source-code-ip (open-input-bytes (get-output-bytes source-code-op))])
-					  'val
+      (fprintf op "var invoke = ")
-					  next-linkage/drop-multiple))
+      (assemble/write-invoke (append (get-bootstrapping-code)
-                         op)
+                                     (compile (parse-bytecode 
-  (fprintf op ";\n"))
+                                               (open-input-bytes (get-module-bytecode source-code-ip)))
+                                              'val
+                                              next-linkage/drop-multiple))
+                             op)
+      (fprintf op ";\n"))))
 
 
 (define (package-anonymous source-code op)

simulator/simulator-primitives.rkt

@@ -1,6 +1,7 @@
 #lang racket/base
 (require "simulator-structs.rkt"
          "../il-structs.rkt"
+         "simulator-helpers.rkt"
          racket/math
          racket/list
          (for-syntax racket/base))
@@ -170,6 +171,11 @@
                          (error 'member "not a list: ~s" l)]))))
 
 
+(define my-printf (lambda (fmt args)
+                     (apply printf fmt (map (lambda (x)
+                                              (PrimitiveValue->racket x))
+                                            args))))
+
 
 
 (define current-continuation-marks   
@@ -258,11 +264,11 @@
                                                      
                                                      
                                                      equal?
+                                                     symbol?
                                                      
                                                      
-                                                    
+                                                     (my-printf printf)
-                                                     
+                                                     )
-                                                     symbol?)
                                       #:constants (null pi e
                                                         current-continuation-marks
                                                         continuation-mark-set->list)))

simulator/simulator-structs.rkt

@@ -7,6 +7,14 @@
          "../lexical-structs.rkt")
 
 
+
+
+;; A special "label" in the system that causes evaluation to stop.
+(define-struct: halt ())
+(define HALT (make-halt))
+
+
+
 (define-type PrimitiveValue (Rec PrimitiveValue (U String Number Symbol Boolean
                                                    Null VoidValue
                                                    undefined
@@ -79,7 +87,7 @@
   #:transparent)
 
 
-(define-struct: CallFrame ([return : LinkedLabel]
+(define-struct: CallFrame ([return : (U LinkedLabel halt)]
                            ;; The procedure being called.  Used to optimize self-application
                            [proc : (U closure #f)]
                            ;; TODO: add continuation marks
@@ -89,7 +97,7 @@
   #:mutable)  ;; mutable because we want to allow mutation of proc.
 
 (define-struct: PromptFrame ([tag : ContinuationPromptTagValue]
-                             [return : LinkedLabel]
+                             [return : (U LinkedLabel halt)]
                              [env-depth : Natural]
                              [temps : (HashTable Symbol PrimitiveValue)]
                              [marks : (HashTable PrimitiveValue PrimitiveValue)])

simulator/simulator.rkt

@@ -27,14 +27,22 @@
                [racket->PrimitiveValue (Any -> PrimitiveValue)])
              
 
-(provide new-machine can-step? step! current-instruction
+(provide new-machine 
+         can-step?
+         step! 
+         current-instruction
          current-simulated-output-port
-         machine-control-size)
+         machine-control-size
+         invoke-module-as-main)
 
 
 (define current-simulated-output-port (make-parameter (current-output-port)))
 
 
+
+(define end-of-program-text 'end-of-program-text)
+
+
 (: new-machine (case-lambda [(Listof Statement) -> machine]
                             [(Listof Statement) Boolean -> machine]))
 (define new-machine
@@ -45,11 +53,12 @@
       [with-bootstrapping-code? : Boolean])
      (let*: ([after-bootstrapping : Symbol (make-label 'afterBootstrapping)]
              [program-text : (Listof Statement)
-                           (cond [with-bootstrapping-code?
+                           (append (cond [with-bootstrapping-code?
-                                  (append (get-bootstrapping-code)
+                                          (append (get-bootstrapping-code)
-                                          program-text)]
+                                                  program-text)]
-                                 [else
+                                         [else
-                                  program-text])])
+                                          program-text])
+                                   (list end-of-program-text))])
             (let: ([m : machine (make-machine (make-undefined)
                                               (make-undefined)
                                               (make-undefined)
@@ -79,6 +88,25 @@
 
 
 
+
+(: invoke-module-as-main (machine Symbol -> 'ok))
+;; Assuming the module has been loaded in, sets the machine
+;; up to invoke its body.
+(define (invoke-module-as-main m module-name)
+  (let ([frame (make-PromptFrame
+                default-continuation-prompt-tag-value
+                HALT
+                (length (machine-env m))
+                (make-hasheq)
+                (make-hasheq))]
+        [module-record (hash-ref (machine-modules m) module-name)])
+    (control-push! m frame)
+    (jump! m (module-record-label module-record))))
+    
+               
+
+
+
 (: can-step? (machine -> Boolean))
 ;; Produces true if we can make a further step in the simulation.
 (define (can-step? m)
@@ -771,10 +799,17 @@
 	 (error 'GetControlStackLabel)]
 	[(PromptFrame? frame)
 	 (let ([label (PromptFrame-return frame)])
-	   (LinkedLabel-label label))]
+	   (cond [(halt? label)
+                  end-of-program-text]
+                 [else
+                  (LinkedLabel-label label)]))]
 	[(CallFrame? frame)
 	 (let ([label (CallFrame-return frame)])
-	   (LinkedLabel-label label))]))]
+	   (cond
+             [(halt? label)
+              end-of-program-text]
+             [else
+              (LinkedLabel-label label)]))]))]
     
     [(ControlStackLabel/MultipleValueReturn? an-oparg)
      (let ([frame (ensure-frame (first (machine-control m)))])
@@ -783,11 +818,19 @@
 	 (error 'GetControlStackLabel/MultipleValueReturn)]
 	[(PromptFrame? frame)
 	 (let ([label (PromptFrame-return frame)])
-	   (LinkedLabel-linked-to label))]
+	   (cond
+             [(halt? label)
+              end-of-program-text]
+             [else
+              (LinkedLabel-linked-to label)]))]
 	[(CallFrame? frame)
 	 (let ([label (CallFrame-return frame)])
-	   (LinkedLabel-linked-to label))]))]
+           (cond
-
+             [(halt? label)
+              end-of-program-text]
+             [else
+              (LinkedLabel-linked-to label)]))]))]
+    
     [(ControlFrameTemporary? an-oparg)
      (let ([ht (frame-temps (control-top m))])
        (hash-ref ht

tests/test-compiler.rkt

@@ -54,7 +54,8 @@
              #:debug? (debug? false)
              #:stack-limit (stack-limit false)
              #:control-limit (control-limit false)
-             #:with-bootstrapping? (with-bootstrapping? false))
+             #:with-bootstrapping? (with-bootstrapping? false)
+             #:as-main-module (as-main-module #f))
   (let ([m (new-machine (run-compiler code) with-bootstrapping?)])
     (let loop ([steps 0])
       (when debug?
@@ -76,7 +77,15 @@
          (step! m)
          (loop (add1 steps))]
         [else
-         (values m steps)]))))
+         (cond
+           [as-main-module
+            ;; Set the pc to the module's entry point
+            ;; Set the return point to halt on exit.
+            (invoke-module-as-main m as-main-module)
+            (set! as-main-module #f)
+            (loop (add1 steps))]
+           [else         
+            (values m steps)])]))))
 
 
 ;; Atomic expressions
@@ -1327,6 +1336,13 @@
 
 
 
+(test '(module foo racket/base
+         (printf "hello world"))
+      (make-undefined)
+      #:as-main-module 'foo)
+
+
+
 
 
 ;; begin0 is still broken.