diff --git a/hustle/assert.rkt b/hustle/assert.rkt index a7c4077..97b3ccc 100644 --- a/hustle/assert.rkt +++ b/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) diff --git a/hustle/compile-ops.rkt b/hustle/compile-ops.rkt index da59401..5b3f943 100644 --- a/hustle/compile-ops.rkt +++ b/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) diff --git a/hustle/parse.rkt b/hustle/parse.rkt index e307fea..7ce6c19 100644 --- a/hustle/parse.rkt +++ b/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!))) diff --git a/hustle/types.h b/hustle/types.h index 0c5e74c..542da79 100644 --- a/hustle/types.h +++ b/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 + + diff --git a/hustle/types.rkt b/hustle/types.rkt index d1c081a..35aaea9 100644 --- a/hustle/types.rkt +++ b/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)) diff --git a/hustle/values.c b/hustle/values.c index b96fffb..7ddb261 100644 --- a/hustle/values.c +++ b/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; }