Make the ABI respect stack etc.

diff --git a/ast.scm b/ast.scm
index c81bc2b38ef4a9bbd70590f83d49dddd2b87948b..a0899192e21a1d44b0fe3296e380604133a3f1d2 100644 (file)
--- a/ast.scm
+++ b/ast.scm
@@ -7,6 +7,7 @@
       ('! #t)
       ('= #t)
       ('bool->int #t)
+      ('print #t)
       (else #f)))
   (cond
    ((list? x)
@@ -15,19 +16,21 @@
       ('let 'let)
       ('lambda 'lambda)
       ('closure 'closure) ; only available in codegen
+      ('static-string 'static-string) ; only available in codegen
       (else 'app)))
    ((builtin? x) 'builtin)
    ((symbol? x) 'var)
    ((integer? x) 'int-literal)
-   ((boolean? x) 'bool-literal)))
+   ((boolean? x) 'bool-literal)
+   ((string? x) 'string-literal)))
 
 (define (ast-traverse f x)
   (case (ast-type x)
     ('let `(let ,(map (lambda (x) (list (car x) (f (cadr x))))
                      (let-bindings x))
-            ,@(map f (let-body e))))
+            ,@(map f (let-body x))))
     ('app (map f x))
-    ('lambda `(lambda ,(lambda-args x) ,(f lambda-body)))
+    ('lambda `(lambda ,(lambda-args x) ,(f (lambda-body x))))
     ('if `(if ,@(map f (cdr x))))
     (else x)))
 

diff --git a/codegen.scm b/codegen.scm
index a1a0aa71280e66b510be50964d9c7c37893b1a91..5303b4975854be55bfc5d36aedcf5e607ebe8db9 100644 (file)
--- a/codegen.scm
+++ b/codegen.scm
@@ -9,28 +9,29 @@
 (define (codegen-add xs si env)
   (define (go ys)
     (if (null? ys)
-      (emit "movq ~a(%rsp), %rax" si)
+      (emit "movq ~a(%rbp), %rax" si)
       (begin
        (let ((y (car ys)))
             (if (integer? y)
-                (emit "addq $~a, ~a(%rsp)" y si)
+                (emit "addq $~a, ~a(%rbp)" y si)
                 (begin
                   (codegen-expr y (- si wordsize) env)
-                  (emit "addq %rax, ~a(%rsp)" si))))
+                  (emit "addq %rax, ~a(%rbp)" si))))
        (go (cdr ys)))))
   (begin
-                                       ; use si(%rsp) as the accumulator
-    (emit "movq $0, ~a(%rsp)" si)
+                                       ; use si(%rbp) as the accumulator
+    (emit "movq $0, ~a(%rbp)" si)
     (go xs)))
 
 (define (codegen-binop opcode)
   (lambda (a b si env)
     (codegen-expr b si env)
-    (emit "movq %rax, ~a(%rsp)" si)
+    (emit "movq %rax, ~a(%rbp)" si)
     (codegen-expr a (- si wordsize) env)
-    (emit "~a ~a(%rsp), %rax" opcode si)))
+    (emit "~a ~a(%rbp), %rax" opcode si)))
 
 (define codegen-sub (codegen-binop "sub"))
+
 (define codegen-mul (codegen-binop "imul"))
 
 (define (codegen-not x si env)
@@ -40,9 +41,9 @@
 
 (define (codegen-eq a b si env)
   (codegen-expr a si env)
-  (emit "movq %rax, ~a(%rsp)" si)
+  (emit "movq %rax, ~a(%rbp)" si)
   (codegen-expr b (- si wordsize) env)
-  (emit "subq ~a(%rsp), %rax" si)
+  (emit "subq ~a(%rbp), %rax" si)
   (emit "not %rax")
   (emit "andq $1, %rax"))
 
@@ -83,7 +84,7 @@
         (inner-env (fold-left
                     (lambda (env name expr offset)
                       (codegen-expr expr inner-si env)
-                      (emit "movq %rax, ~a(%rsp)" offset)
+                      (emit "movq %rax, ~a(%rbp)" offset)
                       (cons (cons name offset) env))
                     env names exprs stack-offsets)))
     (for-each (lambda (form)
@@ -94,7 +95,7 @@
   (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)))
+    (emit "movq ~a(%rbp), %rax" offset)))
 
 (define cur-lambda 0)
 (define (fresh-lambda)
@@ -112,7 +113,7 @@
                                        ; first move the captured variables into param registers
     (for-each
      (lambda (e i)
-       (emit "movq ~a(%rsp), ~a"
+       (emit "movq ~a(%rbp), ~a"
             (cdr (assoc e env)) ; offset of the var
             (param-register i)))
      captured (range 0 (length captured)))
@@ -127,30 +128,29 @@
         (emit "movq %rax, ~a" (param-register i))))
      args (range argument-start (length args)))
 
-                                       ; now call
-    (emit "callq ~a" label)))
-
+    (emit "addq $~a, %rsp" si) ; adjust the stack pointer to account all the stuff we put in the env
+    (emit "callq ~a" label)
+    (emit "subq $~a, %rsp" si)))
 
 (define (codegen-lambda l)
   (let* ((label (car l))
         (args (cadr l))
         (captured (caddr l))
         (body (cadddr l))
-        ; captured, then args
-        (vars (append captured args))
+; params = what actually gets passed
+        (params (append captured args))
 
         (param-registers (map param-register
-                            (range 0 (length vars))))
+                              (range 0 (length params))))
         (stack-offsets (map (lambda (i)
                               (* (- wordsize) i))
-                            (range 0 (length vars))))
+                            (range 1 (length params))))
 
         (copy-insts (map (lambda (r o)
-                           (format "movq ~a, ~a(%rsp)"
-                                   r o))
+                           (format "movq ~a, ~a(%rbp)" r o))
                          param-registers stack-offsets))
 
-        (env (map cons vars stack-offsets)))
+        (env (map cons params stack-offsets)))
     (emit "~a:" label)
     (display "## lambda body: ")
     (display body)
@@ -158,11 +158,15 @@
     (display "## environment: ")
     (display env)
     (newline)
-    (amd64-abi
-     (lambda ()
+
+    (emit "push %rbp") ; preserve caller's base pointer
+    (emit "movq %rsp, %rbp") ; set up our own base pointer
+    
     (for-each emit copy-insts)
-       (codegen-expr body (* (- wordsize) (length vars)) env)
-       ))))                    ; move args and capture vars to stack
+    (codegen-expr body (* (- wordsize) (+ 1 (length params))) env)
+
+    (emit "pop %rbp") ; restore caller's base pointer
+    (emit "ret")))
 
 (define cur-label 0)
 (define (fresh-label)
@@ -279,26 +283,28 @@
   (emit "~a:" (car s))
   (emit "\t.string \"~a\"" (cdr s)))
 
-(define (amd64-abi f)
-                                       ; preserve registers
-  (emit "push %rbp")
-  (emit "push %rbx")
-  (for-each (lambda (i)
-             (emit (string-append
-                    "push %r"
-                    (number->string i))))
-           '(12 13 14 15))
-
-  (f) ; call stuff
-                                       ; restore preserved registers
-  (for-each (lambda (i)
-             (emit (string-append
-                    "pop %r"
-                    (number->string i))))
-           '(15 14 13 12))
-  (emit "pop %rbx")
-  (emit "pop %rbp")
-  (emit "ret"))
+;; (define (amd64-abi f)
+;;                                     ; preserve registers
+;;   (emit "push %rbp")
+;;   ;; (emit "push %rbx")
+;;   ;; (for-each (lambda (i)
+;;   ;;              (emit (string-append
+;;   ;;                     "push %r"
+;;   ;;                     (number->string i))))
+;;   ;;            '(12 13 14 15))
+
+;;   (emit "movq %rsp, %rbp")              ; set up the base pointer
+
+;;   (f) ; call stuff
+;;                                     ; restore preserved registers
+;;   ;; (for-each (lambda (i)
+;;   ;;              (emit (string-append
+;;   ;;                     "pop %r"
+;;   ;;                     (number->string i))))
+;;   ;;            '(15 14 13 12))
+;;   ;; (emit "pop %rbx")
+;;   (emit "pop %rbp")
+;;   (emit "ret"))
 
                                        ; 24(%rbp) mem arg 1
                                        ; 16(%rbp) mem arg 0          prev frame
@@ -327,14 +333,14 @@
         (lambdas (car extract-res-1))
         (xform-prog (cdr extract-res-1)))
 
-    (emit "\t.globl _start")
+    (emit "\t.global _start")
     (emit "\t.text")
 ;    (emit ".p2align 4,,15") is this needed?
 
     (for-each codegen-lambda lambdas)
 
-
     (emit "_start:")
+    (emit "movq %rsp, %rbp")            ; set up the base pointer
     (codegen-expr xform-prog 0 '())
 
                                        ; exit syscall

diff --git a/tests.scm b/tests.scm
index 7c73433ca4dbf8f0a0c6e2d5a6d11d5e865c8071..bfd9124510826ea685a814248fd084509510b583 100644 (file)
--- a/tests.scm
+++ b/tests.scm
@@ -17,10 +17,14 @@
             (loop (read-char p) (string-append result (string next))))))))
 
 (define (test-prog prog exit-code)
+  (display prog)
+  (newline)
   (compile-to-binary prog "/tmp/test-prog")
-  (system "/tmp/test-prog"))
+  (test (system "/tmp/test-prog") exit-code))
 
 (define (test-prog-stdout prog output)
+  (display prog)
+  (newline)
   (compile-to-binary prog "/tmp/test-prog")
   (system "/tmp/test-prog > /tmp/test-output.txt")
   (let ((str (read-file "/tmp/test-output.txt")))
@@ -31,10 +35,16 @@
 
 (test-prog '(+ 1 2) 3)
 (test-prog '((lambda (x) ((lambda (y) (+ x y)) 42)) 100) 142)
+
+(test-prog '(* 10 5) 50)
+
 (test-prog '(let ((x (+ 1 32))
                  (y x))
-             ((lambda (z) (+ 1 z)) (* y x)))
-          1090)
+             ((lambda (z) (+ 2 z)) (* y x)))
+          67) ; exit code modulos at 256
 (test-prog '(if ((lambda (x) (= x 2)) 1) 0 (- 32 1)) 31)
+
 (test-prog-stdout '(if (= 3 2) 1 (let () (print "hello world!") 0)) "hello world!")
 
+(test-prog '((lambda (x y) (+ x y)) 1 2) 3)
+(test-prog '((lambda (x) (+ ((lambda (y) (+ y 1)) 3) x)) 2) 6)