Step 4: Binary Primitives

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"))