Skip to content

Commit

Permalink
Hoax and Hustle with new pointer type tagging scheme.
Browse files Browse the repository at this point in the history
  • Loading branch information
@dvanhorn
dvanhorn committed Dec 7, 2024
1 parent 952a135 commit 88e8ffd
Show file tree
Hide file tree
Showing 16 changed files with 316 additions and 277 deletions.
13 changes: 1 addition & 12 deletions hoax/assert.rkt
View file
Original file line number Diff line number Diff line change
@@ -1,12 +1,9 @@
#lang racket
(provide assert-integer assert-char assert-byte assert-codepoint
assert-box assert-cons
assert-natural assert-vector assert-string)
assert-natural)
(require a86/ast)
(require "types.rkt")

(define r9 'r9)

(define (assert-type mask type)
(λ (arg)
(seq (Mov r9 arg)
Expand All @@ -24,14 +21,6 @@

(define assert-char
(assert-type mask-char type-char))
(define assert-box
(assert-type ptr-mask type-box))
(define assert-cons
(assert-type ptr-mask type-cons))
(define assert-vector
(assert-type ptr-mask type-vect))
(define assert-string
(assert-type ptr-mask type-str))

;; Register -> Asm
(define (assert-codepoint r)
Expand Down
186 changes: 99 additions & 87 deletions hoax/compile-ops.rkt
View file
Original file line number Diff line number Diff line change
Expand Up @@ -5,17 +5,6 @@
(require "assert.rkt")
(require a86/ast)

(define rax 'rax)
(define eax 'eax) ; 32-bit load/store
(define rbx 'rbx) ; heap
(define rdi 'rdi) ; arg
(define r8 'r8) ; scratch in op2
(define r9 'r9) ; scratch
(define r10 'r10) ; scratch

(define r15 'r15) ; stack pad (non-volatile)
(define rsp 'rsp) ; stack

;; Op0 -> Asm
(define (compile-op0 p)
(match p
Expand Down Expand Up @@ -59,50 +48,83 @@
(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 zero-mut) ; 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)]
['vector? (type-pred ptr-mask type-vect)]
['string? (type-pred ptr-mask type-str)]
['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))]
['vector?
(seq (Mov r8 (value->bits #f))
(And ax zero-mut)
(Cmp ax 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)
(Mov rax (value->bits #t))
(Cmovne rax r8))]
['vector-length
(let ((zero (gensym))
(done (gensym)))
(seq (assert-vector rax)
(Xor rax type-vect)
(seq (And ax zero-mut)
(Cmp ax type-vector)
(Jne 'err)
(Shr rax 16)
(Cmp rax 0)
(Je zero)
(Mov rax (Offset rax 0))
(Sal rax int-shift)
(Jmp done)
(Label zero)
(Mov rax 0)
(Label done)))]
['string-length
(let ((zero (gensym))
(done (gensym)))
(seq (assert-string rax)
(Xor rax type-str)
(seq (And ax zero-mut)
(Cmp ax type-string)
(Jne 'err)
(Shr rax 16)
(Cmp rax 0)
(Je zero)
(Mov rax (Offset rax 0))
(Sal rax int-shift)
(Jmp done)
(Label zero)
(Mov rax 0)
Expand Down Expand Up @@ -140,56 +162,60 @@
(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)]
['set-box!
(seq (Pop r8)
(Cmp 'r8w type-mutable-box)
(Jne 'err)
(Sar r8 16)
(Mov (Offset r8 0) rax)
(Mov rax (value->bits (void))))]
['make-vector ;; size value
(let ((loop (gensym))
(done (gensym))
(empty (gensym)))
(seq (Pop r8) ;; r8 = size
(seq (Pop r8)
(assert-natural r8)
(Cmp r8 0) ; special case empty vector
(Cmp r8 0) ; special case empty string
(Je empty)

(Mov r9 rbx)
(Xor r9 type-vect)

(Sar r8 int-shift)
(Shl r9 16)
(Mov r9w type-mutable-vector)
(Mov (Offset rbx 0) r8)
(Add rbx 8)

(Label loop)
(Mov (Offset rbx 0) rax)
(Add rbx 8)
(Sub r8 1)
(Sub r8 (value->bits 1))
(Cmp r8 0)
(Jne loop)

(Mov rax r9)
(Jmp done)

(Label empty)
(Mov rax type-vect)
(Lea rax 'the_empty_sequence)
(Shl rax 16)
(Mov ax type-immutable-vector)
(Label done)))]
['vector-ref ; vector index
(seq (Pop r8)
(assert-vector r8)
(And r8w zero-mut)
(Cmp r8w type-vector)
(Jne 'err)
(assert-integer rax)
(Cmp r8 type-vect)
(Je 'err) ; special case for empty vector
(Cmp rax 0)
(Jl 'err)
(Xor r8 type-vect) ; r8 = ptr
(Shr r8 16)
(Mov r9 (Offset r8 0)) ; r9 = len
(Sar rax int-shift) ; rax = index
(Sub r9 1)
(Sub r9 (value->bits 1))
(Cmp r9 rax)
(Jl 'err)
(Sal rax 3)
(Sal rax 1)
(Add r8 rax)
(Mov rax (Offset r8 8)))]
['make-string
Expand All @@ -201,72 +227,58 @@
(assert-char rax)
(Cmp r8 0) ; special case empty string
(Je empty)

(Mov r9 rbx)
(Xor r9 type-str)

(Sar r8 int-shift)
(Shl r9 16)
(Mov r9w type-mutable-string)
(Mov (Offset rbx 0) r8)
(Add rbx 8)

(Sar rax char-shift)

(Add r8 1) ; adds 1
(Sar r8 1) ; when
(Sal r8 1) ; len is odd

(Label loop)
(Mov (Offset rbx 0) eax)
(Add rbx 4)
(Sub r8 1)
(Mov (Offset rbx 0) rax)
(Add rbx 8)
(Sub r8 (value->bits 1))
(Cmp r8 0)
(Jne loop)

(Mov rax r9)
(Jmp done)

(Label empty)
(Mov rax type-str)
(Lea rax 'the_empty_sequence)
(Shl rax 16)
(Mov ax type-immutable-string)
(Label done)))]
['string-ref
['string-ref ; string index
(seq (Pop r8)
(assert-string r8)
(And r8w zero-mut)
(Cmp r8w type-string)
(Jne 'err)
(assert-integer rax)
(Cmp r8 type-str)
(Je 'err) ; special case for empty string
(Cmp rax 0)
(Jl 'err)
(Xor r8 type-str) ; r8 = ptr
(Shr r8 16)
(Mov r9 (Offset r8 0)) ; r9 = len
(Sar rax int-shift) ; rax = index
(Sub r9 1)
(Sub r9 (value->bits 1))
(Cmp r9 rax)
(Jl 'err)
(Sal rax 2)
(Sal rax 1)
(Add r8 rax)
(Mov 'eax (Offset r8 8))
(Sal rax char-shift)
(Xor rax type-char))]))
(Mov rax (Offset r8 8)))]))

;; Op3 -> Asm
(define (compile-op3 p)
(match p
['vector-set!
['vector-set! ; vector index value
(seq (Pop r10)
(Pop r8)
(assert-vector r8)
(Cmp r8w type-mutable-vector)
(Jne 'err)
(assert-integer r10)
(Cmp r8 type-vect)
(Je 'err)
(Cmp r10 0)
(Jl 'err)
(Xor r8 type-vect) ; r8 = ptr
(Mov r9 (Offset r8 0)) ; r9 = len
(Sar r10 int-shift) ; r10 = index
(Sub r9 1)
(Shr r8 16)
(Mov r9 (Offset r8 0)) ; r9 = len
(Sub r9 (value->bits 1))
(Cmp r9 r10)
(Jl 'err)
(Sal r10 3)
(Sal r10 1)
(Add r8 r10)
(Mov (Offset r8 8) rax)
(Mov rax (value->bits (void))))]))
Expand Down
23 changes: 14 additions & 9 deletions hoax/compile.rkt
View file
Original file line number Diff line number Diff line change
Expand Up @@ -33,7 +33,10 @@
;; Error handler
(Label 'err)
pad-stack
(Call 'raise_error)))
(Call 'raise_error)
(Data)
(Label 'the_empty_sequence)
(Dq 0)))

;; type CEnv = (Listof [Maybe Id])
;; Expr CEnv -> Asm
Expand Down Expand Up @@ -67,23 +70,25 @@
(define (compile-string s)
(let ((len (string-length s)))
(if (zero? len)
(seq (Mov rax type-str))
(seq (Mov rax len)
(seq (Lea rax 'the_empty_sequence)
(Shl rax 16)
(Mov ax type-immutable-string))
(seq (Mov rax (value->bits len))
(Mov (Offset rbx 0) rax)
(compile-string-chars (string->list s) 8)
(Mov rax rbx)
(Xor rax type-str)
(Add rbx
(+ 8 (* 4 (if (odd? len) (add1 len) len))))))))
(Shl rax 16)
(Mov ax type-immutable-string)
(Add rbx (+ 8 (add1 len)))))))

;; [Listof Char] Integer -> Asm
(define (compile-string-chars cs i)
(match cs
['() (seq)]
[(cons c cs)
(seq (Mov rax (char->integer c))
(Mov (Offset rbx i) 'eax)
(compile-string-chars cs (+ 4 i)))]))
(seq (Mov rax (value->bits c))
(Mov (Offset rbx i) rax)
(compile-string-chars cs (+ 8 i)))]))

;; Op0 -> Asm
(define (compile-prim0 p)
Expand Down
Loading

0 comments on commit 88e8ffd

Please sign in to comment.