From 43f8c4631ae0a3163c780e7511a96f6b05054544 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Mon, 22 Jul 2019 01:28:50 +0100 Subject: [PATCH] First pass at lambdas and closures --- ast.scm | 9 +++ codegen.scm | 178 +++++++++++++++++++++++++++++++++++++++++++++++----- 2 files changed, 173 insertions(+), 14 deletions(-) diff --git a/ast.scm b/ast.scm index 05716e4..2ffad97 100644 --- a/ast.scm +++ b/ast.scm @@ -21,3 +21,12 @@ (define (var? x) (and (not (list? x)) (symbol? x))) + +(define (builtin? x) + (case x + ('+ #t) + ('- #t) + ('* #t) + ('! #t) + ('bool->int #t) + (else #f))) diff --git a/codegen.scm b/codegen.scm index 3a01dff..04816ab 100644 --- a/codegen.scm +++ b/codegen.scm @@ -35,7 +35,7 @@ (define (codegen-not x si env) (codegen-expr x si env) - (emit "xorq $-1, %rax") + (emit "notq %rax") (emit "andq $1, %rax")) (define (range s n) @@ -62,15 +62,86 @@ (let ((offset (cdr (assoc name env)))) (emit "movq ~a(%rsp), %rax" offset))) +(define cur-lambda 0) +(define (fresh-lambda) + (set! cur-lambda (+ 1 cur-lambda)) + (format "_lambda~a" (- cur-lambda 1))) + + ; for now we can only call closures +(define (codegen-call closure args si env) + (let* ((captured (caddr closure)) + (label (cadr closure)) + (argument-start (length captured))) + + ; first move the captured variables into param registers + (for-each + (lambda (e i) + (emit "movq ~a(%rsp), ~a" + (cdr (assoc e env)) ; offset of the var + (param-register i))) + captured (range 0 (length captured))) + + + ; then codegen the arguments and move them into the next param registers + (for-each + (lambda (e i) + (begin + (codegen-expr e si env) + ; move result to correct param register + (emit "movq %rax, ~a" (param-register i)))) + args (range argument-start (length args))) + + ; now call + (emit "callq ~a" label))) + + +(define (codegen-lambda l) + (let* ((label (car l)) + (args (cadr l)) + (captured (caddr l)) + (body (cadddr l)) + ; captured, then args + (vars (append captured args)) + + (param-registers (map param-register + (range 0 (length vars)))) + (stack-offsets (map (lambda (i) + (* (- wordsize) i)) + (range 0 (length vars)))) + + (copy-insts (map (lambda (r o) + (format "movq ~a, ~a(%rsp)" + r o)) + param-registers stack-offsets)) + + (env (map cons vars stack-offsets))) + (emit "~a:" label) + (display "## lambda body: ") + (display body) + (newline) + (display "## environment: ") + (display env) + (newline) + (amd64-abi + (lambda () + (for-each emit copy-insts) + (codegen-expr body (* (- wordsize) (length vars)) env) + )))) ; move args and capture vars to stack + (define (codegen-expr e si env) - (cond ((app? e) - (case (car e) + (cond ((builtin? e) e) + ((closure? e) e) + + ((app? e) + (let ((callee (codegen-expr (car e) si env))) + (case callee ('+ (codegen-add (cdr e) si env)) ('- (codegen-sub (cadr e) (caddr e) si env)) ('* (codegen-mul (cadr e) (caddr e) si env)) ('! (codegen-not (cadr e) si env)) ('bool->int (codegen-expr (cadr e) si env)) - (else (error #f "can't handle anything else yet")))) + (else (codegen-call callee (cdr e) si env))))) + ((let? e) (codegen-let (let-bindings e) (let-body e) @@ -80,13 +151,57 @@ ((boolean? e) (emit "movq $~a, %rax" (if e 1 0))) (else (emit "movq $~a, %rax" e)))) -(define (codegen program) - (emit ".text") - (emit ".p2align 4,,15") - (emit ".globl _scheme_entry") - (emit "_scheme_entry:") +(define (fold-map f x) (fold-left append '() (map f x))) + +(define (free-vars prog) + (define bound '()) + (define (collect e) + (cond + ((builtin? e) '()) ; do nothing + ((var? e) (if (memq e bound) '() (list e))) + ((lambda? e) + (set! bound (append (lambda-args e) bound)) + (collect (lambda-body e))) - ; handle incoming call from C + ((app? e) (fold-map collect e)) + ((let? e) + (let ((bind-fvs (fold-map (lambda (a) + ((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))) + (else '()))) + (collect prog)) + +(define (closure? e) + (and (list? e) (eqv? (car e) 'closure))) + + ; ((lambda (x) (+ x 1)) 42) => {lambda0: (x) (+ x 1)}, (@lambda0 42) +(define (extract-lambdas program) + (define lambdas '()) + (define (add-lambda e) + (let* ((label (fresh-lambda)) + (args (lambda-args e)) + (captured (free-vars e)) + (body (extract (lambda-body e))) + (new-lambda (list label args captured body))) + (set! lambdas (cons new-lambda lambdas)) + `(closure ,label ,captured))) ; todo: should we string->symbol? + (define (extract e) + (cond + ((lambda? e) (add-lambda e)) + ((let? e) `(let + ,(map extract (let-bindings e)) + ,@(map extract (let-body e)))) + ((app? e) (append (list (extract (car e))) + (map extract (cdr e)))) + (else e))) + (let ((transformed (extract program))) + (cons lambdas transformed))) + +(define (amd64-abi f) + ; preserve registers (emit "push %rbp") (emit "push %rbx") (for-each (lambda (i) @@ -95,9 +210,7 @@ (number->string i)))) '(12 13 14 15)) - ; our code goes here - (codegen-expr program 0 '()) - + (f) ; call stuff ; restore preserved registers (for-each (lambda (i) (emit (string-append @@ -106,9 +219,46 @@ '(15 14 13 12)) (emit "pop %rbx") (emit "pop %rbp") - (emit "ret")) + ; 24(%rbp) mem arg 1 + ; 16(%rbp) mem arg 0 prev frame + ; ----------------------- + ; 8(%rbp) return address cur frame + ; 0(%rbp) prev %rbp + ; -8(%rbp) do what you want + ; ... do what you want + ; 0(%rsp) do what you want + +(define (param-register n) + (case n + (0 "%rdi") + (1 "%rsi") + (2 "%rdx") + (3 "%rcx") + (4 "%r8") + (5 "%r9") + (else (error #f "need to test out the below")) + (else (format "~a(%rsp)" (- n 6))))) + + + +(define (codegen program) + (let* ((extract-result (extract-lambdas program)) + (lambdas (car extract-result)) + (xform-prog (cdr extract-result))) + (emit ".text") + (emit ".p2align 4,,15") + + (for-each codegen-lambda lambdas) + + (emit ".globl _scheme_entry") + (emit "_scheme_entry:") + + + (amd64-abi + (lambda () (codegen-expr xform-prog 0 '()))))) + (define (compile-to-binary program) (when (not (eq? (typecheck program) 'int)) (error #f "not an int")) (let ([tmp-path "/tmp/a.s"]) -- 2.30.2