From 3ce93ef63f164f8dc63c89f1a97f46e200c71d02 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Wed, 17 Jul 2019 23:15:15 +0100 Subject: [PATCH] Add let bindings Also split out some helpers into a separate ast file Need to split compiler out into codegen and main --- ast.scm | 20 +++++++++++++++++++ compiler.scm | 47 +++++++++++++++++++++++++++++++++++-------- typecheck.scm | 55 +++++++++++++++++++++++++++++++++++---------------- 3 files changed, 97 insertions(+), 25 deletions(-) create mode 100644 ast.scm diff --git a/ast.scm b/ast.scm new file mode 100644 index 0000000..19dc7a0 --- /dev/null +++ b/ast.scm @@ -0,0 +1,20 @@ +(define (app? x) + (and (list? x) + (>= (length x) 2) + (not (eq? (car x) 'let)) + (not (eq? (car x) 'lambda)))) + +(define (let? x) + (and (list? x) (eq? (car x) 'let))) + +(define let-bindings cadr) +(define let-body cddr) + +(define (lambda? x) + (and (list? x) (eq? (car x) 'lambda))) + +(define lambda-arg cadr) +(define lambda-body cddr) + +(define (var? x) + (and (not (list? x)) (symbol? x))) diff --git a/compiler.scm b/compiler.scm index 351e11b..d79a37a 100644 --- a/compiler.scm +++ b/compiler.scm @@ -1,11 +1,12 @@ (load "typecheck.scm") +(load "ast.scm") (define (emit . s) (begin (apply printf s) (display "\n"))) -(define (compile-add xs) +(define (codegen-add xs) (define (go ys) (if (null? ys) (emit "movq %rbx, %rax") @@ -16,12 +17,42 @@ (emit "movq $0, %rbx") (go xs))) -(define (compile-expr e) - (if (and (list? e) (eq? (car e) '+)) - (compile-add (cdr e)) - (emit "movq $~a, %rax" e))) +(define (range s n) + (if (= 0 n) '() + (append (range s (- n 1)) + (list (+ s (- n 1)))))) -(define (compile-program program) +(define wordsize 8) + +(define (codegen-let bindings body si env) + (let* ((stack-offsets (map (lambda (x) (- si (* x wordsize))) + (range 0 (length bindings)))) + (inner-si (- si (* (length bindings) wordsize))) + (names (map car bindings)) + (exprs (map cadr bindings)) + (inner-env (append (map cons names stack-offsets) env))) + (for-each (lambda (expr offset) + (codegen-expr expr inner-si env) + (emit "movq %rax, ~a(%rsp)" offset)) + exprs stack-offsets) + (for-each (lambda (form) (codegen-expr form inner-si inner-env)) body))) + +(define (codegen-var name si env) + (let ((offset (cdr (assoc name env)))) + (emit "movq ~a(%rsp), %rax" offset))) + +(define (codegen-expr e si env) + (cond ((and (list? e) (eq? (car e) '+)) + (codegen-add (cdr e))) + ((let? e) (codegen-let + (let-bindings e) + (let-body e) + si + env)) + ((var? e) (codegen-var e si env)) + (else (emit "movq $~a, %rax" e)))) + +(define (codegen program) (emit ".text") (emit ".p2align 4,,15") (emit ".globl _scheme_entry") @@ -37,7 +68,7 @@ '(12 13 14 15)) ; our code goes here - (compile-expr program) + (codegen-expr program 0 '()) ; restore preserved registers (for-each (lambda (i) @@ -55,5 +86,5 @@ (let ([tmp-path "/tmp/a.s"]) (when (file-exists? tmp-path) (delete-file tmp-path)) (with-output-to-file tmp-path - (lambda () (compile-program program))) + (lambda () (codegen program))) (system "clang -fomit-frame-pointer /tmp/a.s rts.c"))) diff --git a/typecheck.scm b/typecheck.scm index 0e4e265..a738429 100644 --- a/typecheck.scm +++ b/typecheck.scm @@ -1,18 +1,13 @@ -(define (app? x) - (and (list? x) (>= (length x) 2) (not (eq? (car x) 'lambda)))) - -(define (lambda? x) - (and (list? x) (eq? (car x) 'lambda))) - -(define lambda-arg caadr) -(define lambda-body caddr) - +(load "ast.scm") ; ('a, ('b, 'a)) -(define (env-lookup env x) +(define (env-lookup env n) (if (null? env) (error #f "empty env") ; it's a type equality - (if (eq? (caar env) x) + (if (eq? (caar env) n) (cdar env) - (env-lookup (cdr env) x)))) + (env-lookup (cdr env) n)))) + +(define (env-insert env n t) + (cons (cons n t) env)) (define abs-arg cadr) @@ -23,19 +18,32 @@ (string->symbol (string-append "t" (number->string (- cur-tvar 1)))))) +(define (last xs) + (if (null? (cdr xs)) + (car xs) + (last (cdr xs)))) + (define (normalize prog) ; (+ a b) -> ((+ a) b) (cond - ((lambda? prog) '(lambda (lambda-arg prog) (normalize (lambda-body prog)))) + ((lambda? prog) (list 'lambda (lambda-arg prog) (normalize (lambda-body prog)))) ((app? prog) (if (null? (cddr prog)) (cons (normalize (car prog)) (normalize (cdr prog))) ; (f a) (normalize (cons (cons (car prog) (list (cadr prog))) (cddr prog))))) ; (f a b) + ((let? prog) + (append (list 'let + (map (lambda (x) (cons (car x) (normalize (cdr x)))) + (let-bindings prog))) + (map normalize (let-body prog)))) (else prog))) (define (typecheck prog) (define (check env x) + ;; (display "check: ") + ;; (display x) + ;; (display "\n") (let ((res (cond @@ -45,6 +53,17 @@ ((eq? x '+) (list '() '(abs int (abs int int)))) ((symbol? x) (list '() (env-lookup env x))) + ((let? x) + (let ((new-env (fold-left + (lambda (acc bind) + (let ((t (check + (env-insert acc (car bind) (fresh-tvar)) + (cadr bind)))) + (env-insert acc (car bind) (cadr t)))) + env (let-bindings x)))) + (check new-env (last (let-body x))))) + + ((lambda? x) (let* ((new-env (cons (cons (lambda-arg x) (fresh-tvar)) env)) (body-type-res (check new-env (lambda-body x))) @@ -86,7 +105,7 @@ (if (abs? resolved-func-type) (let ((return-type (substitute cs (caddr resolved-func-type)))) (list cs return-type)) - (error #f "wah"))))))) + (error #f "not a function"))))))) ;; (display "result of ") ;; (display x) ;; (display ":\n\t") @@ -123,16 +142,18 @@ ; TODO: what's the most appropriate substitution? ; should all constraints just be limited to a pair? (define (substitute cs t) - (define (blah c) + ; gets the first concrete type + ; otherwise returns the last type variable + (define (get-concrete c) (if (null? (cdr c)) (car c) (if (not (tvar? (car c))) (car c) - (blah (cdr c))))) + (get-concrete (cdr c))))) (fold-left (lambda (t c) (if (member t c) - (blah c) + (get-concrete c) t)) t cs)) -- 2.30.2