Treatment for Hoax.

Author: dvanhorn

langs/hoax/compile-ops.rkt

@@ -15,7 +15,7 @@
 ;; Op0 -> Asm
 (define (compile-op0 p)
   (match p
-    ['void      (seq (Mov rax val-void))]
+    ['void      (seq (Mov rax (value->bits (void))))]
     ['read-byte (seq pad-stack
                      (Call 'read_byte)
                      unpad-stack)]
@@ -28,13 +28,13 @@
   (match p
     ['add1
      (seq (assert-integer rax)
-          (Add rax (imm->bits 1)))]
+          (Add rax (value->bits 1)))]
     ['sub1
      (seq (assert-integer rax)
-          (Sub rax (imm->bits 1)))]
+          (Sub rax (value->bits 1)))]
     ['zero?
      (seq (assert-integer rax)
-          (eq-imm 0))]
+          (eq-value 0))]
     ['char?
      (type-pred mask-char type-char)]
     ['char->integer
@@ -46,14 +46,14 @@
           (Sar rax int-shift)
           (Sal rax char-shift)
           (Xor rax type-char))]
-    ['eof-object? (eq-imm eof)]
+    ['eof-object? (eq-value eof)]
     ['write-byte
      (seq (assert-byte rax)
           pad-stack
           (Mov rdi rax)
           (Call 'write_byte)
           unpad-stack
-          (Mov rax val-void))]
+          (Mov rax (value->bits (void))))]
     ['box
      (seq (Mov (Offset rbx 0) rax)
           (Mov rax rbx)
@@ -71,7 +71,7 @@
      (seq (assert-cons rax)
           (Xor rax type-cons)
           (Mov rax (Offset rax 0)))]
-    ['empty? (eq-imm '())]
+    ['empty? (eq-value '())]
     ['box?
      (type-pred ptr-mask type-box)]
     ['cons?
@@ -126,21 +126,13 @@
           (assert-integer r8)
           (assert-integer rax)
           (Cmp r8 rax)
-          (Mov rax val-true)
-          (let ((true (gensym)))
-            (seq (Jl true)
-                 (Mov rax val-false)
-                 (Label true))))]
+          (if-lt))]
     ['=
      (seq (Pop r8)
           (assert-integer r8)
           (assert-integer rax)
           (Cmp r8 rax)
-          (Mov rax val-true)
-          (let ((true (gensym)))
-            (seq (Je true)
-                 (Mov rax val-false)
-                 (Label true))))]
+          (if-equal))]
     ['cons
      (seq (Mov (Offset rbx 0) rax)
           (Pop rax)
@@ -150,7 +142,8 @@
           (Add rbx 16))]
     ['eq?
      (seq (Pop r8)
-          (eq r8 rax))]     
+          (Cmp rax r8)
+	  (if-equal))]
     ['make-vector
      (let ((loop (gensym))
            (done (gensym))
@@ -271,7 +264,7 @@
           (Sal r10 3)
           (Add r8 r10)
           (Mov (Offset r8 8) rax)
-          (Mov rax val-void))]))
+          (Mov rax (value->bits (void))))]))
 
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -287,10 +280,7 @@
   (let ((l (gensym)))
     (seq (And rax mask)
          (Cmp rax type)
-         (Mov rax (imm->bits #t))
-         (Je l)
-         (Mov rax (imm->bits #f))
-         (Label l))))
+         (if-equal))))
 
 (define assert-integer
   (assert-type mask-int type-int))
@@ -308,45 +298,43 @@
 (define (assert-codepoint r)
   (let ((ok (gensym)))
     (seq (assert-integer r)
-         (Cmp r (imm->bits 0))
+         (Cmp r (value->bits 0))
          (Jl 'raise_error_align)
-         (Cmp r (imm->bits 1114111))
+         (Cmp r (value->bits 1114111))
          (Jg 'raise_error_align)
-         (Cmp r (imm->bits 55295))
+         (Cmp r (value->bits 55295))
          (Jl ok)
-         (Cmp r (imm->bits 57344))
+         (Cmp r (value->bits 57344))
          (Jg ok)
          (Jmp 'raise_error_align)
          (Label ok))))
 
 (define (assert-byte r)
   (seq (assert-integer r)
-       (Cmp r (imm->bits 0))
+       (Cmp r (value->bits 0))
        (Jl 'raise_error_align)
-       (Cmp r (imm->bits 255))
+       (Cmp r (value->bits 255))
        (Jg 'raise_error_align)))
 
 (define (assert-natural r)
   (seq (assert-integer r)
-       (Cmp r (imm->bits 0))
+       (Cmp r (value->bits 0))
        (Jl 'raise_error_align)))
 
+;; -> Asm
+;; set rax to #t or #f based on given comparison
+(define (if-compare c)
+  (seq (Mov rax (value->bits #f))
+       (Mov r9  (value->bits #t))
+       (c rax r9)))
+
+(define (if-equal) (if-compare Cmove))
+(define (if-lt) (if-compare Cmovl))
+
 ;; Value -> Asm
-(define (eq-imm imm)
-  (let ((l1 (gensym)))
-    (seq (Cmp rax (imm->bits imm))
-         (Mov rax val-true)
-         (Je l1)
-         (Mov rax val-false)
-         (Label l1))))
-
-(define (eq ir1 ir2)
-  (let ((l1 (gensym)))
-    (seq (Cmp ir1 ir2)
-         (Mov rax val-true)
-         (Je l1)
-         (Mov rax val-false)
-         (Label l1))))
+(define (eq-value v)
+  (seq (Cmp rax (value->bits v))
+       (if-equal)))
 
 ;; Asm
 ;; Dynamically pad the stack to be aligned for a call

langs/hoax/compile.rkt

@@ -47,7 +47,7 @@
 
 ;; Value -> Asm
 (define (compile-value v)
-  (seq (Mov rax (imm->bits v))))
+  (seq (Mov rax (value->bits v))))
 
 ;; Id CEnv -> Asm
 (define (compile-variable x c)
@@ -106,7 +106,7 @@
   (let ((l1 (gensym 'if))
         (l2 (gensym 'if)))
     (seq (compile-e e1 c)
-         (Cmp rax val-false)
+         (Cmp rax (value->bits #f))
          (Je l1)
          (compile-e e2 c)
          (Jmp l2)

langs/hoax/types.rkt

@@ -32,7 +32,7 @@
         [(= b val-empty) '()]
         [else (error "invalid bits")]))
 
-(define (imm->bits v)
+(define (value->bits v)
   (cond [(eof-object? v) val-eof]
         [(integer? v) (arithmetic-shift v int-shift)]
         [(char? v)
@@ -41,7 +41,8 @@
         [(eq? v #t) val-true]
         [(eq? v #f) val-false]
         [(void? v)  val-void]
-        [(empty? v) val-empty]))
+        [(empty? v) val-empty]
+	[else (error "not an immediate value" v)]))
 
 
 (define (imm-bits? v)