diff options
| -rw-r--r-- | compiler.scm | 143 |
1 files changed, 99 insertions, 44 deletions
diff --git a/compiler.scm b/compiler.scm index 3baf0e5..b373ecc 100644 --- a/compiler.scm +++ b/compiler.scm @@ -78,62 +78,117 @@ (define (body x) (third x)) +(define (register name) + (format #f "%~a" name)) + +(define (immediate value) + (format #f "$~a" value)) + +(define rax (register "rax")) +(define rsp (register "rsp")) +(define al (register "al")) + +(define (offset n register) + (format #f "~a(~a)" n register)) + (define (emit template-string . args) (display " ") (apply format #t template-string args) (newline)) +(define (emit-mov src dest) + (emit "mov ~a, ~a" src dest)) + +(define (emit-and mask dest) + (emit "and ~a, ~a" mask dest)) + +(define (emit-or addend dest) + (emit "or ~a, ~a" addend dest)) + +(define (emit-add addend dest) + (emit "add ~a, ~a" addend dest)) + +(define (emit-sub subtrahend dest) + (emit "sub ~a, ~a" subtrahend dest)) + +(define (emit-imul multiplicand dest) + (emit "imul ~a, ~a" multiplicand dest)) + +(define (emit-sal n dest) + (emit "sal ~a, ~a" n dest)) + +(define (emit-shr n dest) + (emit "shr ~a, ~a" n dest)) + +(define (emit-cmp a b) + (emit "cmp ~a, ~a" a b)) + +(define (emit-setl dest) + (emit "setl ~a" dest)) + +(define (emit-setle dest) + (emit "setle ~a" dest)) + +(define (emit-setg dest) + (emit "setg ~a" dest)) + +(define (emit-setge dest) + (emit "setge ~a" dest)) + +(define (emit-sete dest) + (emit "sete ~a" dest)) + (define (emit-tag-check x mask tag si env) (emit-expr x si env) - (emit "and $~a, %rax" mask) - (emit "cmp $~a, %rax" tag) - (emit "mov $0, %rax") - (emit "sete %al") - (emit "sal $~a, %rax" boolean-shift) - (emit "or $~a, %rax" boolean-tag)) + (emit-and (immediate mask) rax) + (emit-cmp (immediate tag) rax) + (emit-mov (immediate 0) rax) + (emit-sete al) + (emit-sal (immediate boolean-shift) rax) + (emit-or (immediate boolean-tag) rax)) (define (emit-comparison x y instruction si env) (emit-expr y si env) - (emit "mov %rax, ~a(%rsp)" si) + (emit-mov rax (offset si rsp)) (emit-expr x (- si wordsize) env) - (emit "cmp ~a(%rsp), %rax" si) - (emit "mov $0, %rax") - (emit "~a %al" instruction) - (emit "sal $~a, %rax" boolean-shift) - (emit "or $~a, %rax" boolean-tag)) + (emit-cmp (offset si rsp) rax) + (emit-mov (immediate 0) rax) + (instruction al) + (emit-sal (immediate boolean-shift) rax) + (emit-or (immediate boolean-tag) rax)) (define (emit-primitive-call x si env) (case (primcall-op x) ((add1) (emit-expr (primcall-operand1 x) si env) - (emit "add $~a, %rax" (immediate-rep 1))) + (emit-add (immediate (immediate-rep 1)) rax)) ((sub1) (emit-expr (primcall-operand1 x) si env) - (emit "sub $~a, %rax" (immediate-rep 1))) + (emit-sub (immediate (immediate-rep 1)) rax)) ((integer->char) (emit-expr (primcall-operand1 x) si env) - (emit "sal $~a, %rax" (- char-shift fixnum-shift)) - (emit "or $~a, %rax" char-tag)) + (emit-sal (immediate (- char-shift fixnum-shift)) rax) + (emit-or (immediate char-tag) rax)) ((char->integer) (emit-expr (primcall-operand1 x) si env) - (emit "shr $~a, %rax" (- char-shift fixnum-shift))) + (emit-shr (immediate (- char-shift fixnum-shift)) rax)) ((zero?) (emit-expr (primcall-operand1 x) si env) ;; Since the tag of fixnums is 0, we can skip an 'andl' ;; instruction that would apply the mask to the immediate ;; value. - (emit "cmp $0, %rax") - (emit "mov $0, %rax") - (emit "sete %al") - (emit "sal $~a, %rax" boolean-shift) - (emit "or $~a, %rax" boolean-tag)) + (emit-cmp (immediate 0) rax) + (emit-mov (immediate 0) rax) + (emit-sete al) + (emit-sal (immediate boolean-shift) rax) + (emit-or (immediate boolean-tag) rax)) ((null?) (emit-expr (primcall-operand1 x) si env) - (emit "cmp $~a, %rax" empty-list) - (emit "mov $0, %rax") - (emit "sete %al") - (emit "sal $~a, %rax" boolean-shift) - (emit "or $~a, %rax" boolean-tag)) + (emit-cmp (immediate empty-list) rax) + (emit-mov (immediate 0) rax) + (emit-sete al) + (emit-sal (immediate boolean-shift) rax) + (emit-or (immediate boolean-tag) rax)) ((integer?) (emit-tag-check (primcall-operand1 x) fixnum-mask fixnum-tag si env)) ((char?) @@ -142,37 +197,37 @@ (emit-tag-check (primcall-operand1 x) boolean-mask boolean-tag si env)) ((+) (emit-expr (primcall-operand2 x) si env) - (emit "mov %rax, ~a(%rsp)" si) + (emit-mov rax (offset si rsp)) (emit-expr (primcall-operand1 x) (- si wordsize) env) - (emit "add ~a(%rsp), %rax" si)) + (emit-add (offset si rsp) rax)) ((-) (emit-expr (primcall-operand2 x) si env) - (emit "mov %rax, ~a(%rsp)" si) + (emit-mov rax (offset si rsp)) (emit-expr (primcall-operand1 x) (- si wordsize) env) - (emit "sub ~a(%rsp), %rax" si)) + (emit-sub (offset si rsp) rax)) ((*) (emit-expr (primcall-operand2 x) si env) - (emit "mov %rax, ~a(%rsp)" si) + (emit-mov rax (offset si rsp)) (emit-expr (primcall-operand1 x) (- si wordsize) env) - (emit "imul ~a(%rsp), %rax" si) + (emit-imul (offset si rsp) rax) ;; When two fixnums (which have 2 tag bits) are multiplied, the ;; relevant bits for the result are now 4 bytes to the left, so ;; we have to shift back 2 bytes. - (emit "shr $~a, %rax" fixnum-shift)) + (emit-shr (immediate fixnum-shift) rax)) ((=) - (emit-comparison (primcall-operand1 x) (primcall-operand2 x) "sete" si env)) + (emit-comparison (primcall-operand1 x) (primcall-operand2 x) emit-sete si env)) ((<) - (emit-comparison (primcall-operand1 x) (primcall-operand2 x) "setl" si env)) + (emit-comparison (primcall-operand1 x) (primcall-operand2 x) emit-setl si env)) ((<=) - (emit-comparison (primcall-operand1 x) (primcall-operand2 x) "setle" si env)) + (emit-comparison (primcall-operand1 x) (primcall-operand2 x) emit-setle si env)) ((>) - (emit-comparison (primcall-operand1 x) (primcall-operand2 x) "setg" si env)) + (emit-comparison (primcall-operand1 x) (primcall-operand2 x) emit-setg si env)) ((>=) - (emit-comparison (primcall-operand1 x) (primcall-operand2 x) "setge" si env) + (emit-comparison (primcall-operand1 x) (primcall-operand2 x) emit-setge si env)) ((eq?) - (emit-comparison (primcall-operand1 x) (primcall-operand2 x) "sete" si env))) + (emit-comparison (primcall-operand1 x) (primcall-operand2 x) emit-sete si env)) ((char=?) - (emit-comparison (primcall-operand1 x) (primcall-operand2 x) "sete" si env)) + (emit-comparison (primcall-operand1 x) (primcall-operand2 x) emit-sete si env)) (else (error "unknown primcall op" (primcall-op x))))) @@ -186,7 +241,7 @@ (emit-expr body si new-env) (let ((b (first b*))) (emit-expr (rhs b) si env) - (emit "mov %rax, ~a(%rsp)" si) + (emit-mov rax (offset si rsp)) (loop (cdr b*) (extend-env (lhs b) si new-env) (- si wordsize)))))) @@ -194,9 +249,9 @@ (define (emit-expr x si env) (cond ((immediate? x) - (emit "mov $~a, %rax" (immediate-rep x))) + (emit-mov (immediate (immediate-rep x)) rax)) ((variable? x) - (emit "mov ~a(%rsp), %rax" (lookup x env))) + (emit-mov (offset (lookup x env) rsp) rax)) ((let? x) (emit-let (bindings x) (body x) si env)) ((primcall? x) |