fixing the lambda issue

whalesong/compiler/compiler.rkt

@@ -27,6 +27,7 @@
 
 (provide (rename-out [-compile compile]
                      [compile raw-compile])
+         compile-for-repl
          compile-general-procedure-call)
 
 
@@ -69,6 +70,49 @@
          (make-AssignImmediate target (make-Reg 'val)))))))
 
 
+;; Compiles an expression for the REPL.
+;; The result of the repl evaluation will be a list in the var register.
+(: compile-for-repl (Expression -> (Listof Statement)))
+(define (compile-for-repl exp)
+  (define lambda-bodies (collect-all-lambdas-with-bodies exp))
+  (define after-lam-bodies: (make-label 'afterLamBodies))
+  (define after-first-seq: (make-label 'afterFirstSeq))
+  (define last: (make-label 'last))
+  (define-values (after-pop-prompt-multiple: after-pop-prompt:)
+    (new-linked-labels 'afterPopPrompt))
+  
+  (optimize-il
+   (statements
+    (append-instruction-sequences
+     ;; Layout the lambda bodies...
+     (make-Goto (make-Label after-lam-bodies:))
+     (compile-lambda-bodies lambda-bodies)
+     
+     after-lam-bodies:
+     
+     ;; Begin a prompted evaluation:
+     (make-PushControlFrame/Prompt default-continuation-prompt-tag
+                                   after-pop-prompt:)
+     (compile exp '() 'val return-linkage/nontail)
+        
+     ;; After coming back from the evaluation, rearrange the return values
+     ;; as a list.
+     after-pop-prompt-multiple:
+     (make-TestAndJump (make-TestZero (make-Reg 'argcount)) after-first-seq:)
+     (make-PushImmediateOntoEnvironment (make-Reg 'val) #f)     
+     after-first-seq:
+     (make-Perform (make-UnspliceRestFromStack! (make-Const 0) (make-Reg 'argcount)))
+     (make-Goto (make-Label last:))
+     
+     after-pop-prompt:
+     (make-PushImmediateOntoEnvironment (make-Reg 'val) #f)
+     (make-Perform (make-UnspliceRestFromStack! (make-Const 0) (make-Const 1)))
+     
+     last:
+     (make-AssignImmediate 'val (make-EnvLexicalReference 0 #f))
+     (make-PopEnvironment (make-Const 1) (make-Const 0))))))
+
+  
 
 
 

whalesong/repl-prototype/htdocs/repl.js

@@ -66,6 +66,8 @@ $(document).ready(function() {
     };
 
 
+    // Print: Racket value -> void
+    // Prints the racket value out.
     var print = function(elt) {
 	var outputPort =
 	    M.params.currentOutputPort;
@@ -121,4 +123,21 @@ $(document).ready(function() {
                 success: onCompile,
                 error: onError});
     };
+
+
+    // Things that we need to make as automated tests:
+    //
+    // Make sure: (let () (define (f x) (f x)) (f 42))
+    // is interruptable.
+    //
+    // Test: simple expressions, functions, etc.
+    //
+    // Test: multiple value return, even zero
+    //
+    // Test: require image library, try drawing a few things.
+    //
+    // Test: compile a module.
+    //
+
+
 });

whalesong/repl-prototype/server.rkt

@@ -7,6 +7,7 @@
          racket/runtime-path
          racket/port
          racket/match
+         racket/pretty
          web-server/servlet-env
          web-server/servlet
          "../make/make-structs.rkt"
@@ -72,24 +73,12 @@
                     (define op (open-output-bytes))
                     (write raw-bytecode op)
                     (define whalesong-bytecode (parse-bytecode (open-input-bytes (get-output-bytes op))))
-                    (displayln whalesong-bytecode)
+                    (define compiled-bytecode (compile-for-repl whalesong-bytecode))
-                    (define compiled-bytecode 
+                    (pretty-print compiled-bytecode)
-                      (let ([after-first-seq (make-label 'afterFirstSeqEvaluated)])
-                        (optimize-il
-                         (statements
-                          (append-instruction-sequences
-                           (raw-compile whalesong-bytecode '() 'val next-linkage/keep-multiple-on-stack) 
-                           (make-TestAndJump (make-TestZero (make-Reg 'argcount)) after-first-seq)
-                           (make-PushImmediateOntoEnvironment (make-Reg 'val) #f)
-                           after-first-seq
-                           (make-Perform (make-UnspliceRestFromStack! (make-Const 0) (make-Reg 'argcount)))
-                           (make-AssignImmediate 'val (make-EnvLexicalReference 0 #f))
-                           (make-PopEnvironment (make-Const 1) (make-Const 0)))))))
-                    (displayln compiled-bytecode)
                     (define assembled-op (open-output-string))
                     (define assembled (assemble/write-invoke compiled-bytecode #f assembled-op))
                     (cons (get-output-string assembled-op) (loop))])))
-         (printf "assembled codes ~a\n" assembled-codes)
+         #;(printf "assembled codes ~a\n" assembled-codes)
          (write-json (hash 'compiledCodes assembled-codes)
                      op)]
         [else