1718 lines
39 KiB
NASM
1718 lines
39 KiB
NASM
default rel
|
|
|
|
section .bss
|
|
ifile resb 0x20
|
|
buf resb 0x100
|
|
align 8,db 0
|
|
atoms times 24 resb 8
|
|
global env
|
|
heap resq 0
|
|
|
|
section .data
|
|
QUOTE_STR db "quote", 0
|
|
QUOTE_STR_LEN equ $ - QUOTE_STR
|
|
TRUE_STR db "true", 0
|
|
TRUE_STR_LEN equ $ - TRUE_STR
|
|
PLUS_STR db "+"
|
|
PLUS_STR_LEN equ $ - PLUS_STR
|
|
MINUS_STR db "-"
|
|
MINUS_STR_LEN equ $ - MINUS_STR
|
|
BITAND_STR db "bitand"
|
|
BITAND_STR_LEN equ $ - BITAND_STR
|
|
BITOR_STR db "bitor"
|
|
BITOR_STR_LEN equ $ - BITOR_STR
|
|
BITXOR_STR db "bitxor"
|
|
BITXOR_STR_LEN equ $ - BITXOR_STR
|
|
MUL_STR db "*"
|
|
MUL_STR_LEN equ $ - MUL_STR
|
|
DIV_STR db "/"
|
|
DIV_STR_LEN equ $ - DIV_STR
|
|
REM_STR db "%"
|
|
REM_STR_LEN equ $ - REM_STR
|
|
LT_STR db "<"
|
|
LT_STR_LEN equ $ - LT_STR
|
|
EQ_STR db "="
|
|
EQ_STR_LEN equ $ - EQ_STR
|
|
CAR_STR db "car"
|
|
CAR_STR_LEN equ $ - CAR_STR
|
|
CDR_STR db "cdr"
|
|
CDR_STR_LEN equ $ - CDR_STR
|
|
NOT_STR db "not"
|
|
NOT_STR_LEN equ $ - NOT_STR
|
|
NILQ_STR db "nil?"
|
|
NILQ_STR_LEN equ $ - NILQ_STR
|
|
LAMBDA_STR db "lambda"
|
|
LAMBDA_STR_LEN equ $ - LAMBDA_STR
|
|
DEFINE_STR db "define"
|
|
DEFINE_STR_LEN equ $ - DEFINE_STR
|
|
EVAL_STR db "eval"
|
|
EVAL_STR_LEN equ $ - EVAL_STR
|
|
IF_STR db "if"
|
|
IF_STR_LEN equ $ - IF_STR
|
|
LET_STR db "let"
|
|
LET_STR_LEN equ $ - LET_STR
|
|
LET_STAR_STR db "let*"
|
|
LET_STAR_STR_LEN equ $ - LET_STAR_STR
|
|
STR_LEN_STR db "str-len"
|
|
STR_LEN_STR_LEN equ $ - STR_LEN_STR
|
|
STR_PARTS_STR db "str-parts"
|
|
STR_PARTS_STR_LEN equ $ - STR_PARTS_STR
|
|
SYSCALL_STR db "syscall"
|
|
SYSCALL_STR_LEN equ $ - SYSCALL_STR
|
|
CONCAT_STR db "concat"
|
|
CONCAT_STR_LEN equ $ - CONCAT_STR
|
|
APPEND_STR db "append"
|
|
APPEND_STR_LEN equ $ - APPEND_STR
|
|
NTH_STR db "nth"
|
|
NTH_STR_LEN equ $ - NTH_STR
|
|
SET_NTH_STR db "set-nth"
|
|
SET_NTH_STR_LEN equ $ - SET_NTH_STR
|
|
|
|
align 8, db 0
|
|
ATOM_QUOTE:
|
|
dq 1
|
|
dq QUOTE_STR
|
|
dq QUOTE_STR_LEN
|
|
align 8, db 0
|
|
ATOM_T:
|
|
dq 1
|
|
dq TRUE_STR
|
|
dq 1
|
|
|
|
section .text
|
|
|
|
global heap_alloc
|
|
global heap_dealloc
|
|
|
|
global ifile
|
|
global init_source
|
|
global getc
|
|
global peekc
|
|
|
|
panic_abort:
|
|
mov rdi, 1
|
|
mov rax, 60
|
|
syscall
|
|
|
|
;; rdi: *u8
|
|
strlen:
|
|
xor rax, rax
|
|
.strlen_loop:
|
|
cmp byte [rdi + rax], 0
|
|
je .strlen_done
|
|
inc rax
|
|
jmp .strlen_loop
|
|
.strlen_done:
|
|
ret
|
|
|
|
;; @param lhs: (rdi, rsi)
|
|
;; @param rhs: (rdx, rcx)
|
|
;; @return al
|
|
strcmp:
|
|
cmp rcx, rsi
|
|
cmovb rsi, rcx ; if rhs is shorter, use its length for the loop
|
|
xor eax, eax
|
|
.strcmp_loop:
|
|
cmp rsi, rax
|
|
jz .strcmp_equal
|
|
movzx ecx, byte [rdx + rax]
|
|
cmp byte [rdi + rax], cl
|
|
lea rax, [rax + 1]
|
|
je .strcmp_loop
|
|
seta al ; al = lhs > rhs
|
|
sbb al, 0 ; al = al - CF
|
|
ret
|
|
.strcmp_equal:
|
|
xor eax, eax
|
|
ret
|
|
|
|
;; rdi: src
|
|
;; rsi: dst
|
|
;; rdx: len
|
|
memcpy:
|
|
.loop:
|
|
test rdx, rdx
|
|
jz .done
|
|
mov al, byte [rdi]
|
|
mov byte [rsi], al
|
|
inc rsi
|
|
inc rdi
|
|
dec rdx
|
|
jmp .loop
|
|
.done:
|
|
ret
|
|
|
|
;; Source
|
|
;; struct {
|
|
;; i32 fd;
|
|
;; // peeked: Option<Option<u8>>;
|
|
;; struct { u8 c; u8 peeked:1; u8 peeked_some:1; } peeked;
|
|
;; u8* buf;
|
|
;; u64 buf_cur;
|
|
;; u64 buf_len;
|
|
;; }
|
|
|
|
;; initialises a new source at $rdi with file descriptor $esi
|
|
init_source:
|
|
mov dword [rdi], esi ; fd
|
|
mov word [rdi + 4], 0 ; peeked = None
|
|
push rdi
|
|
mov rdi, 0x1000
|
|
mov rsi, 0x8
|
|
call heap_alloc
|
|
pop rdi
|
|
mov qword [rdi + 8], rax ; buf
|
|
mov qword [rdi + 16], 0 ; buf_cur
|
|
mov qword [rdi + 24], 0 ; buf_len
|
|
mov rax, rdi
|
|
ret
|
|
|
|
getc_inner:
|
|
lea rax, [rel ifile]
|
|
mov cx, word [rax + 4] ; peeked
|
|
test ch, 1
|
|
jz .iter_next
|
|
test ch, 2 ; peeked_some
|
|
setnz dl
|
|
and edx, 1
|
|
mov al, cl
|
|
ret
|
|
.iter_next:
|
|
mov rdi, qword [rax + 16] ; buf_cur
|
|
cmp rdi, qword [rax + 24] ; buf_len
|
|
jae .read
|
|
inc qword [rax + 16] ; buf_cur++
|
|
mov rsi, qword [rax + 8] ; buf
|
|
mov al, byte [rsi + rdi]
|
|
mov edx, 1 ; peeked_some = true
|
|
ret
|
|
.read:
|
|
mov rdi, qword [rax] ; fd
|
|
mov rsi, qword [rax + 8] ; buf
|
|
mov rdx, 0x1000 ; read 0x1000 bytes
|
|
push rax
|
|
mov rax, 0 ; syscall: read
|
|
syscall
|
|
cmp rax, 0
|
|
jle .eof
|
|
mov rdi, rax ; number of bytes read
|
|
pop rax
|
|
mov qword [rax + 24], rdi ; buf_len = number of bytes read
|
|
mov qword [rax + 16], 0 ; buf_cur = 0
|
|
jmp .iter_next
|
|
.eof:
|
|
pop rax
|
|
xor dl, dl ; peeked_some = false
|
|
ret
|
|
|
|
peekc:
|
|
call getc_inner
|
|
lea rdi, [rel ifile]
|
|
movzx ecx, dl
|
|
shl ecx, 1
|
|
inc ecx
|
|
shl ecx, 8
|
|
and eax, 0xff
|
|
or ecx, eax
|
|
mov word [rdi + 4], cx ; peeked = Some(Some(c))
|
|
ret
|
|
|
|
getc:
|
|
call getc_inner
|
|
lea rdi, [rel ifile]
|
|
mov word [rdi + 4], 0 ; peeked = None
|
|
and eax, 0xff
|
|
ret
|
|
|
|
;; Allocator
|
|
|
|
;; allocates $rdi bytes worth of pages via mmap
|
|
alloc_pages:
|
|
mov rax, 9 ; syscall: mmap
|
|
mov rsi, rdi ; length: rdi
|
|
xor rdi, rdi ; addr: NULL
|
|
mov rdx, 3 ; prot: PROT_READ | PROT_WRITE
|
|
mov r10, 34 ; flags: MAP_PRIVATE | MAP_ANONYMOUS
|
|
mov r8, -1 ; fd: -1
|
|
xor r9, r9 ; offset: 0
|
|
syscall
|
|
cmp rax, -1
|
|
jae panic_abort
|
|
ret
|
|
|
|
dealloc_pages:
|
|
mov rax, 11 ; syscall: munmap
|
|
mov rdi, rsi ; addr: rsi
|
|
mov rsi, rdx ; length: rdx
|
|
syscall
|
|
cmp rax, -1
|
|
jae panic_abort
|
|
ret
|
|
|
|
;; reallocates memory at $rdi[..$rsi] to a new location of size $rdx.
|
|
realloc_pages:
|
|
sub rsp, 24
|
|
mov qword [rsp], rsi
|
|
mov qword [rsp + 8], rdi
|
|
mov rdi, rdx
|
|
call alloc_pages
|
|
mov rsi, rdi
|
|
mov rdi, qword [rsp + 8]
|
|
mov rdx, qword [rsp]
|
|
mov qword [rsp + 16], rax
|
|
call memcpy
|
|
mov rdi, qword [rsp + 8]
|
|
mov rsi, qword [rsp]
|
|
call dealloc_pages
|
|
mov rax, qword [rsp + 16]
|
|
add rsp, 24
|
|
ret
|
|
|
|
;;
|
|
;; `heap` is a pointer to a struct of the form struct { [slab; 9] slabs; }
|
|
;; when the heap is empty, `heap` is NULL, and the first allocation will allocate 0x1000 bytes for the heap struct, as well as the first slabs
|
|
;; slabs have the following form: struct { u64 tail_end; u64* free; block* first_block; }
|
|
;; blocks have the following form: struct { [[u8; SIZE]; (PAGESIZE*4-8)/SIZE] chunks; block* next; }
|
|
|
|
;; slabs need to keep track of free chunks, so the smallest allocation is 0x8 bytes, and they must keep track of the tail of the last block. each block has to keep track of the next block.
|
|
;; the correct slab for a given allocation size is log2(next_power_of_two(size)) - 3 such that the first slab is for allocations of at most 0x8 bytes, the second slab is for 0x10 bytes, then 0x20, 0x40, 0x80, ...
|
|
;; each block is 4 pages long so that the 0x800 byte slab doesn't waste half its page for the tail pointer.
|
|
;; allocations of size 0x1000 or larger are allocated directly via mmap.
|
|
|
|
make_slab:
|
|
push rdi
|
|
mov rdi, 0x4000
|
|
call alloc_pages
|
|
mov qword [rax + 0x4000 - 8], 0 ; initialize the tail pointer to NULL
|
|
pop rdi
|
|
mov qword [rdi], 0 ; tail_end = 0
|
|
mov qword [rdi + 8], 0 ; free = NULL
|
|
mov qword [rdi + 16], rax ; first_block = allocated
|
|
mov qword [rdi + 24], rax ; last_block = allocated
|
|
mov rax, rdi
|
|
ret
|
|
|
|
init_heap:
|
|
push r14
|
|
xor r14, r14
|
|
mov rax, qword [rel heap]
|
|
test rax, rax
|
|
jnz .done
|
|
mov rdi, 0x1000
|
|
call alloc_pages
|
|
mov qword [rel heap], rax
|
|
.loop:
|
|
cmp r14, 9
|
|
jge .done
|
|
mov rdi, r14
|
|
shl rdi, 5 ; idx * 32
|
|
mov rax, qword [rel heap]
|
|
lea rdi, [rax + rdi] ; &heap.slabs[idx]
|
|
call make_slab
|
|
inc r14
|
|
jmp .loop
|
|
.done:
|
|
pop r14
|
|
ret
|
|
|
|
;; finds the correct slab for an allocation with size $rdi and align $rsi
|
|
slab_bucket:
|
|
xor rax, rax
|
|
dec rdi ; if size is a power of two, dec so we can later inc
|
|
dec rsi ; ^^
|
|
or rdi, rsi ; we only care about the log2, so just gather all the bits
|
|
bsr rsi, rdi ; log2((size-1) | (align-1))
|
|
sub rsi, 2 ; +1 for the dec, -3 to collapse the first 3 slabs into one
|
|
cmovae rax, rsi ; saturating sub
|
|
ret
|
|
|
|
slab_alloc:
|
|
push rbx
|
|
mov rax, qword [rdi + 8] ; free
|
|
test rax, rax
|
|
jz .no_free
|
|
mov rdx, qword [rax] ; next free chunk
|
|
mov qword [rdi + 8], rdx ; free = next
|
|
pop rbx
|
|
ret
|
|
.no_free:
|
|
add esi, 3 ; undo the -3 from slab_bucket to get the actual log2(size)
|
|
and esi, 63 ; clamp for safety
|
|
mov edx, 16376 ; 0x4000 - 8
|
|
mov ecx, esi
|
|
shr rdx, cl ; 0x4000 - 8 >> log2(size)
|
|
mov rax, qword [rdi] ; tail_end
|
|
mov rbx, qword [rdi + 24] ; last_block
|
|
cmp rax, rdx
|
|
jb .alloc_from_block
|
|
push rsi
|
|
push rax
|
|
push rdi
|
|
mov rdi, 0x4000 ; allocate a new block
|
|
call alloc_pages
|
|
mov qword [rax + 0x4000 - 8], 0 ; initialize the tail pointer to NULL
|
|
pop rdi
|
|
mov rsi, qword [rdi + 24] ; last_block
|
|
mov qword [rsi + 0x4000 - 8], rax
|
|
mov qword [rdi + 24], rax ; last_block = new block
|
|
mov rbx, rax
|
|
pop rax
|
|
pop rsi
|
|
.alloc_from_block:
|
|
inc qword [rdi] ; tail_end++
|
|
mov ecx, esi
|
|
shl rax, cl
|
|
add rax, rbx
|
|
pop rbx
|
|
ret
|
|
|
|
;; allocate a chunk of memory of size $rdi and alignment $rsi
|
|
heap_alloc:
|
|
mov rax, qword [rel heap]
|
|
cmp rax, 0
|
|
je .init
|
|
.is_init:
|
|
push rdi
|
|
call slab_bucket
|
|
cmp rax, 9
|
|
jge .mmap
|
|
mov rsi, rax
|
|
shl rax, 5 ; idx * 32
|
|
mov rdi, qword [rel heap]
|
|
lea rdi, [rdi + rax] ; &heap.slabs[idx]
|
|
call slab_alloc
|
|
pop rdi
|
|
ret
|
|
.init:
|
|
push rdi
|
|
push rsi
|
|
call init_heap
|
|
pop rsi
|
|
pop rdi
|
|
jmp .is_init
|
|
.mmap:
|
|
pop rdi
|
|
call alloc_pages
|
|
ret
|
|
|
|
;; deallocates a chunk of memory at $rdi of size $rsi and alignment $rdx
|
|
heap_dealloc:
|
|
push rsi
|
|
push rdi
|
|
mov rdi, rsi
|
|
mov rsi, rdx
|
|
call slab_bucket
|
|
cmp rax, 9
|
|
jge .mmap
|
|
mov rsi, rax
|
|
shl rax, 5 ; idx * 32
|
|
mov rdi, qword [rel heap]
|
|
lea rdi, [rdi + rax] ; &heap.slabs[idx]
|
|
mov rax, qword [rdi + 8] ; free
|
|
pop rsi
|
|
mov qword [rsi], rax
|
|
mov qword [rdi + 8], rsi
|
|
pop rsi
|
|
ret
|
|
.mmap:
|
|
pop rdi
|
|
pop rsi
|
|
call dealloc_pages
|
|
ret
|
|
|
|
|
|
|
|
;; Tokenizer
|
|
|
|
;; returns 1 if the result of `peekc()` is $dil
|
|
;; treats all characters less than ' ' as spaces.
|
|
is_ch:
|
|
push rdi
|
|
call peekc
|
|
pop rdi
|
|
mov dl, al ; cl = peekc()
|
|
cmp al, ' '
|
|
setbe al ; al = peekc() <= ' '
|
|
mov ecx, ' '
|
|
mul cl ; al = (peekc() <= ' ') ? ' ' : 0
|
|
cmp dil, ' '
|
|
cmovne ax, cx ; al = (dil == ' ') ? ((peekc() <= ' ') ? ' ' : 0) : peekc()
|
|
cmp al, dil
|
|
setz al ; al = (al == dil)
|
|
ret
|
|
|
|
;; converts char $dil to a digit with radix $rsi, returning it in $edx. $al is set to 1 if the char is a valid digit, and 0 otherwise.
|
|
to_digit:
|
|
lea eax, [rsi - 2]
|
|
cmp eax, 35
|
|
jae .invalid
|
|
movzx rdi, dil
|
|
lea edx, [rdi - 65] ; 'A' = 65
|
|
and edx, -33 ; convert to uppercase
|
|
add edx, 10 ; 'A' should map to 10
|
|
lea eax, [rdi - 48] ; '0' = 48
|
|
cmp esi, 11
|
|
cmovb edx, eax ; if radix <= 10, then take the difference from '0'
|
|
cmp edi, 58
|
|
cmovb edx, eax ; or if char < '9', then take the difference from '0'
|
|
xor eax, eax
|
|
cmp edx, esi
|
|
setb al ; al = edx < radix
|
|
ret
|
|
.invalid:
|
|
xor eax, eax
|
|
ret
|
|
|
|
;; reads the next token from ifile into buf
|
|
next_token:
|
|
push r14
|
|
xor r14, r14
|
|
sub rsp, 8
|
|
mov qword [rsp], 0 ; flags
|
|
.skip_whitespaces:
|
|
mov rdi, ' '
|
|
call is_ch
|
|
test al, al
|
|
jz .test_kw
|
|
call getc
|
|
jmp .skip_whitespaces
|
|
.test_kw:
|
|
call peekc
|
|
movzx ecx, al
|
|
sub cl, `'`
|
|
cmp cl, `)` - `'`
|
|
jg .eat
|
|
; one of '()
|
|
call getc
|
|
lea rdi, [rel buf]
|
|
mov byte [rdi], al
|
|
inc r14
|
|
jmp .done
|
|
.escapes:
|
|
db `\"'\\\n\r\t`
|
|
.eat:
|
|
cmp al, '"'
|
|
sete cl
|
|
mov byte [rsp], cl ; remember that we are parsing a string literal
|
|
.eatloop:
|
|
call getc
|
|
mov cl, byte [rsp]
|
|
not cl
|
|
test cl, 3 ; if string_flag | escape_flag, unescape the character
|
|
jnz .skip_unescaping
|
|
; unescaping \", \', \\, \n, \r, \t
|
|
xor ecx, ecx
|
|
sub al, `"`
|
|
jz .unescape
|
|
inc cl
|
|
sub al, `'` - `"`
|
|
jz .unescape
|
|
inc cl
|
|
sub al, `\\` - `'`
|
|
jz .unescape
|
|
inc cl
|
|
sub al, `n` - `\\`
|
|
jz .unescape
|
|
inc cl
|
|
sub al, `r` - `n`
|
|
jnz panic_abort ; invalid escape sequence
|
|
.unescape:
|
|
lea rdi, [rel .escapes]
|
|
add rdi, rcx
|
|
mov cl, byte [rdi]
|
|
lea rdi, [rel buf]
|
|
mov byte [rdi + r14], cl
|
|
and byte [rsp], 0b11111101 ; clear the escape flag
|
|
inc r14
|
|
jmp .eatloop
|
|
.skip_unescaping:
|
|
cmp al, `\\`
|
|
sete cl
|
|
shl cl, 1
|
|
or byte [rsp], cl ; set the escape flag
|
|
mov cl, byte [rsp]
|
|
not cl
|
|
test cl, 3 ; if string_flag | escape_flag, jump to .eatloop
|
|
je .eatloop
|
|
|
|
lea rdi, [rel buf]
|
|
mov byte [rdi + r14], al
|
|
inc r14
|
|
|
|
cmp al, '"'
|
|
sete cl
|
|
test cl, byte [rsp] ; if getc() == '"' && string_flag, we are done
|
|
jnz .done
|
|
|
|
call peekc
|
|
cmp al, ' '
|
|
setle cl
|
|
mov dl, byte [rsp]
|
|
not dl
|
|
and cl, dl ; if peekc() == ' ' && !string, we are done
|
|
cmp cl, 1
|
|
je .done
|
|
cmp al, '('
|
|
je .done
|
|
cmp al, ')'
|
|
je .done
|
|
jmp .eatloop
|
|
.done:
|
|
lea rdi, [rel buf]
|
|
mov byte [rdi + r14], 0 ; null-terminate the token
|
|
add rsp, 8
|
|
pop r14
|
|
movzx eax, byte [rel buf]
|
|
ret
|
|
|
|
global parse_next_token
|
|
parse_next_token:
|
|
call next_token
|
|
parse_cur_token:
|
|
cmp byte [rel buf], `(`
|
|
je parse_list
|
|
cmp byte [rel buf], `'`
|
|
je parse_quote
|
|
cmp byte [rel buf], `"`
|
|
je parse_string
|
|
cmp byte [rel buf], `\\`
|
|
je parse_char
|
|
jmp parse_atom
|
|
|
|
|
|
parse_list:
|
|
sub rsp, 16
|
|
lea rax, [rel nil]
|
|
mov qword [rsp], rax ; head = nil
|
|
mov qword [rsp + 8], rax ; tail = nil
|
|
.tailcall:
|
|
call next_token
|
|
cmp al, `)`
|
|
je .done
|
|
cmp al, '.'
|
|
jnz .list
|
|
; dotted pair
|
|
call parse_next_token
|
|
mov rsi, rax
|
|
mov rdi, qword [rsp] ; head
|
|
call set_cdr
|
|
call next_token
|
|
cmp al, `)`
|
|
jnz panic_abort
|
|
jmp .done
|
|
.list:
|
|
call parse_cur_token
|
|
mov rdi, rax
|
|
lea rsi, [rel nil]
|
|
call cons ; (t . nil)
|
|
xchg rax, qword [rsp + 8] ; replace(&mut tail, (t . nil))
|
|
lea rsi, [rel nil]
|
|
cmp rax, rsi
|
|
je .init_tail
|
|
mov rdi, rax
|
|
mov rsi, qword [rsp + 8]
|
|
call set_cdr
|
|
jmp .tailcall
|
|
.init_tail:
|
|
mov rax, qword [rsp + 8]
|
|
mov qword [rsp], rax
|
|
jmp .tailcall
|
|
.done:
|
|
mov rax, qword [rsp] ; return head
|
|
add rsp, 16
|
|
ret
|
|
|
|
parse_quote:
|
|
call parse_next_token
|
|
mov rdi, rax
|
|
lea rsi, [rel nil]
|
|
call cons ; (t . nil)
|
|
push rax
|
|
lea rdi, [rel ATOM_QUOTE]
|
|
mov esi, OBJ_ATOM
|
|
call obj_set_tag_in_place
|
|
push rdi
|
|
call obj_inc_ref ; increment refcount of ATOM_QUOTE
|
|
pop rdi
|
|
pop rsi
|
|
call cons ; (quote . (t . nil))
|
|
ret
|
|
|
|
parse_num:
|
|
push r12
|
|
xor rax, rax
|
|
sub rsp, 16
|
|
mov qword [rsp], 0 ; acc
|
|
mov dword [rsp + 8], 10 ; radix
|
|
lea r12, [rel buf]
|
|
cmp byte [r12], `-`
|
|
sete al
|
|
sub qword [rsp], rax ; acc = -1 if negative
|
|
lea r12, [r12 + rax]
|
|
cmp byte [r12], `0`
|
|
jne .loop
|
|
inc r12
|
|
cmp byte [r12], `x`
|
|
sete al
|
|
lea r12, [r12 + rax]
|
|
lea eax, [eax + eax*2]
|
|
shl eax, 1 ; eax = (x ? 6 : 0)
|
|
add dword [rsp + 8], eax ; radix = (x ? 16 : 10)
|
|
.loop:
|
|
mov dil, byte [r12]
|
|
test dil, dil
|
|
jz .done
|
|
|
|
mov esi, dword [rsp + 8] ; radix
|
|
call to_digit
|
|
test al, al
|
|
jz .done
|
|
mov rax, qword [rsp] ; acc
|
|
mov esi, dword [rsp + 8] ; radix
|
|
mov rcx, rdx
|
|
imul rsi
|
|
add rax, rcx
|
|
mov qword [rsp], rax ; acc = acc * radix + digit
|
|
inc r12
|
|
jmp .loop
|
|
.done:
|
|
cmp byte [r12], 0
|
|
setz al
|
|
lea rcx, [rel buf]
|
|
sub r12, rcx ; r12 = length of the number string
|
|
mul r12
|
|
mov rdx, qword [rsp] ; acc
|
|
add rsp, 16
|
|
pop r12
|
|
ret
|
|
|
|
parse_atom:
|
|
call parse_num
|
|
test al, al
|
|
jz .not_num
|
|
mov rdi, rdx
|
|
call make_num
|
|
ret
|
|
.not_num:
|
|
lea rdi, [rel buf]
|
|
call strlen
|
|
push rax
|
|
mov rdi, rax
|
|
mov rsi, 1
|
|
call heap_alloc
|
|
pop rdx ; len
|
|
push rax ; data
|
|
push rdx ; len
|
|
lea rdi, [rel buf]
|
|
mov rsi, rax
|
|
call memcpy
|
|
|
|
; data, len
|
|
pop rsi ; len
|
|
pop rdi ; data
|
|
call make_atom
|
|
ret
|
|
|
|
|
|
|
|
SPACE_CHAR db "\Space"
|
|
SPACE_CHAR_LEN equ $ - SPACE_CHAR
|
|
NL_CHAR db "\NL"
|
|
NL_CHAR_LEN equ $ - NL_CHAR
|
|
TAB_CHAR db "\Tab"
|
|
TAB_CHAR_LEN equ $ - TAB_CHAR
|
|
parse_char:
|
|
sub rsp, 8
|
|
lea rdi, [rel buf]
|
|
call strlen
|
|
mov dword [rsp], eax
|
|
lea rdi, [rel buf]
|
|
mov esi, eax
|
|
lea rdx, [rel SPACE_CHAR]
|
|
mov ecx, SPACE_CHAR_LEN
|
|
call strcmp
|
|
test al, al
|
|
mov eax, ' '
|
|
je .done
|
|
lea rdi, [rel buf]
|
|
mov esi, dword [rsp]
|
|
lea rdx, [rel NL_CHAR]
|
|
mov ecx, NL_CHAR_LEN
|
|
call strcmp
|
|
test al, al
|
|
mov eax, 10
|
|
je .done
|
|
lea rdi, [rel buf]
|
|
mov esi, dword [rsp]
|
|
lea rdx, [rel TAB_CHAR]
|
|
mov ecx, TAB_CHAR_LEN
|
|
call strcmp
|
|
test al, al
|
|
mov eax, 9
|
|
je .done
|
|
lea rdi, [rel buf]
|
|
movzx eax, byte [rdi + 1] ; get the second character of the char literal
|
|
.done:
|
|
shl ax, 8
|
|
add rsp, 8
|
|
ret
|
|
|
|
parse_string:
|
|
sub rsp, 8
|
|
lea rdi, [rel buf]
|
|
call strlen
|
|
sub eax, 2 ; subtract 2 for the quotes
|
|
mov dword [rsp], eax
|
|
mov edi, eax
|
|
mov esi, 8
|
|
call heap_alloc
|
|
lea rdi, [rel buf]
|
|
inc rdi
|
|
mov edi, eax
|
|
mov edx, dword [rsp]
|
|
push rax
|
|
call memcpy
|
|
|
|
pop rdx
|
|
mov edi, dword [rsp]
|
|
mov esi, edi
|
|
call make_str
|
|
add rsp, 8
|
|
ret
|
|
|
|
;; LispObject
|
|
|
|
OBJ_BYTE equ 0 ; inline { u8 tag: 3; u8 value: 8; }
|
|
OBJ_NUM equ 1 ; { u64 refcount; i64 value; } | inline { u8 tag: 3; i32 value: 32; i24 magic; }
|
|
OBJ_PRIM equ 2 ; { u64 refcount; u64* fn_ptr; }
|
|
OBJ_CONS equ 3 ; { u64 refcount; LispObject car; LispObject cdr; }
|
|
OBJ_CLOS equ 4 ; { u64 refcount; LispObject params; Cons body_env; }
|
|
OBJ_ATOM equ 5 ; { u64 refcount; u64 length; u8* data; }
|
|
OBJ_ARR equ 6 ; { u64 refcount; u32 len; u32 cap; TaggedPtr* data; }
|
|
; OBJ_STR equ 7
|
|
|
|
OBJ_NUM_MAGIC equ 0x5555
|
|
OBJ_INLINE_NUM equ 0x5555000000000001
|
|
|
|
OBJ_SIZES db 1, 8, 8, 16, 16, 16, 16
|
|
|
|
dtor_table:
|
|
dd 0
|
|
dd dtor_table - dtor_num
|
|
dd dtor_table - dtor_prim
|
|
dd dtor_table - dtor_cons
|
|
dd dtor_table - dtor_clos
|
|
dd dtor_table - dtor_atom
|
|
dd dtor_table - dtor_arr
|
|
dd 0
|
|
|
|
dtor_num:
|
|
call obj_ptr_part
|
|
shr rax, 56
|
|
test eax, OBJ_NUM_MAGIC
|
|
je .inline
|
|
call obj_into_ptr_part
|
|
mov esi, 16
|
|
call heap_dealloc
|
|
.inline:
|
|
ret
|
|
|
|
dtor_byte:
|
|
dtor_prim: ; shouldn't be hit, but just in case, prim is leaked
|
|
ret
|
|
dtor_cons:
|
|
dtor_clos:
|
|
call obj_ptr_part
|
|
push rax
|
|
mov rdi, qword [rax + 8] ; car
|
|
call obj_dec_ref
|
|
mov rax, qword [rsp]
|
|
mov rdi, qword [rax + 16] ; cdr
|
|
call obj_dec_ref
|
|
pop rdi
|
|
mov esi, 16
|
|
call heap_dealloc
|
|
ret
|
|
dtor_atom:
|
|
call obj_ptr_part
|
|
push rax
|
|
mov rdi, qword [rax + 8] ; data pointer
|
|
mov rsi, qword [rax + 16] ; length
|
|
call heap_dealloc
|
|
pop rdi
|
|
mov esi, 16
|
|
call heap_dealloc
|
|
ret
|
|
dtor_arr:
|
|
call obj_ptr_part
|
|
push rax
|
|
mov rdi, qword [rax + 16] ; data pointer
|
|
mov eax, edi
|
|
and eax, 0x7
|
|
lea rsi, [rel OBJ_SIZES]
|
|
movzx eax, byte [rsi + rax] ; size of each element
|
|
mul dword [rax + 8] ; capacity
|
|
mov esi, eax
|
|
call obj_into_ptr_part
|
|
call heap_dealloc
|
|
pop rdi
|
|
mov esi, 16
|
|
call heap_dealloc
|
|
ret
|
|
|
|
|
|
obj_inc_ref:
|
|
call obj_is_nil
|
|
je .done
|
|
call obj_tag_part
|
|
cmp al, OBJ_BYTE
|
|
je .done
|
|
cmp al, OBJ_NUM
|
|
je .num
|
|
.inc:
|
|
call obj_ptr_part
|
|
inc qword [rax] ; increment refcount
|
|
.done:
|
|
ret
|
|
.num:
|
|
call obj_ptr_part
|
|
shr rax, 56
|
|
test eax, OBJ_NUM_MAGIC
|
|
je .done
|
|
jmp .inc
|
|
|
|
obj_dec_ref:
|
|
call obj_is_nil
|
|
je .done
|
|
call obj_tag_part
|
|
cmp al, OBJ_BYTE
|
|
je .done
|
|
cmp al, OBJ_NUM
|
|
je .num
|
|
.dec:
|
|
call obj_ptr_part
|
|
dec qword [rax] ; decrement refcount
|
|
jnz .done
|
|
call obj_tag_part
|
|
lea rdx, qword [rel dtor_table]
|
|
movsx esi, dword [rdx + rax*4]
|
|
test esi, esi
|
|
jz .done
|
|
add rdx, rsi
|
|
jmp rdx
|
|
.done:
|
|
ret
|
|
.num:
|
|
call obj_ptr_part
|
|
shr rax, 56
|
|
test eax, OBJ_NUM_MAGIC
|
|
je .done
|
|
jmp .dec
|
|
|
|
;; construct a LispObject of type OBJ_BYTE with value $dil
|
|
make_byte:
|
|
shl edi, 8
|
|
mov sil, OBJ_BYTE
|
|
call obj_set_tag
|
|
ret
|
|
|
|
;; construct a LispObject of type OBJ_NUM with value $rdi
|
|
make_num:
|
|
mov rax, rdi
|
|
shr rax, 32
|
|
test eax, eax
|
|
jz .inline
|
|
push rdi
|
|
mov edi, 16
|
|
mov esi, 8
|
|
call heap_alloc
|
|
mov qword [rax], 1 ; refcount = 1
|
|
pop rdi
|
|
mov qword [rax + 8], rdi ; value
|
|
mov rdi, rax
|
|
mov esi, OBJ_NUM
|
|
call obj_set_tag
|
|
ret
|
|
.inline:
|
|
make_inline_num:
|
|
mov eax, edi ; take the lower 32 bits of rdi
|
|
shl rax, 8 ; shift left by 8 to make room for the tag
|
|
mov rdi, OBJ_INLINE_NUM
|
|
or rax, rdi ; set the tag to OBJ_INLINE_NUM
|
|
ret
|
|
|
|
;; construct a LispObject of type OBJ_PRIM with fn_ptr $rdi
|
|
make_prim:
|
|
push rdi
|
|
mov edi, 16
|
|
mov esi, 8
|
|
call heap_alloc
|
|
mov qword [rax], 1 ; refcount = 1
|
|
pop rdi
|
|
mov qword [rax + 8], rdi ; fn_ptr
|
|
or rax, OBJ_PRIM
|
|
ret
|
|
|
|
;; construct a LispObject of type OBJ_CLOS with params $rdi, body $rsi, and env $rdx
|
|
clos:
|
|
make_clos:
|
|
push rdx
|
|
call cons
|
|
mov rdi, rax
|
|
pop rsi
|
|
call cons
|
|
mov rdi, rax
|
|
mov esi, OBJ_CLOS
|
|
call obj_set_tag
|
|
ret
|
|
|
|
;; construct a LispObject of type OBJ_CONS with car $rdi and cdr $rsi
|
|
cons:
|
|
make_cons:
|
|
push rdi
|
|
push rsi
|
|
mov edi, 24
|
|
mov esi, 8
|
|
call heap_alloc
|
|
pop rsi
|
|
pop rdi
|
|
mov dword [rax], 1 ; refcount = 1
|
|
mov qword [rax + 8], rdi ; car
|
|
mov qword [rax + 16], rsi ; cdr
|
|
mov rdi, rax
|
|
mov esi, OBJ_CONS
|
|
call obj_set_tag
|
|
ret
|
|
|
|
;; constructs a LispObject of type OBJ_ATOM with data pointer $rdi and length $rsi
|
|
make_atom:
|
|
push rdi
|
|
push rsi
|
|
mov edi, 16
|
|
mov esi, 8
|
|
call heap_alloc
|
|
pop rsi
|
|
pop rdi
|
|
mov dword [rax], 1 ; refcount = 1
|
|
mov qword [rax + 8], rdi ; data pointer
|
|
mov qword [rax + 16], rsi ; length
|
|
or rax, OBJ_ATOM
|
|
ret
|
|
|
|
;; construct a LispObject of type OBJ_ARR with length $rdi, capacity $rsi, data pointer $rdx and data type $rcx
|
|
make_arr:
|
|
push rcx
|
|
push rdx
|
|
push rsi
|
|
push rdi
|
|
mov edi, 16
|
|
mov esi, 8
|
|
call heap_alloc
|
|
pop rdi
|
|
pop rsi
|
|
pop rdx
|
|
pop rcx
|
|
and rcx, 0x7
|
|
or rdx, rcx
|
|
|
|
mov dword [rax], 1 ; refcount = 1
|
|
mov dword [rax + 4], esi ; len
|
|
mov dword [rax + 8], edi ; cap
|
|
mov qword [rax + 16], rdx ; data pointer
|
|
or rax, OBJ_ARR
|
|
ret
|
|
|
|
;; construct a LispObject of type OBJ_ARR with length $rdi, capacity $rsi, data pointer $rdx and data type OBJ_BYTE
|
|
;; data pointer must be 8-byte aligned.
|
|
make_str:
|
|
mov rcx, OBJ_BYTE
|
|
jmp make_arr
|
|
|
|
global nil
|
|
align 8,db 0
|
|
nil dq 1 ; the nil object, with refcount = 1
|
|
|
|
is_nil:
|
|
obj_is_nil:
|
|
cmp rdi, qword [rel nil]
|
|
sete al
|
|
ret
|
|
|
|
obj_set_tag:
|
|
mov rax, rsi
|
|
and rax, 0x7
|
|
or rax, rdi
|
|
ret
|
|
|
|
obj_set_tag_in_place:
|
|
and rsi, 0x7
|
|
or rdi, rsi
|
|
ret
|
|
|
|
obj_tag_part:
|
|
mov rax, rdi
|
|
and eax, 0x7
|
|
ret
|
|
|
|
obj_into_tag_part:
|
|
and edi, 0x7
|
|
ret
|
|
|
|
obj_ptr_part:
|
|
mov rax, rdi
|
|
and rax, -8
|
|
ret
|
|
|
|
obj_into_ptr_part:
|
|
and rdi, -8
|
|
ret
|
|
|
|
obj_assert_tag:
|
|
push rax
|
|
call obj_tag_part
|
|
cmp al, sil
|
|
jne panic_abort
|
|
pop rax
|
|
ret
|
|
|
|
;; inline num opt:
|
|
num_is_inline:
|
|
mov rax, rdi
|
|
not rax
|
|
mov rdx, OBJ_INLINE_NUM
|
|
test rax, rdx
|
|
setz al
|
|
ret
|
|
|
|
num_val:
|
|
call num_is_inline
|
|
je .inline
|
|
call obj_ptr_part
|
|
call obj_ptr_part
|
|
mov rax, qword [rax + 8]
|
|
ret
|
|
.inline:
|
|
mov rax, rdi
|
|
shr rax, 8
|
|
movsx rax, eax
|
|
ret
|
|
|
|
num_set_val:
|
|
call num_is_inline
|
|
je .inline
|
|
call obj_ptr_part
|
|
mov qword [rax + 8], rsi
|
|
ret
|
|
.inline:
|
|
mov edi, esi
|
|
jmp make_inline_num
|
|
|
|
car:
|
|
call obj_tag_part
|
|
cmp al, OBJ_CONS
|
|
jne panic_abort
|
|
call obj_ptr_part
|
|
mov rax, qword [rax + 8]
|
|
ret
|
|
|
|
cdr:
|
|
call obj_tag_part
|
|
cmp al, OBJ_CONS
|
|
jne panic_abort
|
|
call obj_ptr_part
|
|
mov rax, qword [rax + 16]
|
|
ret
|
|
|
|
set_cdr:
|
|
call obj_tag_part
|
|
cmp al, OBJ_CONS
|
|
jne panic_abort
|
|
call obj_ptr_part
|
|
mov qword [rax + 16], rsi
|
|
ret
|
|
|
|
car_cdr:
|
|
call obj_tag_part
|
|
cmp al, OBJ_CONS
|
|
jne panic_abort
|
|
call obj_ptr_part
|
|
mov rax, qword [rax + 8] ; car
|
|
mov rdx, qword [rax + 16] ; cdr
|
|
ret
|
|
|
|
clos_env:
|
|
call obj_tag_part
|
|
cmp al, OBJ_CLOS
|
|
jne panic_abort
|
|
call obj_ptr_part
|
|
mov rax, qword [rax + 16] ; env
|
|
ret
|
|
|
|
clos_params:
|
|
call obj_tag_part
|
|
cmp al, OBJ_CLOS
|
|
jne panic_abort
|
|
call obj_ptr_part
|
|
mov rdi, qword [rax + 8] ; (params . body)
|
|
call car
|
|
ret
|
|
|
|
clos_body:
|
|
call obj_tag_part
|
|
cmp al, OBJ_CLOS
|
|
jne panic_abort
|
|
call obj_ptr_part
|
|
mov rdi, qword [rax + 8] ; (params . body)
|
|
call cdr
|
|
ret
|
|
|
|
;; Atoms & GEnv
|
|
|
|
section .bss
|
|
align 8, db 0
|
|
env resq 1
|
|
env_tail resq 1
|
|
|
|
section .text
|
|
|
|
;; append variable $rdi with value $rsi to the global env.
|
|
genv_append:
|
|
call cons
|
|
mov rdi, rax
|
|
lea rsi, [rel nil]
|
|
call cons
|
|
mov rsi, rax
|
|
mov rdi, qword [rel env_tail]
|
|
call set_cdr
|
|
mov qword [rel env_tail], rsi
|
|
ret
|
|
|
|
;; k: $rdi, v: $rsi, e: $rdx -> ((k . v) . e)
|
|
prepend:
|
|
push rdx
|
|
call cons
|
|
mov rdi, rax
|
|
pop rsi
|
|
call cons
|
|
ret
|
|
|
|
;; makes a (atom . prim) pair from a string $rdi of length $rsi and a primitive function pointer $rdx, and appends it to the global env.
|
|
cons_atom_prim:
|
|
push rdx
|
|
call make_atom
|
|
pop rdi
|
|
push rax
|
|
call make_prim
|
|
pop rdi
|
|
mov rsi, rax
|
|
jmp genv_append
|
|
|
|
init_env:
|
|
lea rdi, [rel ATOM_T]
|
|
mov esi, OBJ_ATOM
|
|
call obj_set_tag_in_place
|
|
mov rsi, rdi
|
|
call cons ; (t . t)
|
|
mov rdi, rax
|
|
lea rsi, [rel nil]
|
|
call cons ; ((t . t) . nil)
|
|
mov qword [rel env], rax
|
|
mov qword [rel env_tail], rax
|
|
|
|
lea rdi, [rel p_quote]
|
|
call make_prim
|
|
lea rdi, [rel ATOM_QUOTE]
|
|
or rdi, OBJ_ATOM
|
|
mov rsi, rax
|
|
jmp genv_append
|
|
|
|
mov rdi, PLUS_STR
|
|
mov esi, PLUS_STR_LEN
|
|
lea rdx, [rel p_add]
|
|
call cons_atom_prim
|
|
|
|
mov rdi, MINUS_STR
|
|
mov esi, MINUS_STR_LEN
|
|
lea rdx, [rel p_sub]
|
|
call cons_atom_prim
|
|
|
|
mov rdi, MUL_STR
|
|
mov esi, MUL_STR_LEN
|
|
lea rdx, [rel p_mul]
|
|
call cons_atom_prim
|
|
|
|
mov rdi, DIV_STR
|
|
mov esi, DIV_STR_LEN
|
|
lea rdx, [rel p_div]
|
|
call cons_atom_prim
|
|
|
|
mov rdi, REM_STR
|
|
mov esi, REM_STR_LEN
|
|
lea rdx, [rel p_rem]
|
|
call cons_atom_prim
|
|
|
|
mov rdi, BITAND_STR
|
|
mov esi, BITAND_STR_LEN
|
|
lea rdx, [rel p_bitand]
|
|
call cons_atom_prim
|
|
|
|
mov rdi, BITOR_STR
|
|
mov esi, BITOR_STR_LEN
|
|
lea rdx, [rel p_bitor]
|
|
call cons_atom_prim
|
|
|
|
mov rdi, BITXOR_STR
|
|
mov esi, BITXOR_STR_LEN
|
|
lea rdx, [rel p_bitxor]
|
|
call cons_atom_prim
|
|
|
|
mov rdi, LT_STR
|
|
mov esi, LT_STR_LEN
|
|
lea rdx, [rel p_lt]
|
|
call cons_atom_prim
|
|
|
|
mov rdi, EQ_STR
|
|
mov esi, EQ_STR_LEN
|
|
lea rdx, [rel p_eq]
|
|
call cons_atom_prim
|
|
|
|
mov rdi, CAR_STR
|
|
mov esi, CAR_STR_LEN
|
|
lea rdx, [rel p_car]
|
|
call cons_atom_prim
|
|
|
|
mov rdi, CDR_STR
|
|
mov esi, CDR_STR_LEN
|
|
lea rdx, [rel p_cdr]
|
|
call cons_atom_prim
|
|
|
|
mov rdi, NILQ_STR
|
|
mov esi, NILQ_STR_LEN
|
|
lea rdx, [rel p_is_nil]
|
|
call cons_atom_prim
|
|
|
|
mov rdi, LAMBDA_STR
|
|
mov esi, LAMBDA_STR_LEN
|
|
lea rdx, [rel p_lambda]
|
|
call cons_atom_prim
|
|
|
|
mov rdi, DEFINE_STR
|
|
mov esi, DEFINE_STR_LEN
|
|
lea rdx, [rel p_define]
|
|
call cons_atom_prim
|
|
|
|
mov rdi, EVAL_STR
|
|
mov esi, EVAL_STR_LEN
|
|
lea rdx, [rel p_eval]
|
|
call cons_atom_prim
|
|
|
|
mov rdi, IF_STR
|
|
mov esi, IF_STR_LEN
|
|
lea rdx, [rel p_if]
|
|
call cons_atom_prim
|
|
|
|
mov rdi, LET_STR
|
|
mov esi, LET_STR_LEN
|
|
lea rdx, [rel p_let]
|
|
call cons_atom_prim
|
|
|
|
mov rdi, LETSTAR_STR
|
|
mov esi, LETSTAR_STR_LEN
|
|
lea rdx, [rel p_letstar]
|
|
call cons_atom_prim
|
|
|
|
mov rdi, STR_LEN_STR
|
|
mov esi, STR_LEN_STR_LEN
|
|
lea rdx, [rel p_str_len]
|
|
call cons_atom_prim
|
|
|
|
mov rdi, STR_PARTS_STR
|
|
mov esi, STR_PARTS_STR_LEN
|
|
lea rdx, [rel p_str_parts]
|
|
call cons_atom_prim
|
|
|
|
mov rdi, SYSCALL_STR
|
|
mov esi, SYSCALL_STR_LEN
|
|
lea rdx, [rel p_syscall]
|
|
call cons_atom_prim
|
|
|
|
mov rdi, APPEND_STR
|
|
mov esi, APPEND_STR_LEN
|
|
lea rdx, [rel p_append]
|
|
call cons_atom_prim
|
|
|
|
mov rdi, CONCAT_STR
|
|
mov esi, CONCAT_STR_LEN
|
|
lea rdx, [rel p_concat]
|
|
call cons_atom_prim
|
|
|
|
mov rdi, NTH_STR
|
|
mov esi, NTH_STR_LEN
|
|
lea rdx, [rel p_nth]
|
|
call cons_atom_prim
|
|
|
|
mov rdi, SET_NTH_STR
|
|
mov esi, SET_NTH_STR_LEN
|
|
lea rdx, [rel p_set_nth]
|
|
call cons_atom_prim
|
|
|
|
mov rax, qword [rel env]
|
|
ret
|
|
|
|
;; Evaluation
|
|
|
|
global eval:
|
|
;; evaluate the expression $rdi in the environment $rsi.
|
|
eval:
|
|
call obj_tag_part
|
|
cmp al, OBJ_ATOM
|
|
je .atom
|
|
cmp al, OBJ_CONS
|
|
jne .uneval
|
|
sub rsp, 16
|
|
mov qword [rsp], rsi ; save env
|
|
call cdr
|
|
mov qword [rsp + 8], rax ; cdr
|
|
call car
|
|
mov rdi, rax ; car
|
|
mov rsi, qword [rsp] ; env
|
|
call eval
|
|
mov rdi, rax ; eval(car, env)
|
|
mov rsi, qword [rsp + 8] ; cdr
|
|
mov rdx, qword [rsp] ; env
|
|
call apply ; apply(eval(car, env), cdr, env)
|
|
add rsp, 16
|
|
ret
|
|
.atom:
|
|
call assoc
|
|
ret
|
|
.uneval:
|
|
mov rax, rdi
|
|
ret
|
|
|
|
;; apply the function $rdi to the argument list $rsi in the environment $rdx.
|
|
apply:
|
|
call obj_tag_part
|
|
cmp al, OBJ_PRIM
|
|
je .prim
|
|
cmp al, OBJ_CLOS
|
|
jne panic_abort
|
|
call reduce
|
|
ret
|
|
.prim:
|
|
call obj_ptr_part
|
|
mov rax, qword [rax + 8] ; fn_ptr
|
|
mov rdi, rsi ; argument list
|
|
mov rsi, rdx ; env
|
|
jmp rax
|
|
|
|
;; returns the value associated with the symbol $rdi in the environment $rsi, or nil if not found.
|
|
assoc:
|
|
sub rsp, 16
|
|
mov qword [rsp], rsi ; save env
|
|
mov qword [rsp + 8], rdi ; save symbol
|
|
.loop:
|
|
mov rdi, qword [rsp] ; env
|
|
call is_nil
|
|
jnz .not_found
|
|
call obj_tag_part
|
|
cmp al, OBJ_CONS
|
|
jne .not_found
|
|
call car
|
|
mov rdi, rax ; (sym . val)
|
|
call car
|
|
mov rdi, rax ; sym
|
|
mov rsi, qword [rsp + 8] ; symbol
|
|
call obj_eq
|
|
test al, al
|
|
je .found
|
|
mov rdi, qword [rsp] ; env
|
|
call cdr
|
|
mov qword [rsp], rax ; env = cdr(env)
|
|
jmp .loop
|
|
.found:
|
|
mov rdi, qword [rsp] ; env
|
|
call car
|
|
mov rdi, rax ; (sym . val)
|
|
call cdr
|
|
mov rax, rdi ; return val
|
|
add rsp, 16
|
|
ret
|
|
.not_found:
|
|
lea rax, [rel nil]
|
|
add rsp, 16
|
|
ret
|
|
|
|
;; applies the closure $rdi to the argument list $rsi in the environment $rdx, and returns the result.
|
|
reduce:
|
|
sub rsp, 32
|
|
mov qword [rsp], rdx ; env
|
|
mov qword [rsp + 8], rdi ; closure
|
|
call clos_env
|
|
mov rdi, rax
|
|
call obj_is_nil
|
|
cmove rax, qword [rel env]
|
|
mov qword [rsp + 16], rax ; clos_env = clos_env(closure) or global env
|
|
mov rdi, rsi
|
|
mov rsi, qword [rsp] ; env
|
|
call eval_list
|
|
mov rsi, rax ; eval_list(args, env)
|
|
mov rdi, qword [rsp + 8] ; closure
|
|
call clos_params
|
|
mov rdi, rax ; params
|
|
mov rdx, qword [rsp + 16] ; clos_env
|
|
call bind_list ; bind_list(params, eval_list(args, env), clos_env)
|
|
mov rsi, rax ; new_env
|
|
mov rdi, qword [rsp + 8] ; closure
|
|
call clos_body
|
|
mov rdi, rax ; body
|
|
call eval
|
|
add rsp, 32
|
|
ret
|
|
|
|
;; zips the list of symbols $rdi with the list of values $rsi, binds each pair to the environment $rdx, and returns the new environment.
|
|
bind_list:
|
|
sub rsp, 24
|
|
mov qword [rsp], rdx ; save env
|
|
.tailcall:
|
|
call obj_is_nil
|
|
je .done
|
|
call car_cdr ; (sym . syms)
|
|
mov qword [rsp + 8], rdx ; syms
|
|
mov rcx, rax ; sym
|
|
mov rdi, rsi
|
|
call car_cdr ; (val . vals)
|
|
mov qword [rsp + 16], rdx ; vals
|
|
mov rdi, rcx ; sym
|
|
mov rsi, rax ; val
|
|
mov rdx, qword [rsp] ; env
|
|
call prepend ; ((sym . val) . env)
|
|
mov qword [rsp], rax ; env = ((sym . val) . env)
|
|
mov rdi, qword [rsp + 8] ; syms
|
|
mov rsi, qword [rsp + 16] ; vals
|
|
jmp .tailcall
|
|
.done:
|
|
mov rax, qword [rsp] ; return env
|
|
add rsp, 24
|
|
ret
|
|
|
|
;; takes a list $rdi and an environment $rsi, and maps each element of the list with `eval`
|
|
eval_list:
|
|
sub rsp, 32
|
|
mov qword [rsp], rsi ; env
|
|
lea rax, [rel nil]
|
|
mov qword [rsp + 8], rax ; tail = nil
|
|
mov qword [rsp + 16], rax ; head = nil
|
|
.tailcall:
|
|
call obj_is_nil
|
|
je .done
|
|
call obj_tag_part
|
|
cmp al, OBJ_CONS
|
|
jne .not_cons
|
|
call car_cdr
|
|
mov qword [rsp + 24], rdx ; cdr
|
|
mov rdi, rax ; car
|
|
mov rsi, qword [rsp] ; env
|
|
call eval
|
|
mov rdi, rax ; eval(car, env)
|
|
lea rsi, [rel nil]
|
|
call cons ; (eval(car, env) . nil)
|
|
xchg rax, qword [rsp + 8] ; replace(&mut tail, new_tail)
|
|
lea rsi, [rel nil]
|
|
cmp rax, rsi
|
|
je .init_tail
|
|
mov rdi, rax
|
|
mov rsi, qword [rsp + 8] ; tail
|
|
call set_cdr
|
|
mov rdi, qword [rsp + 24] ; cdr
|
|
jmp .tailcall
|
|
.init_tail:
|
|
mov rax, qword [rsp + 8] ; tail
|
|
mov qword [rsp + 16], rax ; head = tail
|
|
mov rdi, qword [rsp + 24] ; cdr
|
|
jmp .tailcall
|
|
.not_cons:
|
|
mov rsi, qword [rsp] ; env
|
|
call eval
|
|
mov rsi, rax
|
|
mov rdi, qword [rsp + 8] ; tail
|
|
call set_cdr
|
|
.done:
|
|
mov rax, qword [rsp + 16] ; head
|
|
add rsp, 32
|
|
ret
|
|
|
|
obj_eq:
|
|
sub rsp, 24
|
|
cmp rdi, rsi
|
|
je .equal
|
|
mov qword [rsp], rdi ; lhs
|
|
mov qword [rsp + 8], rsi ; rhs
|
|
call obj_tag_part
|
|
mov dl, al
|
|
mov rdi, rsi
|
|
call obj_tag_part
|
|
cmp al, dl ; lhs_tag == rhs_tag?
|
|
jne .not_equal
|
|
cmp al, OBJ_BYTE
|
|
je .byte
|
|
cmp al, OBJ_NUM
|
|
je .num
|
|
cmp al, OBJ_PRIM
|
|
je .prim
|
|
cmp al, OBJ_CONS
|
|
je .cons
|
|
cmp al, OBJ_CLOS
|
|
je .clos
|
|
cmp al, OBJ_ATOM
|
|
je .atom
|
|
cmp al, OBJ_ARR
|
|
je .arr
|
|
.byte: ; bytes shouldn't ever hit this, so it's ok to panic
|
|
jmp panic_abort
|
|
.num:
|
|
mov rdi, qword [rsp] ; lhs
|
|
call num_val
|
|
mov qword [rsp], rax
|
|
mov rdi, qword [rsp + 8] ; rhs
|
|
call num_val
|
|
cmp rax, qword [rsp]
|
|
je .equal
|
|
jmp .not_equal
|
|
.prim:
|
|
mov rdi, qword [rsp] ; lhs
|
|
call obj_ptr_part
|
|
mov rdx, qword [rax + 8] ; lhs fn_ptr
|
|
mov rdi, qword [rsp + 8] ; rhs
|
|
call obj_ptr_part
|
|
cmp rdx, qword [rax + 8] ; lhs fn_ptr == rhs fn_ptr?
|
|
je .equal
|
|
jmp .not_equal
|
|
.cons:
|
|
.clos:
|
|
mov rdi, qword [rsp] ; lhs
|
|
call obj_ptr_part
|
|
mov rdx, qword [rax + 16] ; lhs cdr
|
|
mov rax, qword [rax + 8] ; lhs car
|
|
mov qword [rsp], rax ; save lhs car
|
|
mov rdi, qword [rsp + 8] ; rhs
|
|
call obj_ptr_part
|
|
mov rsi, qword [rax + 16] ; rhs cdr
|
|
mov rax, qword [rax + 8] ; rhs car
|
|
mov qword [rsp + 8], rax ; save rhs car
|
|
mov rdi, qword [rsp] ; lhs car
|
|
call obj_eq ; lhs car == rhs car?
|
|
jne .not_equal
|
|
mov rdi, qword [rsp] ; lhs cdr
|
|
mov rsi, qword [rsp + 8] ; rhs cdr
|
|
call obj_eq ; lhs cdr == rhs cdr?
|
|
je .equal
|
|
jmp .not_equal
|
|
.atom:
|
|
mov rdi, qword [rsp] ; lhs
|
|
call obj_ptr_part
|
|
mov rdx, qword [rax + 16] ; lhs length
|
|
mov rax, qword [rax + 8] ; lhs data pointer
|
|
mov rdi, qword [rsp + 8] ; rhs
|
|
mov qword [rsp], rax ; save lhs data pointer
|
|
mov qword [rsp + 8], rdx ; save lhs length
|
|
call obj_ptr_part
|
|
mov rsi, qword [rax + 16] ; rhs length
|
|
mov rdi, qword [rax + 8] ; rhs data pointer
|
|
mov rdx, qword [rsp] ; lhs data pointer
|
|
mov rcx, qword [rsp + 8] ; lhs length
|
|
cmp rsi, rdx ; rhs length == lhs length?
|
|
jne .not_equal
|
|
call strcmp
|
|
test al, al
|
|
je .equal
|
|
jmp .not_equal
|
|
.arr:
|
|
mov rdi, qword [rsp] ; lhs
|
|
mov rsi, qword [rsp + 8] ; rhs
|
|
add rsp, 24
|
|
jmp arr_eq
|
|
|
|
arr_eq:
|
|
; compare lengths
|
|
; compare tags
|
|
; compare element-wise
|
|
; special-case for OBJ_BYTE arrays: compare data directly
|
|
push r12
|
|
sub rsp, 32
|
|
mov qword [rsp], rdi ; lhs
|
|
mov qword [rsp + 16], rsi ; rhs
|
|
|
|
call obj_ptr_part
|
|
mov edx, dword [rax + 8] ; lhs length
|
|
mov rcx, qword [rax + 16] ; lhs data pointer
|
|
mov dword [rsp], edx
|
|
mov qword [rsp + 8], rcx
|
|
|
|
mov rdi, rsi
|
|
call obj_ptr_part
|
|
mov edx, dword [rax + 8] ; rhs length
|
|
mov rcx, qword [rax + 16] ; rhs data pointer
|
|
cmp edx, dword [rsp] ; rhs length == lhs length?
|
|
jne .not_equal
|
|
mov dword [rsp + 16], edx
|
|
mov qword [rsp + 24], rcx
|
|
mov al, byte [rsp + 8] ; lhs data type
|
|
mov dl, byte [rsp + 24] ; rhs data type
|
|
and al, 0x7
|
|
and dl, 0x7
|
|
cmp al, dl ; lhs data type == rhs data type?
|
|
jne .not_equal
|
|
cmp al, OBJ_BYTE
|
|
jne .elementwise
|
|
; strcmp
|
|
mov rdi, qword [rsp + 8] ; lhs data pointer
|
|
mov esi, dword [rsp] ; length
|
|
mov rdx, qword [rsp + 24] ; rhs data pointer
|
|
mov ecx, esi
|
|
call strcmp
|
|
test al, al
|
|
je .equal
|
|
jmp .not_equal
|
|
.elementwise:
|
|
mov byte [rsp + 4], al ; data type
|
|
xor r12, r12
|
|
and qword [rsp + 8], -8 ; lhs data pointer
|
|
and qword [rsp + 24], -8 ; rhs data pointer
|
|
.loop:
|
|
cmp r12d, dword [rsp] ; index < length?
|
|
jge .equal
|
|
movzx ecx, byte [rsp + 4] ; data type
|
|
lea rax, byte [rel OBJ_SIZES]
|
|
movzx eax, byte [rax + rcx] ; size of each element
|
|
mul r12d
|
|
mov rdi, qword [rsp + 8] ; lhs data pointer
|
|
add rdi, rax ; lhs data pointer + index * size
|
|
or rdi, rcx ; lhs data pointer + index * size | data type
|
|
mov rsi, qword [rsp + 24] ; rhs data pointer
|
|
add rsi, rax ; rhs data pointer + index * size
|
|
or rsi, rcx ; rhs data pointer + index * size | data type
|
|
call obj_eq ; lhs[i] == rhs[i]?
|
|
jne .not_equal
|
|
inc r12d
|
|
jmp .loop
|
|
.equal:
|
|
add rsp, 32
|
|
pop r12
|
|
xor eax, eax
|
|
mov al, 1
|
|
ret
|
|
.not_equal:
|
|
add rsp, 32
|
|
pop r12
|
|
xor eax, eax
|
|
cmp eax, 1
|
|
ret
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|