-(define (app? x)
- (and (list? x)
- (>= (length x) 2)
- (not (eq? (car x) 'let))
- (not (eq? (car x) 'lambda))))
+(define (ast-type x)
+ (define (builtin? x)
+ (case x
+ ('+ #t)
+ ('- #t)
+ ('* #t)
+ ('! #t)
+ ('= #t)
+ ('bool->int #t)
+ (else #f)))
+ (cond
+ ((list? x)
+ (case (car x)
+ ('if 'if)
+ ('let 'let)
+ ('lambda 'lambda)
+ ('closure 'closure) ; only available in codegen
+ (else 'app)))
+ ((builtin? x) 'builtin)
+ ((symbol? x) 'var)
+ ((integer? x) 'int-literal)
+ ((boolean? x) 'bool-literal)))
-(define (let? x)
- (and (list? x) (eq? (car x) 'let)))
+;; (define (ast-recurse f x)
+;; (cond (
(define let-bindings cadr)
(define let-body cddr)
; for use elsewhere
(define lambda-args cadr)
(define lambda-body caddr)
-
-(define (var? x)
- (and (not (list? x)) (symbol? x)))
-
-(define (builtin? x)
- (case x
- ('+ #t)
- ('- #t)
- ('* #t)
- ('! #t)
- ('bool->int #t)
- (else #f)))
)))) ; move args and capture vars to stack
(define (codegen-expr e si env)
- (cond ((builtin? e) e)
- ((closure? e) e)
-
- ((app? e)
+ (case (ast-type e)
+ ('builtin e)
+ ('closure e)
+ ('app
(let ((callee (codegen-expr (car e) si env)))
(case callee
('+ (codegen-add (cdr e) si env))
('bool->int (codegen-expr (cadr e) si env))
(else (codegen-call callee (cdr e) si env)))))
- ((let? e) (codegen-let
- (let-bindings e)
+ ('let (codegen-let (let-bindings e)
(let-body e)
si
env))
- ((var? e) (codegen-var e si env))
- ((boolean? e) (emit "movq $~a, %rax" (if e 1 0)))
- (else (emit "movq $~a, %rax" e))))
+
+ ('var (codegen-var e si env))
+
+ ('string-literal (emit "movq ~a, %rax" label))
+ ('bool-literal (emit "movq $~a, %rax" (if e 1 0)))
+ ('int-literal (emit "movq $~a, %rax" e))
+
+ (else (error #f "don't know how to codegen this"))))
+
(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)
+ (case (ast-type e)
+ ('builtin '()) ; do nothing
+ ('var (if (memq e bound) '() (list e)))
+ ('lambda
(set! bound (append (lambda-args e) bound))
(collect (lambda-body e)))
- ((app? e) (fold-map collect e))
- ((let? e)
+ ('app (fold-map collect e))
+ ('let
(let ((bind-fvs (fold-map (lambda (a)
((set! bound (cons (car a) bound))
(collect (cdr a))))
(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 '())
(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
+ (case (ast-type e)
+ ('lambda (add-lambda e))
+ ('let `(let
,(map extract (let-bindings e))
,@(map extract (let-body e))))
- ((app? e) (append (list (extract (car e)))
+ ('app (append (list (extract (car e)))
(map extract (cdr e))))
(else e)))
(let ((transformed (extract program)))
(cons lambdas transformed)))
+;(define (extract-strings program))
+
(define (amd64-abi f)
; preserve registers
(emit "push %rbp")
(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))
(define (normalize prog) ; (+ a b) -> ((+ a) b)
- (cond
+ (case (ast-type prog)
+ ('lambda
; (lambda (x y) (+ x y)) -> (lambda (x) (lambda (y) (+ x y)))
- ((lambda? prog)
(if (> (length (lambda-args prog)) 1)
(list 'lambda (list (car (lambda-args prog)))
(normalize (list 'lambda (cdr (lambda-args prog)) (caddr prog))))
(list 'lambda (lambda-args prog) (normalize (caddr prog)))))
- ((app? prog)
+ ('app
(if (null? (cddr prog))
`(,(normalize (car prog)) ,(normalize (cadr prog))) ; (f a)
`(,(list (normalize (car prog)) (normalize (cadr prog)))
,(normalize (caddr prog))))) ; (f a b)
;; (list (list (normalize (car prog))
;; (normalize (cadr prog))) (normalize (caddr prog))))) ; (f a b)
- ((let? prog)
+ ('let
(append (list 'let
(map (lambda (x) `(,(car x) ,(normalize (cadr x))))
(let-bindings prog)))
(map normalize (let-body prog))))
+ ('if `(if ,(normalize (cadr prog))
+ ,(normalize (caddr prog))
+ ,(normalize (cadddr prog))))
(else prog)))
(define (builtin-type x)
('- '(abs int (abs int int)))
('* '(abs int (abs int int)))
('! '(abs bool bool))
+ ('= '(abs int (abs int bool)))
('bool->int '(abs bool int))
(else #f)))
;; (newline)
(let
((res
- (cond
- ((integer? x) (list '() 'int))
- ((boolean? x) (list '() 'bool))
- ((builtin-type x) (list '() (builtin-type x)))
- ((symbol? x) (list '() (env-lookup env x)))
- ((let? x)
+ (case (ast-type x)
+ ('int-literal (list '() 'int))
+ ('bool-literal (list '() 'bool))
+ ('builtin (list '() (builtin-type x)))
+
+ ('if
+ (let* ((cond-type-res (check env (cadr x)))
+ (then-type-res (check env (caddr x)))
+ (else-type-res (check env (cadddr x)))
+ (then-eq-else-cs (unify (cadr then-type-res)
+ (cadr else-type-res)))
+ (cs (consolidate
+ (car then-type-res)
+ (consolidate (car else-type-res)
+ then-eq-else-cs)))
+ (return-type (substitute cs (cadr then-type-res))))
+ (when (not (eqv? (cadr cond-type-res) 'bool))
+ (error #f "if condition isn't bool"))
+ (list cs return-type)))
+
+ ('var (list '() (env-lookup env x)))
+ ('let
(let ((new-env (fold-left
(lambda (acc bind)
(let ((t (check
(check new-env (last (let-body x)))))
- ((lambda? x)
+ ('lambda
(let* ((new-env (env-insert env (lambda-arg x) (fresh-tvar)))
(body-type-res (check new-env (lambda-body x)))
(cs (car body-type-res))
resolved-arg-type
(cadr body-type-res)))))
- ((app? x) ; (f a)
+ ('app ; (f a)
(let* ((arg-type-res (check env (cadr x)))
(arg-type (cadr arg-type-res))
(func-type-res (check env (car x)))
projects / scheme.git / commitdiff