Add support for recursive let binding codegen

diff --git a/abi.md b/abi.md
index 0185ec03acc4803a0bcc45f710d19d2ab23e77e1..eafb1748dbe009d527203948dd705cbed99ce486 100644 (file)
--- a/abi.md
+++ b/abi.md
@@ -26,6 +26,19 @@ lambda code  1st        2nd       3rd
 address      captive    captive   captive   ...
 ```
 
+## note on recursive closures
+
+The following example shows a recursive lambda, that results in a
+closure that captures itself.
+```
+(let ([f (closure lambda0 (f))])
+  (f 42))
+```
+When this happens, `codegen-let` will insert `(f . 'self-captive)`
+into the environment when codegen'ing the closure. `codegen-closure`
+will then pick this up, and use it to insert its own heap address into
+its inner environment.
+
 # lambdas
 
 lambdas use the system v amd64 calling convention.

diff --git a/codegen.scm b/codegen.scm
index 52c494bb233fb728ff907fa5fed63db57fb05478..941dc158e89e61a4a30027b00641f942a80da0ef 100644 (file)
--- a/codegen.scm
+++ b/codegen.scm
@@ -84,19 +84,48 @@
 (define wordsize 8)
 
 (define (codegen-let bindings body si env)
-  (let* ((stack-offsets (map (lambda (x) (- si (* x wordsize)))
+
+                                       ; is this a closure that captures itself?
+                                       ; e.g. (let ([x 3] [f (closure lambda0 (f x))]) (f))
+  (define (self-captive-closure? name expr)
+    (and (eqv? (ast-type expr) 'closure)
+        (memv name (caddr expr))))
+  
+  (let* ((stack-offsets (map (lambda (name x) ; assoc map of binding name to offset
+                              (cons name (- si (* x wordsize))))
+                            (map car bindings)
                             (range 0 (length bindings))))
         (inner-si (- si (* (length bindings) wordsize)))
-        (names (map car bindings))
-        (exprs (map cadr bindings))
-
-                                       ; recursive let bindings: build environment as we go
-        (inner-env (fold-left
-                    (lambda (env name expr offset)
-                      (codegen-expr expr inner-si env)
-                      (emit "movq %rax, ~a(%rbp)" offset)
-                      (cons (cons name offset) env))
-                    env names exprs stack-offsets)))
+
+        (get-offset (lambda (n) (cdr (assoc n stack-offsets))))
+        
+        [inner-env
+         (fold-left
+          (lambda (env comps)
+            (let ([scc-env
+                   (fold-left
+                    (lambda (acc name)
+                      (cons (cons name (get-offset name))
+                            acc))
+                    env
+                    comps)])
+              (for-each 
+               (lambda (name)
+                 (let ([expr (cadr (assoc name bindings))])
+                   (emit "## generating ~a with scc-env ~a" name scc-env)
+                   (if (self-captive-closure? name expr)
+                                       ; if self-captive, insert a flag into the environment to let
+                                       ; codegen-closure realise this!
+                       (codegen-expr expr
+                                     inner-si
+                                     (cons (cons name 'self-captive)
+                                           scc-env))
+                       (codegen-expr expr inner-si scc-env))
+                   (emit "movq %rax, ~a(%rbp)" (get-offset name))))
+               comps)
+              scc-env))
+          env (reverse (sccs (graph bindings))))])
+    
     (for-each (lambda (form)
                (codegen-expr form inner-si inner-env))
              body)))
@@ -139,9 +168,15 @@
                                        ; store the captured vars
     (for-each
      (lambda (var-name new-offset)
+       (let ([orig-offset (cdr (assoc var-name env))])
+        (emit "### captive ~a" var-name)
+        (if (eqv? orig-offset 'self-captive)
+                                       ; captive refers to this closure:
+                                       ; move heap addr of this closure to stack! 
+            (emit "movq %rax, ~a(%rax)" new-offset)
             (begin
-        (emit "movq ~a(%rbp), %rbx" (cdr (assoc var-name env)))
-        (emit "movq %rbx, ~a(%rax)" new-offset)))
+              (emit "movq ~a(%rbp), %rbx" orig-offset)
+              (emit "movq %rbx, ~a(%rax)" new-offset)))))
      captured
      heap-offsets)))
 
@@ -198,11 +233,11 @@
 (define (codegen-lambda l)
   (let* ((label (car l))
         (stuff (cdr l))
-        (captured (car stuff))
+        (captives (car stuff))
         (args (cadr stuff))
         (body (caddr stuff))
                                        ; params = what actually gets passed
-        (params (append captured args))
+        (params (append captives args))
 
         (stack-offsets (map (lambda (i)
                               (* (- wordsize) i))
@@ -212,7 +247,7 @@
     (emit "~a:" label)
 
     (display "## lambda captives: ")
-    (display captured)
+    (display captives)
     (newline)
     (display "## lambda args: ")
     (display args)
@@ -230,9 +265,10 @@
     (for-each
      (lambda (i)
        (begin
-        (emit "movq ~a(~a), %rbx" i (param-register 0))
+        (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))))
-     (range 0 (length captured)))
+     (range 0 (length captives)))
 
                                        ; load the args onto the stack
     (for-each
@@ -241,7 +277,7 @@
         (emit "movq ~a, %rbx" (param-register (+ 1 i)))
         (emit "movq %rbx, ~a(%rbp)"
               (* (- wordsize)
-                 (+ (length captured) i)))))
+                 (+ (length captives) i)))))
      (range 0 (length args)))
     
     (codegen-expr body (* (- wordsize) (+ 1 (length params))) env)
@@ -308,19 +344,21 @@
   (define (collect e)
     (case (ast-type e)
       ('builtin '()) ; do nothing
-      ('var (if (memq e bound) '() (list e)))
+      ('var (if (memv e bound) '() (list e)))
       ('lambda
+         (begin
            (set! bound (append (lambda-args e) bound))
-       (collect (lambda-body e)))
+           (collect (lambda-body e))))
 
       ('app (fold-map collect e))
+      ('if (fold-map collect (cdr e)))
       ('let
-         (let ((bind-fvs (fold-map (lambda (a)
-                                     ((set! bound (cons (car a) bound))
+         (let ([bind-fvs (fold-map (lambda (a)
+                                     (begin
+                                       (set! bound (cons (car a) bound))
                                        (collect (cdr a))))
-                                   (let-bindings cadr)))
-               (body-fvs (fold-map collect (let-body e))))
-           (append bind-fvs body-fvs)))
+                                   (let-bindings e))])
+           (append bind-fvs (fold-map collect (let-body e)))))
       (else '())))
   (collect prog))
 
@@ -378,7 +416,7 @@
   (define (extract e)
     (case (ast-type e)
       ('lambda (add-lambda e))
-      ('let `(let ,(map extract (let-bindings e))
+      ('let `(let ,(map (lambda (b) `(,(car b) ,@(extract (cdr b)))) (let-bindings e))
               ,@(map extract (let-body e))))
       ('app (append
                                        ; if a builtin is used as a function, don't generate lambda

diff --git a/tests.scm b/tests.scm
index bcda209fe2b069bc3778b5f80665877203d067cb..c4b81f15158e4a7f63152edab863dc9c5e10988b 100644 (file)
--- a/tests.scm
+++ b/tests.scm
@@ -112,3 +112,12 @@
                     
              (pow 3 2))
           8)
+
+(test-prog '(let ([pow (lambda (p y)
+                        (let ([go (lambda (n x)
+                                    (if (= n 0)
+                                        x
+                                        (go (- n 1) (* x y))))])
+                          (go p 1)))])
+             (pow 4 2))
+          16)