diff --git a/stages/lisp0/lisp1.asm b/stages/lisp0/lisp1.asm index 8c99a63..820cbe5 100644 --- a/stages/lisp0/lisp1.asm +++ b/stages/lisp0/lisp1.asm @@ -6,8 +6,6 @@ section .bss align 8,db 0 atoms times 24 resb 8 global env - env resq 1 - env_tail resq 1 heap resq 0 section .data @@ -15,6 +13,61 @@ section .data 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 @@ -22,9 +75,9 @@ ATOM_QUOTE: dq QUOTE_STR_LEN align 8, db 0 ATOM_T: - dq 1 dq 1 dq TRUE_STR + dq 1 section .text @@ -931,6 +984,7 @@ make_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 @@ -1085,3 +1139,579 @@ car_cdr: 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 + + + + + + +