;;; Copyright (C) 2018 Keziah Wesley
;;;
;;; You can redistribute and/or modify this file under the terms of the
;;; GNU Affero General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option) any
;;; later version.
;;;
;;; This file is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Affero General Public License for more details.
;;;
;;; You should have received a copy of the GNU Affero General Public
;;; License along with this file. If not, see
;;; .
global _start
default rel
%macro doj 3
dw %1, %2
dd %3
%endmacro
%macro dop 4
db ((ops.%1 - ops)>>3), %2, %3, %4
%endmacro
%macro dop 3
db ((ops.%1 - ops)>>3), %2
dw %3
%endmacro
%macro defop 1
.%1: dq op_%1
%endmacro
;;; tracing: abort if not primtype match (XXX: actual tests usu. more complex...)
%macro tr_guard_pt 1
%endmacro
;;; tracing: abort if not fulltype match
%macro tr_guard_tt 1
%endmacro
%macro tr_guard_bounds 0
%endmacro
;;; profiling: count jumps if offset negative.
%macro pr_j 2
%endmacro
;;; log if tracing. record if profiling and offset negative.
%macro tr_br_taken 2
%endmacro
;;; tracing: log road not taken.
%macro tr_br_fallthrough 2
%endmacro
%define PT_FIX 1h
%define PT_BYTES 2h
%define PT_STRING 3h
%define PT_UBLOCK 4h
%define PT_DOPE 5h
%define PT_RECORD 6h
%define PT_BYTES 7h
%define TT_MSUBR (PT_RECORD | 0100h) ; aka RVECTOR
%define TT_CODE (PT_UBLOCK | 0100h)
%define TT_DOPE_UB (PT_DOPE | (PT_UBLOCK << 8))
;%macro leafcall 1
; lea r14, [.leaf_ret]
; jmp %1
; .leaf_ret:
;%endmacro
section .rodata
align 8
ops:
defop error
defop applyb
defop return
defop nthrb
defop princ
defop constb
defop halt
defop adj
defop subb
defop grtrb
defop mull
defop jump
defop andb
defop lshb
defop addb
defop newyl
defop putyl
defop restyl
errStr db 'An error has occurred.',0xA
errLen equ $-errStr
byeStr db 0xA,'Goodbye!',0xA
byeLen equ $-byeStr
section .data
;
;
;reqs: ;
;
;
;opt1: ;
;<... =local2>
;opt2: ;
;<... =local3>
;chk: ;
;
;body:
;reqs: ;
;opt1: ;
;<... =local2>
;opt2: ;
;<... =local3>
;chk: ;
;
;body:
;; >
unparse_code:
;; implicit locals (0-1):
;; 0: RVECTOR
;; 1: ARGS TUPLE
;; reserved locals (2-2):
;; 2: N (arg)
;; 3: buf
;; 4: x
;; 5: i
;; stack (4-):
dop adj, 3, 0
dop nthrb, 0, 1, 2
dop constb, 12, 5, 0
dop newyl, 5, ' ', 3
dop andb, 7, 2, 4
dop lshb, -3, 2, 2
dop addb, '0', 4, 4
dop putyl, 5, 4, 3
dop subb, 1, 5, 5
dop grtrb, 0, -6, 2
dop restyl, 5, 3, 3
dop return, 3, 0
.len equ ($-unparse_code) >> 2
align 8
doj TT_DOPE_UB, 0, .len
unparse_rv:
doj TT_CODE, unparse_code.len, unparse_code
doj TT_MSUBR, unparse_rv.len, unparse_rv
.len equ ($-unparse_rv) >> 3
fact_code:
;; implicit locals (0-1):
;; 0: RVECTOR
;; 1: ARGS TUPLE
;; reserved locals (2-3):
;; 2: N (arg)
;; 3: FACT
;; 4: tmp0
;; stack (5-):
dop adj, 3, 0
dop nthrb, 0, 1, 2
dop nthrb, 1, 0, 3
dop grtrb, 1, 2, 2
dop constb, 1, 2, 0
dop return, 2, 0
dop subb, 1, 2, 5
dop applyb, 1, 3, 4
dop mull, 2, 4, 4
dop return, 4, 0
.len equ ($-fact_code) >> 2
align 8
doj TT_DOPE_UB, 0, .len
fact_rv:
doj TT_CODE, fact_code.len, fact_code
doj TT_MSUBR, fact_rv.len, fact_rv
.len equ ($-fact_rv) >> 3
toplevel_code:
;; implicit locals (0-1):
;; 0: RVECTOR
;; 1: ARGS TUPLE
;; reserved locals (2-2):
;; 2: tmp0
;; 3: MSUBR unparse
;; stack (4-):
dop adj, 2, 0
dop constb, 5, 4, 0
dop nthrb, 1, 0, 2
dop applyb, 1, 2, 4
dop adj, 1, 0
dop nthrb, 2, 0, 3
dop applyb, 1, 3, 3
dop princ, 3, 0
dop constb, 0, 0, 2
dop halt, 2, 0
.len equ ($-toplevel_code) >> 2
align 8
doj TT_DOPE_UB, 0, .len
toplevel_rv:
doj TT_CODE, toplevel_code.len, toplevel_code
doj TT_MSUBR, fact_rv.len, fact_rv
doj TT_MSUBR, unparse_rv.len, unparse_rv
.len equ ($-toplevel_rv) >> 3
oj_toplevel doj TT_MSUBR, toplevel_rv.len, toplevel_rv
section .bss
;; state:
;; esi: ip
;; ebp: bp [nonnegative idxes are locals, neg are cur FRAME's fields]
;; esp: sp [top of stack. starts at end of locals. grows UP.]
;; edi: next free heap pos [grows up.]
;; on entry into an op:
;; rbx: B
;; rax: CD
section .text
;; inline this for "release mode", but it's a useful breakpoint
dispatch:
lodsd
movzx edx, al
movzx ebx, ah
shr eax, 16
jmp [ops + 8*rdx]
%macro dispatch 0
jmp dispatch
%endmacro
_start:
;; Setup memory layout:
mov edx, 1|2 ; int prot = PROT_READ | PROT_WRITE
mov r10d, 2|32|64 ; int flags = MAP_PRIVATE | MAP_ANONYMOUS | MAP_32BIT
mov r8d, -1 ; int fd = -1
xor edi, edi ; void *addr = NULL
xor r9d, r9d ; off_t offset = 0
;; initial stack (1MB)
mov esi, 100000h ; size_t length
mov eax, 9 ; mmap
syscall
mov esp, eax
;; major heap...
;; (large-alloc space)...
;; FFI stack pool...
;; minor heap (default: 8MB)
mov esi, 800000h ; size_t length
mov eax, 9 ; mmap
syscall
mov edi, eax
;; Load some builtins into the heap
;; Setup a PROCESS for the GC...
;; boot:
;; point locals to a static MSUBR object for the toplevel MSUBR
mov ebp, oj_toplevel
;; set eax,ebx as if we'd just read
xor eax, eax
xor ebx, ebx
xor esi, esi ; toplevel must not return
jmp op_applyb
op_princ: ; PRINC [B]:STRING
mov rax, [rbp + 8*rbx]
cmp al, PT_STRING
je .string
cmp al, PT_BYTES
jne error
.bytes:
.string:
mov r8, rsi
mov r9, rdi
mov edx, eax ; size_t
shr edx, 16 ; count
shr rax, 32 ; const void *
mov esi, eax ; buf
mov eax, 1 ; write(2)
mov edi, eax ; int fd = stdout
syscall
mov rsi, r8
mov rdi, r9
cmp eax, edx
jne error
dispatch
op_halt: ; HALT [B]:FIX
mov edx, byeLen ; size_t count
mov esi, byeStr ; const void *buf
mov eax, 1 ; write(2)
lea edi, [rax+rax] ; int fd = stderr
syscall
mov rax, [rbp + 8*rbx]
cmp al, PT_FIX
;jne error
shr rax, 32
mov edi, eax ; int status
mov eax, 60 ; exit(2)
syscall
op_applyb: ;
; ignore [=] for now. we'll re-decode this insn in op_return
movzx eax, al
mov rax, [rbp + 8*rax]
cmp ax, TT_MSUBR
jne error
mov rdx, rax
%ifdef DEBUG
test eax, 0ffff0000h
jz error
%endif
shr rax, 32
mov rax, [rax]
%ifdef DEBUG
cmp ax, TT_CODE
jne error
test eax, 0ffff0000h
jz error
%endif
mov ecx, ebx
;; save a FRAME of state to return to:
neg rbx
lea ebx, [rsp+8*rbx]
add esp, 16
mov r8d, ebp
mov ebp, esp
;; FRAME:
;mov [rbp-16], e-- ; padding
mov [rbp-12], ebx ; start of args on stack
mov [rbp-8], esi ; return-to ip
mov [rbp-4], r8d ; prev FRAME/locals boundary
;; implicit locals:
shl rbx, 32
shl ecx, 16
lea rbx, [rbx+rcx+PT_RECORD]
mov [rbp], rdx ; 0: MSUBR (RVECTOR)
mov [rbp+8], rbx ; 1: ARGS TUPLE
add esp, 24
shr rax, 32
mov esi, eax
dispatch
op_return: ;
mov rbx, [rbp+8*rbx]
mov esp, [rbp-12]
mov esi, [rbp-8]
mov ebp, [rbp-4]
mov eax, [rsi-4]
shr eax, 24
mov [rbp+8*rax], rbx
dispatch
op_nthrb: ;
movzx ecx, al
movzx edx, ah
mov rax, [rbp + 8*rcx]
cmp al, PT_RECORD
;; TODO: fallback to pmorphic
jne error
mov ecx, eax
shr ecx, 16
cmp ebx, ecx
jge error
shr rax, 32
mov rax, [rax+8*rbx]
mov [rbp+8*rdx], rax
dispatch
;; BodyLnTP
op_restyl: ;
movzx ecx, al
movzx edx, ah
mov rax, [rbp + 8*rcx]
cmp al, PT_BYTES
;; TODO: fallback to pmorphic
jne error
mov rbx, [rbp + 8*rbx]
sub rbx, PT_FIX ; (dec rbx) if PT_FIX==1
test bx, bx
jnz error
add rax, rbx
rol rax, 32
rol rbx, 16
sub rax, rbx
jo error
ror rax, 32
mov [rbp+8*rdx], rax
dispatch
op_putyl: ;
movzx edx, al
mov rcx, [rbp + 8*rbx]
cmp cl, PT_FIX
jne error
shr rcx, 32
jz error
;; rcx = offset
movzx eax, ah
mov rax, [rbp + 8*rax]
cmp al, PT_BYTES
;; TODO: fallback to pmorphic
jne error
;; rax = bytes
mov rdx, [rbp + 8*rdx]
cmp dx, PT_FIX
jne error
shr rdx, 32
;; rdx = val
shr rax, 16
cmp cx, ax
jg error
shr rax, 16
mov [rax + rcx - 1], dl
dispatch
op_constb: ;
movzx edx, al
sub eax, edx
or eax, PT_FIX
shl rbx, 32
or rbx, rax
mov [rbp+8*rdx], rbx
dispatch
op_adj: ;
lea esp, [rsp+8*rbx]
dispatch
op_subb: ;
movzx edx, ah
movzx eax, al
mov rax, [rbp+8*rax]
cmp ax, PT_FIX
setne cl
shl rbx, 32
sub rax, rbx
seto bl
or cl, bl
jnz error
mov [rbp+8*rdx], rax
dispatch
op_addb: ;
movzx edx, ah
movzx eax, al
mov rax, [rbp+8*rax]
cmp ax, PT_FIX
setne cl
shl rbx, 32
add rax, rbx
seto bl
or cl, bl
jnz error
mov [rbp+8*rdx], rax
dispatch
op_andb: ;
movzx edx, ah
movzx eax, al
mov rax, [rbp+8*rax]
cmp ax, PT_FIX
jne error
shl rbx, 32
and rax, rbx
or rax, PT_FIX
mov [rbp+8*rdx], rax
dispatch
op_lshb: ;
movzx edx, ah
movzx eax, al
mov rax, [rbp+8*rax]
cmp ax, PT_FIX
jne error
lea ecx, [rbx-32]
neg ecx
shr rax, cl
shl rax, 32
or rax, PT_FIX
mov [rbp+8*rdx], rax
dispatch
op_newyl: ;
movzx edx, ah
mov rbx, [rbp+8*rbx]
cmp bx, PT_FIX
jne error
shr rbx, 32
movzx eax, al ; " a"
mov ecx, eax
shl ecx, 8
or eax, ecx ; " aa"
mov ecx, eax
shl ecx, 16
or eax, ecx ; " aaaa"
mov ecx, eax
shl rcx, 32
or rax, rcx ; "aaaaaaaa"
mov ecx, ebx
;; write object
shl rbx, 48
or rbx, rdi
rol rbx, 32
or rbx, PT_BYTES
mov [rbp+8*rdx], rbx
;jmp blitheap_op
blitheap_op: ; rax=init ecx=len (dword [rdx]: rewritten if base != edi)
add ecx, 7
shr ecx, 3
lea ecx, [rdi + rcx]
.init:
stosq
cmp edi, ecx
jl .init
dispatch
op_mull: ;
movzx edx, ah
movzx eax, al
mov rbx, [rbp+8*rbx]
mov rax, [rbp+8*rax]
cmp bx, PT_FIX
setne cl
cmp ax, bx
setne ch
or cl, ch
shr rbx, 32
shr rax, 32
imul eax, ebx
seto ch
or cl, ch
jnz error
shl rax, 32
or rax, PT_FIX
mov [rbp+8*rdx], rax
dispatch
op_grtrb: ;
movsx rdx, al
movzx eax, ah
mov rax, [rbp+8*rax]
cmp ax, PT_FIX
jne error
shr rax, 32
cmp eax, ebx
jle .done
lea esi, [rsi+4*rdx]
.done:
dispatch
op_jump: ;
movsx eax, ax
lea esi, [esi+4*eax]
dispatch
op_error: ; ERROR local:atom local:any local:any
error:
mov r8d, esi
mov r9d, edi
mov edx, errLen ; size_t count
mov esi, errStr ; const void *buf
mov eax, 1 ; write(2)
lea edi, [rax+rax] ; int fd = stderr
syscall
mov esi, r8d
mov edi, r9d
mov edi, -1 ; int status
mov eax, 60 ; exit(2)
syscall