Cleaning up H through J.

cmsc430 · Dec 7, 2024 · 59b2a31 · 59b2a31
1 parent bd696bf
commit 59b2a31
Show file tree

Hide file tree

Showing 16 changed files with 339 additions and 301 deletions.
diff --git a/hoax/assert.rkt b/hoax/assert.rkt
@@ -1,9 +1,57 @@
 #lang racket
 (provide assert-integer assert-char assert-byte assert-codepoint
+         cons->address box->address address->type
+         mutable-box->address
+         vector->address string->address
+         mutable-vector->address mutable-string->address
          assert-natural)
 (require a86/ast)
 (require "types.rkt")
 
+(define r9 'r9)
+
+(define (cons->address r)
+  (seq (Cmp (reg-16-bit r) type-cons)
+       (Jne 'err)
+       (Sar r 16)))
+
+(define (box->address r)
+  (seq (And (reg-16-bit r) zero-mut)
+       (Cmp (reg-16-bit r) type-box)
+       (Jne 'err)
+       (Sar r 16)))
+
+(define (mutable-box->address r)
+  (seq (Cmp (reg-16-bit r) type-mutable-box)
+       (Jne 'err)
+       (Sar r 16)))
+
+(define (vector->address r)
+  (seq (And (reg-16-bit r) zero-mut)
+       (Cmp (reg-16-bit r) type-vector)
+       (Jne 'err)
+       (Sar r 16)))
+
+(define (mutable-vector->address r)
+  (seq (Cmp (reg-16-bit r) type-mutable-vector)
+       (Jne 'err)
+       (Sar r 16)))
+
+(define (mutable-string->address r)
+  (seq (Cmp (reg-16-bit r) type-mutable-string)
+       (Jne 'err)
+       (Sar r 16)))
+
+(define (string->address r)
+  (seq (And (reg-16-bit r) zero-mut)
+       (Cmp (reg-16-bit r) type-string)
+       (Jne 'err)
+       (Sar r 16)))
+
+(define (address->type r t)
+  (seq (Shl r 16)
+       (Mov (reg-16-bit r) t)))
+
 (define (assert-type mask type)
   (λ (arg)
     (seq (Mov r9 arg)

diff --git a/hoax/compile-ops.rkt b/hoax/compile-ops.rkt
@@ -5,6 +5,15 @@
 (require "assert.rkt")
 (require a86/ast)
 
+(define rax 'rax)
+(define rdi 'rdi)
+(define rbx 'rbx)
+(define r8 'r8)
+(define r9 'r9)
+(define r10 'r10)
+(define r15 'r15)
+(define rsp 'rsp)
+
 ;; Op0 -> Asm
 (define (compile-op0 p)
   (match p
@@ -48,87 +57,54 @@
           (Call 'write_byte)
           unpad-stack)]
     ['box
-     (seq (Mov (Offset rbx 0) rax)    ; memory write
-          (Mov rax rbx)               ; put box in rax
-          (Shl rax 16)
-          (Mov ax type-mutable-box)  ; tag as a mutable box
+     (seq (Mov (Offset rbx 0) rax)
+          (Mov rax rbx)
+          (address->type rax type-mutable-box)
           (Add rbx 8))]
     ['box-immutable
      (seq (Mov (Offset rbx 0) rax)
           (Mov rax rbx)
-          (Shl rax 16)
-          (Mov ax type-immutable-box)
+          (address->type rax type-immutable-box)
           (Add rbx 8))]
     ['unbox
-     (seq (And ax zero-mut) ; delete the mut bit
-          (Cmp ax type-box)
-          (Jnz 'err)
-          (Shr rax 16)
+     (seq (box->address rax)
           (Mov rax (Offset rax 0)))]
     ['car
-     (seq (Cmp ax type-cons)
-          (Jnz 'err)
-          (Shr rax 16)
+     (seq (cons->address rax)
           (Mov rax (Offset rax 8)))]
     ['cdr
-     (seq (Cmp ax type-cons)
-          (Jnz 'err)
-          (Shr rax 16)
+     (seq (cons->address rax)
           (Mov rax (Offset rax 0)))]
     ['empty? (seq (Cmp rax (value->bits '())) if-equal)]
     ['cons?
      (seq (Mov r8 (value->bits #f))
-          (Cmp ax type-cons)
+          (Cmp (reg-16-bit rax) type-cons)
           (Mov rax (value->bits #t))
           (Cmovne rax r8))]
     ['box?
      (seq (Mov r8 (value->bits #f))
-          (Cmp ax type-immutable-box)
-          (Mov r9 (value->bits #t))
-          (Cmp ax type-mutable-box)
-          (Mov r9 (value->bits #t))
-          (Mov rax r9)
+          (And (reg-16-bit rax) zero-mut)
+          (Cmp (reg-16-bit rax) type-box)
+          (Mov rax (value->bits #t))
           (Cmovne rax r8))]
     ['vector?
      (seq (Mov r8 (value->bits #f))
-          (And ax zero-mut)
-          (Cmp ax type-vector)
+          (And (reg-16-bit rax) zero-mut)
+          (Cmp (reg-16-bit rax) type-vector)
           (Mov rax (value->bits #t))
           (Cmovne rax r8))]
     ['string?
      (seq (Mov r8 (value->bits #f))
-          (And ax zero-mut)
-          (Cmp ax type-string)
+          (And (reg-16-bit rax) zero-mut)
+          (Cmp (reg-16-bit rax) type-string)
           (Mov rax (value->bits #t))
           (Cmovne rax r8))]
     ['vector-length
-     (let ((zero (gensym))
-           (done (gensym)))
-       (seq (And ax zero-mut)
-            (Cmp ax type-vector)
-            (Jne 'err)
-            (Shr rax 16)
-            (Cmp rax 0)
-            (Je zero)
-            (Mov rax (Offset rax 0))
-            (Jmp done)
-            (Label zero)
-            (Mov rax 0)
-            (Label done)))]
+     (seq (vector->address rax)
+          (Mov rax (Offset rax 0)))]
     ['string-length
-     (let ((zero (gensym))
-           (done (gensym)))
-       (seq (And ax zero-mut)
-            (Cmp ax type-string)
-            (Jne 'err)
-            (Shr rax 16)
-            (Cmp rax 0)
-            (Je zero)
-            (Mov rax (Offset rax 0))
-            (Jmp done)
-            (Label zero)
-            (Mov rax 0)
-            (Label done)))]))
+     (seq (string->address rax)
+          (Mov rax (Offset rax 0)))]))
 
 
 ;; Op2 -> Asm
@@ -162,18 +138,15 @@
           (Pop rax)
           (Mov (Offset rbx 8) rax)
           (Mov rax rbx)
-          (Shl rax 16)
-          (Mov ax type-cons)
+          (address->type rax type-cons)
           (Add rbx 16))]
     ['eq?
      (seq (Pop r8)
           (Cmp rax r8)
           if-equal)]
     ['set-box!
      (seq (Pop r8)
-          (Cmp 'r8w type-mutable-box)
-          (Jne 'err)
-          (Sar r8 16)
+          (mutable-box->address r8)
           (Mov (Offset r8 0) rax)
           (Mov rax (value->bits (void))))]
     ['make-vector ;; size value
@@ -185,8 +158,7 @@
             (Cmp r8 0) ; special case empty string
             (Je empty)
             (Mov r9 rbx)
-            (Shl r9 16)
-            (Mov r9w type-mutable-vector)
+            (address->type r9 type-mutable-vector)
             (Mov (Offset rbx 0) r8)
             (Add rbx 8)
             (Label loop)
@@ -199,18 +171,14 @@
             (Jmp done)
             (Label empty)
             (Lea rax 'the_empty_sequence)
-            (Shl rax 16)
-            (Mov ax type-immutable-vector)
+            (address->type rax type-immutable-vector)
             (Label done)))]
     ['vector-ref ; vector index
      (seq (Pop r8)
-          (And r8w zero-mut)
-          (Cmp r8w type-vector)
-          (Jne 'err)
+          (vector->address r8)
           (assert-integer rax)
           (Cmp rax 0)
           (Jl 'err)
-          (Shr r8 16)
           (Mov r9 (Offset r8 0))  ; r9 = len
           (Sub r9 (value->bits 1))
           (Cmp r9 rax)
@@ -228,8 +196,7 @@
             (Cmp r8 0) ; special case empty string
             (Je empty)
             (Mov r9 rbx)
-            (Shl r9 16)
-            (Mov r9w type-mutable-string)
+            (address->type r9 type-mutable-string)
             (Mov (Offset rbx 0) r8)
             (Add rbx 8)
             (Label loop)
@@ -242,18 +209,14 @@
             (Jmp done)
             (Label empty)
             (Lea rax 'the_empty_sequence)
-            (Shl rax 16)
-            (Mov ax type-immutable-string)
+            (address->type rax type-immutable-string)
             (Label done)))]
     ['string-ref ; string index
      (seq (Pop r8)
-          (And r8w zero-mut)
-          (Cmp r8w type-string)
-          (Jne 'err)
+          (string->address r8)
           (assert-integer rax)
           (Cmp rax 0)
           (Jl 'err)
-          (Shr r8 16)
           (Mov r9 (Offset r8 0))  ; r9 = len
           (Sub r9 (value->bits 1))
           (Cmp r9 rax)
@@ -266,14 +229,12 @@
 (define (compile-op3 p)
   (match p
     ['vector-set! ; vector index value
-     (seq (Pop r10)
-          (Pop r8)
-          (Cmp r8w type-mutable-vector)
-          (Jne 'err)
+     (seq (Pop r10) ; index
+          (Pop r8)  ; value
+          (mutable-vector->address r8)
           (assert-integer r10)
           (Cmp r10 0)
           (Jl 'err)
-          (Shr r8 16)
           (Mov r9 (Offset r8 0))  ; r9 = len
           (Sub r9 (value->bits 1))
           (Cmp r9 r10)

diff --git a/hoax/compile.rkt b/hoax/compile.rkt
@@ -5,6 +5,7 @@
 (require "ast.rkt")
 (require "compile-ops.rkt")
 (require "types.rkt")
+(require "assert.rkt")
 (require a86/ast)
 
 (define rax 'rax)
@@ -71,15 +72,13 @@
   (let ((len (string-length s)))
     (if (zero? len)
         (seq (Lea rax 'the_empty_sequence)
-             (Shl rax 16)
-             (Mov ax type-immutable-string))
+             (address->type rax type-immutable-string))
         (seq (Mov rax (value->bits len))
              (Mov (Offset rbx 0) rax)
              (compile-string-chars (string->list s) 8)
              (Mov rax rbx)
-             (Shl rax 16)
-             (Mov ax type-immutable-string)
-             (Add rbx (+ 8 (add1 len)))))))
+             (address->type rax type-immutable-string)
+             (Add rbx (* 8 (add1 len)))))))
 
 ;; [Listof Char] Integer -> Asm
 (define (compile-string-chars cs i)

diff --git a/hoax/types.rkt b/hoax/types.rkt
@@ -11,6 +11,7 @@
 ;; Mutable and immutable must differ only in the lsb of the tag
 
 (define zero-mut #xFFFD) ; use to zero out mutability bit
+(define ptr-type-mask #xFFFF)
 
 (define type-box            (ptr-type-enum #b000))
 (define type-mutable-box    (ptr-type-enum #b001))
@@ -82,19 +83,16 @@
   (zero? (bitwise-and v imm-mask)))
 
 (define (cons-bits? v)
-  (= type-cons (bitwise-and v #xFFFF)))
+  (= type-cons (bitwise-and v ptr-type-mask)))
 
 (define (box-bits? v)
-  (or (= type-mutable-box (bitwise-and v #xFFFF))
-      (= type-immutable-box (bitwise-and v #xFFFF))))
+  (= type-box (bitwise-and v ptr-type-mask zero-mut)))
 
 (define (vect-bits? v)
-  (or (= type-mutable-vector (bitwise-and v #xFFFF))
-      (= type-immutable-vector (bitwise-and v #xFFFF))))
+  (= type-vector (bitwise-and v ptr-type-mask zero-mut)))
 
 (define (str-bits? v)
-   (or (= type-mutable-string (bitwise-and v #xFFFF))
-       (= type-immutable-string (bitwise-and v #xFFFF))))
+   (= type-string (bitwise-and v ptr-type-mask zero-mut)))
 
 ;; BoxValue* -> Address
 (define (box-pointer v)

diff --git a/hustle/assert.rkt b/hustle/assert.rkt
@@ -1,8 +1,32 @@
 #lang racket
-(provide assert-integer assert-char assert-byte assert-codepoint)
+(provide assert-integer assert-char assert-byte assert-codepoint
+         cons->address box->address address->type
+         mutable-box->address)
 (require a86/ast)
 (require "types.rkt")
 
+(define r9 'r9)
+
+(define (cons->address r)
+  (seq (Cmp (reg-16-bit r) type-cons)
+       (Jne 'err)
+       (Sar r 16)))
+
+(define (box->address r)
+  (seq (And (reg-16-bit r) zero-mut)
+       (Cmp (reg-16-bit r) type-box)
+       (Jne 'err)
+       (Sar r 16)))
+
+(define (mutable-box->address r)
+  (seq (Cmp (reg-16-bit r) type-mutable-box)
+       (Jne 'err)
+       (Sar r 16)))
+
+(define (address->type r t)
+  (seq (Shl r 16)
+       (Mov (reg-16-bit r) t)))
+
 (define (assert-type mask type)
   (λ (arg)
     (seq (Mov r9 arg)