WIP new tag scheme.

hustle/assert.rkt

@@ -5,6 +5,7 @@
 (require "types.rkt")
 
 (define r9 'r9)
+(define r8 'r8)
 
 (define (assert-type mask type)
   (λ (arg)
@@ -23,10 +24,11 @@
 
 (define assert-char
   (assert-type mask-char type-char))
+
 (define assert-box
-  (assert-type ptr-mask type-box))
+  (assert-type #xFF type-box))
 (define assert-cons
-  (assert-type ptr-mask type-cons))
+  (assert-type #xFF type-cons))
 
 ;; Register -> Asm
 (define (assert-codepoint r)

hustle/compile-ops.rkt

@@ -6,6 +6,7 @@
 (require a86/ast)
 
 (define rax 'rax)
+(define ax  'ax)  ; pointer type tag
 (define rbx 'rbx) ; heap
 (define rdi 'rdi) ; arg
 (define r8  'r8)  ; scratch in op2
@@ -57,26 +58,47 @@
           (Call 'write_byte)
           unpad-stack)]
     ['box
-     (seq (Mov (Offset rbx 0) rax) ; memory write
-          (Mov rax rbx)            ; put box in rax
-          (Xor rax type-box)       ; tag as a 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
+          (Add rbx 8))]
+    ['box-immutable
+     (seq (Mov (Offset rbx 0) rax)
+          (Mov rax rbx)
+          (Shl rax 16)
+          (Mov ax type-immutable-box)
           (Add rbx 8))]
     ['unbox
-     (seq (assert-box rax)
-          (Xor rax type-box)
+     (seq (And ax #b11111101) ; delete the mut bit
+          (Cmp ax type-box)
+          (Jnz 'err)
+          (Shr rax 16)
           (Mov rax (Offset rax 0)))]
     ['car
-     (seq (assert-cons rax)
-          (Xor rax type-cons)
+     (seq (Cmp ax type-cons)
+          (Jnz 'err)
+          (Shr rax 16)
           (Mov rax (Offset rax 8)))]
     ['cdr
-     (seq (assert-cons rax)
-          (Xor rax type-cons)
+     (seq (Cmp ax type-cons)
+          (Jnz 'err)
+          (Shr rax 16)
           (Mov rax (Offset rax 0)))]
-
     ['empty? (seq (Cmp rax (value->bits '())) if-equal)]
-    ['cons? (type-pred ptr-mask type-cons)]
-    ['box?  (type-pred ptr-mask type-box)]))
+    ['cons?
+     (seq (Mov r8 (value->bits #f))          
+          (Cmp ax 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)
+          (Cmovne rax r8))]))
 
 
 ;; Op2 -> Asm
@@ -110,12 +132,20 @@
           (Pop rax)
           (Mov (Offset rbx 8) rax)
           (Mov rax rbx)
-          (Xor rax type-cons)
+          (Shl rax 16)
+          (Mov ax type-cons)
           (Add rbx 16))]
     ['eq?
      (seq (Pop r8)
           (Cmp rax r8)
-          if-equal)]))
+          if-equal)]
+    ['set-box!
+     (seq (Pop r8)
+          (Cmp 'r8w type-mutable-box)
+          (Jnz 'err)
+          (Sar r8 16)
+          (Mov (Offset r8 0) rax)
+          (Mov rax (value->bits (void))))]))
 
 (define (type-pred mask type)
   (seq (And rax mask)

hustle/parse.rkt

@@ -88,8 +88,8 @@
 (define (op1? x)
   (memq x '(add1 sub1 zero? char? integer->char char->integer
                  write-byte eof-object?
-                 box unbox empty? cons? box? car cdr)))
+                 box box-immutable unbox empty? cons? box? car cdr)))
 
 (define (op2? x)
-  (memq x '(+ - < = eq? cons)))
+  (memq x '(+ - < = eq? cons set-box!)))
 

hustle/types.h

@@ -2,25 +2,36 @@
 #define TYPES_H
 
 /*
+  Important: must agree with types.rkt!
+  
   Bit layout of values
 
-  Values are either:
-  - Immediates: end in #b000
-  - Pointers
-
-  Immediates are either
-  - Integers:   end in  #b0 000
-  - Characters: end in #b01 000
-  - True:              #b11 000
-  - False:           #b1 11 000
-  - Eof:            #b10 11 000
-  - Void:           #b11 11 000
-  - Empty:         #b100 11 000
+  Values:
+  - Immediates:   end in #b0
+  - Pointers:     end in #b1
+  Immediates:
+  - Integers:   end in  #b00  
+  - Characters: end in #b010
+  - #t:             #b000110
+  - #f:             #b001110
+  - eof:            #b010110
+  - void:           #b011110
+  - '():            #b100110
+
+  Addresses are assumed to have 0s in two most significant bytes
+  (canonical address form) So a tagged pointer shifts an address to
+  the left by 16 and uses those 16 bits to tag the pointer type.
 */
-#define imm_shift        3
-#define ptr_type_mask    ((1 << imm_shift) - 1)
-#define box_type_tag     1
-#define cons_type_tag    2
+
+#define imm_shift        1
+#define ptr_type_mask    ((16 << imm_shift) - 1)
+
+#define ptr_type_tag           1
+#define box_immutable_type_tag ((0 << imm_shift) | ptr_type_tag)
+#define box_mutable_type_tag   ((1 << imm_shift) | ptr_type_tag)
+#define cons_type_tag          ((2 << imm_shift) | ptr_type_tag)
+#define ptr_shift              16
+
 #define int_shift        (1 + imm_shift)
 #define int_type_mask    ((1 << int_shift) - 1)
 #define int_type_tag     (0 << (int_shift - 1))
@@ -36,3 +47,5 @@
 #define val_empty ((4 << char_shift) | nonchar_type_tag)
 
 #endif
+
+

hustle/types.rkt

@@ -2,17 +2,31 @@
 (provide (all-defined-out))
 (require ffi/unsafe)
 
-(define imm-shift          3)
-(define imm-mask       #b111)
-(define ptr-mask       #b111)
-(define type-box       #b001)
-(define type-cons      #b010)
+(define type-box              #b0001)
+(define type-mutable-box      #b0011)
+(define type-cons             #b0101)
+(define type-proc             #b0111)
+(define type-string           #b1001)
+(define type-mutable-string   #b1011)
+
+(define type-immutable-box type-box)
+(define type-immutable-string type-string)
+
+(define (bin n)
+    (string-append "#x"
+                   (~a (number->string n 2)
+                       #:min-width 64
+                       #:left-pad-string "0"
+                       #:align 'right)))
+
+(define imm-shift          1)
+(define imm-mask         #b1)
 (define int-shift (+ 1 imm-shift))
-(define mask-int #b1111)
+(define mask-int #b11)
 (define char-shift (+ 2 imm-shift))
-(define type-int #b0000)
-(define type-char #b01000)
-(define mask-char #b11111)
+(define type-int   #b00)
+(define type-char #b010)
+(define mask-char #b111)
 
 (define (bits->value b)
   (cond [(= b (value->bits #t))  #t]
@@ -25,21 +39,23 @@
         [(char-bits? b)
          (integer->char (arithmetic-shift b (- char-shift)))]
         [(box-bits? b)
-         (box (bits->value (mem-ref b)))]
+         (define p (untag b))
+         (box (bits->value (mem-ref p)))]
         [(cons-bits? b)
-         (cons (bits->value (mem-ref (+ b 8)))
-               (bits->value (mem-ref b)))]
+         (define p (untag b))
+         (cons (bits->value (mem-ref (+ p 8)))
+               (bits->value (mem-ref p)))]
         [else (error "invalid bits")]))
 
 (define (value->bits v)
-  (cond [(eq? v #t) #b00011000]
-        [(eq? v #f) #b00111000]
+  (cond [(eq? v #t)      #b000110]
+        [(eq? v #f)      #b001110]        
+        [(eof-object? v) #b010110]        
+        [(void? v)       #b011110]
+        [(empty? v)      #b100110]
         [(integer? v) (arithmetic-shift v int-shift)]
-        [(eof-object? v) #b01011000]
-        [(void? v) #b01111000]
-        [(empty? v)      #b10011000]
         [(char? v)
-         (bitwise-ior type-char
+         (bitwise-xor type-char
                       (arithmetic-shift (char->integer v) char-shift))]
         [else (error "not an immediate value" v)]))
 
@@ -49,19 +65,16 @@
 (define (char-bits? v)
   (= type-char (bitwise-and v mask-char)))
 
-(define (imm-bits? v)
-  (zero? (bitwise-and v imm-mask)))
-
 (define (cons-bits? v)
-  (= type-cons (bitwise-and v imm-mask)))
+  (= type-cons (bitwise-and v #xFF)))
 
 (define (box-bits? v)
-  (= type-box (bitwise-and v imm-mask)))
+  (or (= type-mutable-box (bitwise-and v #xFF))
+      (= type-immutable-box (bitwise-and v #xFF))))
 
 (define (untag i)
-  (arithmetic-shift (arithmetic-shift i (- (integer-length ptr-mask)))
-                    (integer-length ptr-mask)))
+  (arithmetic-shift i -16))
 
 (define (mem-ref i)
-  (ptr-ref (cast (untag i) _int64 _pointer) _int64))
+  (ptr-ref (cast i _int64 _pointer) _int64))
 

hustle/values.c

@@ -4,7 +4,8 @@
 type_t val_typeof(val_t x)
 {
   switch (x & ptr_type_mask) {
-  case box_type_tag:
+  case box_immutable_type_tag:
+  case box_mutable_type_tag:
     return T_BOX;
   case cons_type_tag:
     return T_CONS;
@@ -73,18 +74,18 @@ val_t val_wrap_void(void)
 
 val_box_t* val_unwrap_box(val_t x)
 {
-  return (val_box_t *)(x ^ box_type_tag);
+  return (val_box_t *)(x >> ptr_shift);
 }
 val_t val_wrap_box(val_box_t* b)
 {
-  return ((val_t)b) | box_type_tag;
+  return ((val_t)b << ptr_shift) | box_mutable_type_tag;
 }
 
 val_cons_t* val_unwrap_cons(val_t x)
 {
-  return (val_cons_t *)(x ^ cons_type_tag);
+  return (val_cons_t *)(x >> ptr_shift);
 }
 val_t val_wrap_cons(val_cons_t *c)
 {
-  return ((val_t)c) | cons_type_tag;
+  return ((val_t)c << ptr_shift) | cons_type_tag;
 }