diff options
| -rw-r--r-- | compiler.scm | 170 |
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")) |