diff --git a/hoax/assert.rkt b/hoax/assert.rkt index 7559c2a..6d54572 100644 --- 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 index e5a4775..d72a33b 100644 --- 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,8 +138,7 @@ (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) @@ -171,9 +146,7 @@ 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 index 3e0e65b..8842040 100644 --- 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 index 399ea5e..0982b8d 100644 --- 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 index dfd7684..f70fd17 100644 --- 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) diff --git a/hustle/compile-ops.rkt b/hustle/compile-ops.rkt index 6ddf543..4728bd2 100644 --- a/hustle/compile-ops.rkt +++ b/hustle/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,46 +57,35 @@ (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))])) @@ -122,8 +120,7 @@ (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) @@ -131,9 +128,7 @@ 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))))])) diff --git a/hustle/compile.rkt b/hustle/compile.rkt index ba56577..9e38681 100644 --- a/hustle/compile.rkt +++ b/hustle/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) diff --git a/hustle/types.rkt b/hustle/types.rkt index 16a7aa4..632d482 100644 --- a/hustle/types.rkt +++ b/hustle/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)) @@ -67,11 +68,10 @@ (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))) ;; BoxValue* -> Address (define (box-pointer v) diff --git a/iniquity/assert.rkt b/iniquity/assert.rkt index 7559c2a..6d54572 100644 --- a/iniquity/assert.rkt +++ b/iniquity/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/iniquity/compile-ops.rkt b/iniquity/compile-ops.rkt index e5a4775..d72a33b 100644 --- a/iniquity/compile-ops.rkt +++ b/iniquity/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,8 +138,7 @@ (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) @@ -171,9 +146,7 @@ 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/iniquity/compile.rkt b/iniquity/compile.rkt index da86c01..03515af 100644 --- a/iniquity/compile.rkt +++ b/iniquity/compile.rkt @@ -7,6 +7,7 @@ (require "ast.rkt") (require "compile-ops.rkt") (require "types.rkt") +(require "assert.rkt") (require a86/ast) (define rax 'rax) @@ -93,15 +94,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/iniquity/types.rkt b/iniquity/types.rkt index 399ea5e..0982b8d 100644 --- a/iniquity/types.rkt +++ b/iniquity/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/jig/assert.rkt b/jig/assert.rkt index 7559c2a..6d54572 100644 --- a/jig/assert.rkt +++ b/jig/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/jig/compile-ops.rkt b/jig/compile-ops.rkt index e5a4775..d72a33b 100644 --- a/jig/compile-ops.rkt +++ b/jig/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,8 +138,7 @@ (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) @@ -171,9 +146,7 @@ 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/jig/compile.rkt b/jig/compile.rkt index d82e9be..8d5a825 100644 --- a/jig/compile.rkt +++ b/jig/compile.rkt @@ -7,6 +7,7 @@ (require "ast.rkt") (require "compile-ops.rkt") (require "types.rkt") +(require "assert.rkt") (require a86/ast) (define rax 'rax) @@ -94,15 +95,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/jig/types.rkt b/jig/types.rkt index 399ea5e..0982b8d 100644 --- a/jig/types.rkt +++ b/jig/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)