From 61a245e4b4530a7309df95e4f5d49fa8b5854c74 Mon Sep 17 00:00:00 2001
From: Danny Yoo <dyoo@cs.wpi.edu>
Date: Tue, 8 Feb 2011 17:02:54 -0500
Subject: [PATCH] all the operations should be open-coded to reduce procedure
 calls.

---
 cm.rkt     | 270 +++++++++++++++++++++++++++++++++++++----------------
 runtime.js | 103 +++++++-------------
 2 files changed, 222 insertions(+), 151 deletions(-)

diff --git a/cm.rkt b/cm.rkt
index a1815e4..a0be5d5 100644
--- a/cm.rkt
+++ b/cm.rkt
@@ -31,7 +31,16 @@
           [else
            (loop (rest cenv) (add1 depth))])))
 
-  
+;; global-lexical-address?: lexical-address -> boolean
+;; Produces true if the address refers to the toplevel environment.
+(define (global-lexical-address? address)
+  (eq? address 'not-found))
+
+
+;; extend-lexical-environment: lexical-environment (listof symbol) -> lexical-envrionment
+(define (extend-lexical-environment cenv names)
+  (cons names cenv))
+
 
 
 
@@ -97,39 +106,73 @@
 
 
 (define (compile-variable exp cenv target linkage)
-  ;; FIXME: must find lexical address
-  (end-with-linkage linkage
-                    (make-instruction-sequence
-                     '(env)
-                     (list target)
-                     `((assign ,target
-                               (op lookup-variable-value)
-                               (const ,exp)
-                               (reg env))))))
+  (let ([lexical-pos (find-variable exp cenv)])
+    (cond
+      [(global-lexical-address? lexical-pos)
+       (end-with-linkage linkage
+                         (make-instruction-sequence
+                          '(env)
+                          (list target)
+                          ;; Slight modification: explicitly testing for
+                          ;; global variable binding before lookup.
+                          `((perform (op check-bound-global!)
+                                     (const ,exp)
+                                     (reg env))
+                            (assign ,target
+                                    (op lookup-variable-value)
+                                    (const ,exp)
+                                    (reg env)))))]
+      [else
+       (end-with-linkage linkage
+                         (make-instruction-sequence
+                          '(env)
+                          (list target)
+                          `((assign ,target
+                                    (op lexical-address-lookup)
+                                    (const ,(first lexical-pos))
+                                    (const ,(second lexical-pos))
+                                    (reg env)))))])))
 
 
 
 (define (compile-assignment exp cenv target linkage)
-  ;; FIXME: must find lexical address
-  (let ([var (assignment-variable exp)]
-        [get-value-code
-         (compile (assignment-value exp) cenv 'val 'next)])
-    (end-with-linkage
-     linkage
-     (preserving '(env)
-                 get-value-code
-                 (make-instruction-sequence
-                  '(env val)
-                  (list target)
-                  `((perform (op set-variable-value!)
-                             (const ,var)
-                             (reg val)
-                             (reg env))
-                    (assign ,target (const ok))))))))
+  (let* ([var (assignment-variable exp)]
+         [get-value-code
+          (compile (assignment-value exp) cenv 'val 'next)]
+         [lexical-address
+          (find-variable var cenv)])
+    (cond
+      [(global-lexical-address? lexical-address)
+       (end-with-linkage
+        linkage
+        (preserving '(env)
+                    get-value-code
+                    (make-instruction-sequence
+                     '(env val)
+                     (list target)
+                     `((perform (op set-variable-value!)
+                                (const ,var)
+                                (reg val)
+                                (reg env))
+                       (assign ,target (const ok))))))]
+      [else
+       (end-with-linkage
+        linkage
+        (preserving '(env)
+                    get-value-code
+                    (make-instruction-sequence
+                     '(env val)
+                     (list target)
+                     `((perform (op lexical-address-set!)
+                                (const ,(first lexical-address))
+                                (const ,(second lexical-address))
+                                (reg env)
+                                (reg val))
+                       (assign ,target (const ok))))))])))
 
 
+;; FIXME: exercise 5.43
 (define (compile-definition exp cenv target linkage)
-  ;; FIXME: must find lexical address
   (let ([var (definition-variable exp)]
         [get-value-code
          (compile (definition-value exp) cenv 'val 'next)])
@@ -184,7 +227,6 @@
 
 
 (define (compile-lambda exp cenv target linkage) 
-  ;; FIXME: must extend compile-time lexical environment
   (let ([proc-entry (make-label 'entry)]
         [after-lambda (make-label 'afterLambda)])
     (let ([lambda-linkage
@@ -200,14 +242,21 @@
                            `((assign ,target
                                      (op make-compiled-procedure)
                                      (label ,proc-entry)
+                                     ;; TODO: rather than capture the whole
+                                     ;; environment, we may instead
+                                     ;; just capture the free variables.
+                                     ;; But that requires that we box
+                                     ;; up all set!-ed variables, in order
+                                     ;; to preserve semantics of set!
                                      (reg env)))))
         (compile-lambda-body exp cenv
                              proc-entry))
        after-lambda))))
 
+
 (define (compile-lambda-body exp cenv proc-entry)
-  ;; FIXME: must extend compile-time lexical environment
-  (let ([formals (lambda-parameters exp)])
+  (let* ([formals (lambda-parameters exp)]
+         [extended-cenv (extend-lexical-environment cenv formals)])
     (append-instruction-sequences
      (make-instruction-sequence 
       '(env proc argl)
@@ -216,10 +265,9 @@
         (assign env (op compiled-procedure-env) (reg proc))
         (assign env
                 (op extend-environment)
-                (const ,formals)
                 (reg argl)
                 (reg env))))
-     (compile-sequence (lambda-body exp) cenv 'val 'return))))
+     (compile-sequence (lambda-body exp) extended-cenv 'val 'return))))
 
 
 (define (compile-application exp cenv target linkage) 
@@ -263,7 +311,7 @@
         (preserving '(env)
                     code-for-next-arg
                     (code-to-get-rest-args (cdr operand-codes))))))
-              
+
 
 (define (compile-procedure-call target linkage)
   (let ([primitive-branch (make-label 'primitiveBranch)]
@@ -325,9 +373,9 @@
         [(and (not (eq? target 'val))
               (eq? linkage 'return))
          (error 'compile "return linkage, target not val: ~s" target)]))
-                   
-            
-             
+
+
+
 
 
 
@@ -373,10 +421,10 @@
                                  `((restore ,first-reg))))
                         seq2)
             (preserving (cdr regs) seq1 seq2)))))
-            
-  
-  
-  
+
+
+
+
 (define (append-instruction-sequences . seqs)
   (define (append-2-sequences seq1 seq2)
     (make-instruction-sequence
@@ -517,10 +565,10 @@
        (loop (car stmts)
              '()
              (cons (make-basic-block name  
-                               (if last-stmt-goto? 
-                                   (reverse acc)
-                                   (reverse (append `((goto (label ,(car stmts))))
-                                                    acc))))
+                                     (if last-stmt-goto? 
+                                         (reverse acc)
+                                         (reverse (append `((goto (label ,(car stmts))))
+                                                          acc))))
                    basic-blocks)
              (cdr stmts)
              (tagged-list? (car stmts) 'goto))]
@@ -577,17 +625,17 @@
        [(op? (caddr stmt))
         (format "MACHINE.~a=~a;" 
                 (cadr stmt)
-                (assemble-op-call (op-name (caddr stmt))
-                                  (cdddr stmt)))]
+                (assemble-op-expression (op-name (caddr stmt))
+                                        (cdddr stmt)))]
        [else
         (error 'assemble "~a" stmt)])]
     [(tagged-list? stmt 'perform)
-     (assemble-op-call (op-name (cadr stmt))
-                       (cddr stmt))]
+     (assemble-op-statement (op-name (cadr stmt))
+                            (cddr stmt))]
     [(tagged-list? stmt 'test)
      (format "if(~a){"
-             (assemble-op-call (op-name (cadr stmt))
-                               (cddr stmt)))]
+             (assemble-op-expression (op-name (cadr stmt))
+                                     (cddr stmt)))]
     [(tagged-list? stmt 'branch)
      (format "if(--MACHINE.callsBeforeTrampoline){return ~a()}else{throw ~a}}"
              (assemble-location (cadr stmt))
@@ -615,29 +663,87 @@
           [else
            (format "~s" val)])))
 
-(define (assemble-op-call op-name inputs)
-  (case op-name
-    [(compiled-procedure-entry)
-     (format "~a.label" (assemble-input (first inputs)))]
-    [(compiled-procedure-env)
-     (format "~a.env" (assemble-input (first inputs)))]
-    [else
-     (format "~a(~a)"
-             (case op-name
-               
-               [(lookup-variable-value) "_envLookup"]
-               [(set-variable-value!) "_envSet"]
-               [(define-variable!) "_envDefine"]
-               [(extend-environment) "_envExtend"]
-               
-               [(false?) "_isFalse"]
-               [(make-compiled-procedure) "_makeClosure"]
-               [(list) "_list"]
-               [(cons) "_cons"]
-               [(primitive-procedure?) "_isPrimProc"]
-               [(apply-primitive-procedure) "_applyPrimProc"]
-               [else (error 'assemble "~e" op-name)])
-             (string-join (map assemble-input inputs) ","))]))
+(define (assemble-op-expression op-name inputs)
+  (let ([assembled-inputs (map assemble-input inputs)])
+    (case op-name
+      ;; open coding some of the primitive operations:
+      [(compiled-procedure-entry)
+       (format "(~a.label)" (assemble-input (first inputs)))]
+      [(compiled-procedure-env)
+       (format "(~a.env)" (assemble-input (first inputs)))]
+      [(make-compiled-procedure)
+       (format "(new Closure(~a, ~a))"
+               (second assembled-inputs)
+               (first assembled-inputs))]
+      [(false?)
+       (format "(!(~a))" (assemble-input (first inputs)))]
+      [(cons)
+       (format "[~a]" (string-join (map assemble-input inputs) ","))]
+      [(list)
+       (cond [(empty? inputs)
+              "undefined"]
+             [else
+              (let loop ([assembled-inputs assembled-inputs])
+                (cond
+                  [(empty? assembled-inputs)
+                   "undefined"]
+                  [else
+                   (format "[~a, ~a]"
+                           (first assembled-inputs)
+                           (loop (rest assembled-inputs)))]))])]
+      [(apply-primitive-procedure)
+       (format "~a(~a)" 
+               (first assembled-inputs)
+               (second assembled-inputs))]
+      [(lexical-address-lookup)
+       (format "(~a).valss[~a][~a]"
+               (third assembled-inputs)
+               (first assembled-inputs)
+               (second assembled-inputs))]
+      [(primitive-procedure?)
+       (format "(typeof(~a) === 'function')"
+               (first assembled-inputs))]
+      [(extend-environment)
+       (format "(new ExtendedEnvironment(~a, ~a)"
+               (second assembled-inputs)
+               (first assembled-inputs))]
+      [(lookup-variable-value)
+       (format "((~a).globalBindings[~a])"
+               (second assembled-inputs)
+               (first assembled-inputs))]
+      [else
+       (error 'assemble "~e" op-name)])))
+
+
+(define (assemble-op-statement op-name inputs)
+  (let ([assembled-inputs (map assemble-input inputs)])
+    (case op-name
+      [(define-variable!)
+       (format "(~a).globalBindings[~a] = ~a;"
+               (third assembled-inputs)
+               (first assembled-inputs)
+               (second assembled-inputs))]
+      [(set-variable-value!)
+       (format "(~a).globalBindings[~a] = ~a;"
+               (third assembled-inputs)
+               (first assembled-inputs)
+               (second assembled-inputs))]
+      [(lexical-address-set!)
+       (format "(~a).valss[~a][~a] = ~a;"
+               (third assembled-inputs)
+               (first assembled-inputs)
+               (second assembled-inputs)
+               (fourth assembled-inputs))]
+      [(check-bound-global!)
+       (format "if (! (~a).globalBindings.hasOwnProperty(~a)) { throw new Error('Not bound: ~a') }"
+               (second assembled-inputs)
+               (first assembled-inputs)
+               (first assembled-inputs))]
+      [else
+       (error 'assemble-op-statement "~a" op-name)])))
+
+
+
 
 (define (assemble-input an-input)
   (cond
@@ -663,7 +769,7 @@
 (define (assemble-label a-label)
   (symbol->string (cadr a-label)))
 
- 
+
 
 
 
@@ -683,10 +789,10 @@
 
 
 #;(test '(define (factorial n)
-         (if (= n 0)
-             1
-             (* (factorial (- n 1))
-                n))))
+           (if (= n 0)
+               1
+               (* (factorial (- n 1))
+                  n))))
 (test '(define (gauss n)
          (if (= n 0)
              0
@@ -694,7 +800,7 @@
                 n))))
 
 #;(test '(define (fib m)
-         (if (< n 2)
-             1
-             (+ (fib (- n 1))
-                (fib (- n 2))))))
\ No newline at end of file
+           (if (< n 2)
+               1
+               (+ (fib (- n 1))
+                  (fib (- n 2))))))
\ No newline at end of file
diff --git a/runtime.js b/runtime.js
index 974e4a6..6c9e76c 100644
--- a/runtime.js
+++ b/runtime.js
@@ -1,84 +1,49 @@
+// Type representations:
+//
+// number are numbers
+//
+// cons pairs are [first, rest]
+// 
+// function closures are Closures
+// primitive procedures are regular functions.
+
 var TopEnvironment = function() {
-    this.bindings = {'=': 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.parent = undefined;
+    this.globalBindings = {
+	'=': 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 = [];
 };
 
-var ExtendedEnvironment = function(parent) {
-    this.bindings = {};
-    this.parent = parent;
+var ExtendedEnvironment = function(parent, vs) {
+    var vals = [];
+    while(vs) {
+	vals.push(vs[0]);
+	vs = vs[1];
+    }
+    this.valss = parent.valss.slice();
+    this.valss.shift(vals);
+    this.globalBindings = parent.globalBindings;
 };
 
 
+// A closure consists of its free variables as well as a label
+// into its text segment.
 var Closure = function(env, label) {
     this.env = env;
     this.label = label;
 };
 
 
-var _isFalse = function(x) { if(x) return false; return true; }
-var _isPrimProc = function(x) { return typeof(x) === 'function'; };
-var _applyPrimProc = function(p, argl) { return p(argl); }
-var _closureEnv = function(c) { return c.env; }
-var _closureEntry = function(c) { return c.label; }
-var _makeClosure = function(l, e) { return new Closure(e, l); }
-var _envDefine = function(n, v, e) {
-    e.bindings[n] = v;
-};
-var _envExtend = function(ns, vs, e) {
-    var e2 = new ExtendedEnvironment(e);
-    while(ns) {
-        e2.bindings[ns[0]] = vs[0];
-        ns = ns[1]; vs = vs[1];
-    }
-    return e2;
-};
-var _envLookup = function(n, e) {
-    while (e) {
-        if (e.bindings.hasOwnProperty(n)) { 
-	    return e.bindings[n]; 
-	}
-        e = e.parent;
-    }
-    throw new Error("Not bound: " + n);
-};
-
-
-//////////////////////////////////////////////////////////////////////
-// Lexical addressing
-var _lexicalAddressLookup = function(depth, pos, env) {
-    // FIXME
-};
-
-var _lexicalAddressAssign = function(depth, pos, env, value) {
-    // FIXME
-};
-
-//////////////////////////////////////////////////////////////////////
-
-
-
-
-
-var _cons = function(x, y) { return [x, y]; }
-var _list = function() {
-    var i;
-    var result;
-    for (i = arguments.length - 1; i >= 0; i--) {
-        result = [arguments[i], result];
-    }
-    return result;
-}
-
-
 var MACHINE={callsBeforeTrampoline: 100, 
              env: new TopEnvironment(),
              proc:undefined,