From 556da1eb404e9b6c132cd075d7666de4c5b904d2 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Tue, 30 Jul 2019 22:24:41 +0100 Subject: [PATCH] Add support for recursive let binding codegen --- abi.md | 13 ++++++++ codegen.scm | 92 +++++++++++++++++++++++++++++++++++++---------------- tests.scm | 9 ++++++ 3 files changed, 87 insertions(+), 27 deletions(-) diff --git a/abi.md b/abi.md index 0185ec0..eafb174 100644 --- 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 52c494b..941dc15 100644 --- 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 bcda209..c4b81f1 100644 --- 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) -- 2.30.2