summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--compiler.scm170
1 files changed, 121 insertions, 49 deletions
diff --git a/compiler.scm b/compiler.scm
index 12ab894..411fe65 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -3,10 +3,8 @@
(ice-9 rdelim)
(srfi srfi-1))
-(define (emit template-string . args)
- (apply format #t template-string args)
- (newline))
-
+;; Assuming a 64 bit intel machine here.
+(define wordsize 8)
(define fixnum-mask 3)
(define fixnum-shift 2)
(define fixnum-tag 0)
@@ -18,6 +16,10 @@
(define boolean-tag 31)
(define empty-list 47) ;; #b00101111
+(define (emit template-string . args)
+ (apply format #t template-string args)
+ (newline))
+
(define (immediate-rep x)
(cond
((integer? x)
@@ -46,7 +48,10 @@
null?
integer?
char?
- boolean?))))
+ boolean?
+ + - *
+ = < <= > >=
+ eq? char=?))))
(define (primcall-op x)
(first x))
@@ -54,8 +59,11 @@
(define (primcall-operand1 x)
(second x))
-(define (emit-tag-check x mask tag)
- (emit-expr x)
+(define (primcall-operand2 x)
+ (third x))
+
+(define (emit-tag-check x mask tag si)
+ (emit-expr x si)
(emit "andl $~a, %eax" mask)
(emit "cmpl $~a, %eax" tag)
(emit "movl $0, %eax")
@@ -63,55 +71,102 @@
(emit "sall $~a, %eax" boolean-shift)
(emit "orl $~a, %eax" boolean-tag))
-(define (emit-expr x)
+(define (emit-comparison x y instruction si)
+ (emit-expr y si)
+ (emit "movl %eax, ~a(%rsp)" si)
+ (emit-expr x (- si wordsize))
+ (emit "cmpl ~a(%rsp), %eax" si)
+ (emit "movl $0, %eax")
+ (emit "~a %al" instruction)
+ (emit "sall $~a, %eax" boolean-shift)
+ (emit "orl $~a, %eax" boolean-tag))
+
+(define (emit-primitive-call x si)
+ (case (primcall-op x)
+ ((add1)
+ (emit-expr (primcall-operand1 x) si)
+ (emit "addl $~a, %eax" (immediate-rep 1)))
+ ((sub1)
+ (emit-expr (primcall-operand1 x) si)
+ (emit "subl $~a, %eax" (immediate-rep 1)))
+ ((integer->char)
+ (emit-expr (primcall-operand1 x) si)
+ (emit "sall $~a, %eax" (- char-shift fixnum-shift))
+ (emit "orl $~a, %eax" char-tag))
+ ((char->integer)
+ (emit-expr (primcall-operand1 x) si)
+ (emit "shr $~a, %eax" (- char-shift fixnum-shift)))
+ ((zero?)
+ (emit-expr (primcall-operand1 x) si)
+ ;; Since the tag of fixnums is 0, we can skip an 'andl'
+ ;; instruction that would apply the mask to the immediate
+ ;; value.
+ (emit "cmpl $0, %eax")
+ (emit "movl $0, %eax")
+ (emit "sete %al")
+ (emit "sall $~a, %eax" boolean-shift)
+ (emit "orl $~a, %eax" boolean-tag))
+ ((null?)
+ (emit-expr (primcall-operand1 x) si)
+ (emit "cmpl $~a, %eax" empty-list)
+ (emit "movl $0, %eax")
+ (emit "sete %al")
+ (emit "sall $~a, %eax" boolean-shift)
+ (emit "orl $~a, %eax" boolean-tag))
+ ((integer?)
+ (emit-tag-check (primcall-operand1 x) fixnum-mask fixnum-tag si))
+ ((char?)
+ (emit-tag-check (primcall-operand1 x) char-mask char-tag si))
+ ((boolean?)
+ (emit-tag-check (primcall-operand1 x) boolean-mask boolean-tag si))
+ ((+)
+ (emit-expr (primcall-operand2 x) si)
+ (emit "movl %eax, ~a(%rsp)" si)
+ (emit-expr (primcall-operand1 x) (- si wordsize))
+ (emit "addl ~a(%rsp), %eax" si))
+ ((-)
+ (emit-expr (primcall-operand2 x) si)
+ (emit "movl %eax, ~a(%rsp)" si)
+ (emit-expr (primcall-operand1 x) (- si wordsize))
+ (emit "subl ~a(%rsp), %eax" si))
+ ((*)
+ (emit-expr (primcall-operand2 x) si)
+ (emit "movl %eax, ~a(%rsp)" si)
+ (emit-expr (primcall-operand1 x) (- si wordsize))
+ (emit "imull ~a(%rsp), %eax" si)
+ ;; 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, %eax" fixnum-shift))
+ ((=)
+ (emit-comparison (primcall-operand1 x) (primcall-operand2 x) "sete" si))
+ ((<)
+ (emit-comparison (primcall-operand1 x) (primcall-operand2 x) "setl" si))
+ ((<=)
+ (emit-comparison (primcall-operand1 x) (primcall-operand2 x) "setle" si))
+ ((>)
+ (emit-comparison (primcall-operand1 x) (primcall-operand2 x) "setg" si))
+ ((>=)
+ (emit-comparison (primcall-operand1 x) (primcall-operand2 x) "setge" si))
+ ((eq?)
+ (emit-comparison (primcall-operand1 x) (primcall-operand2 x) "sete" si))
+ ((char=?)
+ (emit-comparison (primcall-operand1 x) (primcall-operand2 x) "sete" si))
+ (else
+ (error "unknown primcall op" (primcall-op x)))))
+
+
+(define (emit-expr x si)
(cond
((immediate? x)
(emit "movl $~a, %eax" (immediate-rep x)))
((primcall? x)
- (case (primcall-op x)
- ((add1)
- (emit-expr (primcall-operand1 x))
- (emit "addl $~a, %eax" (immediate-rep 1)))
- ((sub1)
- (emit-expr (primcall-operand1 x))
- (emit "subl $~a, %eax" (immediate-rep 1)))
- ((integer->char)
- (emit-expr (primcall-operand1 x))
- (emit "sall $~a, %eax" (- char-shift fixnum-shift))
- (emit "orl $~a, %eax" char-tag))
- ((char->integer)
- (emit-expr (primcall-operand1 x))
- (emit "shr $~a, %eax" (- char-shift fixnum-shift)))
- ((zero?)
- (emit-expr (primcall-operand1 x))
- ;; Since the tag of fixnums is 0, we can skip an 'andl'
- ;; instruction that would apply the mask to the immediate
- ;; value.
- (emit "cmpl $0, %eax")
- (emit "movl $0, %eax")
- (emit "sete %al")
- (emit "sall $~a, %eax" boolean-shift)
- (emit "orl $~a, %eax" boolean-tag))
- ((null?)
- (emit-expr (primcall-operand1 x))
- (emit "cmpl $~a, %eax" empty-list)
- (emit "movl $0, %eax")
- (emit "sete %al")
- (emit "sall $~a, %eax" boolean-shift)
- (emit "orl $~a, %eax" boolean-tag))
- ((integer?)
- (emit-tag-check (primcall-operand1 x) fixnum-mask fixnum-tag))
- ((char?)
- (emit-tag-check (primcall-operand1 x) char-mask char-tag))
- ((boolean?)
- (emit-tag-check (primcall-operand1 x) boolean-mask boolean-tag))
- (else
- (error "unknown primcall op" (primcall-op x)))))
+ (emit-primitive-call x si))
(else
(error "unknown expression" x))))
(define (compile-program x)
- (emit-expr x)
+ (emit-expr x (- wordsize))
(emit "ret"))
(define (compile-and-run x)
@@ -169,4 +224,21 @@ scheme_entry:
(test-case '(boolean? 1) "#f")
(test-case '(boolean? #\b) "#f")
(test-case '(boolean? #f) "#t")
- (test-case '(boolean? #t) "#t"))
+ (test-case '(boolean? #t) "#t")
+ (test-case '(+ 1 2) "3")
+ (test-case '(- 3 1) "2")
+ (test-case '(* 2 3) "6")
+ (test-case '(= 1 2) "#f")
+ (test-case '(= 1 1) "#t")
+ (test-case '(< 2 1) "#f")
+ (test-case '(< 1 2) "#t")
+ (test-case '(<= 2 1) "#f")
+ (test-case '(<= 1 2) "#t")
+ (test-case '(<= 2 2) "#t")
+ (test-case '(> 1 2) "#f")
+ (test-case '(> 2 1) "#t")
+ (test-case '(>= 1 2) "#f")
+ (test-case '(>= 2 1) "#t")
+ (test-case '(>= 2 2) "#t")
+ (test-case '(char=? #\a #\b) "#f")
+ (test-case '(char=? #\b #\b) "#t"))