Add ast-traverse helper

[scheme.git] / codegen.scm

diff --git a/codegen.scm b/codegen.scm
index 04816ab75d533b6b950ff7fe17813cfce1880383..70a8ca4aa0df75518989d386502765e90e535137 100644 (file)
--- a/codegen.scm
+++ b/codegen.scm
@@ -51,14 +51,21 @@
         (inner-si (- si (* (length bindings) wordsize)))
         (names (map car bindings))
         (exprs (map cadr bindings))
         (inner-si (- si (* (length bindings) wordsize)))
         (names (map car bindings))
         (exprs (map cadr bindings))

-        (inner-env (append (map cons names stack-offsets) env)))
-  (for-each (lambda (expr offset)
+
+        ; recursive let bindings: build environment as we go
+        (inner-env (fold-left
+                    (lambda (env name expr offset)

                       (codegen-expr expr inner-si env)
                       (codegen-expr expr inner-si env)

-             (emit "movq %rax, ~a(%rsp)" offset))
-           exprs stack-offsets)
-  (for-each (lambda (form) (codegen-expr form inner-si inner-env)) body)))
+                      (emit "movq %rax, ~a(%rsp)" offset)
+                      (cons (cons name offset) env))
+                    env names exprs stack-offsets)))
+    (for-each (lambda (form)
+               (codegen-expr form inner-si inner-env))
+             body)))

 
 (define (codegen-var name si env)
 
 (define (codegen-var name si env)

+  (when (not (assoc name env))
+    (error #f (format "Variable ~a is not bound" name)))

   (let ((offset (cdr (assoc name env))))
     (emit "movq ~a(%rsp), %rax" offset)))
 
   (let ((offset (cdr (assoc name env))))
     (emit "movq ~a(%rsp), %rax" offset)))
 


@@ -129,10 +136,10 @@
        ))))                    ; move args and capture vars to stack
 
 (define (codegen-expr e si env)
        ))))                    ; move args and capture vars to stack
 
 (define (codegen-expr e si env)

-  (cond ((builtin? e) e)
-       ((closure? e) e)
-       
-       ((app? e)
+  (case (ast-type e)
+    ('builtin e)
+    ('closure e)
+    ('app

      (let ((callee (codegen-expr (car e) si env)))
        (case callee
         ('+ (codegen-add (cdr e) si env))
      (let ((callee (codegen-expr (car e) si env)))
        (case callee
         ('+ (codegen-add (cdr e) si env))


@@ -142,29 +149,34 @@
         ('bool->int (codegen-expr (cadr e) si env))
         (else (codegen-call callee (cdr e) si env)))))
 
         ('bool->int (codegen-expr (cadr e) si env))
         (else (codegen-call callee (cdr e) si env)))))
 

-       ((let? e) (codegen-let
-                  (let-bindings e)
+    ('let (codegen-let (let-bindings e)

                       (let-body e)
                       si
                       env))
                       (let-body e)
                       si
                       env))

-       ((var? e) (codegen-var e si env))
-       ((boolean? e) (emit "movq $~a, %rax" (if e 1 0)))
-       (else (emit "movq $~a, %rax" e))))
+
+    ('var (codegen-var e si env))
+
+    ('string-literal (emit "movq ~a, %rax" label))
+    ('bool-literal (emit "movq $~a, %rax" (if e 1 0)))
+    ('int-literal (emit "movq $~a, %rax" e))
+
+    (else (error #f "don't know how to codegen this"))))
+

 
 (define (fold-map f x) (fold-left append '() (map f x)))
 
 (define (free-vars prog)
   (define bound '())
   (define (collect e)
 
 (define (fold-map f x) (fold-left append '() (map f x)))
 
 (define (free-vars prog)
   (define bound '())
   (define (collect e)

-    (cond
-     ((builtin? e) '()) ; do nothing
-     ((var? e) (if (memq e bound) '() (list e)))
-     ((lambda? e)
+    (case (ast-type e)
+      ('builtin '()) ; do nothing
+      ('var (if (memq e bound) '() (list e)))
+      ('lambda

          (set! bound (append (lambda-args e) bound))
        (collect (lambda-body e)))
 
          (set! bound (append (lambda-args e) bound))
        (collect (lambda-body e)))
 

-     ((app? e) (fold-map collect e))
-     ((let? e)
+      ('app (fold-map collect e))
+      ('let

          (let ((bind-fvs (fold-map (lambda (a)
                                      ((set! bound (cons (car a) bound))
                                       (collect (cdr a))))
          (let ((bind-fvs (fold-map (lambda (a)
                                      ((set! bound (cons (car a) bound))
                                       (collect (cdr a))))


@@ -174,9 +186,6 @@
       (else '())))
   (collect prog))
 
       (else '())))
   (collect prog))
 

-(define (closure? e)
-  (and (list? e) (eqv? (car e) 'closure)))
-

                                        ; ((lambda (x) (+ x 1)) 42) => {lambda0: (x) (+ x 1)}, (@lambda0 42)
 (define (extract-lambdas program)
   (define lambdas '())
                                        ; ((lambda (x) (+ x 1)) 42) => {lambda0: (x) (+ x 1)}, (@lambda0 42)
 (define (extract-lambdas program)
   (define lambdas '())


@@ -189,17 +198,19 @@
       (set! lambdas (cons new-lambda lambdas))
       `(closure ,label ,captured))) ; todo: should we string->symbol?
   (define (extract e)
       (set! lambdas (cons new-lambda lambdas))
       `(closure ,label ,captured))) ; todo: should we string->symbol?
   (define (extract e)

-    (cond
-     ((lambda? e) (add-lambda e))
-     ((let? e) `(let
+    (case (ast-type e)
+     ('lambda (add-lambda e))
+     ('let `(let

                    ,(map extract (let-bindings e))
                  ,@(map extract (let-body e))))
                    ,(map extract (let-bindings e))
                  ,@(map extract (let-body e))))

-     ((app? e) (append (list (extract (car e)))
+     ('app (append (list (extract (car e)))

                       (map extract (cdr e))))
      (else e)))
   (let ((transformed (extract program)))
     (cons lambdas transformed)))
 
                       (map extract (cdr e))))
      (else e)))
   (let ((transformed (extract program)))
     (cons lambdas transformed)))
 

+;(define (extract-strings program))
+

 (define (amd64-abi f)
                                        ; preserve registers
   (emit "push %rbp")
 (define (amd64-abi f)
                                        ; preserve registers
   (emit "push %rbp")


@@ -241,8 +252,6 @@
     (else (error #f "need to test out the below"))
     (else (format "~a(%rsp)" (- n 6)))))
 
     (else (error #f "need to test out the below"))
     (else (format "~a(%rsp)" (- n 6)))))
 

-                
-

 (define (codegen program)
   (let* ((extract-result (extract-lambdas program))
         (lambdas (car extract-result))
 (define (codegen program)
   (let* ((extract-result (extract-lambdas program))
         (lambdas (car extract-result))


@@ -259,10 +268,10 @@
     (amd64-abi
      (lambda () (codegen-expr xform-prog 0 '())))))
 
     (amd64-abi
      (lambda () (codegen-expr xform-prog 0 '())))))
 

-(define (compile-to-binary program)
+(define (compile-to-binary program output)

   (when (not (eq? (typecheck program) 'int)) (error #f "not an int"))
   (let ([tmp-path "/tmp/a.s"])
     (when (file-exists? tmp-path) (delete-file tmp-path))
     (with-output-to-file tmp-path
       (lambda () (codegen program)))
   (when (not (eq? (typecheck program) 'int)) (error #f "not an int"))
   (let ([tmp-path "/tmp/a.s"])
     (when (file-exists? tmp-path) (delete-file tmp-path))
     (with-output-to-file tmp-path
       (lambda () (codegen program)))

-    (system "clang -fomit-frame-pointer /tmp/a.s rts.c")))
+    (system (format "clang -fomit-frame-pointer /tmp/a.s rts.c -o ~a" output))))