summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--compiler.scm143
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)