a little work on the runtime.

assemble.rkt

@@ -8,9 +8,13 @@
 
 
 (define-struct basic-block (name stmts) #:transparent)
+
+
+;; fracture: (listof stmt) -> (listof basic-block)
 (define (fracture stmts)
   (let* ([first-block-label (make-label 'start)]
-         [headers (cons first-block-label (collect-headers stmts))])
+         [jump-targets 
+          (cons first-block-label (collect-general-jump-targets stmts))])
     (let loop ([name first-block-label]
                [acc '()]
                [basic-blocks '()]
@@ -22,7 +26,7 @@
                         basic-blocks))]
         [(symbol? (car stmts))
          (cond
-           [(member (car stmts) headers)
+           [(member (car stmts) jump-targets)
             (loop (car stmts)
                   '()
                   (cons (make-basic-block name  
@@ -47,6 +51,7 @@
                (tagged-list? (car stmts) 'goto))]))))
 
 
+
 ;; unique: (listof symbol -> listof symbol)
 (define (unique los)
   (let ([ht (make-hasheq)])
@@ -56,9 +61,9 @@
       k)))
 
 
-;; collect-headers: (listof stmt) -> (listof label)
+;; collect-general-jump-targets: (listof stmt) -> (listof label)
 ;; collects all the labels that are potential targets for GOTOs or branches.
-(define (collect-headers stmts)
+(define (collect-general-jump-targets stmts)
   (define (collect-input an-input)
     (cond
       [(reg? an-input)
@@ -114,6 +119,71 @@
 
 
 
+;; collect-indirect-jump-targets: (listof stmt) -> (listof label)
+;; collects the labels that are potential targets for GOTOs or branches from
+;; indirect jumps.
+;; The only interesting case should be where there's a register assignment
+;; whose value is a label.
+(define (collect-indirect-jump-targets stmts)
+  (define (collect-input an-input)
+    (cond
+      [(reg? an-input)
+       empty]
+      [(const? an-input)
+       empty]
+      [(label? an-input)
+       empty]
+      [else (error 'collect-input "~e" an-input)]))
+  (define (collect-location a-location)
+    (cond
+      [(reg? a-location)
+       empty]
+      [(label? a-location)
+       empty]
+      [else 
+       (error 'collect-location "~e" a-location)]))
+  (unique
+   (let loop ([stmts stmts])
+     (cond [(empty? stmts)
+            empty]
+           [else
+            (let ([stmt (first stmts)])
+              (append (cond
+                        [(symbol? stmt)
+                         empty]
+                        [(tagged-list? stmt 'assign)
+                         (cond 
+                           [(reg? (caddr stmt))
+                            empty]
+                           [(label? (caddr stmt))
+                            ;; Watch assignments of labels into registers.
+                            (list (label-name (caddr stmt)))]
+                           [(const? (caddr stmt))
+                            empty]
+                           [(op? (caddr stmt))
+                            empty]
+                           [else
+                            (error 'assemble "~a" stmt)])]
+                        [(tagged-list? stmt 'perform)
+                         empty]
+                        [(tagged-list? stmt 'test)
+                         empty]
+                        [(tagged-list? stmt 'branch)
+                         empty]
+                        [(tagged-list? stmt 'goto)
+                         empty]
+                        [(tagged-list? stmt 'save)
+                         empty]
+                        [(tagged-list? stmt 'restore)
+                         empty]
+                        [else
+                         (error 'assemble "~a" stmt)])
+                      (loop (rest stmts))))]))))
+
+
+
+
+
 ;; assemble-basic-block: basic-block -> string
 (define (assemble-basic-block a-basic-block)
   (format "var ~a=function(){\nif(--MACHINE.callsBeforeTrampoline < 0) { throw ~a; }\n~a};"

cm.rkt

@@ -479,13 +479,14 @@
          (fracture (statements (compile source-code
                                         '()
                                         'val
-                                        'next)))])
+                                        'return)))])
     (printf "var invoke = function(MACHINE, k) {\n")
     (for-each (lambda (basic-block)
                 (displayln (assemble-basic-block basic-block))
                 (newline))
               basic-blocks)
-    (printf "_harness(~a, k); };\n"
+    (printf "MACHINE.cont = k;\n")
+    (printf "trampoline(~a, function() {}); };\n"
             (basic-block-name (first basic-blocks)))))
 
 

runtime.js

@@ -17,8 +17,16 @@ var TopEnvironment = function() {
             return argl[0] + argl[1][0];
         },
 
+        '*': function(argl) {
+            return argl[0] * argl[1][0];
+        },
+
 	'-': function(argl) {
             return argl[0] - argl[1][0];
+        },
+	
+	'/': function(argl) {
+	    return argl[0] / argl[1][0];
 	}
     };
     this.valss = [];
@@ -44,6 +52,44 @@ var Closure = function(env, label) {
 };
 
 
+// adaptToJs: closure -> (array (X -> void) -> void)
+// Converts closures to functions that can be called from the
+// JavaScript toplevel.
+Closure.adaptToJs = function() {
+    return function(args, k) {
+        var oldEnv = MACHINE.env;
+	var oldCont = MACHINE.cont;
+	var oldProc = MACHINE.proc;
+	var oldArgl = MACHINE.argl;
+	var oldVal = MACHINE.val;
+	trampoline(
+	    function() {
+		var proc = _envLookup("gauss", MACHINE.env);
+		MACHINE.proc = proc;
+		MACHINE.argl = undefined;
+		for(var i = args.length - 1; i >= 0; i--) {
+		    MACHINE.argl = _list(args[i], MACHINE.argl);
+		}
+		
+		MACHINE.cont = function() {
+		    var result = MACHINE.val;
+                    MACHINE.env = oldEnv;
+		    MACHINE.cont = oldCont;
+		    MACHINE.proc = oldProc;
+		    MACHINE.argl = oldArgl;
+		    MACHINE.val = oldVal;
+                    k(result);
+		};
+		
+		_closureEntry(proc)();
+            },
+            function() {
+            });
+    }
+};
+
+
+
 var MACHINE={callsBeforeTrampoline: 100, 
              env: new TopEnvironment(),
              proc:undefined, 
@@ -54,20 +100,17 @@ var MACHINE={callsBeforeTrampoline: 100,
 
 
 // harness: (->) (->) -> void
-var _harness = function(thunk, k) {
+var trampoline = function(initialJump, k) {
-    var toCall;
+    var thunk = initialJump;
     MACHINE.callsBeforeTrampoline = 100;
     while(thunk) {
         try {
-            toCall = thunk;
+            thunk();
-            thunk = undefined;
+	    break;
-            toCall();
         } catch (e) {
             if (typeof(e) === 'function') {
                 thunk = e;
                 MACHINE.callsBeforeTrampoline = 100;
-            } else if (e === 'done') {
-                break;
             } else {
 	        throw e;
             }

structs.rkt

@@ -78,8 +78,11 @@
 
 (define empty-instruction-sequence (make-instruction-sequence '() '() '()))
 
-(define (make-label l)
+(define make-label
-  (gensym l))
+  (let ([n 0])
+    (lambda (l)
+      (set! n (add1 n))
+      (string->symbol (format "~a~a" l n)))))
 
 
 (define (registers-needed s)