X-Git-Url: http://git.lukelau.me/?p=scheme.git;a=blobdiff_plain;f=codegen.scm;h=7a12fc2228795b588cfbf117d3f1e7712f282be6;hp=a19b53df53fa239bc700a5d06cccfd86298d7601;hb=9d93b066cfd6505849dff12146159bedeadf96b9;hpb=25a4c23da2d76f3bb951d01b1c3175be80441a0a diff --git a/codegen.scm b/codegen.scm index a19b53d..7a12fc2 100644 --- a/codegen.scm +++ b/codegen.scm @@ -1,5 +1,8 @@ (load "typecheck.scm") (load "ast.scm") +(load "platform.scm") + +(define target host-os) (define (emit . s) (begin @@ -9,28 +12,29 @@ (define (codegen-add xs si env) (define (go ys) (if (null? ys) - (emit "movq ~a(%rsp), %rax" si) + (emit "movq ~a(%rbp), %rax" si) (begin (let ((y (car ys))) (if (integer? y) - (emit "addq $~a, ~a(%rsp)" y si) + (emit "addq $~a, ~a(%rbp)" y si) (begin (codegen-expr y (- si wordsize) env) - (emit "addq %rax, ~a(%rsp)" si)))) + (emit "addq %rax, ~a(%rbp)" si)))) (go (cdr ys))))) (begin - ; use si(%rsp) as the accumulator - (emit "movq $0, ~a(%rsp)" si) + ; use si(%rbp) as the accumulator + (emit "movq $0, ~a(%rbp)" si) (go xs))) (define (codegen-binop opcode) (lambda (a b si env) (codegen-expr b si env) - (emit "movq %rax, ~a(%rsp)" si) + (emit "movq %rax, ~a(%rbp)" si) (codegen-expr a (- si wordsize) env) - (emit "~a ~a(%rsp), %rax" opcode si))) + (emit "~a ~a(%rbp), %rax" opcode si))) (define codegen-sub (codegen-binop "sub")) + (define codegen-mul (codegen-binop "imul")) (define (codegen-not x si env) @@ -40,11 +44,37 @@ (define (codegen-eq a b si env) (codegen-expr a si env) - (emit "movq %rax, ~a(%rsp)" si) + (emit "movq %rax, ~a(%rbp)" si) (codegen-expr b (- si wordsize) env) - (emit "subq ~a(%rsp), %rax" si) - (emit "not %rax") - (emit "andq $1, %rax")) + (emit "## ~a = ~b" a b) + (emit "cmpq ~a(%rbp), %rax" si) + (emit "sete %al")) + + ; 'write file handle addr-string num-bytes + +(define (codegen-print x si env) + (codegen-expr x si env) ; x should be a static-string, producing a label + + ; make a copy of string address since %rax and %rdi are clobbered + (emit "mov %rax, %rbx") + + ; get the length of the null terminated string + (emit "mov %rax, %rdi") + (emit "xor %al, %al") ; set %al to 0 + (emit "mov $-1, %rcx") ; max search length = max int = -1 + (emit "cld") ; clear direction flag, search up in memory + (emit "repne scasb") ; scan string, %rcx = -strlen - 1 - 1 + + (emit "not %rcx") ; -%rcx = strlen + 1 + (emit "dec %rcx") + + (emit "movq %rbx, %rsi") ; string addr + (emit "movq %rcx, %rdx") ; num bytes + (emit "movq $1, %rdi") ; file handle (stdout) + (case target + ('darwin (emit "mov $0x2000004, %rax")) ; syscall 4 (write) + ('linux (emit "mov $1, %rax"))) ; syscall 1 (write) + (emit "syscall")) (define (range s n) (if (= 0 n) '() @@ -54,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(%rsp)" 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))) @@ -75,75 +134,155 @@ (when (not (assoc name env)) (error #f (format "Variable ~a is not bound" name))) (let ((offset (cdr (assoc name env)))) - (emit "movq ~a(%rsp), %rax" offset))) + (emit "movq ~a(%rbp), %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) - (when (not (eq? (ast-type closure) 'closure)) - (error #f (format "~a is not a closure" closure))) - (let* ((captured (caddr closure)) - (label (cadr closure)) - (argument-start (length captured))) - - ; first move the captured variables into param registers + ; a closure on the heap looks like: + ; 0 8 16 24 + ; addr var1.... var2.... var3.... + +(define (codegen-closure label captured si env) + (let* ((heap-offsets (map (lambda (i) (+ 8 (* 8 i))) + (range 0 (length captured))))) ; 4, 12, 20, etc. + + (emit "## creating closure") + + (emit "movq heap_start@GOTPCREL(%rip), %rbx") + + (emit "movq (%rbx), %rax") ; %rax = heap addr of closure + + + ; point heap_start to next space + (emit "addq $~a, (%rbx)" (+ 8 (* 8 (length captured)))) + + (emit "## storing address to lambda") + ; store the address to the lambda code + (emit "movq ~a@GOTPCREL(%rip), %rbx" label) + (emit "movq %rbx, 0(%rax)") + + (emit "## storing captives") + ; store the captured vars (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))) + (lambda (var-name heap-offset) + (let ([stack-offset (cdr (assoc var-name env))]) + (emit "### captive ~a" var-name) + (if (eqv? stack-offset 'self-captive) + ; captive refers to this closure: + ; move heap addr of this closure to stack! + (emit "movq %rax, ~a(%rax)" heap-offset) + (begin + (emit "movq ~a(%rbp), %rbx" stack-offset) + (emit "movq %rbx, ~a(%rax)" heap-offset))))) + captured + heap-offsets))) + + ; for now we can only call closures +(define (codegen-call f args si env) + (codegen-expr f si env) + + (emit "## starting call") + (emit "movq %rax, ~a(%rbp)" si) ; store address of closure first on stack - ; then codegen the arguments and move them into the next param registers + ; codegen the arguments, store them intermediately (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))) + (emit "## arg no. ~a" (- i 1)) + (codegen-expr e (- si (* wordsize i)) env) + ; store intermediate result on stack + (emit "movq %rax, ~a(%rbp)" (- si (* wordsize i))))) + + args (range 1 (length args))) + + ; now that we have everything we need on the stack, + ; move them into the param registers + + (emit "## moving args into place") + (for-each + (lambda (i) (emit "movq ~a(%rbp), ~a" + (- si (* wordsize i)) + (param-register i))) + (range 1 (length args))) + + ; todo: can this be made more efficient + (emit "movq ~a(%rbp), %rax" si) ; load back pointer to closure + + (emit "## moving captives into place") + + ; move captives into first argument + (emit "movq %rax, %rbx") + (emit "addq $8, %rbx") + (emit "movq %rbx, ~a" (param-register 0)) + + (emit "## performing call") - ; now call - (emit "callq ~a" label))) + (emit "addq $~a, %rsp" si) ; adjust the stack pointer to account all the stuff we put in the env + (emit "callq *(%rax)") ; call closure function + (emit "subq $~a, %rsp" si)) + ; LAMBDAS: + ; 1st param: pointer to captured args + ; 2nd param: 1st arg + ; 3rd param: 2nd arg, etc. (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)))) + (stuff (cdr l)) + (captives (car stuff)) + (args (cadr stuff)) + (body (caddr stuff)) + ; params = what actually gets passed + (params (append captives args)) - (copy-insts (map (lambda (r o) - (format "movq ~a, ~a(%rsp)" - r o)) - param-registers stack-offsets)) + (stack-offsets (map (lambda (i) + (* (- wordsize) (+ 1 i))) + (range 0 (length params)))) - (env (map cons vars stack-offsets))) + (env (map cons params stack-offsets))) (emit "~a:" label) + + (display "## lambda captives: ") + (display captives) + (newline) + (display "## lambda args: ") + (display args) + (newline) (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 + + (emit "push %rbp") ; preserve caller's base pointer + + (emit "movq %rsp, %rbp") ; set up our own base pointer + + ; load the captured vars onto the stack + (for-each + (lambda (i) + (begin + (emit "# loading captive ~a" (list-ref captives i)) + (emit "movq ~a(~a), %rbx" (* wordsize i) (param-register 0)) + (emit "movq %rbx, ~a(%rbp)" (* (- wordsize) (+ 1 i))))) + (range 0 (length captives))) + + ; load the args onto the stack + (for-each + (lambda (i) + (begin + (emit "movq ~a, %rbx" (param-register (+ 1 i))) + (emit "movq %rbx, ~a(%rbp)" + (* (- wordsize) + (+ 1 (length captives) i))))) + (range 0 (length args))) + + (codegen-expr body (* (- wordsize) (+ 1 (length params))) env) + + (emit "pop %rbp") ; restore caller's base pointer + (emit "ret"))) (define cur-label 0) (define (fresh-label) @@ -163,19 +302,22 @@ (emit "~a:" exit-label))) (define (codegen-expr e si env) + (emit "# ~a" e) (case (ast-type e) - ('builtin e) - ('closure e) + ('closure (codegen-closure (cadr e) (caddr e) si env)) ('app - (let ((callee (codegen-expr (car e) si env))) - (case callee + (case (car e) ('+ (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)) ('= (codegen-eq (cadr e) (caddr e) si env)) ('bool->int (codegen-expr (cadr e) si env)) - (else (codegen-call callee (cdr e) si env))))) + ('print (codegen-print (cadr e) si env)) + (else (codegen-call (car e) (cdr e) si env)))) + + ; this is a builtin being passed around as a variable + ('builtin (emit "movq $~a, %rax" (builtin-id e))) ('let (codegen-let (let-bindings e) (let-body e) @@ -186,37 +328,45 @@ ('if (codegen-if (cadr e) (caddr e) (cadddr 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)) + ('static-string (emit "movq ~a@GOTPCREL(%rip), %rax" + (cadr 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) (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)) - ; ((lambda (x) (+ x 1)) 42) => {lambda0: (x) (+ x 1)}, (@lambda0 42) + ; ((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) @@ -224,42 +374,108 @@ (args (lambda-args e)) (captured (free-vars e)) (body (extract (lambda-body e))) - (new-lambda (list label args captured body))) + (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 extract (let-bindings e)) + ('let `(let ,(map (lambda (b) `(,(car b) ,@(extract (cdr b)))) (let-bindings e)) ,@(map extract (let-body e)))) - ('app (append (list (extract (car 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)) - -(define (amd64-abi f) - ; preserve registers - (emit "push %rbp") - (emit "push %rbx") - (for-each (lambda (i) - (emit (string-append - "push %r" - (number->string i)))) - '(12 13 14 15)) - - (f) ; call stuff - ; restore preserved registers - (for-each (lambda (i) - (emit (string-append - "pop %r" - (number->string i)))) - '(15 14 13 12)) - (emit "pop %rbx") - (emit "pop %rbp") - (emit "ret")) +(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))) + +;; (define (amd64-abi f) +;; ; preserve registers +;; (emit "push %rbp") +;; ;; (emit "push %rbx") +;; ;; (for-each (lambda (i) +;; ;; (emit (string-append +;; ;; "push %r" +;; ;; (number->string i)))) +;; ;; '(12 13 14 15)) + +;; (emit "movq %rsp, %rbp") ; set up the base pointer + +;; (f) ; call stuff +;; ; restore preserved registers +;; ;; (for-each (lambda (i) +;; ;; (emit (string-append +;; ;; "pop %r" +;; ;; (number->string i)))) +;; ;; '(15 14 13 12)) +;; ;; (emit "pop %rbx") +;; (emit "pop %rbp") +;; (emit "ret")) ; 24(%rbp) mem arg 1 ; 16(%rbp) mem arg 0 prev frame @@ -281,26 +497,92 @@ (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)"))) + (define (codegen program) - (let* ((extract-result (extract-lambdas program)) - (lambdas (car extract-result)) - (xform-prog (cdr extract-result))) - (emit ".text") - (emit ".p2align 4,,15") + (set! cur-label 0) + (set! cur-lambda 0) + (let* ((extract-res-0 (extract-strings program)) + (strings (car extract-res-0)) + (extract-res-1 (extract-lambdas (cdr extract-res-0))) + (lambdas (car extract-res-1)) + (xform-prog (cdr extract-res-1))) + + (emit "\t.global _start") + (emit "\t.text") + ; (emit ".p2align 4,,15") is this needed? (for-each codegen-lambda lambdas) - (emit ".globl _scheme_entry") - (emit "_scheme_entry:") + (emit "_start:") + + (initialize-heap) + + (emit "movq %rsp, %rbp") ; set up the base pointer + (codegen-expr xform-prog (- wordsize) '()) - (amd64-abi - (lambda () (codegen-expr xform-prog 0 '()))))) + ; exit syscall + (emit "mov %rax, %rdi") + (case target + ('darwin (emit "movq $0x2000001, %rax")) + ('linux (emit "mov $60, %rax"))) + (emit "syscall") -(define (compile-to-binary program output) + (emit ".data") + + (emit "heap_start:") + (emit "\t.quad 0") + + (for-each emit-string-data strings))) + +(define (compile-to-binary program output t) + (set! target t) (when (not (eq? (typecheck program) 'int)) (error #f "not an int")) (let ([tmp-path "/tmp/a.s"]) (when (file-exists? tmp-path) (delete-file tmp-path)) (with-output-to-file tmp-path (lambda () (codegen program))) - (system (format "clang -fomit-frame-pointer /tmp/a.s rts.c -o ~a" output)))) + + (case target + ('darwin + (system "as /tmp/a.s -o /tmp/a.o") + (system (format "ld /tmp/a.o -e _start -macosx_version_min 10.14 -static -o ~a" output))) + ('linux + (system "as /tmp/a.s -o /tmp/a.o") + (system (format "ld /tmp/a.o -o ~a" output)))))) + +; NOTES +; syscalls in linux and darwin use the following arguments for syscall instruction: +; %rax = syscall # +; %rdi = 1st arg +; %rsi = 2nd arg +; %rdx = 3rd arg +; %r10 = 4th arg +; %r8 = 5th arg +; %r9 = 6th arg + +; on darwin, the syscall is offset by 0x2000000 +; https://opensource.apple.com/source/xnu/xnu-2782.20.48/bsd/kern/syscalls.master +; documentation for most syscalls: /Applications/Xcode.app/Contents/Developer/Platforms/MacOSX.platform/Developer/SDKs/MacOSX.sdk/usr/include/sys