Skip to content

Commit

Permalink
Treatment for Knock.
Browse files Browse the repository at this point in the history
  • Loading branch information
@dvanhorn
dvanhorn committed Dec 7, 2024
1 parent 59b2a31 commit 0ce1895
Show file tree
Hide file tree
Showing 9 changed files with 287 additions and 218 deletions.
57 changes: 47 additions & 10 deletions knock/assert.rkt
View file
Original file line number Diff line number Diff line change
@@ -1,12 +1,57 @@
#lang racket
(provide assert-integer assert-char assert-byte assert-codepoint
assert-box assert-cons
assert-natural assert-vector assert-string)
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)
Expand All @@ -24,14 +69,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
183 changes: 78 additions & 105 deletions knock/compile-ops.rkt
View file
Original file line number Diff line number Diff line change
Expand Up @@ -6,15 +6,13 @@
(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
(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)
Expand Down Expand Up @@ -59,54 +57,54 @@
(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)
(Mov rax rbx)
(address->type rax type-mutable-box)
(Add rbx 8))]
['box-immutable
(seq (Mov (Offset rbx 0) rax)
(Mov rax rbx)
(address->type rax type-immutable-box)
(Add rbx 8))]
['unbox
(seq (assert-box rax)
(Xor rax type-box)
(seq (box->address rax)
(Mov rax (Offset rax 0)))]
['car
(seq (assert-cons rax)
(Xor rax type-cons)
(seq (cons->address rax)
(Mov rax (Offset rax 8)))]
['cdr
(seq (assert-cons rax)
(Xor rax type-cons)
(seq (cons->address rax)
(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 (reg-16-bit rax) type-cons)
(Mov rax (value->bits #t))
(Cmovne rax r8))]
['box?
(seq (Mov r8 (value->bits #f))
(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 (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 (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 (assert-vector rax)
(Xor rax type-vect)
(Cmp rax 0)
(Je zero)
(Mov rax (Offset rax 0))
(Sal rax int-shift)
(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 (assert-string rax)
(Xor rax type-str)
(Cmp rax 0)
(Je zero)
(Mov rax (Offset rax 0))
(Sal rax int-shift)
(Jmp done)
(Label zero)
(Mov rax 0)
(Label done)))]))
(seq (string->address rax)
(Mov rax (Offset rax 0)))]))


;; Op2 -> Asm
Expand Down Expand Up @@ -140,56 +138,52 @@
(Pop rax)
(Mov (Offset rbx 8) rax)
(Mov rax rbx)
(Xor rax type-cons)
(address->type rax type-cons)
(Add rbx 16))]
['eq?
(seq (Pop r8)
(Cmp rax r8)
if-equal)]
['set-box!
(seq (Pop r8)
(mutable-box->address r8)
(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)
(address->type r9 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)
(address->type rax type-immutable-vector)
(Label done)))]
['vector-ref ; vector index
(seq (Pop r8)
(assert-vector r8)
(vector->address r8)
(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
(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 +195,51 @@
(assert-char rax)
(Cmp r8 0) ; special case empty string
(Je empty)

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

(Sar r8 int-shift)
(address->type r9 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)
(address->type rax type-immutable-string)
(Label done)))]
['string-ref
['string-ref ; string index
(seq (Pop r8)
(assert-string r8)
(string->address r8)
(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
(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!
(seq (Pop r10)
(Pop r8)
(assert-vector r8)
['vector-set! ; vector index value
(seq (Pop r10) ; index
(Pop r8) ; value
(mutable-vector->address r8)
(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)
(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
Loading

0 comments on commit 0ce1895

Please sign in to comment.