Merge remote branch 'origin/master'

bootstrapped-primitives.rkt

@@ -4,11 +4,13 @@
          "il-structs.rkt"
          "compiler.rkt"
          "compiler-structs.rkt"
-         "typed-parse.rkt")
+         "typed-parse.rkt"
+         "where-is-collects.rkt")
 
 (require/typed "parameters.rkt"
                (current-defined-name (Parameterof (U Symbol LamPositionalName))))
-
+(require/typed "parse-bytecode.rkt"
+               (parse-bytecode (Path -> Expression)))
 
 
 
@@ -17,6 +19,17 @@
 
 
 
+
+;; We'll hardcode the compilation of some Racket modules here.
+(: hardcoded-modules-to-compile (Listof Path))
+(define hardcoded-modules-to-compile
+  (list
+   (build-path collects-path "racket" "private" "modbeg.rkt")
+   ))
+
+
+
+
 ;; The primitive code necessary to do call/cc
 
 (: call/cc-label Symbol)
@@ -85,7 +98,16 @@
 (define (get-bootstrapping-code)
   
   (append
+
+   ;; module code
+   (apply append (map (lambda: ([p : Path])
+                               (compile (parse-bytecode p)
+                                        'val
+                                        next-linkage/drop-multiple))
+                      hardcoded-modules-to-compile))
+
    
+   ;; Other primitives
    (make-bootstrapped-primitive-code 
     'map 
     '(letrec ([map (lambda (f l)

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,11 @@
 				    'values
 				    'call-with-values
                                     'apply
+                                    'printf
+                                    
+                                    'map
+                                    'for-each
+                                    'current-print
                                     ))
 (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)

parse-bytecode-5.1.1.rkt

@@ -30,9 +30,9 @@
    (lambda (mpi relative-to)
      (cond
        [(eq? mpi #f)
-        'self]
+        (current-module-path)]
        [(self-module-path-index? mpi)
-        'self]
+        (current-module-path)]
        [else
         (resolve-module-path-index mpi relative-to)]))))
 
@@ -121,6 +121,11 @@
      (parameterize ([seen-closures (make-hasheq)])
        (let ([compilation-top (zo-parse in)])
          (parse-top compilation-top)))]
+    
+    [(compiled-expression? in)
+     (let ([op (open-output-bytes)])
+       (write in op)
+       (parse-bytecode (open-input-bytes (get-output-bytes op))))]
 
     [(path? in)
      (let*-values ([(normal-path) (normalize-path in)]
@@ -144,8 +149,32 @@
 (define (parse-top a-top)
   (match a-top
     [(struct compilation-top (max-let-depth prefix code))
-     (make-Top (parse-prefix prefix) 
+     (maybe-fix-module-name
-               (parse-top-code code))]))
+      (make-Top (parse-prefix prefix) 
+                (parse-top-code code)))]))
+
+
+
+;; maybe-fix-module-name: expression -> expression
+;; When we're compiling a module directly from memory, it doesn't have a file path.
+;; We rewrite the ModuleName to its given name.
+(define (maybe-fix-module-name exp)
+  (match exp
+    [(struct Top (top-prefix 
+                  (struct Module ((and name (? symbol?))
+                                  (struct ModuleName ('self 'self))
+                                  module-prefix
+                                  module-requires
+                                  module-code))))
+     (make-Top top-prefix
+               (make-Module name
+                            (make-ModuleName name name) (current-module-path)
+                            module-prefix
+                            module-requires
+                            module-code))]
+    [else
+     exp]))
+
 
 
 (define (parse-prefix a-prefix)
@@ -197,7 +226,8 @@
           (make-ModuleName (rewrite-path resolved-path-name)
                            (normalize-path resolved-path-name))]
          [else
-          (error 'wrap-module-name "Unable to resolve module path ~s" resolved-path-name)]))]))
+          (error 'wrap-module-name "Unable to resolve module path ~s."
+                 resolved-path-name)]))]))
           
        
 

parse-bytecode.rkt

@@ -1,11 +1,32 @@
 #lang racket/base
 (require "version-case/version-case.rkt"
+         racket/file
+         (prefix-in whalesong: "version.rkt")
          (for-syntax racket/base))
 
 (version-case
   [(version>= (version) "5.1.1")
    (begin      
      (require "parse-bytecode-5.1.1.rkt")
-     (provide (all-from-out "parse-bytecode-5.1.1.rkt")))]
+     (provide (except-out (all-from-out "parse-bytecode-5.1.1.rkt")
+                          parse-bytecode)))]
   [else
-   (error 'parse-bytecode "Whalesong doesn't have a compatible parser for Racket ~a" (version))])
+   (error 'parse-bytecode "Whalesong doesn't have a compatible parser for Racket ~a" (version))])
+
+
+(provide (rename-out [my-parse-bytecode parse-bytecode]))
+
+
+(define (my-parse-bytecode x)
+  (cond
+    [(path? x)
+     (parse-bytecode x)]
+    [else
+     (parse-bytecode x)]))
+
+
+(define cache-dir (build-path (find-system-path 'pref-dir)
+                              "whalesong"
+                              whalesong:version))
+(unless (directory-exists? cache-dir)
+  (make-directory* cache-dir))

path-rewriter.rkt

@@ -1,6 +1,7 @@
 #lang racket/base
 
 (require "parameters.rkt"
+         "where-is-collects.rkt"
          racket/path
          racket/contract
          racket/list
@@ -34,7 +35,7 @@
       (string->symbol
        (string-append "collects/"
                       (path->string
-                       (find-relative-path collects a-path))))]
+                       (find-relative-path collects-path a-path))))]
      [(within-this-project-path? a-path)
       (string->symbol
        (string-append "whalesong/"
@@ -49,24 +50,14 @@
       #f])))
 
 
-(define collects
+       
-  (normalize-path
-   (let ([p (find-system-path 'collects-dir)])
-     (cond
-      [(relative-path? p)
-       (find-executable-path (find-system-path 'exec-file)
-                             (find-system-path 'collects-dir))]
-      [else
-       p]))))
-        
-
 
 (define (within-root? a-path)
   (within? (current-root-path) a-path))
 
 
 (define (within-collects? a-path)
-  (within? collects a-path))
+  (within? collects-path a-path))
 
 
 (define (within-this-project-path? a-path)

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)
@@ -425,6 +453,9 @@
           
           
           [(InstallModuleEntry!? op)
+           (printf "installing module ~s\n"
+                   (ModuleName-name 
+                    (InstallModuleEntry!-path op)))
            (hash-set! (machine-modules m)
                       (ModuleName-name (InstallModuleEntry!-path op))
                       (make-module-record (InstallModuleEntry!-name op)
@@ -771,10 +802,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 +821,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

@@ -3,7 +3,11 @@
 (require "../simulator/simulator.rkt"
          "../simulator/simulator-structs.rkt"
          "../simulator/simulator-helpers.rkt"
-         "test-helpers.rkt")
+         "../parameters.rkt"
+         "test-helpers.rkt"
+         racket/runtime-path)
+
+(define-runtime-path this-test-path ".")
 
   
 
@@ -54,7 +58,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 +81,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
@@ -1326,12 +1339,20 @@
       #:with-bootstrapping? #t)
 
 
+(parameterize ([current-module-path (build-path this-test-path "foo.rkt")])
+  (test '(module foo racket/base
+           (printf "hello world"))
+        (make-undefined)
+        #:as-main-module 'whalesong/tests/foo.rkt
+        #:with-bootstrapping? #t))
+
+
 
 
 
 ;; begin0 is still broken.
 
-#;(test '(letrec ([f (lambda (x)
+(test '(letrec ([f (lambda (x)
                      (if (= x 0)
                          0
                          (+ x (f (sub1 x)))))])
@@ -1341,14 +1362,14 @@
 
 
 
-#;(test '(let () (define (f x y z)
+(test '(let () (define (f x y z)
                  (values y x z))
            (call-with-values (lambda () (f 3 1 4))
                              (lambda args (list args))))
         '((1 3 4))
         #:with-bootstrapping? #t)
 
-#;(test '(let () (define (f x y z)
+(test '(let () (define (f x y z)
                  (begin0 (values y x z)
                          (display "")))
            (call-with-values (lambda () (f 3 1 4))

tests/test-parse-bytecode.rkt

@@ -3,12 +3,15 @@
 (require compiler/zo-parse
          rackunit
          racket/match
+         racket/path
          "../parameters.rkt"
          "../parse-bytecode.rkt"
          "../lexical-structs.rkt"
          "../expression-structs.rkt"
+         racket/runtime-path
          (for-syntax racket/base))
 
+(define-runtime-path this-test-path ".")
 
 (define (run-zo-parse stx)
   (parameterize ([current-namespace (make-base-namespace)]
@@ -398,7 +401,30 @@
                    (#%provide f))))
               
 
-(check-true
+(parameterize ([current-root-path this-test-path]
+               [current-module-path (build-path this-test-path "foo.rkt")])
+  (check-true
+   (match (run-my-parse #'(module foo racket/base))
+     [(struct Top ((? Prefix?)
+                   (struct Module ('foo
+                                   (struct ModuleName 
+                                     ('whalesong/tests/foo.rkt
+                                      (? (lambda (p)
+                                           (and (path? p)
+                                                (equal? (normalize-path p)
+                                                        (normalize-path 
+                                                         (build-path this-test-path "foo.rkt"))))))))
+                                      
+                                   (struct Prefix (list))
+                                   (list (struct ModuleName ('collects/racket/base.rkt
+                                                             _)))
+                                   (struct Splice ('()))))))
+      #t]
+     [else
+      #f])))
+
+
+#;(check-true
  (match (parameterize ([current-root-path (build-path "/blah")]
                        [current-module-path (build-path "/blah" "foo" "bar.rkt")])
                 (run-my-parse '(module foo '#%kernel

version.rkt

@@ -0,0 +1,4 @@
+#lang typed/racket/base
+(provide version)
+(: version String)
+(define version "1.0")

where-is-collects.rkt

@@ -0,0 +1,18 @@
+#lang typed/racket/base
+(require/typed racket/path
+               (normalize-path (Path -> Path)))
+(require/typed typed/racket/base
+               (relative-path? (Any -> Boolean))
+               (find-executable-path (Path Path -> Path)))
+
+(provide collects-path)
+
+(define collects-path
+  (normalize-path
+   (let ([p (find-system-path 'collects-dir)])
+     (cond
+      [(relative-path? p)
+       (find-executable-path (find-system-path 'exec-file)
+                             (find-system-path 'collects-dir))]
+      [else
+       p]))))