atoms, eval, obj_eq

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
+
+    
+
+    
+    
+    
+