+
+ ('var (codegen-var e si env))
+
+ ('if (codegen-if (cadr e) (caddr e) (cadddr e) si env))
+
+ ('bool-literal (emit "movq $~a, %rax" (if e 1 0)))
+ ('int-literal (emit "movq $~a, %rax" e))
+
+ ('static-string (emit "movq ~a@GOTPCREL(%rip), %rax"
+ (cadr e)))
+
+ ('stack (codegen-expr (caddr e) si env))
+
+ (else (error #f "don't know how to codegen this"))))
+
+ ; takes in a expr annotated with types and returns a type-less AST
+ ; with stack values wrapped
+(define (annotate-stack-values data-layout ann-e)
+ (define (stack-type? type)
+ (assoc type data-layout))
+ (define (strip e)
+ (ast-traverse strip (ann-expr e)))
+ (let* ([e (ann-expr ann-e)]
+ [type (ann-type ann-e)])
+ (if (stack-type? type)
+ `(stack ,type ,(ast-traverse strip e))
+ (ast-traverse (lambda (x)
+ (annotate-stack-values data-layout x))
+ e))))
+
+(define (free-vars prog)
+ (define bound '())
+ (define (collect e)
+ (case (ast-type e)
+ ('builtin '()) ; do nothing
+ ('var (if (memv e bound) '() (list e)))
+ ('lambda
+ (begin
+ (set! bound (append (lambda-args e) bound))
+ (collect (lambda-body e))))
+
+ ('app (flat-map collect e))
+ ('if (flat-map collect (cdr e)))
+ ('let
+ (let ([bind-fvs (flat-map (lambda (a)
+ (begin
+ (set! bound (cons (car a) bound))
+ (collect (cdr a))))
+ (let-bindings e))])
+ (append bind-fvs (flat-map collect (let-body e)))))
+ (else '())))
+ (collect prog))
+
+ ; ((lambda (x) (+ x y)) 42) => ((closure lambda1 (y)) 42)
+ ; [(lambda1 . ((y), (x), (+ x y))]
+ ; for builtins, this generates a closure if it is used
+ ; outside of an immediate app
+ ; but only one closure for each builtin
+
+(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 (cons label (list captured args body))))
+ (set! lambdas (cons new-lambda lambdas))
+ `(closure ,label ,captured))) ; todo: should we string->symbol?
+
+ (define (find-builtin-lambda e)
+ (let [(l (assq (builtin-name e) lambdas))]
+ (if l `(closure ,(car l) ,(caadr l)) #f)))
+
+ (define (builtin-name e)
+ (case e
+ ('+ "_add")
+ ('- "_sub")
+ ('* "_mul")
+ ('! "_not")
+ ('= "_eq")
+ ('bool->int "_bool2int")
+ ('print "_print")
+ (else (error #f "don't know this builtin"))))
+ (define (builtin-args e)
+ (case e
+ ('+ '(x y))
+ ('- '(x y))
+ ('* '(x y))
+ ('! '(x))
+ ('= '(x y))
+ ('bool->int '(x))
+ ('print '(x))
+ (else (error #f "don't know this builtin"))))
+
+ (define (add-builtin-lambda e)
+ (let* [(label (builtin-name e))
+ (captured '())
+ (args (builtin-args e))
+ (body `(,e ,@args))
+ (new-lambda (cons label (list captured args body)))]
+ (set! lambdas (cons new-lambda lambdas))
+ `(closure ,label ,captured)))
+
+ (define (extract e)
+ (case (ast-type e)
+ ('lambda (add-lambda 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
+ (if (eqv? 'builtin (ast-type (car e)))
+ (list (car e))
+ (list (extract (car e))))
+ (map extract (cdr e))))
+
+ ('builtin
+ (if (find-builtin-lambda e)
+ (find-builtin-lambda e)
+ (add-builtin-lambda e)))
+
+
+ (else (ast-traverse extract e))))
+ (let ((transformed (extract program)))
+ (cons lambdas transformed)))
+
+(define (extract-strings program)
+ (let ((cur-string 0)
+ (strings '())) ; assoc list of labels -> string
+ (define (fresh-string)
+ (set! cur-string (+ cur-string 1))
+ (format "string~a" (- cur-string 1)))
+ (define (extract e)
+ (case (ast-type e)
+ ('string-literal
+ (let ((label (fresh-string)))
+ (set! strings (cons (cons label e) strings))
+ `(static-string ,label)))
+ (else (ast-traverse extract e))))
+ (let ((transformed (extract program)))
+ (cons strings transformed))))
+
+(define (emit-string-data s)
+ (emit "~a:" (car s))
+ (emit "\t.string \"~a\"" (cdr s)))
+
+ ; 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 (initialize-heap)
+ (let ((mmap
+ (case target
+ ('darwin "0x20000c5")
+ ('linux "9"))))
+ ; allocate some heap memory
+ (emit "mov $~a, %rax" mmap) ; mmap
+ (emit "xor %rdi, %rdi") ; addr = null
+ (emit "movq $1024, %rsi") ; length = 1kb
+ (emit "movq $0x3, %rdx") ; prot = read | write = 0x2 | 0x1
+ ; flags = anonymous | private
+ (case target
+ ('darwin (emit "movq $0x1002, %r10")) ; anon = 0x1000, priv = 0x02
+ ('linux (emit "movq $0x22, %r10"))) ; anon = 0x20, priv = 0x02
+ (emit "movq $-1, %r8") ; fd = -1
+ (emit "xor %r9, %r9") ; offset = 0
+ (emit "syscall")
+ ; %rax now contains pointer to the start of the heap
+ ; keep track of it
+
+ (emit "movq heap_start@GOTPCREL(%rip), %rsi")
+ (emit "movq %rax, (%rsi)")))