X-Git-Url: https://git.lukelau.me/?a=blobdiff_plain;f=codegen.scm;h=10e005f8ad90e840aad396da4a0cdb5032163f6c;hb=5ea42a37be529974bff32b719bd91e004d1dfcd8;hp=941dc158e89e61a4a30027b00641f942a80da0ef;hpb=ab0b66e68a85e8e71442ee70a81c16d04e66145d;p=scheme.git

diff --git a/codegen.scm b/codegen.scm
index 941dc15..10e005f 100644
--- a/codegen.scm
+++ b/codegen.scm
@@ -76,11 +76,6 @@
     ('linux  (emit "mov $1, %rax"))) ; syscall 1 (write)
   (emit "syscall"))
 
-(define (range s n)
-  (if (= 0 n) '()
-      (append (range s (- n 1))
-	      (list (+ s (- n 1))))))
-
 (define wordsize 8)
 
 (define (codegen-let bindings body si env)
@@ -167,16 +162,16 @@
     (emit "## storing captives")
 					; store the captured vars
     (for-each
-     (lambda (var-name new-offset)
-       (let ([orig-offset (cdr (assoc var-name env))])
+     (lambda (var-name heap-offset)
+       (let ([stack-offset (cdr (assoc var-name env))])
 	 (emit "### captive ~a" var-name)
-	 (if (eqv? orig-offset 'self-captive)
+	 (if (eqv? stack-offset 'self-captive)
 					; captive refers to this closure:
 					; move heap addr of this closure to stack! 
-	     (emit "movq %rax, ~a(%rax)" new-offset)
+	     (emit "movq %rax, ~a(%rax)" heap-offset)
 	     (begin
-	       (emit "movq ~a(%rbp), %rbx" orig-offset)
-	       (emit "movq %rbx, ~a(%rax)" new-offset)))))
+	       (emit "movq ~a(%rbp), %rbx" stack-offset)
+	       (emit "movq %rbx, ~a(%rax)" heap-offset)))))
      captured
      heap-offsets)))
 
@@ -240,7 +235,7 @@
 	 (params (append captives args))
 
 	 (stack-offsets (map (lambda (i)
-			       (* (- wordsize) i))
+			       (* (- wordsize) (+ 1 i)))
 			     (range 0 (length params))))
 
 	 (env (map cons params stack-offsets)))
@@ -259,7 +254,6 @@
     (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
@@ -267,7 +261,7 @@
        (begin
 	 (emit "# loading captive ~a" (list-ref captives i))
 	 (emit "movq ~a(~a), %rbx" (* wordsize i) (param-register 0))
-	 (emit "movq %rbx, ~a(%rbp)" (* (- wordsize) i))))
+	 (emit "movq %rbx, ~a(%rbp)" (* (- wordsize) (+ 1 i)))))
      (range 0 (length captives)))
 
 					; load the args onto the stack
@@ -277,7 +271,7 @@
 	 (emit "movq ~a, %rbx" (param-register (+ 1 i)))
 	 (emit "movq %rbx, ~a(%rbp)"
 	       (* (- wordsize)
-		  (+ (length captives) i)))))
+		  (+ 1 (length captives) i)))))
      (range 0 (length args)))
     
     (codegen-expr body (* (- wordsize) (+ 1 (length params))) env)
@@ -350,15 +344,15 @@
 	    (set! bound (append (lambda-args e) bound))
 	    (collect (lambda-body e))))
 
-      ('app (fold-map collect e))
-      ('if (fold-map collect (cdr e)))
+      ('app (flat-map collect e))
+      ('if (flat-map collect (cdr e)))
       ('let
-	  (let ([bind-fvs (fold-map (lambda (a)
+	  (let ([bind-fvs (flat-map (lambda (a)
 				      (begin
 					(set! bound (cons (car a) bound))
 					(collect (cdr a))))
 				    (let-bindings e))])
-	    (append bind-fvs (fold-map collect (let-body e)))))
+	    (append bind-fvs (flat-map collect (let-body e)))))
       (else '())))
   (collect prog))
 
@@ -524,7 +518,9 @@
 (define (codegen program)
   (set! cur-label 0)
   (set! cur-lambda 0)
-  (let* ((extract-res-0 (extract-strings program))
+  (let* ([body (program-body program)]	
+	 
+	 (extract-res-0 (extract-strings body))
 	 (strings (car extract-res-0))
 	 (extract-res-1 (extract-lambdas (cdr extract-res-0)))
 	 (lambdas (car extract-res-1))
@@ -541,7 +537,8 @@
     (initialize-heap)
 
     (emit "movq %rsp, %rbp")            ; set up the base pointer
-    (codegen-expr xform-prog 0 '())
+    
+    (codegen-expr xform-prog (- wordsize) '())
 
 					; exit syscall
     (emit "mov %rax, %rdi")
@@ -559,7 +556,7 @@
 
 (define (compile-to-binary program output t)
   (set! target t)
-  (when (not (eq? (typecheck program) 'int)) (error #f "not an int"))
+  (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