Treatment for Hustle.

Author: dvanhorn

langs/hustle/compile-ops.rkt

@@ -13,7 +13,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)]
@@ -26,18 +26,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?
-     (let ((l1 (gensym)))
-       (seq (assert-integer rax)
-            (Cmp rax 0)
-            (Mov rax val-true)
-            (Je l1)
-            (Mov rax val-false)
-            (Label l1)))]
+     (seq (assert-integer rax)
+          (eq-value 0))]
     ['char? (type-pred mask-char type-char)]
     ['char->integer
      (seq (assert-char rax)
@@ -48,7 +43,7 @@
           (Sar rax int-shift)
           (Sal rax char-shift)
           (Xor rax type-char))]
-    ['eof-object? (eq-imm val-eof)]
+    ['eof-object? (eq-value eof)]
     ['write-byte
      (seq (assert-byte rax)
           pad-stack
@@ -73,7 +68,7 @@
      (seq (assert-cons rax)
           (Xor rax type-cons)
           (Mov rax (Offset rax 0)))]
-    ['empty? (eq-imm val-empty)]
+    ['empty? (eq-value '())]
     ['cons? (type-pred ptr-mask type-cons)]
     ['box?  (type-pred ptr-mask type-box)]))
 
@@ -96,21 +91,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)
@@ -120,7 +107,8 @@
           (Add rbx 16))]
     ['eq?
      (seq (Pop r8)
-          (eq r8 rax))]))
+          (Cmp rax r8)
+          (if-equal))]))
 
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -133,13 +121,9 @@
          (Jne 'raise_error_align))))
 
 (define (type-pred mask type)
-  (let ((l (gensym)))
-    (seq (And rax mask)
-         (Cmp rax type)
-         (Mov rax (imm->bits #t))
-         (Je l)
-         (Mov rax (imm->bits #f))
-         (Label l))))
+  (seq (And rax mask)
+       (Cmp rax type)
+       (if-equal)))
 
 (define assert-integer
   (assert-type mask-int type-int))
@@ -153,40 +137,38 @@
 (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)))
 
-;; Imm -> Asm
-(define (eq-imm imm)
-  (let ((l1 (gensym)))
-    (seq (Cmp rax 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))))
+;; -> 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-value v)
+  (seq (Cmp rax (value->bits v))
+       (if-equal)))
 
 ;; Asm
 ;; Dynamically pad the stack to be aligned for a call

langs/hustle/compile.rkt

@@ -45,7 +45,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)
@@ -73,7 +73,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/hustle/interp-heap-bits.rkt

@@ -18,15 +18,15 @@
 ;; Expr REnv Heap -> Answer
 (define (interp-env-heap e r h)
   (match e    
-    [(Int i)  (cons h (imm->bits i))]
-    [(Bool b) (cons h (imm->bits b))]
-    [(Char c) (cons h (imm->bits c))]
-    [(Eof)    (cons h (imm->bits eof))]
-    [(Empty)  (cons h (imm->bits '()))]
+    [(Int i)  (cons h (value->bits i))]
+    [(Bool b) (cons h (value->bits b))]
+    [(Char c) (cons h (value->bits c))]
+    [(Eof)    (cons h (value->bits eof))]
+    [(Empty)  (cons h (value->bits '()))]
     [(Var x)  (cons h (lookup r x))]
-    [(Prim0 'void) (cons h (imm->bits (void)))]
-    [(Prim0 'read-byte) (cons h (imm->bits (read-byte)))]
-    [(Prim0 'peek-byte) (cons h (imm->bits (peek-byte)))]
+    [(Prim0 'void) (cons h (value->bits (void)))]
+    [(Prim0 'read-byte) (cons h (value->bits (read-byte)))]
+    [(Prim0 'peek-byte) (cons h (value->bits (peek-byte)))]
     [(Prim1 p e)
      (match (interp-env-heap e r h)
        ['err 'err]
@@ -44,7 +44,7 @@
      (match (interp-env-heap p r h)
        ['err 'err]
        [(cons h v)
-        (if (= v (imm->bits #f))            
+        (if (= v (value->bits #f))
             (interp-env-heap e2 r h)
             (interp-env-heap e1 r h))])]
     [(Begin e1 e2)     

langs/hustle/interp-prims-heap-bits.rkt

@@ -6,39 +6,39 @@
 ;; Op1 Value* Heap -> Answer*
 (define (interp-prim1 p v h)
   (match (list p v)
-    [(list 'add1  (? int-bits? i))        (cons h (+ i (imm->bits 1)))]
-    [(list 'sub1  (? int-bits? i))        (cons h (- i (imm->bits 1)))]
-    [(list 'zero? (? int-bits? i))        (cons h (imm->bits (zero? i)))]
-    [(list 'char? v)                      (cons h (imm->bits (char-bits? v)))]
-    [(list 'char->integer (? char-bits?)) (cons h (imm->bits (char->integer (bits->value v))))]
-    [(list 'integer->char (? cp-bits?))   (cons h (imm->bits (integer->char (bits->value v))))]
-    [(list 'eof-object? v)                (cons h (if (= v (imm->bits eof)) val-true val-false))]
+    [(list 'add1  (? int-bits? i))        (cons h (+ i (value->bits 1)))]
+    [(list 'sub1  (? int-bits? i))        (cons h (- i (value->bits 1)))]
+    [(list 'zero? (? int-bits? i))        (cons h (value->bits (zero? i)))]
+    [(list 'char? v)                      (cons h (value->bits (char-bits? v)))]
+    [(list 'char->integer (? char-bits?)) (cons h (value->bits (char->integer (bits->value v))))]
+    [(list 'integer->char (? cp-bits?))   (cons h (value->bits (integer->char (bits->value v))))]
+    [(list 'eof-object? v)                (cons h (if (= v (value->bits eof)) val-true val-false))]
     [(list 'write-byte (? byte-bits?))    (cons h (begin (write-byte (bits->value v)) val-void))]
     [(list 'box v)                        (alloc-box v h)]
     [(list 'unbox (? box-bits?  i))       (cons h (heap-ref h i))]
     [(list 'car   (? cons-bits? i))       (cons h (heap-ref h i))]
     [(list 'cdr   (? cons-bits? i))       (cons h (heap-ref h (+ i (arithmetic-shift 1 imm-shift))))]
-    [(list 'empty? v)                     (cons h (if (= (imm->bits '()) v) val-true val-false))]
+    [(list 'empty? v)                     (cons h (if (= (value->bits '()) v) val-true val-false))]
     [_                                    'err]))
 
 ;; Op2 Value* Value* Heap -> Answer*
 (define (interp-prim2 p v1 v2 h)
   (match (list p v1 v2)
     [(list '+ (? int-bits? i1) (? int-bits? i2)) (cons h (+ i1 i2))]
     [(list '- (? int-bits? i1) (? int-bits? i2)) (cons h (- i1 i2))]
-    [(list '< (? int-bits? i1) (? int-bits? i2)) (cons h (imm->bits (< i1 i2)))]
-    [(list '= (? int-bits? i1) (? int-bits? i2)) (cons h (imm->bits (= i1 i2)))]
-    [(list 'eq? v1 v2)                           (cons h (imm->bits (= v1 v2)))]
+    [(list '< (? int-bits? i1) (? int-bits? i2)) (cons h (value->bits (< i1 i2)))]
+    [(list '= (? int-bits? i1) (? int-bits? i2)) (cons h (value->bits (= i1 i2)))]
+    [(list 'eq? v1 v2)                           (cons h (value->bits (= v1 v2)))]
     [(list 'cons v1 v2)                          (alloc-cons v1 v2 h)]
     [_  'err]))
 
 ;; Bits -> Boolean
 (define (byte-bits? i)
   (and (int-bits? i)
-       (<= (imm->bits 0) i (imm->bits 255))))
+       (<= (value->bits 0) i (value->bits 255))))
 
 ;; Bits -> Boolean
 (define (cp-bits? v)
   (and (int-bits? v)
-       (or (<= (imm->bits 0) v (imm->bits 55295))
-           (<= (imm->bits 57344) v (imm->bits 1114111)))))
+       (or (<= (value->bits 0) v (value->bits 55295))
+           (<= (value->bits 57344) v (value->bits 1114111)))))

langs/hustle/types.rkt

@@ -30,7 +30,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)
@@ -39,7 +39,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)