;;; 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
;;; <http://www.gnu.org/licenses/>.

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

	;<destrucr? 1 # =>
	;<destrucxn 1 start..end>

;reqs:	;<destrucr? 1 opts local1>
        ;<destrucr? 1 opts local2>
	;<error NEED-MORE-ARGS>
;opt1:  ;<destrucr? 1 opt2 local3>
	;<... =local2>
;opt2: 	;<destrucr? 1 chk local4>
	;<... =local3>
;chk:	;<empr? 1 body>
	;<error TOO-MANY-ARGS>
;body:

;reqs:	;<destrucxn local1..local2>
;opt1:  ;<destrucr? 1 opt2 local3>
	;<... =local2>
;opt2: 	;<destrucr? 1 chk local4>
	;<... =local3>
;chk:	;<empr? 1 body>
	;<error TOO-MANY-ARGS>
;body:

;; <MAPF ,STRING <FUNCTION (x) ...>>

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 <APPLY 0 0 0>
	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:			; <APPLY nargs:byte local:msubr =>
	; 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:			; <RETURN any:local>
	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: 			; <NTH index:byte record:local =>
	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:			; <RESTYL index:local bytes:local =>
	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:			; <PUTYL local:index value:local local:bytes> 
	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:			; <CONSTB byte = hitype:byte>
	movzx edx, al
	sub eax, edx
	or eax, PT_FIX
	shl rbx, 32
	or rbx, rax
	mov [rbp+8*rdx], rbx

	dispatch

op_adj:				; <ADJ byte>
	lea esp, [rsp+8*rbx]

	dispatch

op_subb:			; <SUBB rhs:byte in:fix =>
	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:			; <ADDB ubyte local:fix => 
	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:			; <ANDB byte local:fix => 
	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:			; <LSHB byte local:fix => 
	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:			; <NEWYB len:local initial:byte => 
	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:			; <MULL b:fix c:fix =>
	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:			; <GRTRB? rhs:byte tgt in:fix>
	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:			; <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