Add ast-find

[scheme.git] / codegen.scm

diff --git a/codegen.scm b/codegen.scm
index dda14713ad69a2eda8f676387f3497ff647f735b..00e01296af20661539f8fda3d882c6fa39547092 100644 (file)
--- a/codegen.scm
+++ b/codegen.scm
@@ -1,7 +1,8 @@
 (load "typecheck.scm")
 (load "ast.scm")
+(load "platform.scm")
 
-(define target 'darwin)
+(define target host-os)
 
 (define (emit . s)
   (begin
@@ -67,17 +68,12 @@
   (emit "not %rcx")      ; -%rcx = strlen + 1
   (emit "dec %rcx")
   
-  (case target
-    ('darwin
   (emit "movq %rbx, %rsi") ; string addr
   (emit "movq %rcx, %rdx") ; num bytes
   (emit "movq $1, %rdi")   ; file handle (stdout)
-     (emit "movq $0x2000004, %rax")) ; syscall 4 (write)
-    ('linux
-     (emit "mov %rbx, %rsi")  ; string addr
-     (emit "mov %rcx, %rdx")  ; num bytes
-     (emit "mov $1, %rax")    ; file handle (stdout)
-     (emit "mov $1, %rdi"))) ; syscall 1 (write)
+  (case target
+    ('darwin (emit "mov $0x2000004, %rax")) ; syscall 4 (write)
+    ('linux  (emit "mov $1, %rax"))) ; syscall 1 (write)
   (emit "syscall"))
 
 (define (range s n)
@@ -124,6 +120,8 @@
   (let* ((heap-offsets (map (lambda (i) (+ 8 (* 8 i)))
                            (range 0 (length captured))))) ; 4, 12, 20, etc.
 
+    (emit "## creating closure")
+
     (emit "movq heap_start@GOTPCREL(%rip), %rbx")
     
     (emit "movq (%rbx), %rax")          ; %rax = heap addr of closure
@@ -132,16 +130,18 @@
     ; point heap_start to next space
     (emit "addq $~a, (%rbx)" (+ 8 (* 8 (length captured))))
 
+    (emit "## storing address to lambda")
                                        ; store the address to the lambda code
     (emit "movq ~a@GOTPCREL(%rip), %rbx" label)
     (emit "movq %rbx, 0(%rax)")
 
+    (emit "## storing captives")
                                        ; store the captured vars
     (for-each
      (lambda (var-name new-offset)
-       (emit "movq ~a(%rbp), ~a(rax)"
-            (cdr (assoc var-name env))
-            new-offset))
+       (begin
+        (emit "movq ~a(%rbp), %rbx" (cdr (assoc var-name env)))
+        (emit "movq %rbx, ~a(%rax)" new-offset)))
      captured
      heap-offsets)))
 
@@ -206,7 +206,7 @@
 
         (stack-offsets (map (lambda (i)
                               (* (- wordsize) i))
-                            (range 1 (length params))))
+                            (range 0 (length params))))
 
         (env (map cons params stack-offsets)))
     (emit "~a:" label)
@@ -222,32 +222,33 @@
     (newline)
     
     (emit "push %rbp") ; preserve caller's base pointer
+    
     (emit "movq %rsp, %rbp") ; set up our own base pointer
+    (emit "subq $8, %rbp")   
 
                                        ; load the captured vars onto the stack
     (for-each
      (lambda (i)
-       (emit "movq ~a(~a), ~a(%rbp)"
-            i (param-register 0) (* (- wordsize) i)))
+       (begin
+        (emit "movq ~a(~a), %rbx" i (param-register 0))
+        (emit "movq %rbx, ~a(%rbp)" (* (- wordsize) i))))
      (range 0 (length captured)))
 
                                        ; load the args onto the stack
     (for-each
      (lambda (i)
-       (emit "movq ~a, ~a(%rbp)"
-            (param-register i) (* (- wordsize) i)))
-     (range 1 (length args)))
+       (begin
+        (emit "movq ~a, %rbx" (param-register (+ 1 i)))
+        (emit "movq %rbx, ~a(%rbp)"
+              (* (- wordsize)
+                 (+ (length captured) i)))))
+     (range 0 (length args)))
     
     (codegen-expr body (* (- wordsize) (+ 1 (length params))) env)
 
     (emit "pop %rbp") ; restore caller's base pointer
     (emit "ret")))
 
-(define (codegen-string label)
-  (case target
-    ('darwin (emit "movq ~a@GOTPCREL(%rip), %rax" label))
-    ('linux  (emit "lea $~a, %rax" label))))
-
 (define cur-label 0)
 (define (fresh-label)
   (set! cur-label (+ 1 cur-label))
@@ -294,12 +295,12 @@
     ('bool-literal (emit "movq $~a, %rax" (if e 1 0)))
     ('int-literal (emit "movq $~a, %rax" e))
     
-    ('static-string (codegen-string (cadr e)))
+    ('static-string (emit "movq ~a@GOTPCREL(%rip), %rax"
+                         (cadr 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 '())
@@ -348,15 +349,21 @@
       ('+ "_add")
       ('- "_sub")
       ('* "_mul")
+      ('! "_not")
+      ('= "_eq")
       ('bool->int "_bool2int")
-      (else (error #f "fill this out"))))
+      ('print "_print")
+      (else (error #f "don't know this builtin"))))
   (define (builtin-args e)
     (case e
       ('+ '(x y))
       ('- '(x y))
       ('* '(x y))
+      ('! '(x))
+      ('= '(x y))
       ('bool->int '(x))
-      (else (error #f "fill this out"))))
+      ('print '(x))
+      (else (error #f "don't know this builtin"))))
 
   (define (add-builtin-lambda e)
     (let* [(label (builtin-name e))
@@ -375,7 +382,7 @@
       ('app (append
                                        ; if a builtin is used as a function, don't generate lambda
             (if (eqv? 'builtin (ast-type (car e)))
-                '()
+                (list (car e))
                 (list (extract (car e))))
             (map extract (cdr e))))