Step 8: Procedure Calls

1 files changed, 109 insertions, 14 deletions

diff --git a/compiler.scm b/compiler.scm
index ab76e20..f890276 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -40,6 +40,10 @@
 (define (variable? x)
   (symbol? x))
 
+(define (if? x)
+  (and (pair? x)
+       (eq? (first x) 'if)))
+
 (define (let? x)
   (and (pair? x)
        (eq? (first x) 'let)))
@@ -57,9 +61,17 @@
                make-vector vector vector-length vector-ref vector-set!
                make-string string string-length string-ref string-set!))))
 
-(define (if? x)
+(define (labels? x)
   (and (pair? x)
-       (eq? (first x) 'if)))
+       (eq? (first x) 'labels)))
+
+(define (code? x)
+  (and (pair? x)
+       (eq? (first x) 'code)))
+
+(define (labelcall? x)
+  (and (pair? x)
+       (eq? (first x) 'labelcall)))
 
 (define (primcall-op x)
   (first x))
@@ -77,8 +89,8 @@
   (or (assq-ref env name)
       (error "unbound variable:" name)))
 
-(define (extend-env name si env)
-  (cons (cons name si) env))
+(define (extend-env name si-or-label env)
+  (cons (cons name si-or-label) env))
 
 (define (bindings x)
   (second x))
@@ -86,6 +98,12 @@
 (define (body x)
   (third x))
 
+(define (lhs b)
+  (first b))
+
+(define (rhs b)
+  (second b))
+
 (define (test x)
   (second x))
 
@@ -95,6 +113,12 @@
 (define (alternate x)
   (fourth x))
 
+(define (lvar x)
+  (second x))
+
+(define (arguments x)
+  (drop x 2))
+
 (define unique-counter (make-parameter 0))
 
 (define (unique-label)
@@ -179,6 +203,12 @@
 (define (emit-jmp label)
   (emit "jmp ~a" label))
 
+(define (emit-call label)
+  (emit "call ~a" label))
+
+(define (emit-ret)
+  (emit "ret"))
+
 (define (emit-label label)
   (format #t "~a:\n" label))
 
@@ -437,10 +467,6 @@
      (error "unknown primcall op" (primcall-op x)))))
 
 (define (emit-let bindings body si env)
-  (define (lhs b)
-    (first b))
-  (define (rhs b)
-    (second b))
   (let loop ((b* bindings) (new-env env) (si si))
     (if (null? b*)
         (emit-expr body si new-env)
@@ -463,25 +489,90 @@
     (emit-expr altern si env)
     (emit-label L1)))
 
+(define (emit-code label vars body env)
+  (emit-label label)
+  (let loop ((vars vars)
+             (env env)
+             (si (- wordsize)))
+    (if (null? vars)
+        (begin
+          (emit-expr body si env)
+          (emit-ret))
+        (loop (cdr vars)
+              (extend-env (first vars) si env)
+              (- si wordsize)))))
+
+(define (emit-labels lvars body-exp si env)
+  (let* ((lvars* (map (lambda (lvar)
+                        (cons (unique-label) lvar))
+                      lvars))
+         (env* (fold (lambda (lvar env)
+                       (let ((label (first lvar))
+                             (name (second lvar)))
+                         (extend-env name label env)))
+                     env lvars*)))
+    (for-each (lambda (lvar)
+                (let ((label (first lvar))
+                      (code (third lvar)))
+                  (if (code? code)
+                      (emit-code label (bindings code) (body code) env*)
+                      (error "expected a code expression" code))))
+              lvars*)
+    (emit-label "scheme_entry")
+    (emit-expr body-exp si env*)
+    (emit-ret)))
+
+(define (emit-labelcall lvar args si env)
+  (let ((label (lookup lvar env)))
+    (let loop ((args args)
+               (si* (- si wordsize)))
+      (if (null? args)
+          ;; The stack pointer needs to be advanced to one word below
+          ;; the return point of the upcoming call.  Our stack index
+          ;; value starts at (- wordsize).  The 'call' instruction
+          ;; automatically increments the stack pointer by a word.
+          ;; So, if we incremented by the stack index, we'd be moving
+          ;; too far.  We need to advance by one less word.  In the
+          ;; case where nothing has been allocated to the stack before
+          ;; the call, it means not incrementing the stack pointer at
+          ;; all!  Took me awhile to wrap my head around this!
+          (let ((stack-start (+ si wordsize)))
+            (unless (zero? stack-start)
+              (emit-add (immediate stack-start) rsp))
+            (emit-call label)
+            (unless (zero? stack-start)
+              (emit-sub (immediate stack-start) rsp)))
+          (begin
+            (emit-expr (first args) si* env)
+            (emit-mov rax (offset si* rsp))
+            (loop (cdr args)
+                  (- si* wordsize)))))))
+
 (define (emit-expr x si env)
   (cond
    ((immediate? x)
     (emit-mov (immediate (immediate-rep x)) rax))
    ((variable? x)
     (emit-mov (offset (lookup x env) rsp) rax))
+   ((if? x)
+    (emit-if (test x) (consequent x) (alternate x) si env))
    ((let? x)
     (emit-let (bindings x) (body x) si env))
    ((primcall? x)
     (emit-primitive-call x si env))
-   ((if? x)
-    (emit-if (test x) (consequent x) (alternate x) si env))
+   ((labels? x)
+    (emit-labels (bindings x) (body x) si env))
+   ((labelcall? x)
+    (emit-labelcall (lvar x) (arguments x) si env))
    (else
     (error "unknown expression" x))))
 
 (define (compile-program x)
   (parameterize ((unique-counter 0))
-    (emit-expr x (- wordsize) '())
-    (emit "ret")))
+    (let ((x* (if (labels? x)
+                  x
+                  `(labels () ,x))))
+      (emit-expr x* (- wordsize) '()))))
 
 (define (compile-and-run x)
   (with-output-to-file "scheme_entry.s"
@@ -490,7 +581,6 @@
 .p2align 4
 .globl	scheme_entry
 .type	scheme_entry, @function
-scheme_entry:
 ")
       (compile-program x)))
   (unless (zero? (system* "gcc" "-c" "scheme_entry.s"))
@@ -570,4 +660,9 @@ scheme_entry:
   (test-case '(vector-length (make-vector 3)) "3")
   (test-case '(vector-ref (vector 1 2 3) 1) "2")
   (test-case '(string-length (make-string 5)) "5")
-  (test-case '(string-ref (string #\a #\b #\c) 1) "b"))
+  (test-case '(string-ref (string #\a #\b #\c) 1) "b")
+  (test-case '(labels ((perimeter (code (length width)
+                                        (+ (* length 2)
+                                           (* width 2)))))
+                      (labelcall perimeter 4 3))
+             "14"))