russell@unturf.com
5ec9eff5fe
Replaces header format from [size:63 | mark:1] with [size:48 | type:8 | flags:8 (mark in bit 0)]. Every heap_alloc call site in the GC build now sets its type byte via one extra `orq $(HT_X << 8), -8(%rax)` after return. Ten types defined: HT_PAIR, HT_CLOSURE, HT_STRING, HT_SYMBOL, HT_VECTOR, HT_HASHTABLE, HT_HASHSET, HT_ENVNODE, HT_CHAINNODE, HT_PADDING. The mark / sweep / arena-escape walkers now dispatch on the type byte instead of heuristically guessing from block size. Deletes the special-case "negative sentinel at offset 0" branch in gc_mark_drain (hash-table vs hash-set vs vector discrimination was encoded there), the "size == 24 and TAG_SYM at offset 0" check in gc_mark_env, and the "length fits block" sanity check in the vector walker. All that logic collapses into a single compare on the type byte. Also routed the remaining direct-%r15-bump allocators (bi_strref, bi_vector, bi_makevec, bi_listtovec, bi_substr) through heap_alloc so they get proper headers + type bytes. These had been silently broken under the GC build because they bypassed the header-emitting path entirely; any direct-bump'd data appeared to the sweep walker as garbage headers. §6.6.4 cell 4 (asm GC + no snapshot) was crashing at first GC before this change. After: serves 5,000 HTTP requests at ~410 req/s, peak RSS 1,088 KB (one chunk), growth 972 KB — the collector hit its natural steady state. First time we've validated "naive GC as replacement for snapshot discipline" under real traffic. New §6.6.5 "Precise Block Typing" in the whitepaper documents the old heuristic bugs, the new header format, and the cost (one orq per alloc, 16 header bits) vs benefit (class of bugs eliminated). Updated §6.6.4 to reflect cell 4 passing. Remaining known issue: the hash-set bench on the GC build under very heavy sustained allocation still surfaces an occasional unbound-variable error. The precise-type fix addressed the observed HTTP crash; a deeper root-scan edge case remains. Tracked for Fix 2 work. 137 asm no-GC + 137 asm GC + 189 shared functional tests all pass.
6845 lines
164 KiB
ArmAsm
6845 lines
164 KiB
ArmAsm
# uncommonlisp.s — A Scheme interpreter in pure x86_64 assembly
|
||
# No C. No libc. Just Linux syscalls and machine instructions.
|
||
#
|
||
# Value representation (tag in low 3 bits):
|
||
# Tag 0: integer (value in bits 3-63, arithmetic shift right to get)
|
||
# Tag 1: pair (pointer & ~7 -> 16-byte [car, cdr])
|
||
# Tag 2: symbol (pointer & ~7 -> byte length, then chars)
|
||
# Tag 3: closure (pointer & ~7 -> [params, body, env] 24 bytes)
|
||
# Tag 4: builtin (index in bits 3-63)
|
||
# Tag 5: special (0=nil, 8=true, 16=false, 24=void in bits 3+)
|
||
# Tag 6: string (pointer & ~7 -> 8-byte length, then chars)
|
||
#
|
||
# Global registers (callee-saved, never clobbered):
|
||
# %r15 = heap bump pointer
|
||
# %r14 = global environment (linked list of 24-byte nodes)
|
||
# %r13 = heap limit
|
||
#
|
||
# All functions follow a simple convention:
|
||
# - args in %rdi, %rsi, %rdx, %rcx
|
||
# - return in %rax
|
||
# - callee saves %rbx, %rbp, %r12-r15
|
||
# - caller saves %rdi, %rsi, %rdx, %rcx, %r8-r11
|
||
|
||
.equ SYS_READ, 0
|
||
.equ SYS_WRITE, 1
|
||
.equ SYS_OPEN, 2
|
||
.equ SYS_CLOSE, 3
|
||
.equ SYS_LSEEK, 8
|
||
.equ SYS_MMAP, 9
|
||
.equ SYS_MUNMAP,11
|
||
.equ SYS_SOCKET,41
|
||
.equ SYS_CONNECT,42
|
||
.equ SYS_ACCEPT,43
|
||
.equ SYS_BIND, 49
|
||
.equ SYS_LISTEN,50
|
||
.equ SYS_SETSOCKOPT,54
|
||
.equ SYS_EXIT, 60
|
||
.equ SYS_CLOCK_GETTIME, 228
|
||
.equ CLOCK_REALTIME, 0
|
||
|
||
.equ AF_INET, 2
|
||
.equ SOCK_STREAM,1
|
||
.equ SOL_SOCKET,1
|
||
.equ SO_REUSEADDR,2
|
||
|
||
.equ O_RDONLY, 0
|
||
.equ O_WRONLY, 1
|
||
.equ O_CREAT, 64
|
||
.equ O_TRUNC, 512
|
||
.equ SEEK_SET, 0
|
||
.equ SEEK_END, 2
|
||
|
||
.equ TAG_INT, 0
|
||
.equ TAG_PAIR, 1
|
||
.equ TAG_SYM, 2
|
||
.equ TAG_CLOSURE, 3
|
||
.equ TAG_BUILTIN, 4
|
||
.equ TAG_SPECIAL, 5
|
||
.equ TAG_STRING, 6
|
||
.equ TAG_MASK, 7
|
||
|
||
.equ SPECIAL_NIL, 0
|
||
.equ SPECIAL_TRUE, 1
|
||
.equ SPECIAL_FALSE, 2
|
||
.equ SPECIAL_VOID, 3
|
||
|
||
.equ VAL_NIL, ((SPECIAL_NIL << 3) | TAG_SPECIAL)
|
||
.equ VAL_TRUE, ((SPECIAL_TRUE << 3) | TAG_SPECIAL)
|
||
.equ VAL_FALSE, ((SPECIAL_FALSE << 3) | TAG_SPECIAL)
|
||
.equ VAL_VOID, ((SPECIAL_VOID << 3) | TAG_SPECIAL)
|
||
|
||
# Ports: encoded as SPECIAL values ≥ PORT_SPECIAL_BASE.
|
||
# Value layout: ((PORT_SPECIAL_BASE + fd) << 3) | TAG_SPECIAL
|
||
# fd is recovered via (val >> 3) - PORT_SPECIAL_BASE.
|
||
.equ PORT_SPECIAL_BASE, 1000
|
||
|
||
.ifdef GC_NAIVE
|
||
# Smaller chunks in the GC build so the collector actually runs
|
||
# on ordinary workloads (otherwise nothing fills a 64 MB chunk
|
||
# fast enough to trigger mark-sweep within a single bench).
|
||
.equ HEAP_SIZE, 0x100000 # 1 MB
|
||
.else
|
||
.equ HEAP_SIZE, 0x4000000 # 64 MB
|
||
.endif
|
||
|
||
# Builtin indices
|
||
.equ BI_ADD, 0
|
||
.equ BI_SUB, 1
|
||
.equ BI_MUL, 2
|
||
.equ BI_EQ, 3
|
||
.equ BI_LT, 4
|
||
.equ BI_GT, 5
|
||
.equ BI_CONS, 6
|
||
.equ BI_CAR, 7
|
||
.equ BI_CDR, 8
|
||
.equ BI_NULLP, 9
|
||
.equ BI_PAIRP, 10
|
||
.equ BI_NOT, 11
|
||
.equ BI_DISPLAY, 12
|
||
.equ BI_NEWLINE, 13
|
||
.equ BI_LIST, 14
|
||
.equ BI_LENGTH, 15
|
||
.equ BI_LE, 16
|
||
.equ BI_GE, 17
|
||
.equ BI_ZEROP, 18
|
||
.equ BI_MODULO, 19
|
||
.equ BI_NUMBERP, 20
|
||
.equ BI_EQVP, 21
|
||
.equ BI_EQUALP, 22
|
||
.equ BI_REMAINDER, 23
|
||
.equ BI_ABS, 24
|
||
.equ BI_MIN, 25
|
||
.equ BI_MAX, 26
|
||
.equ BI_BOOLP, 27
|
||
.equ BI_SYMBOLP, 28
|
||
.equ BI_STRINGP, 29
|
||
.equ BI_PROCP, 30
|
||
.equ BI_QUOTIENT, 31
|
||
.equ BI_NEGATIVEP, 32
|
||
.equ BI_POSITIVEP, 33
|
||
.equ BI_DIV, 34
|
||
.equ BI_ODDP, 35
|
||
.equ BI_EVENP, 36
|
||
.equ BI_APPEND, 37
|
||
.equ BI_REVERSE, 38
|
||
.equ BI_MAP, 39
|
||
.equ BI_FILTER, 40
|
||
.equ BI_FOLDL, 41
|
||
.equ BI_FOREACH, 42
|
||
.equ BI_APPLY, 43
|
||
.equ BI_MEMBER, 44
|
||
.equ BI_ASSOC, 45
|
||
.equ BI_WRITE, 46
|
||
.equ BI_STRLENGTH, 47
|
||
.equ BI_STRREF, 48
|
||
.equ BI_STRAPPEND, 49
|
||
.equ BI_STREQP, 50
|
||
.equ BI_NUMTOSTR, 51
|
||
.equ BI_STRTONUM, 52
|
||
.equ BI_CHARTOINT, 53
|
||
.equ BI_INTTOCHAR, 54
|
||
.equ BI_CHARALPHAP, 55
|
||
.equ BI_CHARNUMP, 56
|
||
.equ BI_VECTOR, 57
|
||
.equ BI_VECREF, 58
|
||
.equ BI_VECSET, 59
|
||
.equ BI_VECLEN, 60
|
||
.equ BI_VECP, 61
|
||
.equ BI_MAKEVEC, 62
|
||
.equ BI_VECTOLIST, 63
|
||
.equ BI_LISTTOVEC, 64
|
||
.equ BI_CHARP, 65
|
||
.equ BI_LISTP, 66
|
||
.equ BI_SUBSTR, 67
|
||
.equ BI_EXPT, 68
|
||
.equ BI_GCD, 69
|
||
.equ BI_INTEGERP, 70
|
||
.equ BI_PORTALSAVE, 71
|
||
.equ BI_PORTALRESUME, 72
|
||
.equ BI_LOAD, 73
|
||
.equ BI_OPENOUT, 74
|
||
.equ BI_CLOSEPORT, 75
|
||
.equ BI_PORTP, 76
|
||
.equ BI_WRITEFILE, 77
|
||
.equ BI_FILETOSTR, 78
|
||
.equ BI_TCPLISTEN, 79
|
||
.equ BI_TCPACCEPT, 80
|
||
.equ BI_TCPCONNECT, 81
|
||
.equ BI_TCPRECV, 82
|
||
.equ BI_TCPSEND, 83
|
||
.equ BI_TCPCLOSE, 84
|
||
.equ BI_HEAPSNAP, 85
|
||
.equ BI_HEAPREST, 86
|
||
.equ BI_CURTIME, 87
|
||
.equ BI_READSTR, 88
|
||
.equ BI_EVAL, 89
|
||
.equ BI_SYMTOSTR, 90
|
||
.equ BI_HT_MAKE, 91
|
||
.equ BI_HT_P, 92
|
||
.equ BI_HT_SET, 93
|
||
.equ BI_HT_REF, 94
|
||
.equ BI_HT_REFD, 95
|
||
.equ BI_HT_DEL, 96
|
||
.equ BI_HT_EXISTS,97
|
||
.equ BI_HT_SIZE, 98
|
||
.equ BI_HT_KEYS, 99
|
||
.equ BI_HT_VALS, 100
|
||
.equ BI_HT_ALIST, 101
|
||
.equ BI_HS_MAKE, 102
|
||
.equ BI_HS_P, 103
|
||
.equ BI_HS_ADD, 104
|
||
.equ BI_HS_HAS, 105
|
||
.equ BI_HS_SIZE, 106
|
||
.equ BI_HS_LIST, 107
|
||
.ifdef GC_NAIVE
|
||
.equ BI_GC_COLLECT, 108
|
||
.equ BI_GC_STATS, 109
|
||
.equ BI_WITH_ARENA, 110
|
||
.equ BI_ARENA_STATS, 111
|
||
.equ BI_ARENA_SET_MODE, 112
|
||
.equ BI_COUNT, 113
|
||
.else
|
||
.equ BI_COUNT, 108
|
||
.endif
|
||
|
||
# ============================================================
|
||
.data
|
||
# ============================================================
|
||
|
||
prompt_str: .ascii "uncommonlisp> "
|
||
.equ prompt_len, . - prompt_str
|
||
|
||
newline_ch: .byte 10
|
||
dquote_ch: .byte '"'
|
||
|
||
# Length-prefixed symbol names for special forms
|
||
sf_quote: .byte 5; .ascii "quote"
|
||
sf_if: .byte 2; .ascii "if"
|
||
sf_define: .byte 6; .ascii "define"
|
||
sf_setbang: .byte 4; .ascii "set!"
|
||
sf_lambda: .byte 6; .ascii "lambda"
|
||
sf_begin: .byte 5; .ascii "begin"
|
||
sf_let: .byte 3; .ascii "let"
|
||
sf_cond: .byte 4; .ascii "cond"
|
||
sf_and: .byte 3; .ascii "and"
|
||
sf_or: .byte 2; .ascii "or"
|
||
sf_else: .byte 4; .ascii "else"
|
||
|
||
# Builtin names (length-prefixed)
|
||
bn_add: .byte 1; .ascii "+"
|
||
bn_sub: .byte 1; .ascii "-"
|
||
bn_mul: .byte 1; .ascii "*"
|
||
bn_eq: .byte 1; .ascii "="
|
||
bn_lt: .byte 1; .ascii "<"
|
||
bn_gt: .byte 1; .ascii ">"
|
||
bn_cons: .byte 4; .ascii "cons"
|
||
bn_car: .byte 3; .ascii "car"
|
||
bn_cdr: .byte 3; .ascii "cdr"
|
||
bn_nullp: .byte 5; .ascii "null?"
|
||
bn_pairp: .byte 5; .ascii "pair?"
|
||
bn_not: .byte 3; .ascii "not"
|
||
bn_display: .byte 7; .ascii "display"
|
||
bn_newline: .byte 7; .ascii "newline"
|
||
bn_list: .byte 4; .ascii "list"
|
||
bn_length: .byte 6; .ascii "length"
|
||
bn_le: .byte 2; .ascii "<="
|
||
bn_ge: .byte 2; .ascii ">="
|
||
bn_zerop: .byte 5; .ascii "zero?"
|
||
bn_modulo: .byte 6; .ascii "modulo"
|
||
bn_numberp: .byte 7; .ascii "number?"
|
||
bn_eqvp: .byte 4; .ascii "eqv?"
|
||
bn_equalp: .byte 6; .ascii "equal?"
|
||
bn_remainder: .byte 9; .ascii "remainder"
|
||
bn_abs: .byte 3; .ascii "abs"
|
||
bn_min: .byte 3; .ascii "min"
|
||
bn_max: .byte 3; .ascii "max"
|
||
bn_boolp: .byte 8; .ascii "boolean?"
|
||
bn_symbolp: .byte 7; .ascii "symbol?"
|
||
bn_stringp: .byte 7; .ascii "string?"
|
||
bn_procp: .byte 10; .ascii "procedure?"
|
||
bn_quotient: .byte 8; .ascii "quotient"
|
||
bn_negativep: .byte 9; .ascii "negative?"
|
||
bn_positivep: .byte 9; .ascii "positive?"
|
||
bn_div: .byte 1; .ascii "/"
|
||
bn_oddp: .byte 4; .ascii "odd?"
|
||
bn_evenp: .byte 5; .ascii "even?"
|
||
bn_append: .byte 6; .ascii "append"
|
||
bn_reverse: .byte 7; .ascii "reverse"
|
||
bn_map: .byte 3; .ascii "map"
|
||
bn_filter: .byte 6; .ascii "filter"
|
||
bn_foldl: .byte 9; .ascii "fold-left"
|
||
bn_foreach: .byte 8; .ascii "for-each"
|
||
bn_apply: .byte 5; .ascii "apply"
|
||
bn_member: .byte 6; .ascii "member"
|
||
bn_assoc: .byte 5; .ascii "assoc"
|
||
bn_write: .byte 5; .ascii "write"
|
||
bn_strlength: .byte 13; .ascii "string-length"
|
||
bn_strref: .byte 10; .ascii "string-ref"
|
||
bn_strappend: .byte 13; .ascii "string-append"
|
||
bn_streqp: .byte 8; .ascii "string=?"
|
||
bn_numtostr: .byte 14; .ascii "number->string"
|
||
bn_strtonum: .byte 14; .ascii "string->number"
|
||
bn_chartoint: .byte 13; .ascii "char->integer"
|
||
bn_inttochar: .byte 13; .ascii "integer->char"
|
||
bn_charalphap: .byte 16; .ascii "char-alphabetic?"
|
||
bn_charnump: .byte 13; .ascii "char-numeric?"
|
||
bn_vector: .byte 6; .ascii "vector"
|
||
bn_vecref: .byte 10; .ascii "vector-ref"
|
||
bn_vecset: .byte 11; .ascii "vector-set!"
|
||
bn_veclen: .byte 13; .ascii "vector-length"
|
||
bn_vecp: .byte 7; .ascii "vector?"
|
||
bn_makevec: .byte 11; .ascii "make-vector"
|
||
bn_vectolist: .byte 12; .ascii "vector->list"
|
||
bn_listtovec: .byte 12; .ascii "list->vector"
|
||
bn_charp: .byte 5; .ascii "char?"
|
||
bn_listp: .byte 5; .ascii "list?"
|
||
bn_substr: .byte 9; .ascii "substring"
|
||
bn_expt: .byte 4; .ascii "expt"
|
||
bn_gcd: .byte 3; .ascii "gcd"
|
||
bn_integerp: .byte 8; .ascii "integer?"
|
||
bn_portalsave: .byte 11; .ascii "portal-save"
|
||
bn_portalresume:.byte 13; .ascii "portal-resume"
|
||
bn_load: .byte 4; .ascii "load"
|
||
bn_openout: .byte 16; .ascii "open-output-file"
|
||
bn_closeport: .byte 10; .ascii "close-port"
|
||
bn_portp: .byte 5; .ascii "port?"
|
||
bn_writefile: .byte 10; .ascii "write-file"
|
||
bn_filetostr: .byte 12; .ascii "file->string"
|
||
bn_tcplisten: .byte 10; .ascii "tcp-listen"
|
||
bn_tcpaccept: .byte 10; .ascii "tcp-accept"
|
||
bn_tcpconnect: .byte 11; .ascii "tcp-connect"
|
||
bn_tcprecv: .byte 8; .ascii "tcp-recv"
|
||
bn_tcpsend: .byte 8; .ascii "tcp-send"
|
||
bn_tcpclose: .byte 9; .ascii "tcp-close"
|
||
bn_heapsnap: .byte 13; .ascii "heap-snapshot"
|
||
bn_heaprest: .byte 12; .ascii "heap-restore"
|
||
bn_curtime: .byte 15; .ascii "current-time-ms"
|
||
bn_readstr: .byte 16; .ascii "read-from-string"
|
||
bn_eval: .byte 4; .ascii "eval"
|
||
bn_symtostr: .byte 14; .ascii "symbol->string"
|
||
bn_htmake: .byte 15; .ascii "make-hash-table"
|
||
bn_htp: .byte 11; .ascii "hash-table?"
|
||
bn_htset: .byte 15; .ascii "hash-table-set!"
|
||
bn_htref: .byte 14; .ascii "hash-table-ref"
|
||
bn_htrefd: .byte 22; .ascii "hash-table-ref/default"
|
||
bn_htdel: .byte 18; .ascii "hash-table-delete!"
|
||
bn_htexists: .byte 18; .ascii "hash-table-exists?"
|
||
bn_htsize: .byte 15; .ascii "hash-table-size"
|
||
bn_htkeys: .byte 15; .ascii "hash-table-keys"
|
||
bn_htvals: .byte 17; .ascii "hash-table-values"
|
||
bn_htalist: .byte 17; .ascii "hash-table->alist"
|
||
bn_hsmake: .byte 13; .ascii "make-hash-set"
|
||
bn_hsp: .byte 9; .ascii "hash-set?"
|
||
bn_hsadd: .byte 13; .ascii "hash-set-add!"
|
||
bn_hshas: .byte 18; .ascii "hash-set-contains?"
|
||
bn_hssize: .byte 13; .ascii "hash-set-size"
|
||
bn_hslist: .byte 14; .ascii "hash-set->list"
|
||
.ifdef GC_NAIVE
|
||
bn_gccollect: .byte 10; .ascii "gc-collect"
|
||
bn_gcstats: .byte 8; .ascii "gc-stats"
|
||
bn_witharena: .byte 10; .ascii "with-arena"
|
||
bn_arenastats: .byte 11; .ascii "arena-stats"
|
||
bn_arenamode: .byte 14; .ascii "arena-set-mode"
|
||
.endif
|
||
|
||
s_hashtable: .ascii "#<hash-table>"
|
||
.equ s_hashtable_len, . - s_hashtable
|
||
s_hashset: .ascii "#<hash-set>"
|
||
.equ s_hashset_len, . - s_hashset
|
||
|
||
err_ht_miss: .ascii "Error: hash-table-ref: missing key\n"
|
||
.equ err_ht_miss_len, . - err_ht_miss
|
||
|
||
portal_magic: .ascii "ULPORTAL"
|
||
.equ PORTAL_MAGIC_LEN, 8
|
||
.equ PORTAL_HDR_SIZE, 48 # magic(8) + heap_size(8) + heap_base(8) + r14(8) + r15(8) + reserved(8)
|
||
|
||
# Builtin name table (pointers filled at init)
|
||
.align 8
|
||
bi_names:
|
||
.quad bn_add, bn_sub, bn_mul, bn_eq, bn_lt, bn_gt
|
||
.quad bn_cons, bn_car, bn_cdr, bn_nullp, bn_pairp, bn_not
|
||
.quad bn_display, bn_newline, bn_list, bn_length
|
||
.quad bn_le, bn_ge, bn_zerop, bn_modulo, bn_numberp
|
||
.quad bn_eqvp, bn_equalp, bn_remainder, bn_abs, bn_min, bn_max
|
||
.quad bn_boolp, bn_symbolp, bn_stringp, bn_procp, bn_quotient
|
||
.quad bn_negativep, bn_positivep
|
||
.quad bn_div, bn_oddp, bn_evenp, bn_append, bn_reverse
|
||
.quad bn_map, bn_filter, bn_foldl, bn_foreach, bn_apply
|
||
.quad bn_member, bn_assoc, bn_write
|
||
.quad bn_strlength, bn_strref, bn_strappend, bn_streqp
|
||
.quad bn_numtostr, bn_strtonum, bn_chartoint, bn_inttochar
|
||
.quad bn_charalphap, bn_charnump
|
||
.quad bn_vector, bn_vecref, bn_vecset, bn_veclen, bn_vecp
|
||
.quad bn_makevec, bn_vectolist, bn_listtovec
|
||
.quad bn_charp, bn_listp, bn_substr, bn_expt, bn_gcd, bn_integerp
|
||
.quad bn_portalsave, bn_portalresume, bn_load
|
||
.quad bn_openout, bn_closeport, bn_portp
|
||
.quad bn_writefile, bn_filetostr
|
||
.quad bn_tcplisten, bn_tcpaccept, bn_tcpconnect
|
||
.quad bn_tcprecv, bn_tcpsend, bn_tcpclose
|
||
.quad bn_heapsnap, bn_heaprest, bn_curtime
|
||
.quad bn_readstr, bn_eval, bn_symtostr
|
||
.quad bn_htmake, bn_htp, bn_htset, bn_htref, bn_htrefd, bn_htdel
|
||
.quad bn_htexists, bn_htsize, bn_htkeys, bn_htvals, bn_htalist
|
||
.quad bn_hsmake, bn_hsp, bn_hsadd, bn_hshas, bn_hssize, bn_hslist
|
||
.ifdef GC_NAIVE
|
||
.quad bn_gccollect, bn_gcstats, bn_witharena, bn_arenastats, bn_arenamode
|
||
.endif
|
||
|
||
# Error messages
|
||
err_unbound: .ascii "Error: unbound variable: "
|
||
.equ err_unbound_len, . - err_unbound
|
||
err_notproc: .ascii "Error: not a procedure\n"
|
||
.equ err_notproc_len, . - err_notproc
|
||
err_oom: .ascii "Error: out of memory\n"
|
||
.equ err_oom_len, . - err_oom
|
||
|
||
# Print strings
|
||
s_true: .ascii "#t"
|
||
s_false: .ascii "#f"
|
||
s_nil: .ascii "()"
|
||
s_void: .ascii "#<void>"
|
||
s_proc: .ascii "#<procedure>"
|
||
s_bi: .ascii "#<builtin>"
|
||
s_port: .ascii "#<port>"
|
||
s_lparen: .ascii "("
|
||
s_rparen: .ascii ")"
|
||
s_space: .ascii " "
|
||
s_dotsp: .ascii " . "
|
||
s_minus: .ascii "-"
|
||
s_hashparen: .ascii "#("
|
||
|
||
# Interned special form symbols (filled at init)
|
||
.align 8
|
||
sym_quote_val: .quad 0
|
||
sym_if_val: .quad 0
|
||
sym_define_val: .quad 0
|
||
sym_setbang_val:.quad 0
|
||
sym_lambda_val: .quad 0
|
||
sym_begin_val: .quad 0
|
||
sym_let_val: .quad 0
|
||
sym_cond_val: .quad 0
|
||
sym_and_val: .quad 0
|
||
sym_or_val: .quad 0
|
||
sym_else_val: .quad 0
|
||
|
||
# ============================================================
|
||
.bss
|
||
# ============================================================
|
||
.align 8
|
||
input_buf: .skip 65536
|
||
input_pos: .skip 8
|
||
input_end: .skip 8
|
||
input_buf_ptr: .skip 8 # points at active read buffer (stdin buf or mmap'd file)
|
||
input_is_file: .skip 8 # 0 = stdin (refill allowed), 1 = file (EOF at end)
|
||
output_fd: .skip 8 # active fd for printer syscalls (defaults to 1 = stdout)
|
||
is_tty: .skip 8
|
||
num_buf: .skip 64
|
||
sym_table: .skip 16384 # 2048 symbol pointers
|
||
sym_count: .skip 8
|
||
heap_base: .skip 8
|
||
# Hash table for O(1) symbol interning (MOAD-0001 fix)
|
||
# 1024 buckets, each a pointer to chain head (or 0 = empty)
|
||
# Chain nodes: 16 bytes [sym_ptr, next_ptr], allocated from heap
|
||
.equ SYM_HASH_BITS, 10
|
||
.equ SYM_HASH_SIZE, 1024
|
||
sym_hash_buckets: .skip 8192 # 1024 * 8 bytes
|
||
|
||
.ifdef GC_NAIVE
|
||
# ───────────────────────────────────────────────────────────
|
||
# Naive mark-and-sweep GC state (control group for bench).
|
||
# Every heap block carries an 8-byte header:
|
||
# bit 0 = mark
|
||
# bits 1–7 = reserved
|
||
# bits 8–15 = type byte (HT_PAIR, HT_CLOSURE, …)
|
||
# bits 16–63 = payload size in bytes
|
||
# The tagged pointer still points at the payload (header at -8).
|
||
# The type byte lets mark / sweep / arena walkers dispatch
|
||
# precisely instead of guessing from block size — earlier versions
|
||
# had to reject 24-byte strings-masquerading-as-env-nodes via
|
||
# TAG_SYM checks at offset 0, and 40-byte strings masquerading
|
||
# as vectors via a length-fits-block check. Type byte kills the
|
||
# entire class of bugs.
|
||
.equ HT_FREE, 0 # not used during normal ops (0 = unknown / free)
|
||
.equ HT_PAIR, 1
|
||
.equ HT_CLOSURE, 2
|
||
.equ HT_STRING, 3
|
||
.equ HT_SYMBOL, 4
|
||
.equ HT_VECTOR, 5
|
||
.equ HT_HASHTABLE, 6
|
||
.equ HT_HASHSET, 7
|
||
.equ HT_ENVNODE, 8
|
||
.equ HT_CHAINNODE, 9
|
||
.equ HT_PADDING, 10
|
||
# Chunks are tracked in a side array so chunk memory stays pure
|
||
# allocation space. Free blocks are linked via a global list
|
||
# whose nodes reuse the header word as size and the first 8 bytes
|
||
# of payload as the next-pointer.
|
||
# ───────────────────────────────────────────────────────────
|
||
.equ GC_MAX_CHUNKS, 32
|
||
.equ GC_MARK_STACK_CAP, 16384 # 16K tagged values; 128 KB
|
||
stack_top: .skip 8 # captured at _start
|
||
gc_chunk_base: .skip 256 # 32 * 8
|
||
gc_chunk_end: .skip 256 # 32 * 8
|
||
gc_chunk_count: .skip 8
|
||
gc_free_list: .skip 8 # head pointer (or 0)
|
||
gc_mark_stack: .skip 131072 # 16K * 8
|
||
gc_mark_depth: .skip 8
|
||
gc_collections: .skip 8 # counter for --gc-stat
|
||
gc_live_bytes: .skip 8 # updated at end of sweep
|
||
# ── Arena (meta-GC scope) ──
|
||
# When arena_active != 0, heap_alloc bypasses the free list and
|
||
# bumps only, so gc_free_list's chain stays pristine across the
|
||
# arena body and can be restored verbatim on a successful reset.
|
||
arena_active: .skip 8
|
||
arena_r15_snap: .skip 8
|
||
arena_calls: .skip 8
|
||
arena_resets: .skip 8
|
||
arena_escapes: .skip 8
|
||
arena_bytes_reclaimed: .skip 8
|
||
# ── Adaptive policy state ──
|
||
# EMA of recent escape rate, scaled 0..256 (256 = 100% escape).
|
||
# Update on each arena: rate = (rate*7 + sample*256) / 8 where
|
||
# sample is 0 for reset, 1 for escape. When rate > threshold and
|
||
# probe countdown > 0, bi_with_arena skips the verifier and goes
|
||
# straight to gc_sweep (treats it as an escape). When countdown
|
||
# reaches zero, forces a verify as a probe so the policy can
|
||
# re-evaluate whether escapes are still dominant.
|
||
arena_escape_rate: .skip 8 # 0..256
|
||
arena_verifies_skipped: .skip 8
|
||
arena_probe_countdown: .skip 8
|
||
arena_adaptive_mode: .skip 8 # 0 = greedy (always verify), 1 = adaptive
|
||
.endif
|
||
|
||
# ============================================================
|
||
.text
|
||
# ============================================================
|
||
.globl _start
|
||
|
||
# ============================================================
|
||
# _start: entry point
|
||
# ============================================================
|
||
_start:
|
||
.ifdef GC_NAIVE
|
||
# Capture initial stack pointer before any push — stack_top is
|
||
# the upper bound of the conservative root scan.
|
||
movq %rsp, stack_top(%rip)
|
||
.endif
|
||
# Allocate heap
|
||
movq $SYS_MMAP, %rax
|
||
xorq %rdi, %rdi
|
||
movq $HEAP_SIZE, %rsi
|
||
movq $3, %rdx # PROT_READ|PROT_WRITE
|
||
movq $0x22, %r10 # MAP_PRIVATE|MAP_ANONYMOUS
|
||
movq $-1, %r8
|
||
xorq %r9, %r9
|
||
syscall
|
||
movq %rax, %r15 # heap pointer
|
||
movq %rax, heap_base(%rip) # save base for portal
|
||
leaq HEAP_SIZE(%r15), %r13 # heap limit
|
||
.ifdef GC_NAIVE
|
||
# Register this chunk.
|
||
movq %rax, gc_chunk_base(%rip)
|
||
leaq HEAP_SIZE(%rax), %rcx
|
||
movq %rcx, gc_chunk_end(%rip)
|
||
movq $1, gc_chunk_count(%rip)
|
||
# Default: adaptive policy on. (arena-set-mode 0) disables it.
|
||
movq $1, arena_adaptive_mode(%rip)
|
||
.endif
|
||
|
||
# Init global env = 0 (empty)
|
||
xorq %r14, %r14
|
||
|
||
# Init input
|
||
movq $0, input_pos(%rip)
|
||
movq $0, input_end(%rip)
|
||
leaq input_buf(%rip), %rax
|
||
movq %rax, input_buf_ptr(%rip)
|
||
movq $0, input_is_file(%rip)
|
||
movq $1, output_fd(%rip)
|
||
|
||
# Check tty
|
||
movq $16, %rax # sys_ioctl
|
||
xorq %rdi, %rdi # stdin
|
||
movq $0x5401, %rsi # TCGETS
|
||
subq $256, %rsp
|
||
movq %rsp, %rdx
|
||
syscall
|
||
addq $256, %rsp
|
||
xorq %rcx, %rcx
|
||
testq %rax, %rax
|
||
sete %cl
|
||
movq %rcx, is_tty(%rip)
|
||
|
||
# Intern special forms
|
||
call init_special_forms
|
||
|
||
# Register builtins
|
||
call init_builtins
|
||
|
||
# Set up a generous stack area (16 KB stack frame for deep recursion)
|
||
# Actually the OS already gave us a stack, so we're fine.
|
||
|
||
# REPL
|
||
repl_top:
|
||
cmpq $0, is_tty(%rip)
|
||
je .repl_no_prompt
|
||
movq $SYS_WRITE, %rax
|
||
movq $1, %rdi
|
||
leaq prompt_str(%rip), %rsi
|
||
movq $prompt_len, %rdx
|
||
syscall
|
||
.repl_no_prompt:
|
||
call scheme_read
|
||
testq %rax, %rax
|
||
jz repl_exit # EOF
|
||
|
||
# Skip void
|
||
cmpq $VAL_VOID, %rax
|
||
je repl_top
|
||
|
||
# Eval
|
||
movq %rax, %rdi
|
||
movq %r14, %rsi
|
||
call eval
|
||
|
||
# Skip void results
|
||
cmpq $VAL_VOID, %rax
|
||
je repl_top
|
||
|
||
# Print
|
||
movq %rax, %rdi
|
||
call scheme_print
|
||
|
||
# Newline
|
||
movq $SYS_WRITE, %rax
|
||
movq $1, %rdi
|
||
leaq newline_ch(%rip), %rsi
|
||
movq $1, %rdx
|
||
syscall
|
||
|
||
jmp repl_top
|
||
|
||
repl_exit:
|
||
movq $SYS_EXIT, %rax
|
||
xorq %rdi, %rdi
|
||
syscall
|
||
|
||
# ============================================================
|
||
# heap_alloc: allocate %rdi bytes, return pointer in %rax
|
||
# Bumps %r15. If out of space, mmap more.
|
||
# ============================================================
|
||
.ifndef GC_NAIVE
|
||
heap_alloc:
|
||
# Align size up to 8
|
||
addq $7, %rdi
|
||
andq $-8, %rdi
|
||
movq %r15, %rax
|
||
addq %rdi, %r15
|
||
cmpq %r13, %r15
|
||
jae .heap_grow
|
||
ret
|
||
.heap_grow:
|
||
# Allocate a new chunk
|
||
pushq %rax
|
||
pushq %rdi
|
||
movq $SYS_MMAP, %rax
|
||
xorq %rdi, %rdi
|
||
movq $HEAP_SIZE, %rsi
|
||
movq $3, %rdx
|
||
movq $0x22, %r10
|
||
movq $-1, %r8
|
||
xorq %r9, %r9
|
||
syscall
|
||
cmpq $-1, %rax
|
||
je die_oom
|
||
movq %rax, %r15
|
||
leaq HEAP_SIZE(%r15), %r13
|
||
popq %rdi
|
||
popq %rax # discard old pointer
|
||
movq %r15, %rax
|
||
addq %rdi, %r15
|
||
ret
|
||
.endif
|
||
|
||
.ifdef GC_NAIVE
|
||
# GC-flavored heap_alloc.
|
||
# Layout: every block is [header:8 | payload:size]
|
||
# header = (size << 1) | mark. Pointer returned = header+8.
|
||
# Try free list first-fit; else bump; if bump overflows, GC; if
|
||
# still no room, register a new chunk.
|
||
#
|
||
# ABI parity with the non-GC heap_alloc: preserves every register
|
||
# except %rax (return) and the %r15 bump pointer. Callers like
|
||
# bi_append hold state in %rcx across heap_alloc; we mustn't break
|
||
# that contract just because we added a GC path.
|
||
heap_alloc:
|
||
addq $7, %rdi
|
||
andq $-8, %rdi # aligned payload size
|
||
testq %rdi, %rdi
|
||
jnz 1f
|
||
movq $8, %rdi # minimum payload = 8 bytes (free-list next ptr)
|
||
1:
|
||
pushq %rbx
|
||
pushq %rcx
|
||
pushq %rdx
|
||
pushq %rsi
|
||
pushq %rbp
|
||
pushq %r8
|
||
pushq %r9
|
||
pushq %r10
|
||
pushq %r11
|
||
pushq %r12
|
||
movq %rdi, %rbx # size (callee-save register for this function)
|
||
|
||
# Arena mode: skip free-list reuse so the chain stays valid
|
||
# for a verbatim restore at (with-arena) exit.
|
||
cmpq $0, arena_active(%rip)
|
||
jne .ha_bump
|
||
movq %rbx, %rdi
|
||
call gc_freelist_alloc
|
||
testq %rax, %rax
|
||
jnz .ha_done
|
||
|
||
.ha_bump:
|
||
# Check-then-write: only emit the header if the new block fits,
|
||
# so a rolled-back attempt never leaves a stale header that sweep
|
||
# would later walk through.
|
||
leaq 8(%rbx), %r12 # total bytes (header + payload)
|
||
movq %r15, %rcx
|
||
addq %r12, %rcx # proposed new %r15
|
||
cmpq %r13, %rcx
|
||
ja .ha_overflow
|
||
movq %rbx, %rdx
|
||
shlq $16, %rdx # header = (size << 16) | (type<<8) | mark; caller patches type
|
||
movq %rdx, (%r15)
|
||
movq %r15, %rax
|
||
addq $8, %rax # payload ptr
|
||
movq %rcx, %r15 # commit bump
|
||
.ha_done:
|
||
popq %r12
|
||
popq %r11
|
||
popq %r10
|
||
popq %r9
|
||
popq %r8
|
||
popq %rbp
|
||
popq %rsi
|
||
popq %rdx
|
||
popq %rcx
|
||
popq %rbx
|
||
ret
|
||
|
||
.ha_overflow:
|
||
# Bump rejected (no commit). Run GC, retry free list, retry bump.
|
||
call gc_collect
|
||
movq %rbx, %rdi
|
||
call gc_freelist_alloc
|
||
testq %rax, %rax
|
||
jnz .ha_done
|
||
# Retry bump in current chunk (GC may have recovered nothing at
|
||
# the tail, but try once in case free list had pure fragments).
|
||
leaq 8(%rbx), %r12
|
||
movq %r15, %rcx
|
||
addq %r12, %rcx
|
||
cmpq %r13, %rcx
|
||
ja .ha_grow
|
||
movq %rbx, %rdx
|
||
shlq $16, %rdx
|
||
movq %rdx, (%r15)
|
||
movq %r15, %rax
|
||
addq $8, %rax
|
||
movq %rcx, %r15
|
||
jmp .ha_done
|
||
|
||
.ha_grow:
|
||
# Before abandoning the current chunk, fill its remaining tail
|
||
# with a single dead block so the sweep walker has a coherent
|
||
# last-block sentinel. Without this, the gap between %r15 and
|
||
# the mmap end is garbage that sweep would misread as headers.
|
||
movq %r13, %rax
|
||
subq %r15, %rax # tail bytes remaining (>= 0)
|
||
cmpq $16, %rax
|
||
jb .ha_grow_no_pad # too small for header+min-payload; accept leak
|
||
movq %rax, %rdx
|
||
subq $8, %rdx # padding payload size
|
||
movq %rdx, %rcx
|
||
shlq $16, %rcx # header; type will be patched to HT_PADDING below
|
||
orq $(HT_PADDING << 8), %rcx
|
||
movq %rcx, (%r15)
|
||
# Link onto free list directly so sweep doesn't need to know.
|
||
movq gc_free_list(%rip), %rcx
|
||
movq %rcx, 8(%r15)
|
||
movq %r15, gc_free_list(%rip)
|
||
addq %rax, %r15 # %r15 now == %r13
|
||
.ha_grow_no_pad:
|
||
movq $SYS_MMAP, %rax
|
||
xorq %rdi, %rdi
|
||
movq $HEAP_SIZE, %rsi
|
||
movq $3, %rdx
|
||
movq $0x22, %r10
|
||
movq $-1, %r8
|
||
xorq %r9, %r9
|
||
syscall
|
||
cmpq $-1, %rax
|
||
je die_oom
|
||
movq %rax, %r15
|
||
leaq HEAP_SIZE(%rax), %r13
|
||
movq gc_chunk_count(%rip), %rdx
|
||
cmpq $GC_MAX_CHUNKS, %rdx
|
||
jae die_oom
|
||
leaq gc_chunk_base(%rip), %rcx
|
||
movq %rax, (%rcx,%rdx,8)
|
||
leaq gc_chunk_end(%rip), %rcx
|
||
movq %r13, (%rcx,%rdx,8)
|
||
incq %rdx
|
||
movq %rdx, gc_chunk_count(%rip)
|
||
jmp .ha_bump
|
||
|
||
# gc_freelist_alloc(%rdi=size) -> %rax = payload ptr or 0 if none fits
|
||
# First-fit scan. Splits large blocks if the leftover >= 24 bytes
|
||
# (header + min payload). Caller has aligned %rdi to 8.
|
||
gc_freelist_alloc:
|
||
movq gc_free_list(%rip), %rax # cursor (header addr)
|
||
xorq %rcx, %rcx # prev (0)
|
||
.gfa_scan:
|
||
testq %rax, %rax
|
||
jz .gfa_empty
|
||
movq (%rax), %rdx # header
|
||
shrq $16, %rdx # block payload size (bits 16..63)
|
||
cmpq %rdi, %rdx
|
||
jb .gfa_next
|
||
# Fits. Unlink.
|
||
movq 8(%rax), %rsi # next free
|
||
testq %rcx, %rcx
|
||
jnz 1f
|
||
movq %rsi, gc_free_list(%rip)
|
||
jmp 2f
|
||
1:
|
||
movq %rsi, 8(%rcx)
|
||
2:
|
||
# If leftover space is >= 24, split (keep the remainder on the list).
|
||
movq %rdx, %r8
|
||
subq %rdi, %r8 # leftover payload bytes
|
||
cmpq $24, %r8
|
||
jb .gfa_return_whole
|
||
# Split: new tail free block at %rax + 8 + %rdi.
|
||
# tail header size = r8 - 8 (one of the leftover bytes becomes the tail header)
|
||
leaq 8(%rax,%rdi), %r9 # tail header addr
|
||
subq $8, %r8
|
||
movq %r8, %r10
|
||
shlq $16, %r10 # tail header, type=0 (free), mark=0
|
||
movq %r10, (%r9)
|
||
movq gc_free_list(%rip), %r11
|
||
movq %r11, 8(%r9)
|
||
movq %r9, gc_free_list(%rip)
|
||
# Shrink current block's header — keep its type byte, just resize.
|
||
movq (%rax), %r10 # old header
|
||
andq $0xff00, %r10 # keep type byte; drop old size+mark
|
||
movq %rdi, %rdx
|
||
shlq $16, %rdx
|
||
orq %r10, %rdx # new header: new size + old type
|
||
movq %rdx, (%rax)
|
||
.gfa_return_whole:
|
||
addq $8, %rax # payload ptr
|
||
ret
|
||
.gfa_next:
|
||
movq %rax, %rcx
|
||
movq 8(%rax), %rax
|
||
jmp .gfa_scan
|
||
.gfa_empty:
|
||
xorq %rax, %rax
|
||
ret
|
||
|
||
# gc_collect: stop-the-world mark-and-sweep.
|
||
# Saves all caller registers on stack, scans:
|
||
# 1. %r14 global env (tagged)
|
||
# 2. sym_else_val (tagged)
|
||
# 3. sym_table entries (untagged symbol storage)
|
||
# 4. sym_hash_buckets chains (untagged chain nodes + their sym_ptrs)
|
||
# 5. stack words from %rsp to stack_top (conservative: tag check + chunk range check)
|
||
# Marks transitively via an explicit mark stack. Then sweeps every
|
||
# chunk linearly using each block's size-header and rebuilds the
|
||
# free list.
|
||
gc_collect:
|
||
# Any in-flight arena is now aborted: once GC runs, the snapshot
|
||
# is stale (free list rebuilt, blocks may have moved off/on the
|
||
# chain). with-arena's exit will see arena_active=0 and skip
|
||
# the reset attempt.
|
||
movq $0, arena_active(%rip)
|
||
# Save all general-purpose registers so the stack scan catches
|
||
# tagged values that were live in registers at GC entry.
|
||
pushq %rax
|
||
pushq %rbx
|
||
pushq %rcx
|
||
pushq %rdx
|
||
pushq %rsi
|
||
pushq %rdi
|
||
pushq %rbp
|
||
pushq %r8
|
||
pushq %r9
|
||
pushq %r10
|
||
pushq %r11
|
||
pushq %r12
|
||
|
||
# Clear mark stack.
|
||
movq $0, gc_mark_depth(%rip)
|
||
|
||
# Root 1: global env. Env nodes are UNTAGGED 24-byte triples
|
||
# (sym, val, parent_untagged), so we walk them with the dedicated
|
||
# env walker rather than the tagged-pointer push.
|
||
movq %r14, %rdi
|
||
call gc_mark_env
|
||
|
||
# Root 2: cached else sym.
|
||
movq sym_else_val(%rip), %rdi
|
||
call gc_push_if_heap
|
||
|
||
# Root 3: sym_table (untagged symbol storage pointers).
|
||
movq sym_count(%rip), %rcx
|
||
leaq sym_table(%rip), %rsi
|
||
.gcc_r_sym:
|
||
testq %rcx, %rcx
|
||
jz .gcc_r_sym_done
|
||
pushq %rcx
|
||
pushq %rsi
|
||
movq (%rsi), %rdi
|
||
testq %rdi, %rdi
|
||
jz 1f
|
||
call gc_mark_untagged
|
||
1:
|
||
popq %rsi
|
||
popq %rcx
|
||
addq $8, %rsi
|
||
decq %rcx
|
||
jmp .gcc_r_sym
|
||
.gcc_r_sym_done:
|
||
|
||
# Root 4: sym_hash_buckets — each bucket head is an untagged
|
||
# chain-node pointer; chain nodes are [sym_ptr:8][next:8], all
|
||
# allocated via heap_alloc so they carry GC headers. Walk each
|
||
# chain and mark both the node and the symbol it references.
|
||
movq $SYM_HASH_SIZE, %rcx
|
||
leaq sym_hash_buckets(%rip), %rsi
|
||
.gcc_r_bkt:
|
||
testq %rcx, %rcx
|
||
jz .gcc_r_bkt_done
|
||
movq (%rsi), %rdi # bucket head (untagged, or 0)
|
||
.gcc_r_chain:
|
||
testq %rdi, %rdi
|
||
jz .gcc_r_bkt_next
|
||
pushq %rcx
|
||
pushq %rsi
|
||
pushq %rdi
|
||
call gc_mark_untagged # mark chain node's header
|
||
popq %rdi
|
||
movq (%rdi), %r8 # sym_ptr (untagged)
|
||
pushq %rdi
|
||
testq %r8, %r8
|
||
jz 2f
|
||
movq %r8, %rdi
|
||
call gc_mark_untagged
|
||
2:
|
||
popq %rdi
|
||
movq 8(%rdi), %rdi # next chain node
|
||
popq %rsi
|
||
popq %rcx
|
||
jmp .gcc_r_chain
|
||
.gcc_r_bkt_next:
|
||
addq $8, %rsi
|
||
decq %rcx
|
||
jmp .gcc_r_bkt
|
||
.gcc_r_bkt_done:
|
||
|
||
# Root 5: conservative stack scan. Each word gets two tries:
|
||
# (a) treat as tagged value → gc_push_if_heap; (b) treat as an
|
||
# untagged env-node pointer → gc_mark_env (size-guarded). (b)
|
||
# catches the live %rbp (current local env) which the tagged
|
||
# path skips because env nodes look like TAG_INT.
|
||
movq %rsp, %rsi
|
||
movq stack_top(%rip), %rdx
|
||
.gcc_r_stk:
|
||
cmpq %rdx, %rsi
|
||
jae .gcc_r_stk_done
|
||
pushq %rsi
|
||
pushq %rdx
|
||
movq (%rsi), %rdi
|
||
call gc_push_if_heap
|
||
popq %rdx
|
||
popq %rsi
|
||
pushq %rsi
|
||
pushq %rdx
|
||
movq (%rsi), %rdi
|
||
call gc_mark_env
|
||
popq %rdx
|
||
popq %rsi
|
||
addq $8, %rsi
|
||
jmp .gcc_r_stk
|
||
.gcc_r_stk_done:
|
||
|
||
# Drain mark stack: each entry is a tagged value whose header
|
||
# has NOT yet been marked. Pop, mark, recurse by tag.
|
||
call gc_mark_drain
|
||
|
||
# Sweep.
|
||
call gc_sweep
|
||
|
||
# Stats.
|
||
incq gc_collections(%rip)
|
||
|
||
# Restore registers.
|
||
popq %r12
|
||
popq %r11
|
||
popq %r10
|
||
popq %r9
|
||
popq %r8
|
||
popq %rbp
|
||
popq %rdi
|
||
popq %rsi
|
||
popq %rdx
|
||
popq %rcx
|
||
popq %rbx
|
||
popq %rax
|
||
ret
|
||
|
||
# gc_mark_untagged: %rdi = untagged heap ptr. Set mark bit in
|
||
# the header (at ptr-8). No recursion — used for chain nodes and
|
||
# symbol storage which don't contain tagged pointers.
|
||
gc_mark_untagged:
|
||
testq %rdi, %rdi
|
||
jz .gmu_end
|
||
# Ensure ptr lives in a chunk.
|
||
call gc_ptr_in_chunk
|
||
testq %rax, %rax
|
||
jz .gmu_end
|
||
orq $1, -8(%rdi)
|
||
.gmu_end:
|
||
ret
|
||
|
||
# gc_mark_env: %rdi = untagged env node pointer (24-byte triple
|
||
# [sym, val, parent_untagged]) — walks the parent chain, marking
|
||
# each node's header and pushing (sym, val) to the mark stack for
|
||
# transitive tagged-value marking. Size-guarded: the walk stops if
|
||
# a node's header size isn't 24, so the scan can be called on any
|
||
# word (closure env, stack-resident %rbp, global %r14) without
|
||
# fear of walking off a wrong-sized block.
|
||
gc_mark_env:
|
||
testq %rdi, %rdi
|
||
jz .gme_end
|
||
# Must be 8-byte aligned and in a chunk.
|
||
testq $7, %rdi
|
||
jnz .gme_end
|
||
pushq %rdi
|
||
call gc_ptr_in_chunk
|
||
movq %rax, %rcx
|
||
popq %rdi
|
||
testq %rcx, %rcx
|
||
jz .gme_end
|
||
# Precise type dispatch: we want HT_ENVNODE exactly. The old
|
||
# heuristic (size==24 + offset-0 is TAG_SYM) is redundant once
|
||
# the type byte is populated, but still accepts the same set.
|
||
movzbq -7(%rdi), %rax # header byte 1 (type byte)
|
||
cmpq $HT_ENVNODE, %rax
|
||
jne .gme_end
|
||
# Already marked? Skip.
|
||
testq $1, -8(%rdi)
|
||
jnz .gme_end
|
||
orq $1, -8(%rdi)
|
||
# Push sym and val as tagged values.
|
||
pushq %rdi
|
||
movq (%rdi), %rdi
|
||
call gc_push_if_heap
|
||
movq (%rsp), %rdi
|
||
movq 8(%rdi), %rdi
|
||
call gc_push_if_heap
|
||
popq %rdi
|
||
# Tail-walk parent.
|
||
movq 16(%rdi), %rdi
|
||
jmp gc_mark_env
|
||
.gme_end:
|
||
ret
|
||
|
||
# gc_ptr_in_chunk: %rdi = raw ptr. Returns %rax != 0 if ptr falls
|
||
# inside a registered chunk's allocation range, else 0.
|
||
gc_ptr_in_chunk:
|
||
movq gc_chunk_count(%rip), %rcx
|
||
xorq %r8, %r8
|
||
leaq gc_chunk_base(%rip), %r9
|
||
leaq gc_chunk_end(%rip), %r10
|
||
.gpc_loop:
|
||
cmpq %rcx, %r8
|
||
jae .gpc_no
|
||
movq (%r9,%r8,8), %rdx # base
|
||
cmpq %rdx, %rdi
|
||
jb .gpc_next
|
||
movq (%r10,%r8,8), %rdx # end
|
||
cmpq %rdx, %rdi
|
||
jae .gpc_next
|
||
movq $1, %rax
|
||
ret
|
||
.gpc_next:
|
||
incq %r8
|
||
jmp .gpc_loop
|
||
.gpc_no:
|
||
xorq %rax, %rax
|
||
ret
|
||
|
||
# gc_push_if_heap: %rdi = possibly-tagged value. If it looks like
|
||
# a heap-pointing tagged value AND points into a chunk AND its
|
||
# header is not yet marked, push onto the mark stack.
|
||
gc_push_if_heap:
|
||
movq %rdi, %rax
|
||
andq $TAG_MASK, %rax
|
||
# Heap-pointing tags: PAIR(1), SYM(2), CLOSURE(3), STRING(6), 7(vector/ht/hs).
|
||
cmpq $TAG_PAIR, %rax
|
||
je .gpih_try
|
||
cmpq $TAG_SYM, %rax
|
||
je .gpih_try
|
||
cmpq $TAG_CLOSURE, %rax
|
||
je .gpih_try
|
||
cmpq $TAG_STRING, %rax
|
||
je .gpih_try
|
||
cmpq $7, %rax
|
||
je .gpih_try
|
||
ret
|
||
.gpih_try:
|
||
movq %rdi, %rsi
|
||
andq $-8, %rsi # untagged ptr
|
||
pushq %rdi
|
||
movq %rsi, %rdi
|
||
call gc_ptr_in_chunk
|
||
movq %rax, %rcx
|
||
popq %rdi
|
||
testq %rcx, %rcx
|
||
jz .gpih_end
|
||
movq %rdi, %rsi
|
||
andq $-8, %rsi
|
||
testq $1, -8(%rsi)
|
||
jnz .gpih_end # already marked
|
||
# Push.
|
||
movq gc_mark_depth(%rip), %rcx
|
||
cmpq $GC_MARK_STACK_CAP, %rcx
|
||
jae .gpih_end # silently drop on overflow — correctness preserved
|
||
# (sweep won't reclaim missed-roots, just leaks one cycle)
|
||
leaq gc_mark_stack(%rip), %rsi
|
||
movq %rdi, (%rsi,%rcx,8)
|
||
incq %rcx
|
||
movq %rcx, gc_mark_depth(%rip)
|
||
.gpih_end:
|
||
ret
|
||
|
||
# gc_mark_drain: pop tagged values from mark stack, set header
|
||
# mark, push children based on the TYPE BYTE in the header (bits
|
||
# 8..15). Dispatching by type instead of by tagged-value tag
|
||
# eliminates the class of bugs where a tag-7 value (stack scan
|
||
# false positive) had to be disambiguated by guessing from size.
|
||
gc_mark_drain:
|
||
.gmd_top:
|
||
movq gc_mark_depth(%rip), %rcx
|
||
testq %rcx, %rcx
|
||
jz .gmd_done
|
||
decq %rcx
|
||
movq %rcx, gc_mark_depth(%rip)
|
||
leaq gc_mark_stack(%rip), %rsi
|
||
movq (%rsi,%rcx,8), %rbx # tagged value
|
||
movq %rbx, %rsi
|
||
andq $-8, %rsi # untagged ptr
|
||
testq $1, -8(%rsi)
|
||
jnz .gmd_top # already marked
|
||
orq $1, -8(%rsi) # mark
|
||
movzbq -7(%rsi), %rax # type byte
|
||
cmpq $HT_PAIR, %rax
|
||
je .gmd_pair
|
||
cmpq $HT_CLOSURE, %rax
|
||
je .gmd_closure
|
||
cmpq $HT_VECTOR, %rax
|
||
je .gmd_vector
|
||
cmpq $HT_HASHTABLE, %rax
|
||
je .gmd_hash
|
||
cmpq $HT_HASHSET, %rax
|
||
je .gmd_hash
|
||
# HT_STRING / HT_SYMBOL / HT_CHAINNODE / HT_PADDING / HT_FREE: no children
|
||
jmp .gmd_top
|
||
.gmd_pair:
|
||
movq (%rsi), %rdi
|
||
call gc_push_if_heap
|
||
movq %rbx, %rsi
|
||
andq $-8, %rsi
|
||
movq 8(%rsi), %rdi
|
||
call gc_push_if_heap
|
||
jmp .gmd_top
|
||
.gmd_closure:
|
||
# [params:tagged | body:tagged | env:untagged]
|
||
movq (%rsi), %rdi
|
||
call gc_push_if_heap
|
||
movq %rbx, %rsi
|
||
andq $-8, %rsi
|
||
movq 8(%rsi), %rdi
|
||
call gc_push_if_heap
|
||
movq %rbx, %rsi
|
||
andq $-8, %rsi
|
||
movq 16(%rsi), %rdi
|
||
call gc_mark_env # env field is an untagged env chain
|
||
jmp .gmd_top
|
||
.gmd_vector:
|
||
# Vector: first word = length, elements at offset 8.
|
||
# Type byte already confirmed it's a real vector, no size guesswork.
|
||
movq (%rsi), %rdx # length
|
||
xorq %r8, %r8
|
||
.gmd_vec_loop:
|
||
cmpq %rdx, %r8
|
||
jae .gmd_top
|
||
pushq %rdx
|
||
pushq %r8
|
||
pushq %rsi
|
||
movq 8(%rsi,%r8,8), %rdi
|
||
call gc_push_if_heap
|
||
popq %rsi
|
||
popq %r8
|
||
popq %rdx
|
||
incq %r8
|
||
jmp .gmd_vec_loop
|
||
|
||
.gmd_hash:
|
||
# Hash-table or hash-set: nbuckets at offset 16, buckets at 24+.
|
||
movq 16(%rsi), %rcx # nbuckets
|
||
xorq %r8, %r8
|
||
.gmd_ht_loop:
|
||
cmpq %rcx, %r8
|
||
jae .gmd_top
|
||
pushq %rcx
|
||
pushq %r8
|
||
pushq %rsi
|
||
movq 24(%rsi,%r8,8), %rdi
|
||
call gc_push_if_heap
|
||
popq %rsi
|
||
popq %r8
|
||
popq %rcx
|
||
incq %r8
|
||
jmp .gmd_ht_loop
|
||
.gmd_done:
|
||
ret
|
||
|
||
# gc_sweep: walk every chunk linearly, reclaim unmarked blocks
|
||
# onto the free list, clear mark bits on live blocks. Rebuilds
|
||
# the free list from scratch each sweep (no carry-over; simpler).
|
||
gc_sweep:
|
||
movq $0, gc_free_list(%rip)
|
||
movq $0, gc_live_bytes(%rip)
|
||
movq gc_chunk_count(%rip), %rcx
|
||
xorq %r8, %r8 # chunk index
|
||
leaq gc_chunk_base(%rip), %r9
|
||
leaq gc_chunk_end(%rip), %r10
|
||
.gsw_chunk:
|
||
cmpq %rcx, %r8
|
||
jae .gsw_done
|
||
movq (%r9,%r8,8), %rbx # cursor at chunk base
|
||
# If this is the current (last) chunk, walk up to %r15; else up to chunk end.
|
||
movq %rcx, %rdx
|
||
decq %rdx
|
||
cmpq %rdx, %r8
|
||
je .gsw_use_r15
|
||
movq (%r10,%r8,8), %rdi
|
||
jmp .gsw_walk
|
||
.gsw_use_r15:
|
||
movq %r15, %rdi
|
||
.gsw_walk:
|
||
cmpq %rdi, %rbx
|
||
jae .gsw_next_chunk
|
||
movq (%rbx), %rsi # header
|
||
movq %rsi, %r11
|
||
shrq $16, %r11 # payload size (bits 16..63)
|
||
testq $1, %rsi
|
||
jz .gsw_dead
|
||
# Live: clear mark.
|
||
andq $-2, %rsi
|
||
movq %rsi, (%rbx)
|
||
addq %r11, gc_live_bytes(%rip)
|
||
leaq 8(%rbx,%r11), %rbx
|
||
jmp .gsw_walk
|
||
.gsw_dead:
|
||
# Dead: keep existing header (size, mark=0 already), link into free list.
|
||
movq gc_free_list(%rip), %rdx
|
||
movq %rdx, 8(%rbx) # next ptr in payload[0]
|
||
movq %rbx, gc_free_list(%rip)
|
||
leaq 8(%rbx,%r11), %rbx
|
||
jmp .gsw_walk
|
||
.gsw_next_chunk:
|
||
incq %r8
|
||
jmp .gsw_chunk
|
||
.gsw_done:
|
||
ret
|
||
|
||
# bi_gc_collect_user: (gc-collect) -> void. Forces a collection.
|
||
# Uses inline popq sequence since this sits above the RET_VAL macro.
|
||
bi_gc_collect_user:
|
||
call gc_collect
|
||
movq $VAL_VOID, %rax
|
||
popq %r12
|
||
popq %rbp
|
||
popq %rbx
|
||
ret
|
||
|
||
# bi_gc_stats: (gc-stats) -> (cons collections live-bytes)
|
||
bi_gc_stats:
|
||
movq gc_collections(%rip), %rdi
|
||
call make_int
|
||
movq %rax, %rbx
|
||
movq gc_live_bytes(%rip), %rdi
|
||
call make_int
|
||
movq %rax, %rsi
|
||
movq %rbx, %rdi
|
||
call make_pair
|
||
popq %r12
|
||
popq %rbp
|
||
popq %rbx
|
||
ret
|
||
.endif
|
||
|
||
die_oom:
|
||
movq $SYS_WRITE, %rax
|
||
movq $2, %rdi
|
||
leaq err_oom(%rip), %rsi
|
||
movq $err_oom_len, %rdx
|
||
syscall
|
||
movq $SYS_EXIT, %rax
|
||
movq $1, %rdi
|
||
syscall
|
||
|
||
# ============================================================
|
||
# Value constructors
|
||
# ============================================================
|
||
|
||
# make_int: %rdi = integer -> %rax = tagged
|
||
make_int:
|
||
movq %rdi, %rax
|
||
shlq $3, %rax
|
||
# TAG_INT = 0, no or needed
|
||
ret
|
||
|
||
# make_pair: %rdi = car, %rsi = cdr -> %rax = tagged pair
|
||
make_pair:
|
||
pushq %rdi
|
||
pushq %rsi
|
||
movq $16, %rdi
|
||
call heap_alloc
|
||
popq %rsi
|
||
popq %rdi
|
||
.ifdef GC_NAIVE
|
||
orq $(HT_PAIR << 8), -8(%rax)
|
||
.endif
|
||
movq %rdi, (%rax)
|
||
movq %rsi, 8(%rax)
|
||
orq $TAG_PAIR, %rax
|
||
ret
|
||
|
||
# make_closure: %rdi = params, %rsi = body, %rdx = env -> %rax
|
||
make_closure:
|
||
pushq %rdi
|
||
pushq %rsi
|
||
pushq %rdx
|
||
movq $24, %rdi
|
||
call heap_alloc
|
||
popq %rdx
|
||
popq %rsi
|
||
popq %rdi
|
||
.ifdef GC_NAIVE
|
||
orq $(HT_CLOSURE << 8), -8(%rax)
|
||
.endif
|
||
movq %rdi, (%rax) # params
|
||
movq %rsi, 8(%rax) # body
|
||
movq %rdx, 16(%rax) # env
|
||
orq $TAG_CLOSURE, %rax
|
||
ret
|
||
|
||
# make_builtin: %rdi = index -> %rax
|
||
make_builtin:
|
||
movq %rdi, %rax
|
||
shlq $3, %rax
|
||
orq $TAG_BUILTIN, %rax
|
||
ret
|
||
|
||
# ============================================================
|
||
# Environment: linked list of 24-byte nodes [sym, val, next]
|
||
# ============================================================
|
||
|
||
# env_define: %rdi=sym %rsi=val %rdx=env -> %rax = new env head
|
||
env_define:
|
||
pushq %rdi
|
||
pushq %rsi
|
||
pushq %rdx
|
||
movq $24, %rdi
|
||
call heap_alloc
|
||
popq %rdx
|
||
popq %rsi
|
||
popq %rdi
|
||
.ifdef GC_NAIVE
|
||
orq $(HT_ENVNODE << 8), -8(%rax)
|
||
.endif
|
||
movq %rdi, (%rax)
|
||
movq %rsi, 8(%rax)
|
||
movq %rdx, 16(%rax)
|
||
ret
|
||
|
||
# env_lookup: %rdi=sym %rsi=env -> %rax = value (or die)
|
||
env_lookup:
|
||
movq %rsi, %rax
|
||
.env_lk_loop:
|
||
testq %rax, %rax
|
||
jz .env_lk_fail
|
||
cmpq %rdi, (%rax)
|
||
je .env_lk_found
|
||
movq 16(%rax), %rax
|
||
jmp .env_lk_loop
|
||
.env_lk_found:
|
||
movq 8(%rax), %rax
|
||
ret
|
||
.env_lk_fail:
|
||
# Print error
|
||
pushq %rdi
|
||
movq $SYS_WRITE, %rax
|
||
movq $2, %rdi
|
||
leaq err_unbound(%rip), %rsi
|
||
movq $err_unbound_len, %rdx
|
||
syscall
|
||
popq %rdi
|
||
# Print symbol name
|
||
movq %rdi, %rax
|
||
andq $-8, %rax
|
||
movzbq (%rax), %rdx
|
||
leaq 1(%rax), %rsi
|
||
movq $SYS_WRITE, %rax
|
||
movq $2, %rdi
|
||
syscall
|
||
movq $SYS_WRITE, %rax
|
||
movq $2, %rdi
|
||
leaq newline_ch(%rip), %rsi
|
||
movq $1, %rdx
|
||
syscall
|
||
movq $SYS_EXIT, %rax
|
||
movq $1, %rdi
|
||
syscall
|
||
|
||
# env_set: %rdi=sym %rsi=val %rdx=env -> void (mutates)
|
||
env_set:
|
||
movq %rdx, %rax
|
||
.env_set_loop:
|
||
testq %rax, %rax
|
||
jz .env_lk_fail # reuse error
|
||
cmpq %rdi, (%rax)
|
||
je .env_set_found
|
||
movq 16(%rax), %rax
|
||
jmp .env_set_loop
|
||
.env_set_found:
|
||
movq %rsi, 8(%rax)
|
||
ret
|
||
|
||
# ============================================================
|
||
# Symbol interning — MOAD-0001: O(1) hash table lookup
|
||
# Symbols are stored as: 1 byte length, then chars (on heap)
|
||
# sym_table: flat array kept for iteration; sym_hash_buckets: hash chains for O(1) lookup
|
||
# intern_symbol: %rdi=str_ptr %rsi=len -> %rax = tagged symbol
|
||
# Hash function: djb2 (hash = 5381; for each byte: hash = hash*33 + byte)
|
||
# ============================================================
|
||
intern_symbol:
|
||
pushq %rbx
|
||
pushq %r12
|
||
pushq %rbp
|
||
movq %rdi, %rbx # string ptr
|
||
movq %rsi, %r12 # length
|
||
|
||
# Compute djb2 hash of string
|
||
movq $5381, %rax
|
||
xorq %rcx, %rcx
|
||
.isym_hash_loop:
|
||
cmpq %r12, %rcx
|
||
jge .isym_hash_done
|
||
movq %rax, %rdx
|
||
shlq $5, %rdx # hash << 5
|
||
addq %rdx, %rax # hash * 33
|
||
movzbq (%rbx,%rcx), %rdx
|
||
addq %rdx, %rax # + byte
|
||
incq %rcx
|
||
jmp .isym_hash_loop
|
||
.isym_hash_done:
|
||
# Mask to bucket index
|
||
andq $(SYM_HASH_SIZE - 1), %rax
|
||
movq %rax, %rbp # bucket index saved in %rbp
|
||
|
||
# Walk the chain at sym_hash_buckets[bucket]
|
||
leaq sym_hash_buckets(%rip), %rdi
|
||
movq (%rdi,%rbp,8), %r8 # chain head pointer (or 0)
|
||
.isym_chain_walk:
|
||
testq %r8, %r8
|
||
jz .isym_new
|
||
movq (%r8), %r9 # sym_ptr from chain node
|
||
movzbq (%r9), %r10 # candidate length
|
||
cmpq %r12, %r10
|
||
jne .isym_chain_next
|
||
# Compare bytes
|
||
leaq 1(%r9), %r10 # candidate chars
|
||
xorq %r11, %r11
|
||
.isym_chain_cmp:
|
||
cmpq %r12, %r11
|
||
jge .isym_chain_found
|
||
movb (%rbx,%r11), %al
|
||
cmpb (%r10,%r11), %al
|
||
jne .isym_chain_next
|
||
incq %r11
|
||
jmp .isym_chain_cmp
|
||
.isym_chain_found:
|
||
movq %r9, %rax
|
||
orq $TAG_SYM, %rax
|
||
popq %rbp
|
||
popq %r12
|
||
popq %rbx
|
||
ret
|
||
.isym_chain_next:
|
||
movq 8(%r8), %r8 # next pointer in chain
|
||
jmp .isym_chain_walk
|
||
.isym_new:
|
||
# Allocate symbol storage: 1 + length bytes
|
||
# NOTE: %r13 is the global heap limit — do NOT clobber it.
|
||
# Use the stack to save sym_ptr across the second heap_alloc.
|
||
leaq 1(%r12), %rdi
|
||
call heap_alloc
|
||
.ifdef GC_NAIVE
|
||
orq $(HT_SYMBOL << 8), -8(%rax)
|
||
.endif
|
||
# %rax = sym_ptr; fill symbol: length byte + chars
|
||
movb %r12b, (%rax)
|
||
xorq %r8, %r8
|
||
.isym_copy:
|
||
cmpq %r12, %r8
|
||
jge .isym_copied
|
||
movb (%rbx,%r8), %cl
|
||
movb %cl, 1(%rax,%r8)
|
||
incq %r8
|
||
jmp .isym_copy
|
||
.isym_copied:
|
||
pushq %rax # save sym_ptr on stack
|
||
# Add to flat sym_table (for iteration)
|
||
leaq sym_table(%rip), %rdi
|
||
movq sym_count(%rip), %rcx
|
||
movq %rax, (%rdi,%rcx,8)
|
||
incq %rcx
|
||
movq %rcx, sym_count(%rip)
|
||
# Allocate hash chain node: 16 bytes [sym_ptr, next_ptr]
|
||
movq $16, %rdi
|
||
call heap_alloc
|
||
.ifdef GC_NAIVE
|
||
orq $(HT_CHAINNODE << 8), -8(%rax)
|
||
.endif
|
||
# Fill chain node: %rax = node_ptr, stack top = sym_ptr
|
||
popq %rcx # rcx = sym_ptr
|
||
movq %rcx, (%rax) # node->sym = sym_ptr
|
||
leaq sym_hash_buckets(%rip), %rdi
|
||
movq (%rdi,%rbp,8), %rdx # old chain head
|
||
movq %rdx, 8(%rax) # node->next = old head
|
||
movq %rax, (%rdi,%rbp,8) # bucket head = new node
|
||
# Return tagged symbol
|
||
movq %rcx, %rax
|
||
orq $TAG_SYM, %rax
|
||
popq %rbp
|
||
popq %r12
|
||
popq %rbx
|
||
ret
|
||
|
||
# intern_static: %rdi = pointer to length-prefixed static string -> %rax = tagged sym
|
||
intern_static:
|
||
movzbq (%rdi), %rsi
|
||
leaq 1(%rdi), %rdi
|
||
jmp intern_symbol
|
||
|
||
# ============================================================
|
||
# Input
|
||
# ============================================================
|
||
|
||
# read_char -> %rax (char or -1 for EOF)
|
||
read_char:
|
||
movq input_pos(%rip), %rax
|
||
cmpq input_end(%rip), %rax
|
||
jl .rc_have
|
||
# File-backed buffer: no refill, straight to EOF
|
||
cmpq $0, input_is_file(%rip)
|
||
jne .rc_eof
|
||
# Refill from stdin into input_buf
|
||
pushq %rbx
|
||
movq $SYS_READ, %rax
|
||
xorq %rdi, %rdi
|
||
leaq input_buf(%rip), %rsi
|
||
movq $65536, %rdx
|
||
syscall
|
||
popq %rbx
|
||
cmpq $0, %rax
|
||
jle .rc_eof
|
||
movq %rax, input_end(%rip)
|
||
movq $0, input_pos(%rip)
|
||
xorq %rax, %rax
|
||
.rc_have:
|
||
movq input_buf_ptr(%rip), %rcx
|
||
movzbq (%rcx,%rax), %rax
|
||
movq input_pos(%rip), %rcx
|
||
incq %rcx
|
||
movq %rcx, input_pos(%rip)
|
||
ret
|
||
.rc_eof:
|
||
movq $-1, %rax
|
||
ret
|
||
|
||
# peek_char -> %rax (char or -1)
|
||
peek_char:
|
||
movq input_pos(%rip), %rax
|
||
cmpq input_end(%rip), %rax
|
||
jl .pc_have
|
||
cmpq $0, input_is_file(%rip)
|
||
jne .pc_eof
|
||
pushq %rbx
|
||
movq $SYS_READ, %rax
|
||
xorq %rdi, %rdi
|
||
leaq input_buf(%rip), %rsi
|
||
movq $65536, %rdx
|
||
syscall
|
||
popq %rbx
|
||
cmpq $0, %rax
|
||
jle .pc_eof
|
||
movq %rax, input_end(%rip)
|
||
movq $0, input_pos(%rip)
|
||
xorq %rax, %rax
|
||
.pc_have:
|
||
movq input_buf_ptr(%rip), %rcx
|
||
movzbq (%rcx,%rax), %rax
|
||
ret
|
||
.pc_eof:
|
||
movq $-1, %rax
|
||
ret
|
||
|
||
# skip_ws: skip whitespace and ;-comments
|
||
skip_ws:
|
||
pushq %rbx
|
||
.sw_loop:
|
||
call peek_char
|
||
cmpq $-1, %rax
|
||
je .sw_done
|
||
cmpb $' ', %al
|
||
je .sw_eat
|
||
cmpb $'\t', %al
|
||
je .sw_eat
|
||
cmpb $'\n', %al
|
||
je .sw_eat
|
||
cmpb $'\r', %al
|
||
je .sw_eat
|
||
cmpb $';', %al
|
||
je .sw_comment
|
||
jmp .sw_done
|
||
.sw_eat:
|
||
call read_char
|
||
jmp .sw_loop
|
||
.sw_comment:
|
||
call read_char
|
||
cmpq $-1, %rax
|
||
je .sw_done
|
||
cmpb $'\n', %al
|
||
jne .sw_comment
|
||
jmp .sw_loop
|
||
.sw_done:
|
||
popq %rbx
|
||
ret
|
||
|
||
# ============================================================
|
||
# Reader
|
||
# scheme_read -> %rax = tagged value (0 for EOF)
|
||
# ============================================================
|
||
scheme_read:
|
||
pushq %rbx
|
||
pushq %r12
|
||
|
||
call skip_ws
|
||
call peek_char
|
||
cmpq $-1, %rax
|
||
je .sr_eof
|
||
|
||
cmpb $'(', %al
|
||
je .sr_list
|
||
cmpb $')', %al
|
||
je .sr_rparen
|
||
cmpb $'\'', %al
|
||
je .sr_quote
|
||
cmpb $'"', %al
|
||
je .sr_string
|
||
cmpb $'#', %al
|
||
je .sr_hash
|
||
cmpb $'-', %al
|
||
je .sr_maybe_neg
|
||
cmpb $'0', %al
|
||
jl .sr_symbol
|
||
cmpb $'9', %al
|
||
jle .sr_number
|
||
jmp .sr_symbol
|
||
|
||
.sr_eof:
|
||
xorq %rax, %rax
|
||
popq %r12
|
||
popq %rbx
|
||
ret
|
||
|
||
.sr_rparen:
|
||
call read_char
|
||
# Try reading again (skip stray rparen)
|
||
popq %r12
|
||
popq %rbx
|
||
jmp scheme_read
|
||
|
||
.sr_quote:
|
||
call read_char # eat '
|
||
call scheme_read # read datum
|
||
movq %rax, %rbx # save datum
|
||
# Build (quote datum): cons(datum, nil) then cons(quote_sym, that)
|
||
movq %rax, %rdi
|
||
movq $VAL_NIL, %rsi
|
||
call make_pair # (datum . ())
|
||
movq %rax, %rsi
|
||
movq sym_quote_val(%rip), %rdi
|
||
call make_pair # (quote datum)
|
||
popq %r12
|
||
popq %rbx
|
||
ret
|
||
|
||
.sr_hash:
|
||
call read_char # eat #
|
||
call read_char
|
||
cmpb $'t', %al
|
||
je .sr_true
|
||
cmpb $'f', %al
|
||
je .sr_false
|
||
movq $VAL_VOID, %rax
|
||
popq %r12
|
||
popq %rbx
|
||
ret
|
||
.sr_true:
|
||
movq $VAL_TRUE, %rax
|
||
popq %r12
|
||
popq %rbx
|
||
ret
|
||
.sr_false:
|
||
movq $VAL_FALSE, %rax
|
||
popq %r12
|
||
popq %rbx
|
||
ret
|
||
|
||
.sr_maybe_neg:
|
||
call read_char # eat '-'
|
||
call peek_char
|
||
cmpq $-1, %rax
|
||
je .sr_minus_sym
|
||
cmpb $'0', %al
|
||
jl .sr_minus_sym
|
||
cmpb $'9', %al
|
||
jle .sr_neg_num
|
||
.sr_minus_sym:
|
||
# It's the symbol "-", read rest of symbol chars
|
||
subq $256, %rsp
|
||
movb $'-', (%rsp)
|
||
movq $1, %rbx # len = 1
|
||
jmp .sr_sym_rest
|
||
.sr_neg_num:
|
||
# Negative number
|
||
xorq %rbx, %rbx # accumulator
|
||
.sr_neg_digits:
|
||
call peek_char
|
||
cmpq $-1, %rax
|
||
je .sr_neg_done
|
||
cmpb $'0', %al
|
||
jl .sr_neg_done
|
||
cmpb $'9', %al
|
||
jg .sr_neg_done
|
||
call read_char
|
||
subq $'0', %rax
|
||
imulq $10, %rbx
|
||
addq %rax, %rbx
|
||
jmp .sr_neg_digits
|
||
.sr_neg_done:
|
||
negq %rbx
|
||
movq %rbx, %rdi
|
||
call make_int
|
||
popq %r12
|
||
popq %rbx
|
||
ret
|
||
|
||
.sr_number:
|
||
call read_char
|
||
subq $'0', %rax
|
||
movq %rax, %rbx # accumulator
|
||
.sr_num_loop:
|
||
call peek_char
|
||
cmpq $-1, %rax
|
||
je .sr_num_done
|
||
cmpb $'0', %al
|
||
jl .sr_num_done
|
||
cmpb $'9', %al
|
||
jg .sr_num_done
|
||
call read_char
|
||
subq $'0', %rax
|
||
imulq $10, %rbx
|
||
addq %rax, %rbx
|
||
jmp .sr_num_loop
|
||
.sr_num_done:
|
||
movq %rbx, %rdi
|
||
call make_int
|
||
popq %r12
|
||
popq %rbx
|
||
ret
|
||
|
||
.sr_symbol:
|
||
subq $256, %rsp
|
||
xorq %rbx, %rbx # length
|
||
.sr_sym_loop:
|
||
call peek_char
|
||
cmpq $-1, %rax
|
||
je .sr_sym_done
|
||
# Delimiters
|
||
cmpb $' ', %al
|
||
je .sr_sym_done
|
||
cmpb $'\t', %al
|
||
je .sr_sym_done
|
||
cmpb $'\n', %al
|
||
je .sr_sym_done
|
||
cmpb $'\r', %al
|
||
je .sr_sym_done
|
||
cmpb $'(', %al
|
||
je .sr_sym_done
|
||
cmpb $')', %al
|
||
je .sr_sym_done
|
||
cmpb $'"', %al
|
||
je .sr_sym_done
|
||
cmpb $';', %al
|
||
je .sr_sym_done
|
||
call read_char
|
||
movb %al, (%rsp,%rbx)
|
||
incq %rbx
|
||
cmpq $250, %rbx
|
||
jge .sr_sym_done
|
||
jmp .sr_sym_loop
|
||
.sr_sym_rest:
|
||
# Entry when we have partial symbol in buffer (e.g. "-")
|
||
jmp .sr_sym_loop
|
||
.sr_sym_done:
|
||
testq %rbx, %rbx
|
||
jz .sr_sym_empty
|
||
movq %rsp, %rdi
|
||
movq %rbx, %rsi
|
||
call intern_symbol
|
||
addq $256, %rsp
|
||
popq %r12
|
||
popq %rbx
|
||
ret
|
||
.sr_sym_empty:
|
||
addq $256, %rsp
|
||
movq $VAL_VOID, %rax
|
||
popq %r12
|
||
popq %rbx
|
||
ret
|
||
|
||
.sr_string:
|
||
call read_char # eat opening "
|
||
subq $256, %rsp
|
||
xorq %rbx, %rbx # length
|
||
.sr_str_loop:
|
||
call read_char
|
||
cmpq $-1, %rax
|
||
je .sr_str_end
|
||
cmpb $'"', %al
|
||
je .sr_str_end
|
||
cmpb $'\\', %al
|
||
je .sr_str_esc
|
||
movb %al, (%rsp,%rbx)
|
||
incq %rbx
|
||
jmp .sr_str_loop
|
||
.sr_str_esc:
|
||
call read_char
|
||
cmpb $'n', %al
|
||
jne 1f
|
||
movb $10, (%rsp,%rbx)
|
||
incq %rbx
|
||
jmp .sr_str_loop
|
||
1: cmpb $'t', %al
|
||
jne 2f
|
||
movb $9, (%rsp,%rbx)
|
||
incq %rbx
|
||
jmp .sr_str_loop
|
||
2: cmpb $'r', %al
|
||
jne 3f
|
||
movb $13, (%rsp,%rbx)
|
||
incq %rbx
|
||
jmp .sr_str_loop
|
||
3: cmpb $'0', %al
|
||
jne 4f
|
||
movb $0, (%rsp,%rbx)
|
||
incq %rbx
|
||
jmp .sr_str_loop
|
||
4: movb %al, (%rsp,%rbx)
|
||
incq %rbx
|
||
jmp .sr_str_loop
|
||
.sr_str_end:
|
||
# Allocate: 8-byte length + data
|
||
pushq %rbx
|
||
leaq 8(%rbx), %rdi
|
||
call heap_alloc
|
||
.ifdef GC_NAIVE
|
||
orq $(HT_STRING << 8), -8(%rax)
|
||
.endif
|
||
popq %rbx
|
||
movq %rbx, (%rax) # 8-byte length
|
||
xorq %rcx, %rcx
|
||
.sr_str_copy:
|
||
cmpq %rbx, %rcx
|
||
jge .sr_str_done
|
||
movb (%rsp,%rcx), %dl
|
||
movb %dl, 8(%rax,%rcx)
|
||
incq %rcx
|
||
jmp .sr_str_copy
|
||
.sr_str_done:
|
||
addq $256, %rsp
|
||
orq $TAG_STRING, %rax
|
||
popq %r12
|
||
popq %rbx
|
||
ret
|
||
|
||
# Read a list after '(' has been consumed
|
||
.sr_list:
|
||
call read_char # eat '('
|
||
call .read_list_elems
|
||
popq %r12
|
||
popq %rbx
|
||
ret
|
||
|
||
# .read_list_elems -> %rax = list (proper or dotted)
|
||
.read_list_elems:
|
||
pushq %rbx
|
||
pushq %r12
|
||
|
||
call skip_ws
|
||
call peek_char
|
||
cmpq $-1, %rax
|
||
je .rle_nil
|
||
cmpb $')', %al
|
||
je .rle_close
|
||
|
||
# Check for dot
|
||
cmpb $'.', %al
|
||
je .rle_maybe_dot
|
||
|
||
# Read element
|
||
call scheme_read
|
||
movq %rax, %rbx # save element
|
||
|
||
# Read rest of list
|
||
call .read_list_elems
|
||
movq %rax, %rsi # rest
|
||
movq %rbx, %rdi # this element
|
||
call make_pair
|
||
|
||
popq %r12
|
||
popq %rbx
|
||
ret
|
||
|
||
.rle_maybe_dot:
|
||
# Could be a dot or a symbol starting with dot
|
||
call read_char # eat '.'
|
||
call peek_char
|
||
cmpb $' ', %al
|
||
je .rle_dot
|
||
cmpb $'\t', %al
|
||
je .rle_dot
|
||
cmpb $'\n', %al
|
||
je .rle_dot
|
||
cmpb $')', %al
|
||
je .rle_dot
|
||
cmpq $-1, %rax
|
||
je .rle_dot
|
||
# Symbol starting with '.': read rest
|
||
subq $256, %rsp
|
||
movb $'.', (%rsp)
|
||
movq $1, %rbx
|
||
.rle_dot_sym_loop:
|
||
call peek_char
|
||
cmpq $-1, %rax
|
||
je .rle_dot_sym_done
|
||
cmpb $' ', %al
|
||
je .rle_dot_sym_done
|
||
cmpb $')', %al
|
||
je .rle_dot_sym_done
|
||
cmpb $'(', %al
|
||
je .rle_dot_sym_done
|
||
call read_char
|
||
movb %al, (%rsp,%rbx)
|
||
incq %rbx
|
||
jmp .rle_dot_sym_loop
|
||
.rle_dot_sym_done:
|
||
movq %rsp, %rdi
|
||
movq %rbx, %rsi
|
||
call intern_symbol
|
||
addq $256, %rsp
|
||
movq %rax, %rbx
|
||
call .read_list_elems
|
||
movq %rax, %rsi
|
||
movq %rbx, %rdi
|
||
call make_pair
|
||
popq %r12
|
||
popq %rbx
|
||
ret
|
||
|
||
.rle_dot:
|
||
# Dotted pair: read one value, skip ws, expect ')'
|
||
call scheme_read
|
||
movq %rax, %rbx
|
||
call skip_ws
|
||
call peek_char
|
||
cmpb $')', %al
|
||
jne .rle_dot_ret
|
||
call read_char
|
||
.rle_dot_ret:
|
||
movq %rbx, %rax
|
||
popq %r12
|
||
popq %rbx
|
||
ret
|
||
|
||
.rle_close:
|
||
call read_char # eat ')'
|
||
.rle_nil:
|
||
movq $VAL_NIL, %rax
|
||
popq %r12
|
||
popq %rbx
|
||
ret
|
||
|
||
# ============================================================
|
||
# Printer
|
||
# scheme_print: %rdi = value
|
||
# ============================================================
|
||
scheme_print:
|
||
pushq %rbx
|
||
pushq %r12
|
||
|
||
movq %rdi, %rbx
|
||
movq %rdi, %rax
|
||
andq $TAG_MASK, %rax
|
||
|
||
cmpq $TAG_INT, %rax
|
||
je .sp_int
|
||
cmpq $TAG_SPECIAL, %rax
|
||
je .sp_special
|
||
cmpq $TAG_SYM, %rax
|
||
je .sp_sym
|
||
cmpq $TAG_PAIR, %rax
|
||
je .sp_pair
|
||
cmpq $TAG_CLOSURE, %rax
|
||
je .sp_closure
|
||
cmpq $TAG_BUILTIN, %rax
|
||
je .sp_builtin
|
||
cmpq $TAG_STRING, %rax
|
||
je .sp_string
|
||
cmpq $7, %rax
|
||
je .sp_vector
|
||
|
||
popq %r12
|
||
popq %rbx
|
||
ret
|
||
|
||
.sp_int:
|
||
sarq $3, %rbx
|
||
movq %rbx, %rdi
|
||
call print_int64
|
||
popq %r12
|
||
popq %rbx
|
||
ret
|
||
|
||
.sp_special:
|
||
movq %rbx, %rax
|
||
shrq $3, %rax
|
||
cmpq $SPECIAL_NIL, %rax
|
||
je .sp_nil
|
||
cmpq $SPECIAL_TRUE, %rax
|
||
je .sp_true
|
||
cmpq $SPECIAL_FALSE, %rax
|
||
je .sp_false
|
||
cmpq $PORT_SPECIAL_BASE, %rax
|
||
jge .sp_port
|
||
# void
|
||
leaq s_void(%rip), %rsi
|
||
movq $7, %rdx
|
||
jmp .sp_write
|
||
.sp_port:
|
||
leaq s_port(%rip), %rsi
|
||
movq $7, %rdx
|
||
jmp .sp_write
|
||
.sp_nil:
|
||
leaq s_nil(%rip), %rsi
|
||
movq $2, %rdx
|
||
jmp .sp_write
|
||
.sp_true:
|
||
leaq s_true(%rip), %rsi
|
||
movq $2, %rdx
|
||
jmp .sp_write
|
||
.sp_false:
|
||
leaq s_false(%rip), %rsi
|
||
movq $2, %rdx
|
||
jmp .sp_write
|
||
|
||
.sp_write:
|
||
movq $SYS_WRITE, %rax
|
||
movq output_fd(%rip), %rdi
|
||
syscall
|
||
popq %r12
|
||
popq %rbx
|
||
ret
|
||
|
||
.sp_sym:
|
||
movq %rbx, %rax
|
||
andq $-8, %rax
|
||
movzbq (%rax), %rdx
|
||
leaq 1(%rax), %rsi
|
||
movq $SYS_WRITE, %rax
|
||
movq output_fd(%rip), %rdi
|
||
syscall
|
||
popq %r12
|
||
popq %rbx
|
||
ret
|
||
|
||
.sp_closure:
|
||
leaq s_proc(%rip), %rsi
|
||
movq $12, %rdx
|
||
jmp .sp_write
|
||
|
||
.sp_builtin:
|
||
leaq s_bi(%rip), %rsi
|
||
movq $10, %rdx
|
||
jmp .sp_write
|
||
|
||
.sp_string:
|
||
movq %rbx, %rax
|
||
andq $-8, %rax
|
||
movq (%rax), %r12 # length
|
||
leaq 8(%rax), %rbx # data ptr
|
||
# Print: "..."
|
||
movq $SYS_WRITE, %rax
|
||
movq output_fd(%rip), %rdi
|
||
leaq dquote_ch(%rip), %rsi
|
||
movq $1, %rdx
|
||
syscall
|
||
movq $SYS_WRITE, %rax
|
||
movq output_fd(%rip), %rdi
|
||
movq %rbx, %rsi
|
||
movq %r12, %rdx
|
||
syscall
|
||
movq $SYS_WRITE, %rax
|
||
movq output_fd(%rip), %rdi
|
||
leaq dquote_ch(%rip), %rsi
|
||
movq $1, %rdx
|
||
syscall
|
||
popq %r12
|
||
popq %rbx
|
||
ret
|
||
|
||
.sp_pair:
|
||
# Print "("
|
||
movq $SYS_WRITE, %rax
|
||
movq output_fd(%rip), %rdi
|
||
leaq s_lparen(%rip), %rsi
|
||
movq $1, %rdx
|
||
syscall
|
||
# Print car
|
||
movq %rbx, %rax
|
||
andq $-8, %rax
|
||
movq (%rax), %rdi
|
||
pushq %rax
|
||
call scheme_print
|
||
popq %rax
|
||
movq 8(%rax), %rbx # cdr
|
||
.sp_pair_rest:
|
||
cmpq $VAL_NIL, %rbx
|
||
je .sp_pair_close
|
||
movq %rbx, %rax
|
||
andq $TAG_MASK, %rax
|
||
cmpq $TAG_PAIR, %rax
|
||
jne .sp_pair_dot
|
||
# Print " " then car
|
||
movq $SYS_WRITE, %rax
|
||
movq output_fd(%rip), %rdi
|
||
leaq s_space(%rip), %rsi
|
||
movq $1, %rdx
|
||
syscall
|
||
movq %rbx, %rax
|
||
andq $-8, %rax
|
||
movq (%rax), %rdi
|
||
pushq %rax
|
||
call scheme_print
|
||
popq %rax
|
||
movq 8(%rax), %rbx
|
||
jmp .sp_pair_rest
|
||
.sp_pair_dot:
|
||
movq $SYS_WRITE, %rax
|
||
movq output_fd(%rip), %rdi
|
||
leaq s_dotsp(%rip), %rsi
|
||
movq $3, %rdx
|
||
syscall
|
||
movq %rbx, %rdi
|
||
call scheme_print
|
||
.sp_pair_close:
|
||
movq $SYS_WRITE, %rax
|
||
movq output_fd(%rip), %rdi
|
||
leaq s_rparen(%rip), %rsi
|
||
movq $1, %rdx
|
||
syscall
|
||
popq %r12
|
||
popq %rbx
|
||
ret
|
||
|
||
.sp_vector:
|
||
# Print "#(" then elements separated by spaces, then ")"
|
||
# %rbx = tagged vector value
|
||
movq %rbx, %rax
|
||
andq $-8, %rax # untagged vector ptr
|
||
movq %rax, %rbx # %rbx = untagged vector ptr
|
||
movq (%rbx), %r12 # %r12 = length (or -1 hash-table, -2 hash-set)
|
||
cmpq $-1, %r12
|
||
je .sp_hashtable_print
|
||
cmpq $-2, %r12
|
||
je .sp_hashset_print
|
||
jmp .sp_vec_real
|
||
.sp_hashtable_print:
|
||
movq $SYS_WRITE, %rax
|
||
movq output_fd(%rip), %rdi
|
||
leaq s_hashtable(%rip), %rsi
|
||
movq $s_hashtable_len, %rdx
|
||
syscall
|
||
popq %r12
|
||
popq %rbx
|
||
ret
|
||
.sp_hashset_print:
|
||
movq $SYS_WRITE, %rax
|
||
movq output_fd(%rip), %rdi
|
||
leaq s_hashset(%rip), %rsi
|
||
movq $s_hashset_len, %rdx
|
||
syscall
|
||
popq %r12
|
||
popq %rbx
|
||
ret
|
||
.sp_vec_real:
|
||
# Print "#("
|
||
movq $SYS_WRITE, %rax
|
||
movq output_fd(%rip), %rdi
|
||
leaq s_hashparen(%rip), %rsi
|
||
movq $2, %rdx
|
||
syscall
|
||
xorq %rcx, %rcx # index = 0
|
||
.sp_vec_loop:
|
||
cmpq %r12, %rcx
|
||
jge .sp_vec_close
|
||
# Print space before all but first element
|
||
testq %rcx, %rcx
|
||
jz .sp_vec_elem
|
||
pushq %rcx
|
||
movq $SYS_WRITE, %rax
|
||
movq output_fd(%rip), %rdi
|
||
leaq s_space(%rip), %rsi
|
||
movq $1, %rdx
|
||
syscall
|
||
popq %rcx
|
||
.sp_vec_elem:
|
||
pushq %rcx
|
||
pushq %rbx
|
||
pushq %r12
|
||
movq 8(%rbx,%rcx,8), %rdi # element at index
|
||
call scheme_print
|
||
popq %r12
|
||
popq %rbx
|
||
popq %rcx
|
||
incq %rcx
|
||
jmp .sp_vec_loop
|
||
.sp_vec_close:
|
||
movq $SYS_WRITE, %rax
|
||
movq output_fd(%rip), %rdi
|
||
leaq s_rparen(%rip), %rsi
|
||
movq $1, %rdx
|
||
syscall
|
||
popq %r12
|
||
popq %rbx
|
||
ret
|
||
|
||
# print_int64: %rdi = signed 64-bit integer
|
||
print_int64:
|
||
pushq %rbx
|
||
movq %rdi, %rax
|
||
testq %rax, %rax
|
||
jns .pi_pos
|
||
pushq %rax
|
||
movq $SYS_WRITE, %rax
|
||
movq output_fd(%rip), %rdi
|
||
leaq s_minus(%rip), %rsi
|
||
movq $1, %rdx
|
||
syscall
|
||
popq %rax
|
||
negq %rax
|
||
.pi_pos:
|
||
leaq num_buf(%rip), %rbx
|
||
addq $63, %rbx # end of buffer
|
||
movb $0, (%rbx) # sentinel
|
||
testq %rax, %rax
|
||
jnz .pi_digits
|
||
decq %rbx
|
||
movb $'0', (%rbx)
|
||
jmp .pi_out
|
||
.pi_digits:
|
||
testq %rax, %rax
|
||
jz .pi_out
|
||
xorq %rdx, %rdx
|
||
movq $10, %rcx
|
||
divq %rcx
|
||
addb $'0', %dl
|
||
decq %rbx
|
||
movb %dl, (%rbx)
|
||
jmp .pi_digits
|
||
.pi_out:
|
||
# Calculate length
|
||
leaq num_buf(%rip), %rax
|
||
addq $63, %rax
|
||
subq %rbx, %rax
|
||
movq %rax, %rdx # length
|
||
movq %rbx, %rsi # start
|
||
movq $SYS_WRITE, %rax
|
||
movq output_fd(%rip), %rdi
|
||
syscall
|
||
popq %rbx
|
||
ret
|
||
|
||
# ============================================================
|
||
# Evaluator
|
||
# eval: %rdi = expr, %rsi = env -> %rax = value
|
||
# Uses TCO: tail positions jump back to .eval_top
|
||
# ============================================================
|
||
eval:
|
||
pushq %rbx
|
||
pushq %rbp
|
||
pushq %r12
|
||
|
||
# %rbp = current env, %rdi = expr
|
||
movq %rsi, %rbp
|
||
|
||
.eval_top:
|
||
# TCO re-entry: %rdi = expr, %rbp = env
|
||
movq %rdi, %rax
|
||
andq $TAG_MASK, %rax
|
||
|
||
# Self-evaluating
|
||
cmpq $TAG_INT, %rax
|
||
je .ev_self
|
||
cmpq $TAG_STRING, %rax
|
||
je .ev_self
|
||
cmpq $TAG_SPECIAL, %rax
|
||
je .ev_self
|
||
cmpq $TAG_BUILTIN, %rax
|
||
je .ev_self
|
||
cmpq $TAG_CLOSURE, %rax
|
||
je .ev_self
|
||
|
||
# Symbol lookup
|
||
cmpq $TAG_SYM, %rax
|
||
je .ev_sym
|
||
|
||
# Must be a pair
|
||
cmpq $TAG_PAIR, %rax
|
||
jne .ev_self
|
||
|
||
# List: check for special forms
|
||
movq %rdi, %rax
|
||
andq $-8, %rax
|
||
movq (%rax), %rbx # car = operator position
|
||
movq 8(%rax), %r12 # cdr = args
|
||
|
||
# Is operator a symbol?
|
||
movq %rbx, %rax
|
||
andq $TAG_MASK, %rax
|
||
cmpq $TAG_SYM, %rax
|
||
jne .ev_app # not a symbol, just apply
|
||
|
||
# Check special forms by comparing tagged symbol values
|
||
cmpq sym_quote_val(%rip), %rbx
|
||
je .ev_quote
|
||
cmpq sym_if_val(%rip), %rbx
|
||
je .ev_if
|
||
cmpq sym_define_val(%rip), %rbx
|
||
je .ev_define
|
||
cmpq sym_setbang_val(%rip), %rbx
|
||
je .ev_setbang
|
||
cmpq sym_lambda_val(%rip), %rbx
|
||
je .ev_lambda
|
||
cmpq sym_begin_val(%rip), %rbx
|
||
je .ev_begin
|
||
cmpq sym_let_val(%rip), %rbx
|
||
je .ev_let
|
||
cmpq sym_cond_val(%rip), %rbx
|
||
je .ev_cond
|
||
cmpq sym_and_val(%rip), %rbx
|
||
je .ev_and
|
||
cmpq sym_or_val(%rip), %rbx
|
||
je .ev_or
|
||
|
||
# Not special form -> application
|
||
jmp .ev_app
|
||
|
||
.ev_self:
|
||
movq %rdi, %rax
|
||
popq %r12
|
||
popq %rbp
|
||
popq %rbx
|
||
ret
|
||
|
||
.ev_sym:
|
||
movq %rbp, %rsi
|
||
# Also search global env
|
||
call env_lookup_both
|
||
popq %r12
|
||
popq %rbp
|
||
popq %rbx
|
||
ret
|
||
|
||
# env_lookup_both: %rdi=sym, %rsi=local_env
|
||
# Searches local first, then %r14 (global)
|
||
env_lookup_both:
|
||
pushq %rdi
|
||
pushq %rsi
|
||
# Search local
|
||
movq %rsi, %rax
|
||
.elb_local:
|
||
testq %rax, %rax
|
||
jz .elb_global
|
||
cmpq %rdi, (%rax)
|
||
je .elb_found
|
||
movq 16(%rax), %rax
|
||
jmp .elb_local
|
||
.elb_global:
|
||
movq %r14, %rax
|
||
.elb_global_loop:
|
||
testq %rax, %rax
|
||
jz .elb_fail
|
||
cmpq %rdi, (%rax)
|
||
je .elb_found
|
||
movq 16(%rax), %rax
|
||
jmp .elb_global_loop
|
||
.elb_found:
|
||
movq 8(%rax), %rax
|
||
popq %rsi
|
||
popq %rdi
|
||
ret
|
||
.elb_fail:
|
||
popq %rsi
|
||
popq %rdi
|
||
jmp .env_lk_fail
|
||
|
||
# ---- quote ----
|
||
.ev_quote:
|
||
# (quote X) -> X
|
||
movq %r12, %rax
|
||
andq $-8, %rax
|
||
movq (%rax), %rax # car of args
|
||
popq %r12
|
||
popq %rbp
|
||
popq %rbx
|
||
ret
|
||
|
||
# ---- if ----
|
||
.ev_if:
|
||
# (if test then [else])
|
||
# %r12 = (test then [else])
|
||
movq %r12, %rax
|
||
andq $-8, %rax
|
||
movq (%rax), %rdi # test expr
|
||
movq 8(%rax), %rax # (then [else])
|
||
andq $-8, %rax
|
||
movq (%rax), %rbx # then expr
|
||
movq 8(%rax), %r12 # (else) or nil
|
||
|
||
# Eval test
|
||
pushq %rbx
|
||
pushq %r12
|
||
movq %rbp, %rsi
|
||
call eval
|
||
popq %r12
|
||
popq %rbx
|
||
|
||
# False or nil -> else branch
|
||
cmpq $VAL_FALSE, %rax
|
||
je .ev_if_else
|
||
cmpq $VAL_NIL, %rax
|
||
je .ev_if_else
|
||
|
||
# True: TCO then
|
||
movq %rbx, %rdi
|
||
jmp .eval_top
|
||
|
||
.ev_if_else:
|
||
cmpq $VAL_NIL, %r12
|
||
je .ev_if_void
|
||
movq %r12, %rax
|
||
andq $-8, %rax
|
||
movq (%rax), %rdi # else expr
|
||
jmp .eval_top
|
||
.ev_if_void:
|
||
movq $VAL_VOID, %rax
|
||
popq %r12
|
||
popq %rbp
|
||
popq %rbx
|
||
ret
|
||
|
||
# ---- define ----
|
||
.ev_define:
|
||
# %r12 = args: (var expr) or ((name params...) body...)
|
||
movq %r12, %rax
|
||
andq $-8, %rax
|
||
movq (%rax), %rbx # first: var or (name params...)
|
||
movq 8(%rax), %r12 # rest
|
||
|
||
movq %rbx, %rax
|
||
andq $TAG_MASK, %rax
|
||
cmpq $TAG_PAIR, %rax
|
||
je .ev_define_func
|
||
|
||
# Simple: (define var expr) — or (define var) with no expr → VAL_VOID
|
||
cmpq $VAL_NIL, %r12
|
||
je .ev_define_no_expr
|
||
movq %r12, %rax
|
||
andq $-8, %rax
|
||
movq (%rax), %rdi # expr
|
||
pushq %rbx
|
||
movq %rbp, %rsi
|
||
call eval
|
||
popq %rbx # var symbol
|
||
jmp .ev_define_bind
|
||
.ev_define_no_expr:
|
||
movq $VAL_VOID, %rax
|
||
.ev_define_bind:
|
||
movq %rbx, %rdi
|
||
movq %rax, %rsi
|
||
movq %r14, %rdx
|
||
call env_define
|
||
movq %rax, %r14 # update global env
|
||
|
||
movq $VAL_VOID, %rax
|
||
popq %r12
|
||
popq %rbp
|
||
popq %rbx
|
||
ret
|
||
|
||
.ev_define_func:
|
||
# (define (name p1 p2 ...) body...)
|
||
movq %rbx, %rax
|
||
andq $-8, %rax
|
||
movq (%rax), %rcx # name symbol
|
||
movq 8(%rax), %rdx # (p1 p2 ...) = params
|
||
|
||
# Make body: if single, use it; if multiple, wrap in (begin ...)
|
||
pushq %rcx # save name
|
||
pushq %rdx # save params
|
||
movq %r12, %rdi
|
||
call wrap_begin
|
||
movq %rax, %rsi # body
|
||
|
||
popq %rdi # params
|
||
movq %rbp, %rdx # env
|
||
call make_closure
|
||
movq %rax, %rsi # closure
|
||
popq %rdi # name
|
||
movq %r14, %rdx
|
||
call env_define
|
||
movq %rax, %r14
|
||
|
||
movq $VAL_VOID, %rax
|
||
popq %r12
|
||
popq %rbp
|
||
popq %rbx
|
||
ret
|
||
|
||
# wrap_begin: %rdi = body list -> %rax = single expr or (begin ...)
|
||
wrap_begin:
|
||
movq %rdi, %rax
|
||
andq $-8, %rax
|
||
movq 8(%rax), %rcx # cdr
|
||
cmpq $VAL_NIL, %rcx
|
||
jne .wb_multi
|
||
# Single body
|
||
movq %rdi, %rax
|
||
andq $-8, %rax
|
||
movq (%rax), %rax
|
||
ret
|
||
.wb_multi:
|
||
pushq %rdi
|
||
movq sym_begin_val(%rip), %rdi
|
||
movq (%rsp), %rsi
|
||
call make_pair
|
||
addq $8, %rsp
|
||
ret
|
||
|
||
# ---- set! ----
|
||
.ev_setbang:
|
||
movq %r12, %rax
|
||
andq $-8, %rax
|
||
movq (%rax), %rbx # var
|
||
movq 8(%rax), %rax
|
||
andq $-8, %rax
|
||
movq (%rax), %rdi # expr
|
||
pushq %rbx
|
||
movq %rbp, %rsi
|
||
call eval
|
||
popq %rbx
|
||
# Try local env first, then global
|
||
movq %rbx, %rdi
|
||
movq %rax, %rsi
|
||
movq %rbp, %rdx
|
||
call env_set_both
|
||
|
||
movq $VAL_VOID, %rax
|
||
popq %r12
|
||
popq %rbp
|
||
popq %rbx
|
||
ret
|
||
|
||
# env_set_both: %rdi=sym %rsi=val %rdx=local_env
|
||
# Searches local first, then %r14 global
|
||
env_set_both:
|
||
movq %rdx, %rax
|
||
.esb_local:
|
||
testq %rax, %rax
|
||
jz .esb_global
|
||
cmpq %rdi, (%rax)
|
||
je .esb_found
|
||
movq 16(%rax), %rax
|
||
jmp .esb_local
|
||
.esb_global:
|
||
movq %r14, %rax
|
||
.esb_global_loop:
|
||
testq %rax, %rax
|
||
jz .esb_fail
|
||
cmpq %rdi, (%rax)
|
||
je .esb_found
|
||
movq 16(%rax), %rax
|
||
jmp .esb_global_loop
|
||
.esb_found:
|
||
movq %rsi, 8(%rax)
|
||
ret
|
||
.esb_fail:
|
||
jmp .env_lk_fail
|
||
|
||
# ---- lambda ----
|
||
.ev_lambda:
|
||
# (lambda (params...) body...)
|
||
movq %r12, %rax
|
||
andq $-8, %rax
|
||
movq (%rax), %rcx # params list
|
||
movq 8(%rax), %rdi # body forms
|
||
|
||
pushq %rcx
|
||
call wrap_begin
|
||
movq %rax, %rsi # body
|
||
popq %rdi # params
|
||
movq %rbp, %rdx # capture env
|
||
call make_closure
|
||
|
||
popq %r12
|
||
popq %rbp
|
||
popq %rbx
|
||
ret
|
||
|
||
# ---- begin ----
|
||
.ev_begin:
|
||
# %r12 = body forms
|
||
cmpq $VAL_NIL, %r12
|
||
je .ev_begin_void
|
||
.ev_begin_loop:
|
||
movq %r12, %rax
|
||
andq $-8, %rax
|
||
movq (%rax), %rdi # current expr
|
||
movq 8(%rax), %r12 # rest
|
||
cmpq $VAL_NIL, %r12
|
||
je .ev_begin_tail
|
||
# Not last: eval and discard
|
||
pushq %r12
|
||
movq %rbp, %rsi
|
||
call eval
|
||
popq %r12
|
||
jmp .ev_begin_loop
|
||
.ev_begin_tail:
|
||
# Last: TCO
|
||
jmp .eval_top
|
||
.ev_begin_void:
|
||
movq $VAL_VOID, %rax
|
||
popq %r12
|
||
popq %rbp
|
||
popq %rbx
|
||
ret
|
||
|
||
# ---- let ----
|
||
.ev_let:
|
||
# (let ((v1 e1) ...) body...) or (let name ((v1 e1) ...) body...)
|
||
movq %r12, %rax
|
||
andq $-8, %rax
|
||
movq (%rax), %rbx # first arg
|
||
movq 8(%rax), %r12 # rest
|
||
|
||
movq %rbx, %rax
|
||
andq $TAG_MASK, %rax
|
||
cmpq $TAG_SYM, %rax
|
||
je .ev_named_let
|
||
|
||
# Regular let: %rbx = bindings, %r12 = body
|
||
movq %rbp, %rcx # extended env starts as current env
|
||
# Process bindings
|
||
.ev_let_binds:
|
||
cmpq $VAL_NIL, %rbx
|
||
je .ev_let_body
|
||
|
||
movq %rbx, %rax
|
||
andq $-8, %rax
|
||
movq (%rax), %rdi # (var expr) pair
|
||
movq 8(%rax), %rbx # rest bindings
|
||
|
||
movq %rdi, %rax
|
||
andq $-8, %rax
|
||
movq (%rax), %r8 # var
|
||
movq 8(%rax), %rax
|
||
andq $-8, %rax
|
||
movq (%rax), %rdi # expr
|
||
|
||
# Eval expr in ORIGINAL env
|
||
pushq %rbx
|
||
pushq %rcx
|
||
pushq %r8
|
||
movq %rbp, %rsi
|
||
call eval
|
||
popq %r8 # var
|
||
popq %rcx # current extended env
|
||
popq %rbx # rest bindings
|
||
|
||
# Bind
|
||
pushq %rbx
|
||
movq %r8, %rdi
|
||
movq %rax, %rsi
|
||
movq %rcx, %rdx
|
||
call env_define
|
||
movq %rax, %rcx # updated env
|
||
popq %rbx
|
||
jmp .ev_let_binds
|
||
|
||
.ev_let_body:
|
||
# eval body in extended env, TCO
|
||
movq %rcx, %rbp # extended env
|
||
movq %r12, %rdi # body forms
|
||
call wrap_begin
|
||
movq %rax, %rdi
|
||
jmp .eval_top
|
||
|
||
# ---- named let ----
|
||
.ev_named_let:
|
||
# %rbx = name sym, %r12 = ((bindings...) body...)
|
||
movq %r12, %rax
|
||
andq $-8, %rax
|
||
movq (%rax), %rcx # bindings list
|
||
movq 8(%rax), %r12 # body forms
|
||
|
||
# Collect params and eval init values
|
||
# We'll build two reversed lists, then reverse them
|
||
pushq %rbx # save loop name
|
||
pushq %r12 # save body forms
|
||
|
||
movq $VAL_NIL, %r8 # params acc (reversed)
|
||
movq $VAL_NIL, %r9 # vals acc (reversed)
|
||
|
||
.ev_nlet_collect:
|
||
cmpq $VAL_NIL, %rcx
|
||
je .ev_nlet_build
|
||
|
||
movq %rcx, %rax
|
||
andq $-8, %rax
|
||
movq (%rax), %rdi # (var expr)
|
||
movq 8(%rax), %rcx # rest bindings
|
||
|
||
movq %rdi, %rax
|
||
andq $-8, %rax
|
||
movq (%rax), %rdi # var
|
||
movq 8(%rax), %rax
|
||
andq $-8, %rax
|
||
movq (%rax), %rsi # expr
|
||
|
||
# Save state
|
||
pushq %rcx
|
||
pushq %r8
|
||
pushq %r9
|
||
pushq %rdi # var
|
||
|
||
# Eval init expr
|
||
movq %rsi, %rdi
|
||
movq %rbp, %rsi
|
||
call eval
|
||
|
||
popq %rdi # var
|
||
popq %r9 # vals acc
|
||
popq %r8 # params acc
|
||
popq %rcx # rest bindings
|
||
|
||
# cons var onto params
|
||
pushq %rax # save evaled value
|
||
pushq %rcx
|
||
pushq %r9
|
||
movq %r8, %rsi
|
||
call make_pair
|
||
movq %rax, %r8
|
||
popq %r9
|
||
popq %rcx
|
||
popq %rax
|
||
|
||
# cons val onto vals
|
||
pushq %rcx
|
||
pushq %r8
|
||
movq %rax, %rdi
|
||
movq %r9, %rsi
|
||
call make_pair
|
||
movq %rax, %r9
|
||
popq %r8
|
||
popq %rcx
|
||
|
||
jmp .ev_nlet_collect
|
||
|
||
.ev_nlet_build:
|
||
# Reverse params
|
||
pushq %r9
|
||
movq %r8, %rdi
|
||
call list_reverse
|
||
movq %rax, %r8 # params (correct order)
|
||
popq %rdi
|
||
call list_reverse
|
||
movq %rax, %r9 # vals (correct order)
|
||
|
||
popq %r12 # body forms
|
||
popq %rbx # loop name
|
||
|
||
# Wrap body
|
||
pushq %rbx
|
||
pushq %r8
|
||
pushq %r9
|
||
movq %r12, %rdi
|
||
call wrap_begin
|
||
movq %rax, %rsi # body
|
||
popq %r9
|
||
popq %rdi # params
|
||
popq %rbx # name
|
||
|
||
# Create closure
|
||
pushq %rbx
|
||
pushq %r9
|
||
movq %rbp, %rdx
|
||
call make_closure
|
||
popq %r9 # vals
|
||
popq %rbx # name
|
||
|
||
# Bind name to closure in env (for recursion)
|
||
pushq %rax # save closure
|
||
pushq %r9
|
||
movq %rbx, %rdi
|
||
movq %rax, %rsi
|
||
movq %rbp, %rdx
|
||
call env_define
|
||
movq %rax, %rbp # env with name bound
|
||
popq %r9
|
||
popq %rax
|
||
|
||
# Patch closure's captured env to include itself
|
||
movq %rax, %rcx
|
||
andq $-8, %rcx
|
||
movq %rbp, 16(%rcx)
|
||
|
||
# Now apply: bind params to vals
|
||
movq %rax, %rcx
|
||
andq $-8, %rcx
|
||
movq (%rcx), %rdi # params
|
||
movq 8(%rcx), %r12 # body
|
||
movq %rbp, %rsi # env
|
||
|
||
movq %r9, %rcx # vals
|
||
.ev_nlet_bind:
|
||
cmpq $VAL_NIL, %rdi
|
||
je .ev_nlet_go
|
||
cmpq $VAL_NIL, %rcx
|
||
je .ev_nlet_go
|
||
|
||
# Get param and val
|
||
pushq %rdi
|
||
pushq %rcx
|
||
pushq %rsi
|
||
|
||
movq %rdi, %rax
|
||
andq $-8, %rax
|
||
movq (%rax), %rdi # param sym
|
||
movq %rcx, %rax
|
||
andq $-8, %rax
|
||
movq (%rax), %rsi # val
|
||
popq %rdx # env
|
||
pushq %rdx
|
||
call env_define
|
||
movq %rax, %rsi # updated env
|
||
|
||
popq %rax # (discard, env now in %rsi)
|
||
popq %rcx
|
||
popq %rdi
|
||
|
||
# Advance
|
||
movq %rdi, %rax
|
||
andq $-8, %rax
|
||
movq 8(%rax), %rdi
|
||
movq %rcx, %rax
|
||
andq $-8, %rax
|
||
movq 8(%rax), %rcx
|
||
jmp .ev_nlet_bind
|
||
|
||
.ev_nlet_go:
|
||
movq %rsi, %rbp
|
||
movq %r12, %rdi
|
||
jmp .eval_top
|
||
|
||
# ---- cond ----
|
||
.ev_cond:
|
||
# %r12 = clauses list
|
||
.ev_cond_loop:
|
||
cmpq $VAL_NIL, %r12
|
||
je .ev_cond_void
|
||
|
||
movq %r12, %rax
|
||
andq $-8, %rax
|
||
movq (%rax), %rbx # first clause (test expr...)
|
||
movq 8(%rax), %r12 # rest clauses
|
||
|
||
movq %rbx, %rax
|
||
andq $-8, %rax
|
||
movq (%rax), %rdi # test
|
||
movq 8(%rax), %rcx # exprs
|
||
|
||
# Check for else
|
||
cmpq sym_else_val(%rip), %rdi
|
||
je .ev_cond_else
|
||
|
||
# Eval test
|
||
pushq %rcx
|
||
pushq %r12
|
||
movq %rbp, %rsi
|
||
call eval
|
||
popq %r12
|
||
popq %rcx
|
||
|
||
cmpq $VAL_FALSE, %rax
|
||
je .ev_cond_loop
|
||
cmpq $VAL_NIL, %rax
|
||
je .ev_cond_loop
|
||
|
||
# True: eval body (TCO for begin)
|
||
jmp .ev_cond_body
|
||
|
||
.ev_cond_else:
|
||
# Fall through to body
|
||
.ev_cond_body:
|
||
# %rcx = body exprs, treat like begin
|
||
movq %rcx, %r12
|
||
jmp .ev_begin
|
||
|
||
.ev_cond_void:
|
||
movq $VAL_VOID, %rax
|
||
popq %r12
|
||
popq %rbp
|
||
popq %rbx
|
||
ret
|
||
|
||
# ---- and ----
|
||
.ev_and:
|
||
cmpq $VAL_NIL, %r12
|
||
je .ev_and_empty
|
||
.ev_and_loop:
|
||
movq %r12, %rax
|
||
andq $-8, %rax
|
||
movq (%rax), %rdi # current
|
||
movq 8(%rax), %r12 # rest
|
||
cmpq $VAL_NIL, %r12
|
||
je .ev_and_tail
|
||
pushq %r12
|
||
movq %rbp, %rsi
|
||
call eval
|
||
popq %r12
|
||
cmpq $VAL_FALSE, %rax
|
||
je .ev_and_false
|
||
cmpq $VAL_NIL, %rax
|
||
je .ev_and_false
|
||
jmp .ev_and_loop
|
||
.ev_and_tail:
|
||
jmp .eval_top
|
||
.ev_and_empty:
|
||
movq $VAL_TRUE, %rax
|
||
popq %r12
|
||
popq %rbp
|
||
popq %rbx
|
||
ret
|
||
.ev_and_false:
|
||
movq $VAL_FALSE, %rax
|
||
popq %r12
|
||
popq %rbp
|
||
popq %rbx
|
||
ret
|
||
|
||
# ---- or ----
|
||
.ev_or:
|
||
cmpq $VAL_NIL, %r12
|
||
je .ev_or_empty
|
||
.ev_or_loop:
|
||
movq %r12, %rax
|
||
andq $-8, %rax
|
||
movq (%rax), %rdi
|
||
movq 8(%rax), %r12
|
||
cmpq $VAL_NIL, %r12
|
||
je .ev_or_tail
|
||
pushq %r12
|
||
movq %rbp, %rsi
|
||
call eval
|
||
popq %r12
|
||
cmpq $VAL_FALSE, %rax
|
||
je .ev_or_loop
|
||
cmpq $VAL_NIL, %rax
|
||
je .ev_or_loop
|
||
# Truthy
|
||
popq %r12
|
||
popq %rbp
|
||
popq %rbx
|
||
ret
|
||
.ev_or_tail:
|
||
jmp .eval_top
|
||
.ev_or_empty:
|
||
movq $VAL_FALSE, %rax
|
||
popq %r12
|
||
popq %rbp
|
||
popq %rbx
|
||
ret
|
||
|
||
# ---- application ----
|
||
.ev_app:
|
||
# %rbx = operator expr (in car position), %r12 = arg exprs
|
||
# We stored these from the pair destructuring above
|
||
|
||
# Eval operator
|
||
movq %rbx, %rdi
|
||
pushq %r12
|
||
movq %rbp, %rsi
|
||
call eval
|
||
popq %r12
|
||
movq %rax, %rbx # evaled operator
|
||
|
||
# Eval args list
|
||
movq %r12, %rdi
|
||
movq %rbp, %rsi
|
||
call eval_list
|
||
movq %rax, %r12 # evaled args
|
||
|
||
# Dispatch
|
||
movq %rbx, %rax
|
||
andq $TAG_MASK, %rax
|
||
cmpq $TAG_BUILTIN, %rax
|
||
je .app_builtin
|
||
cmpq $TAG_CLOSURE, %rax
|
||
je .app_closure
|
||
|
||
# Not a procedure
|
||
movq $SYS_WRITE, %rax
|
||
movq $2, %rdi
|
||
leaq err_notproc(%rip), %rsi
|
||
movq $err_notproc_len, %rdx
|
||
syscall
|
||
movq $SYS_EXIT, %rax
|
||
movq $1, %rdi
|
||
syscall
|
||
|
||
# eval_list: %rdi = expr_list, %rsi = env -> %rax = value_list
|
||
eval_list:
|
||
pushq %rbx
|
||
pushq %r12
|
||
pushq %rbp
|
||
movq %rsi, %rbp
|
||
|
||
cmpq $VAL_NIL, %rdi
|
||
je .el_nil
|
||
|
||
movq %rdi, %rax
|
||
andq $-8, %rax
|
||
movq (%rax), %rbx # car = first expr
|
||
movq 8(%rax), %r12 # cdr = rest
|
||
|
||
# Eval first
|
||
movq %rbx, %rdi
|
||
movq %rbp, %rsi
|
||
call eval
|
||
pushq %rax
|
||
|
||
# Eval rest
|
||
movq %r12, %rdi
|
||
movq %rbp, %rsi
|
||
call eval_list
|
||
movq %rax, %rsi
|
||
popq %rdi
|
||
call make_pair
|
||
|
||
popq %rbp
|
||
popq %r12
|
||
popq %rbx
|
||
ret
|
||
.el_nil:
|
||
movq $VAL_NIL, %rax
|
||
popq %rbp
|
||
popq %r12
|
||
popq %rbx
|
||
ret
|
||
|
||
# ---- apply closure ----
|
||
.app_closure:
|
||
# %rbx = closure (tagged), %r12 = arg values list
|
||
movq %rbx, %rax
|
||
andq $-8, %rax
|
||
movq (%rax), %rdi # params
|
||
movq 8(%rax), %rcx # body
|
||
movq 16(%rax), %rsi # closure env
|
||
movq %r12, %rdx # arg vals
|
||
|
||
# Bind params to args
|
||
.ac_bind:
|
||
cmpq $VAL_NIL, %rdi
|
||
je .ac_go
|
||
cmpq $VAL_NIL, %rdx
|
||
je .ac_go
|
||
|
||
pushq %rdi
|
||
pushq %rcx
|
||
pushq %rdx
|
||
pushq %rsi
|
||
|
||
movq %rdi, %rax
|
||
andq $-8, %rax
|
||
movq (%rax), %rdi # param sym
|
||
movq %rdx, %rax
|
||
andq $-8, %rax
|
||
movq (%rax), %rsi # arg val
|
||
popq %rdx # env
|
||
pushq %rdx
|
||
call env_define
|
||
movq %rax, %rsi # updated env
|
||
|
||
popq %rax # discard
|
||
popq %rdx # arg vals
|
||
popq %rcx # body
|
||
popq %rdi # params
|
||
|
||
# Advance
|
||
movq %rdi, %rax
|
||
andq $-8, %rax
|
||
movq 8(%rax), %rdi
|
||
movq %rdx, %rax
|
||
andq $-8, %rax
|
||
movq 8(%rax), %rdx
|
||
jmp .ac_bind
|
||
|
||
.ac_go:
|
||
# TCO: eval body in extended env
|
||
movq %rsi, %rbp
|
||
movq %rcx, %rdi
|
||
jmp .eval_top
|
||
|
||
# ---- apply builtin ----
|
||
.app_builtin:
|
||
# %rbx = builtin (tagged), %r12 = arg values list
|
||
movq %rbx, %rax
|
||
shrq $3, %rax # index
|
||
|
||
# Jump table — shared entry point for apply_proc_raw dispatch
|
||
.app_builtin_dispatch:
|
||
cmpq $BI_ADD, %rax
|
||
je bi_add
|
||
cmpq $BI_SUB, %rax
|
||
je bi_sub
|
||
cmpq $BI_MUL, %rax
|
||
je bi_mul
|
||
cmpq $BI_EQ, %rax
|
||
je bi_eq
|
||
cmpq $BI_LT, %rax
|
||
je bi_lt
|
||
cmpq $BI_GT, %rax
|
||
je bi_gt
|
||
cmpq $BI_LE, %rax
|
||
je bi_le
|
||
cmpq $BI_GE, %rax
|
||
je bi_ge
|
||
cmpq $BI_CONS, %rax
|
||
je bi_cons
|
||
cmpq $BI_CAR, %rax
|
||
je bi_car
|
||
cmpq $BI_CDR, %rax
|
||
je bi_cdr
|
||
cmpq $BI_NULLP, %rax
|
||
je bi_nullp
|
||
cmpq $BI_PAIRP, %rax
|
||
je bi_pairp
|
||
cmpq $BI_NOT, %rax
|
||
je bi_not
|
||
cmpq $BI_DISPLAY, %rax
|
||
je bi_display
|
||
cmpq $BI_NEWLINE, %rax
|
||
je bi_newline
|
||
cmpq $BI_LIST, %rax
|
||
je bi_list
|
||
cmpq $BI_LENGTH, %rax
|
||
je bi_length
|
||
cmpq $BI_ZEROP, %rax
|
||
je bi_zerop
|
||
cmpq $BI_MODULO, %rax
|
||
je bi_modulo
|
||
cmpq $BI_REMAINDER, %rax
|
||
je bi_remainder
|
||
cmpq $BI_NUMBERP, %rax
|
||
je bi_numberp
|
||
cmpq $BI_EQVP, %rax
|
||
je bi_eqvp
|
||
cmpq $BI_EQUALP, %rax
|
||
je bi_equalp
|
||
cmpq $BI_ABS, %rax
|
||
je bi_abs
|
||
cmpq $BI_MIN, %rax
|
||
je bi_min
|
||
cmpq $BI_MAX, %rax
|
||
je bi_max
|
||
cmpq $BI_BOOLP, %rax
|
||
je bi_boolp
|
||
cmpq $BI_SYMBOLP, %rax
|
||
je bi_symbolp
|
||
cmpq $BI_STRINGP, %rax
|
||
je bi_stringp
|
||
cmpq $BI_PROCP, %rax
|
||
je bi_procp
|
||
cmpq $BI_QUOTIENT, %rax
|
||
je bi_quotient
|
||
cmpq $BI_NEGATIVEP, %rax
|
||
je bi_negativep
|
||
cmpq $BI_POSITIVEP, %rax
|
||
je bi_positivep
|
||
cmpq $BI_DIV, %rax
|
||
je bi_div
|
||
cmpq $BI_ODDP, %rax
|
||
je bi_oddp
|
||
cmpq $BI_EVENP, %rax
|
||
je bi_evenp
|
||
cmpq $BI_APPEND, %rax
|
||
je bi_append
|
||
cmpq $BI_REVERSE, %rax
|
||
je bi_reverse
|
||
cmpq $BI_MAP, %rax
|
||
je bi_map
|
||
cmpq $BI_FILTER, %rax
|
||
je bi_filter
|
||
cmpq $BI_FOLDL, %rax
|
||
je bi_foldl
|
||
cmpq $BI_FOREACH, %rax
|
||
je bi_foreach
|
||
cmpq $BI_APPLY, %rax
|
||
je bi_apply
|
||
cmpq $BI_MEMBER, %rax
|
||
je bi_member
|
||
cmpq $BI_ASSOC, %rax
|
||
je bi_assoc
|
||
cmpq $BI_WRITE, %rax
|
||
je bi_write
|
||
cmpq $BI_STRLENGTH, %rax
|
||
je bi_strlength
|
||
cmpq $BI_STRREF, %rax
|
||
je bi_strref
|
||
cmpq $BI_STRAPPEND, %rax
|
||
je bi_strappend
|
||
cmpq $BI_STREQP, %rax
|
||
je bi_streqp
|
||
cmpq $BI_NUMTOSTR, %rax
|
||
je bi_numtostr
|
||
cmpq $BI_STRTONUM, %rax
|
||
je bi_strtonum
|
||
cmpq $BI_CHARTOINT, %rax
|
||
je bi_chartoint
|
||
cmpq $BI_INTTOCHAR, %rax
|
||
je bi_inttochar
|
||
cmpq $BI_CHARALPHAP, %rax
|
||
je bi_charalphap
|
||
cmpq $BI_CHARNUMP, %rax
|
||
je bi_charnump
|
||
cmpq $BI_VECREF, %rax
|
||
je bi_vecref
|
||
cmpq $BI_VECSET, %rax
|
||
je bi_vecset
|
||
cmpq $BI_VECLEN, %rax
|
||
je bi_veclen
|
||
cmpq $BI_VECP, %rax
|
||
je bi_vecp
|
||
cmpq $BI_VECTOR, %rax
|
||
je bi_vector
|
||
cmpq $BI_MAKEVEC, %rax
|
||
je bi_makevec
|
||
cmpq $BI_VECTOLIST, %rax
|
||
je bi_vectolist
|
||
cmpq $BI_LISTTOVEC, %rax
|
||
je bi_listtovec
|
||
cmpq $BI_CHARP, %rax
|
||
je bi_charp
|
||
cmpq $BI_LISTP, %rax
|
||
je bi_listp
|
||
cmpq $BI_SUBSTR, %rax
|
||
je bi_substr
|
||
cmpq $BI_EXPT, %rax
|
||
je bi_expt
|
||
cmpq $BI_GCD, %rax
|
||
je bi_gcd
|
||
cmpq $BI_INTEGERP, %rax
|
||
je bi_integerp
|
||
cmpq $BI_PORTALSAVE, %rax
|
||
je bi_portal_save
|
||
cmpq $BI_PORTALRESUME, %rax
|
||
je bi_portal_resume
|
||
cmpq $BI_LOAD, %rax
|
||
je bi_load
|
||
cmpq $BI_OPENOUT, %rax
|
||
je bi_open_output_file
|
||
cmpq $BI_CLOSEPORT, %rax
|
||
je bi_close_port
|
||
cmpq $BI_PORTP, %rax
|
||
je bi_portp
|
||
cmpq $BI_WRITEFILE, %rax
|
||
je bi_write_file
|
||
cmpq $BI_FILETOSTR, %rax
|
||
je bi_file_to_string
|
||
cmpq $BI_TCPLISTEN, %rax
|
||
je bi_tcp_listen
|
||
cmpq $BI_TCPACCEPT, %rax
|
||
je bi_tcp_accept
|
||
cmpq $BI_TCPCONNECT, %rax
|
||
je bi_tcp_connect
|
||
cmpq $BI_TCPRECV, %rax
|
||
je bi_tcp_recv
|
||
cmpq $BI_TCPSEND, %rax
|
||
je bi_tcp_send
|
||
cmpq $BI_TCPCLOSE, %rax
|
||
je bi_close_port
|
||
cmpq $BI_HEAPSNAP, %rax
|
||
je bi_heap_snapshot
|
||
cmpq $BI_HEAPREST, %rax
|
||
je bi_heap_restore
|
||
cmpq $BI_CURTIME, %rax
|
||
je bi_current_time_ms
|
||
cmpq $BI_READSTR, %rax
|
||
je bi_read_from_string
|
||
cmpq $BI_EVAL, %rax
|
||
je bi_eval
|
||
cmpq $BI_SYMTOSTR, %rax
|
||
je bi_symbol_to_string
|
||
cmpq $BI_HT_MAKE, %rax
|
||
je bi_make_hash_table
|
||
cmpq $BI_HT_P, %rax
|
||
je bi_hash_table_p
|
||
cmpq $BI_HT_SET, %rax
|
||
je bi_hash_table_set
|
||
cmpq $BI_HT_REF, %rax
|
||
je bi_hash_table_ref
|
||
cmpq $BI_HT_REFD, %rax
|
||
je bi_hash_table_ref_default
|
||
cmpq $BI_HT_DEL, %rax
|
||
je bi_hash_table_delete
|
||
cmpq $BI_HT_EXISTS, %rax
|
||
je bi_hash_table_exists
|
||
cmpq $BI_HT_SIZE, %rax
|
||
je bi_hash_table_size
|
||
cmpq $BI_HT_KEYS, %rax
|
||
je bi_hash_table_keys
|
||
cmpq $BI_HT_VALS, %rax
|
||
je bi_hash_table_values
|
||
cmpq $BI_HT_ALIST, %rax
|
||
je bi_hash_table_to_alist
|
||
cmpq $BI_HS_MAKE, %rax
|
||
je bi_make_hash_set
|
||
cmpq $BI_HS_P, %rax
|
||
je bi_hash_set_p
|
||
cmpq $BI_HS_ADD, %rax
|
||
je bi_hash_set_add
|
||
cmpq $BI_HS_HAS, %rax
|
||
je bi_hash_set_contains
|
||
cmpq $BI_HS_SIZE, %rax
|
||
je bi_hash_set_size
|
||
cmpq $BI_HS_LIST, %rax
|
||
je bi_hash_set_to_list
|
||
.ifdef GC_NAIVE
|
||
cmpq $BI_GC_COLLECT, %rax
|
||
je bi_gc_collect_user
|
||
cmpq $BI_GC_STATS, %rax
|
||
je bi_gc_stats
|
||
cmpq $BI_WITH_ARENA, %rax
|
||
je bi_with_arena
|
||
cmpq $BI_ARENA_STATS, %rax
|
||
je bi_arena_stats
|
||
cmpq $BI_ARENA_SET_MODE, %rax
|
||
je bi_arena_set_mode
|
||
.endif
|
||
|
||
movq $VAL_VOID, %rax
|
||
popq %r12
|
||
popq %rbp
|
||
popq %rbx
|
||
ret
|
||
|
||
# Macro: get arg from %r12, store raw tagged val in dest, advance %r12
|
||
.macro GETARG dest
|
||
movq %r12, %rax
|
||
andq $-8, %rax
|
||
movq 8(%rax), %r12
|
||
movq (%rax), \dest
|
||
.endm
|
||
|
||
.macro RET_VAL
|
||
popq %r12
|
||
popq %rbp
|
||
popq %rbx
|
||
ret
|
||
.endm
|
||
|
||
bi_add:
|
||
xorq %rcx, %rcx
|
||
.ba_loop:
|
||
cmpq $VAL_NIL, %r12
|
||
je .ba_done
|
||
GETARG %rax
|
||
sarq $3, %rax
|
||
addq %rax, %rcx
|
||
jmp .ba_loop
|
||
.ba_done:
|
||
movq %rcx, %rdi
|
||
call make_int
|
||
RET_VAL
|
||
|
||
bi_sub:
|
||
GETARG %rax
|
||
sarq $3, %rax
|
||
movq %rax, %rcx
|
||
cmpq $VAL_NIL, %r12
|
||
je .bs_neg
|
||
.bs_loop:
|
||
cmpq $VAL_NIL, %r12
|
||
je .bs_done
|
||
GETARG %rax
|
||
sarq $3, %rax
|
||
subq %rax, %rcx
|
||
jmp .bs_loop
|
||
.bs_neg:
|
||
negq %rcx
|
||
.bs_done:
|
||
movq %rcx, %rdi
|
||
call make_int
|
||
RET_VAL
|
||
|
||
bi_mul:
|
||
movq $1, %rcx
|
||
.bm_loop:
|
||
cmpq $VAL_NIL, %r12
|
||
je .bm_done
|
||
GETARG %rax
|
||
sarq $3, %rax
|
||
imulq %rax, %rcx
|
||
jmp .bm_loop
|
||
.bm_done:
|
||
movq %rcx, %rdi
|
||
call make_int
|
||
RET_VAL
|
||
|
||
# Comparison helpers
|
||
.macro CMP_BI jmp_if
|
||
GETARG %rcx
|
||
sarq $3, %rcx
|
||
GETARG %rax
|
||
sarq $3, %rax
|
||
cmpq %rax, %rcx
|
||
\jmp_if .cmp_true
|
||
movq $VAL_FALSE, %rax
|
||
RET_VAL
|
||
.endm
|
||
|
||
.cmp_true:
|
||
movq $VAL_TRUE, %rax
|
||
RET_VAL
|
||
.cmp_false:
|
||
movq $VAL_FALSE, %rax
|
||
RET_VAL
|
||
|
||
bi_eq:
|
||
CMP_BI je
|
||
bi_lt:
|
||
CMP_BI jl
|
||
bi_gt:
|
||
CMP_BI jg
|
||
bi_le:
|
||
CMP_BI jle
|
||
bi_ge:
|
||
CMP_BI jge
|
||
|
||
bi_cons:
|
||
GETARG %rdi
|
||
GETARG %rsi
|
||
call make_pair
|
||
RET_VAL
|
||
|
||
bi_car:
|
||
GETARG %rdi
|
||
andq $-8, %rdi
|
||
movq (%rdi), %rax
|
||
RET_VAL
|
||
|
||
bi_cdr:
|
||
GETARG %rdi
|
||
andq $-8, %rdi
|
||
movq 8(%rdi), %rax
|
||
RET_VAL
|
||
|
||
bi_nullp:
|
||
GETARG %rax
|
||
cmpq $VAL_NIL, %rax
|
||
je .cmp_true
|
||
movq $VAL_FALSE, %rax
|
||
RET_VAL
|
||
|
||
bi_pairp:
|
||
GETARG %rax
|
||
andq $TAG_MASK, %rax
|
||
cmpq $TAG_PAIR, %rax
|
||
je .cmp_true
|
||
movq $VAL_FALSE, %rax
|
||
RET_VAL
|
||
|
||
bi_not:
|
||
GETARG %rax
|
||
cmpq $VAL_FALSE, %rax
|
||
je .cmp_true
|
||
cmpq $VAL_NIL, %rax
|
||
je .cmp_true
|
||
movq $VAL_FALSE, %rax
|
||
RET_VAL
|
||
|
||
# resolve_output_fd: optional port arg from %r12. %rax = fd (1 if none).
|
||
# Destructively consumes the port arg if present.
|
||
resolve_output_fd:
|
||
cmpq $VAL_NIL, %r12
|
||
je .rof_stdout
|
||
movq %r12, %rax
|
||
andq $-8, %rax
|
||
movq (%rax), %rcx # port value
|
||
movq 8(%rax), %r12 # advance arg list
|
||
movq %rcx, %rax
|
||
andq $TAG_MASK, %rax
|
||
cmpq $TAG_SPECIAL, %rax
|
||
jne .rof_stdout
|
||
movq %rcx, %rax
|
||
shrq $3, %rax
|
||
cmpq $PORT_SPECIAL_BASE, %rax
|
||
jl .rof_stdout
|
||
subq $PORT_SPECIAL_BASE, %rax
|
||
ret
|
||
.rof_stdout:
|
||
movq $1, %rax
|
||
ret
|
||
|
||
bi_display:
|
||
GETARG %rbx # value to display
|
||
call resolve_output_fd # %rax = fd (stdout or port)
|
||
movq output_fd(%rip), %rcx
|
||
pushq %rcx
|
||
movq %rax, output_fd(%rip)
|
||
|
||
movq %rbx, %rax
|
||
andq $TAG_MASK, %rax
|
||
cmpq $TAG_STRING, %rax
|
||
je .bd_str
|
||
movq %rbx, %rdi
|
||
call scheme_print
|
||
jmp .bd_restore
|
||
.bd_str:
|
||
movq %rbx, %rdi
|
||
andq $-8, %rdi
|
||
movq (%rdi), %rdx
|
||
leaq 8(%rdi), %rsi
|
||
movq $SYS_WRITE, %rax
|
||
movq output_fd(%rip), %rdi
|
||
syscall
|
||
.bd_restore:
|
||
popq %rax
|
||
movq %rax, output_fd(%rip)
|
||
movq $VAL_VOID, %rax
|
||
RET_VAL
|
||
|
||
bi_newline:
|
||
call resolve_output_fd
|
||
movq output_fd(%rip), %rcx
|
||
pushq %rcx
|
||
movq %rax, output_fd(%rip)
|
||
movq $SYS_WRITE, %rax
|
||
movq output_fd(%rip), %rdi
|
||
leaq newline_ch(%rip), %rsi
|
||
movq $1, %rdx
|
||
syscall
|
||
popq %rax
|
||
movq %rax, output_fd(%rip)
|
||
movq $VAL_VOID, %rax
|
||
RET_VAL
|
||
|
||
bi_list:
|
||
movq %r12, %rax
|
||
RET_VAL
|
||
|
||
bi_length:
|
||
GETARG %rdi
|
||
xorq %rcx, %rcx
|
||
.bl_loop:
|
||
cmpq $VAL_NIL, %rdi
|
||
je .bl_done
|
||
movq %rdi, %rax
|
||
andq $-8, %rax
|
||
movq 8(%rax), %rdi
|
||
incq %rcx
|
||
jmp .bl_loop
|
||
.bl_done:
|
||
movq %rcx, %rdi
|
||
call make_int
|
||
RET_VAL
|
||
|
||
bi_zerop:
|
||
GETARG %rax
|
||
sarq $3, %rax
|
||
testq %rax, %rax
|
||
jz .cmp_true
|
||
movq $VAL_FALSE, %rax
|
||
RET_VAL
|
||
|
||
bi_modulo:
|
||
GETARG %rcx
|
||
sarq $3, %rcx
|
||
GETARG %rax
|
||
sarq $3, %rax
|
||
movq %rax, %r8 # divisor
|
||
movq %rcx, %rax # dividend
|
||
cqo
|
||
idivq %r8
|
||
movq %rdx, %rdi # remainder
|
||
# modulo: result has sign of divisor
|
||
testq %rdi, %rdi
|
||
jz .bmod_done
|
||
movq %rdi, %rax
|
||
xorq %r8, %rax
|
||
testq %rax, %rax
|
||
jns .bmod_done
|
||
addq %r8, %rdi
|
||
.bmod_done:
|
||
call make_int
|
||
RET_VAL
|
||
|
||
bi_remainder:
|
||
GETARG %rcx
|
||
sarq $3, %rcx
|
||
GETARG %rax
|
||
sarq $3, %rax
|
||
movq %rax, %r8
|
||
movq %rcx, %rax
|
||
cqo
|
||
idivq %r8
|
||
movq %rdx, %rdi
|
||
call make_int
|
||
RET_VAL
|
||
|
||
bi_numberp:
|
||
GETARG %rax
|
||
andq $TAG_MASK, %rax
|
||
cmpq $TAG_INT, %rax
|
||
je .cmp_true
|
||
movq $VAL_FALSE, %rax
|
||
RET_VAL
|
||
|
||
bi_eqvp:
|
||
GETARG %rcx
|
||
GETARG %rax
|
||
cmpq %rax, %rcx
|
||
je .cmp_true
|
||
movq $VAL_FALSE, %rax
|
||
RET_VAL
|
||
|
||
bi_equalp:
|
||
GETARG %rdi
|
||
GETARG %rsi
|
||
call deep_equal
|
||
RET_VAL
|
||
|
||
# deep_equal: %rdi = a, %rsi = b. Returns VAL_TRUE or VAL_FALSE in %rax
|
||
deep_equal:
|
||
cmpq %rdi, %rsi
|
||
je .deq_true
|
||
# Tags must match for structural compare
|
||
movq %rdi, %rax
|
||
andq $TAG_MASK, %rax
|
||
movq %rsi, %rcx
|
||
andq $TAG_MASK, %rcx
|
||
cmpq %rax, %rcx
|
||
jne .deq_false
|
||
cmpq $TAG_STRING, %rax
|
||
je .deq_string
|
||
cmpq $TAG_PAIR, %rax
|
||
jne .deq_false
|
||
# Both pairs — compare car then cdr
|
||
pushq %rdi
|
||
pushq %rsi
|
||
movq %rdi, %rax
|
||
andq $-8, %rax
|
||
movq (%rax), %rdi # car(a)
|
||
movq %rsi, %rax
|
||
andq $-8, %rax
|
||
movq (%rax), %rsi # car(b)
|
||
call deep_equal
|
||
cmpq $VAL_FALSE, %rax
|
||
popq %rsi
|
||
popq %rdi
|
||
je .deq_false
|
||
# car matched, now cdr
|
||
movq %rdi, %rax
|
||
andq $-8, %rax
|
||
movq 8(%rax), %rdi # cdr(a)
|
||
movq %rsi, %rax
|
||
andq $-8, %rax
|
||
movq 8(%rax), %rsi # cdr(b)
|
||
jmp deep_equal # tail call
|
||
.deq_true:
|
||
movq $VAL_TRUE, %rax
|
||
ret
|
||
.deq_false:
|
||
movq $VAL_FALSE, %rax
|
||
ret
|
||
|
||
.deq_string:
|
||
# Both strings. Compare lengths then bytes.
|
||
movq %rdi, %rax
|
||
andq $-8, %rax
|
||
movq %rsi, %rcx
|
||
andq $-8, %rcx
|
||
movq (%rax), %rdx # len a
|
||
cmpq (%rcx), %rdx # len a vs len b
|
||
jne .deq_false
|
||
leaq 8(%rax), %r8
|
||
leaq 8(%rcx), %r9
|
||
.deq_str_loop:
|
||
testq %rdx, %rdx
|
||
jz .deq_true
|
||
movb (%r8), %al
|
||
cmpb (%r9), %al
|
||
jne .deq_false
|
||
incq %r8
|
||
incq %r9
|
||
decq %rdx
|
||
jmp .deq_str_loop
|
||
|
||
bi_abs:
|
||
GETARG %rax
|
||
sarq $3, %rax
|
||
testq %rax, %rax
|
||
jns 1f
|
||
negq %rax
|
||
1: movq %rax, %rdi
|
||
call make_int
|
||
RET_VAL
|
||
|
||
bi_min:
|
||
GETARG %rax
|
||
sarq $3, %rax
|
||
movq %rax, %rcx
|
||
.bmin_loop:
|
||
cmpq $VAL_NIL, %r12
|
||
je .bmin_done
|
||
GETARG %rax
|
||
sarq $3, %rax
|
||
cmpq %rax, %rcx
|
||
jle .bmin_loop
|
||
movq %rax, %rcx
|
||
jmp .bmin_loop
|
||
.bmin_done:
|
||
movq %rcx, %rdi
|
||
call make_int
|
||
RET_VAL
|
||
|
||
bi_max:
|
||
GETARG %rax
|
||
sarq $3, %rax
|
||
movq %rax, %rcx
|
||
.bmax_loop:
|
||
cmpq $VAL_NIL, %r12
|
||
je .bmax_done
|
||
GETARG %rax
|
||
sarq $3, %rax
|
||
cmpq %rax, %rcx
|
||
jge .bmax_loop
|
||
movq %rax, %rcx
|
||
jmp .bmax_loop
|
||
.bmax_done:
|
||
movq %rcx, %rdi
|
||
call make_int
|
||
RET_VAL
|
||
|
||
bi_boolp:
|
||
GETARG %rax
|
||
cmpq $VAL_TRUE, %rax
|
||
je .cmp_true
|
||
cmpq $VAL_FALSE, %rax
|
||
je .cmp_true
|
||
movq $VAL_FALSE, %rax
|
||
RET_VAL
|
||
|
||
bi_symbolp:
|
||
GETARG %rax
|
||
andq $TAG_MASK, %rax
|
||
cmpq $TAG_SYM, %rax
|
||
je .cmp_true
|
||
movq $VAL_FALSE, %rax
|
||
RET_VAL
|
||
|
||
bi_stringp:
|
||
GETARG %rax
|
||
andq $TAG_MASK, %rax
|
||
cmpq $TAG_STRING, %rax
|
||
je .cmp_true
|
||
movq $VAL_FALSE, %rax
|
||
RET_VAL
|
||
|
||
bi_procp:
|
||
GETARG %rax
|
||
movq %rax, %rcx
|
||
andq $TAG_MASK, %rcx
|
||
cmpq $TAG_CLOSURE, %rcx
|
||
je .cmp_true
|
||
cmpq $TAG_BUILTIN, %rcx
|
||
je .cmp_true
|
||
movq $VAL_FALSE, %rax
|
||
RET_VAL
|
||
|
||
bi_quotient:
|
||
GETARG %rcx
|
||
sarq $3, %rcx
|
||
GETARG %rax
|
||
sarq $3, %rax
|
||
movq %rax, %r8
|
||
movq %rcx, %rax
|
||
cqo
|
||
idivq %r8
|
||
movq %rax, %rdi
|
||
call make_int
|
||
RET_VAL
|
||
|
||
bi_negativep:
|
||
GETARG %rax
|
||
sarq $3, %rax
|
||
testq %rax, %rax
|
||
js .cmp_true
|
||
movq $VAL_FALSE, %rax
|
||
RET_VAL
|
||
|
||
bi_positivep:
|
||
GETARG %rax
|
||
sarq $3, %rax
|
||
testq %rax, %rax
|
||
jg .cmp_true
|
||
movq $VAL_FALSE, %rax
|
||
RET_VAL
|
||
|
||
# apply_proc_raw: %rdi = proc, %rsi = evaled_args_list → %rax = result
|
||
# Calls a procedure (builtin or closure) with already-evaluated arguments
|
||
apply_proc_raw:
|
||
pushq %rbx
|
||
pushq %r12
|
||
pushq %rbp
|
||
movq %rdi, %rbx # proc
|
||
movq %rsi, %r12 # args
|
||
|
||
movq %rbx, %rax
|
||
andq $TAG_MASK, %rax
|
||
cmpq $TAG_BUILTIN, %rax
|
||
je .apr_builtin
|
||
cmpq $TAG_CLOSURE, %rax
|
||
je .apr_closure
|
||
# Not callable
|
||
movq $VAL_VOID, %rax
|
||
popq %rbp
|
||
popq %r12
|
||
popq %rbx
|
||
ret
|
||
|
||
.apr_builtin:
|
||
# Jump to builtin dispatch with %rbx = builtin, %r12 = args
|
||
movq %rbx, %rax
|
||
shrq $3, %rax
|
||
# Inline the dispatch — just call the apply_builtin section
|
||
# Actually, reuse the existing dispatch code by jumping
|
||
jmp .apr_bi_dispatch
|
||
|
||
.apr_closure:
|
||
# Closure: extract params, body, env. Bind args. Eval body.
|
||
movq %rbx, %rax
|
||
andq $-8, %rax
|
||
movq (%rax), %rcx # params
|
||
movq 8(%rax), %rdx # body
|
||
movq 16(%rax), %rbp # captured env
|
||
|
||
# Bind params to args
|
||
movq %r12, %rsi # args
|
||
.apr_bind:
|
||
cmpq $VAL_NIL, %rcx
|
||
je .apr_eval_body
|
||
cmpq $VAL_NIL, %rsi
|
||
je .apr_eval_body
|
||
|
||
# Extract param name and rest params
|
||
movq %rcx, %rax
|
||
andq $-8, %rax
|
||
movq (%rax), %rdi # param name (symbol)
|
||
movq 8(%rax), %rcx # rest params
|
||
|
||
# Extract arg value and rest args
|
||
movq %rsi, %rax
|
||
andq $-8, %rax
|
||
movq 8(%rax), %r8 # rest args (cdr)
|
||
movq (%rax), %rsi # arg value (car)
|
||
|
||
pushq %r8 # save rest args
|
||
pushq %rcx # save rest params
|
||
pushq %rdx # save body
|
||
movq %rbp, %rdx # env
|
||
call env_define
|
||
movq %rax, %rbp
|
||
popq %rdx # restore body
|
||
popq %rcx # restore rest params
|
||
popq %rsi # restore rest args
|
||
jmp .apr_bind
|
||
|
||
.apr_eval_body:
|
||
# Body is already wrap_begin'd: single expr or (begin ...) form.
|
||
# Eval it directly.
|
||
movq %rdx, %rdi # body expression
|
||
movq %rbp, %rsi # env
|
||
call eval
|
||
popq %rbp
|
||
popq %r12
|
||
popq %rbx
|
||
ret
|
||
|
||
.apr_bi_dispatch:
|
||
# Dispatch builtin by index — jump to main dispatch table
|
||
# RET_VAL pops %r12,%rbp,%rbx — matching our pushes in apply_proc_raw
|
||
movq %rbx, %rax
|
||
shrq $3, %rax
|
||
jmp .app_builtin_dispatch
|
||
|
||
# ── New builtins ─────────────────────────────────────────────
|
||
|
||
bi_div:
|
||
GETARG %rcx # first arg (dividend)
|
||
sarq $3, %rcx
|
||
GETARG %rdx # second arg (divisor)
|
||
sarq $3, %rdx
|
||
movq %rcx, %rax # dividend in rax
|
||
movq %rdx, %rcx # divisor in rcx
|
||
cqto # sign-extend rax → rdx:rax
|
||
idivq %rcx # rax = quotient
|
||
movq %rax, %rdi
|
||
call make_int
|
||
RET_VAL
|
||
|
||
bi_oddp:
|
||
GETARG %rax
|
||
sarq $3, %rax
|
||
testq $1, %rax
|
||
jnz .cmp_true
|
||
movq $VAL_FALSE, %rax
|
||
RET_VAL
|
||
|
||
bi_evenp:
|
||
GETARG %rax
|
||
sarq $3, %rax
|
||
testq $1, %rax
|
||
jz .cmp_true
|
||
movq $VAL_FALSE, %rax
|
||
RET_VAL
|
||
|
||
bi_append:
|
||
# (append lst1 lst2) — copy lst1, set last cdr to lst2
|
||
GETARG %rdi # lst1
|
||
GETARG %rsi # lst2 (stays in %r12 if more args, but we take 2)
|
||
cmpq $VAL_NIL, %rdi
|
||
je .bapp_done_rsi
|
||
# Copy lst1
|
||
pushq %rsi
|
||
pushq %rbx
|
||
movq $VAL_NIL, %rbx # result tail
|
||
movq $0, %rcx # first pair ptr
|
||
.bapp_copy:
|
||
cmpq $VAL_NIL, %rdi
|
||
je .bapp_link
|
||
movq %rdi, %rax
|
||
andq $-8, %rax
|
||
pushq %rdi
|
||
movq (%rax), %rdi # car
|
||
movq $VAL_NIL, %rsi
|
||
call make_pair
|
||
# if first, save as head
|
||
testq %rcx, %rcx
|
||
jnz .bapp_notfirst
|
||
movq %rax, %rcx # head
|
||
movq %rax, %rbx # tail
|
||
jmp .bapp_next
|
||
.bapp_notfirst:
|
||
# set tail's cdr
|
||
movq %rbx, %rdx
|
||
andq $-8, %rdx
|
||
movq %rax, 8(%rdx)
|
||
movq %rax, %rbx
|
||
.bapp_next:
|
||
popq %rdi
|
||
movq %rdi, %rax
|
||
andq $-8, %rax
|
||
movq 8(%rax), %rdi # cdr
|
||
jmp .bapp_copy
|
||
.bapp_link:
|
||
# set last cdr to lst2
|
||
# %rbx = last pair (tagged), %rcx = head (tagged)
|
||
# stack: [rbx_saved, rsi=lst2]
|
||
movq %rbx, %rax
|
||
andq $-8, %rax
|
||
popq %rbx # restore saved rbx
|
||
popq %rsi # lst2
|
||
movq %rsi, 8(%rax) # set last pair's cdr to lst2
|
||
movq %rcx, %rax # return head
|
||
RET_VAL
|
||
.bapp_done_rsi:
|
||
movq %rsi, %rax
|
||
RET_VAL
|
||
|
||
bi_reverse:
|
||
GETARG %rdi
|
||
call list_reverse
|
||
RET_VAL
|
||
|
||
bi_map:
|
||
# (map f lst) — apply f to each element, build result list
|
||
# NOTE: %r13 is the heap limit (global), must not be used as scratch.
|
||
# Stack slot for accumulator: [acc] at base of our frame.
|
||
GETARG %rbx # f (proc/closure/builtin)
|
||
GETARG %rdi # lst
|
||
subq $8, %rsp # allocate stack slot for acc
|
||
movq $VAL_NIL, (%rsp) # acc = NIL
|
||
.bmap_loop:
|
||
cmpq $VAL_NIL, %rdi
|
||
je .bmap_done
|
||
pushq %rdi # save input list
|
||
movq %rdi, %rax
|
||
andq $-8, %rax
|
||
movq (%rax), %rdi # car = element
|
||
# Build 1-element arg list: (element)
|
||
movq $VAL_NIL, %rsi
|
||
call make_pair
|
||
movq %rax, %rsi # arg list
|
||
pushq %rbx # save proc
|
||
movq %rbx, %rdi # proc
|
||
call apply_proc_raw
|
||
popq %rbx # restore proc
|
||
# cons result onto acc
|
||
# stack: [input_list] [acc]
|
||
movq %rax, %rdi # result value
|
||
movq 8(%rsp), %rsi # acc (past saved input_list)
|
||
call make_pair
|
||
movq %rax, 8(%rsp) # update acc
|
||
popq %rdi # restore input list
|
||
movq %rdi, %rax
|
||
andq $-8, %rax
|
||
movq 8(%rax), %rdi # cdr of input list
|
||
jmp .bmap_loop
|
||
.bmap_done:
|
||
popq %rdi # acc (from stack slot)
|
||
call list_reverse
|
||
RET_VAL
|
||
|
||
bi_filter:
|
||
# (filter pred lst)
|
||
# NOTE: %r13 is the heap limit (global), must not be used as scratch.
|
||
GETARG %rbx # pred
|
||
GETARG %rdi # lst
|
||
subq $8, %rsp # stack slot for acc
|
||
movq $VAL_NIL, (%rsp) # acc = NIL
|
||
.bfilt_loop:
|
||
cmpq $VAL_NIL, %rdi
|
||
je .bfilt_done
|
||
pushq %rdi # save input list
|
||
movq %rdi, %rax
|
||
andq $-8, %rax
|
||
movq (%rax), %rcx # car = element
|
||
pushq %rcx # save element
|
||
# Call pred on element
|
||
movq %rcx, %rdi
|
||
movq $VAL_NIL, %rsi
|
||
call make_pair
|
||
movq %rax, %rsi # arg list
|
||
pushq %rbx # save pred
|
||
movq %rbx, %rdi # pred
|
||
call apply_proc_raw
|
||
popq %rbx # restore pred
|
||
popq %rcx # restore element
|
||
# Check if result is truthy (not #f)
|
||
cmpq $VAL_FALSE, %rax
|
||
je .bfilt_skip
|
||
# cons element onto acc
|
||
# stack: [input_list] [acc]
|
||
movq %rcx, %rdi
|
||
movq 8(%rsp), %rsi # acc (past saved input_list)
|
||
call make_pair
|
||
movq %rax, 8(%rsp) # update acc
|
||
.bfilt_skip:
|
||
popq %rdi # restore input list
|
||
movq %rdi, %rax
|
||
andq $-8, %rax
|
||
movq 8(%rax), %rdi # cdr
|
||
jmp .bfilt_loop
|
||
.bfilt_done:
|
||
popq %rdi # acc
|
||
call list_reverse
|
||
RET_VAL
|
||
|
||
bi_foldl:
|
||
# (fold-left f init lst)
|
||
# NOTE: %r13 is the heap limit (global), must not be used as scratch.
|
||
GETARG %rbx # f
|
||
GETARG %rcx # init (accumulator)
|
||
GETARG %rdi # lst
|
||
subq $8, %rsp # stack slot for acc
|
||
movq %rcx, (%rsp) # acc = init
|
||
.bfl_loop:
|
||
cmpq $VAL_NIL, %rdi
|
||
je .bfl_done
|
||
pushq %rdi # save input list
|
||
movq %rdi, %rax
|
||
andq $-8, %rax
|
||
movq (%rax), %rdi # car = element
|
||
# Build arg list: (list acc element) for fold-left convention
|
||
pushq %rdi # save element
|
||
movq $VAL_NIL, %rsi
|
||
call make_pair # (element)
|
||
movq %rax, %rsi
|
||
movq 16(%rsp), %rdi # acc (past element, input_list)
|
||
call make_pair # (acc element)
|
||
movq %rax, %rsi # arg list
|
||
pushq %rbx # save proc
|
||
movq %rbx, %rdi # proc
|
||
call apply_proc_raw
|
||
popq %rbx # restore proc
|
||
addq $8, %rsp # discard saved element
|
||
movq %rax, 8(%rsp) # update acc (past saved input_list)
|
||
popq %rdi # restore input list
|
||
movq %rdi, %rax
|
||
andq $-8, %rax
|
||
movq 8(%rax), %rdi # cdr
|
||
jmp .bfl_loop
|
||
.bfl_done:
|
||
popq %rax # acc = result
|
||
RET_VAL
|
||
|
||
bi_foreach:
|
||
# (for-each f lst) — like map but discard results
|
||
GETARG %rbx
|
||
GETARG %rdi
|
||
.bfe_loop:
|
||
cmpq $VAL_NIL, %rdi
|
||
je .bfe_done
|
||
pushq %rdi
|
||
movq %rdi, %rax
|
||
andq $-8, %rax
|
||
movq (%rax), %rdi
|
||
movq $VAL_NIL, %rsi
|
||
call make_pair
|
||
movq %rax, %r12
|
||
pushq %rbx
|
||
movq %rbx, %rdi
|
||
movq %r12, %rsi
|
||
call apply_proc_raw
|
||
popq %rbx
|
||
popq %rdi
|
||
movq %rdi, %rax
|
||
andq $-8, %rax
|
||
movq 8(%rax), %rdi
|
||
jmp .bfe_loop
|
||
.bfe_done:
|
||
movq $VAL_VOID, %rax
|
||
RET_VAL
|
||
|
||
bi_apply:
|
||
# (apply f args-list)
|
||
GETARG %rbx # f
|
||
GETARG %rdi # args-list (already a proper list)
|
||
movq %rbx, %rdi
|
||
# Need to set up %rbx=proc, %r12=args then jump to apply path
|
||
# Actually just call apply_proc_raw
|
||
pushq %rbx
|
||
movq %rbx, %rdi
|
||
movq %r12, %rsi # remaining args = the list
|
||
call apply_proc_raw
|
||
popq %rbx
|
||
RET_VAL
|
||
|
||
bi_member:
|
||
# (member obj lst)
|
||
GETARG %rcx # obj
|
||
GETARG %rdi # lst
|
||
.bmem_loop:
|
||
cmpq $VAL_NIL, %rdi
|
||
je .bmem_false
|
||
movq %rdi, %rax
|
||
andq $-8, %rax
|
||
pushq %rdi
|
||
pushq %rcx
|
||
movq (%rax), %rdi # car
|
||
movq %rcx, %rsi
|
||
call deep_equal
|
||
popq %rcx
|
||
popq %rdi
|
||
cmpq $VAL_TRUE, %rax
|
||
je .bmem_found
|
||
movq %rdi, %rax
|
||
andq $-8, %rax
|
||
movq 8(%rax), %rdi
|
||
jmp .bmem_loop
|
||
.bmem_found:
|
||
movq %rdi, %rax # return the tail
|
||
RET_VAL
|
||
.bmem_false:
|
||
movq $VAL_FALSE, %rax
|
||
RET_VAL
|
||
|
||
bi_assoc:
|
||
# (assoc key alist)
|
||
GETARG %rcx # key
|
||
GETARG %rdi # alist
|
||
.bassoc_loop:
|
||
cmpq $VAL_NIL, %rdi
|
||
je .bassoc_false
|
||
movq %rdi, %rax
|
||
andq $-8, %rax
|
||
movq (%rax), %rdx # car = pair
|
||
movq 8(%rax), %rdi # cdr = rest
|
||
# car of the pair
|
||
movq %rdx, %rax
|
||
andq $-8, %rax
|
||
pushq %rdi
|
||
pushq %rcx
|
||
pushq %rdx
|
||
movq (%rax), %rdi # caar
|
||
movq %rcx, %rsi
|
||
call deep_equal
|
||
popq %rdx
|
||
popq %rcx
|
||
popq %rdi
|
||
cmpq $VAL_TRUE, %rax
|
||
je .bassoc_found
|
||
jmp .bassoc_loop
|
||
.bassoc_found:
|
||
movq %rdx, %rax
|
||
RET_VAL
|
||
.bassoc_false:
|
||
movq $VAL_FALSE, %rax
|
||
RET_VAL
|
||
|
||
bi_write:
|
||
GETARG %rbx # value to write (quoted strings, etc.)
|
||
call resolve_output_fd
|
||
movq output_fd(%rip), %rcx
|
||
pushq %rcx
|
||
movq %rax, output_fd(%rip)
|
||
movq %rbx, %rdi
|
||
call scheme_print
|
||
popq %rax
|
||
movq %rax, output_fd(%rip)
|
||
movq $VAL_VOID, %rax
|
||
RET_VAL
|
||
|
||
bi_strlength:
|
||
GETARG %rax
|
||
andq $-8, %rax
|
||
movq (%rax), %rax # length (first 8 bytes of string obj)
|
||
movq %rax, %rdi
|
||
call make_int
|
||
RET_VAL
|
||
|
||
bi_strref:
|
||
GETARG %rax # string
|
||
andq $-8, %rax
|
||
movq %rax, %rcx # string ptr
|
||
GETARG %rax # index
|
||
sarq $3, %rax
|
||
movzbl 8(%rcx,%rax,1), %r8d # byte at offset (keep across heap_alloc call)
|
||
# Allocate a 1-char string via heap_alloc so the GC build sees
|
||
# a proper header / type byte instead of a headerless direct bump.
|
||
movq $9, %rdi # 8B length + 1B char
|
||
pushq %r8
|
||
call heap_alloc
|
||
popq %r8
|
||
.ifdef GC_NAIVE
|
||
orq $(HT_STRING << 8), -8(%rax)
|
||
.endif
|
||
movq $1, (%rax) # length
|
||
movb %r8b, 8(%rax)
|
||
orq $TAG_STRING, %rax
|
||
RET_VAL
|
||
|
||
bi_strappend:
|
||
# (string-append s1 s2 ...) — variadic
|
||
# Save arg list head for the second pass
|
||
pushq %r12 # original arg list head
|
||
|
||
# Pass 1: total length
|
||
xorq %rcx, %rcx # accumulator
|
||
movq %r12, %rax
|
||
.bsa_len_loop:
|
||
cmpq $VAL_NIL, %rax
|
||
je .bsa_alloc
|
||
movq %rax, %rbx
|
||
andq $-8, %rbx
|
||
movq (%rbx), %rdi # string value
|
||
andq $-8, %rdi
|
||
addq (%rdi), %rcx # += length
|
||
movq 8(%rbx), %rax # advance
|
||
jmp .bsa_len_loop
|
||
|
||
.bsa_alloc:
|
||
# Allocate string cell: 8 byte length + rcx bytes
|
||
movq %rcx, %rbx # save total length
|
||
movq %rcx, %rdi
|
||
addq $8, %rdi
|
||
call heap_alloc
|
||
.ifdef GC_NAIVE
|
||
orq $(HT_STRING << 8), -8(%rax)
|
||
.endif
|
||
movq %rax, %rbp # string object base
|
||
movq %rbx, (%rbp) # store length
|
||
leaq 8(%rbp), %r9 # dest cursor
|
||
|
||
# Pass 2: copy each arg's bytes
|
||
popq %r12 # restore arg list
|
||
pushq %rbp # save string obj
|
||
movq %r12, %rax
|
||
.bsa_copy_loop:
|
||
cmpq $VAL_NIL, %rax
|
||
je .bsa_done
|
||
movq %rax, %rbx
|
||
andq $-8, %rbx
|
||
movq (%rbx), %rdi # string value
|
||
movq 8(%rbx), %rax # save advance
|
||
andq $-8, %rdi
|
||
movq (%rdi), %rcx # length
|
||
leaq 8(%rdi), %r10 # src bytes
|
||
.bsa_byte_loop:
|
||
testq %rcx, %rcx
|
||
jz .bsa_copy_loop
|
||
movb (%r10), %r8b
|
||
movb %r8b, (%r9)
|
||
incq %r10
|
||
incq %r9
|
||
decq %rcx
|
||
jmp .bsa_byte_loop
|
||
|
||
.bsa_done:
|
||
popq %rbp
|
||
movq %rbp, %rax
|
||
orq $TAG_STRING, %rax
|
||
RET_VAL
|
||
|
||
bi_streqp:
|
||
GETARG %rdi
|
||
GETARG %rsi
|
||
andq $-8, %rdi
|
||
andq $-8, %rsi
|
||
movq (%rdi), %rcx # len1
|
||
cmpq (%rsi), %rcx # len2
|
||
jne .cmp_false
|
||
leaq 8(%rdi), %rdi
|
||
leaq 8(%rsi), %rsi
|
||
.bseq_loop:
|
||
testq %rcx, %rcx
|
||
jz .cmp_true
|
||
movb (%rdi), %al
|
||
cmpb (%rsi), %al
|
||
jne .cmp_false
|
||
incq %rdi
|
||
incq %rsi
|
||
decq %rcx
|
||
jmp .bseq_loop
|
||
|
||
bi_numtostr:
|
||
# (number->string n) → string
|
||
# Write digits (reverse) into num_buf[end..], then copy into a heap cell.
|
||
GETARG %rax
|
||
sarq $3, %rax # untag int
|
||
leaq num_buf(%rip), %rdi
|
||
addq $63, %rdi # write backward from end
|
||
movb $0, (%rdi) # sentinel (not used for length)
|
||
movq %rdi, %rsi # save end pos
|
||
# Detect negative
|
||
xorq %r8, %r8 # negative flag
|
||
testq %rax, %rax
|
||
jns .bn2s_absloop
|
||
movq $1, %r8
|
||
negq %rax
|
||
.bn2s_absloop:
|
||
xorq %rdx, %rdx
|
||
movq $10, %rcx
|
||
divq %rcx # rax = q, rdx = r
|
||
addb $'0', %dl
|
||
decq %rdi
|
||
movb %dl, (%rdi)
|
||
testq %rax, %rax
|
||
jnz .bn2s_absloop
|
||
testq %r8, %r8
|
||
jz .bn2s_copy
|
||
decq %rdi
|
||
movb $'-', (%rdi)
|
||
.bn2s_copy:
|
||
# rdi = start of digit bytes, rsi = end (exclusive)
|
||
movq %rsi, %rcx
|
||
subq %rdi, %rcx # length
|
||
# Allocate string cell: 8 byte length + rcx bytes
|
||
pushq %rdi
|
||
pushq %rcx
|
||
movq %rcx, %rdi
|
||
addq $8, %rdi
|
||
call heap_alloc
|
||
.ifdef GC_NAIVE
|
||
orq $(HT_STRING << 8), -8(%rax)
|
||
.endif
|
||
popq %rcx
|
||
popq %rdi
|
||
movq %rcx, (%rax) # length
|
||
movq %rax, %rbx # save obj
|
||
leaq 8(%rax), %rdx
|
||
.bn2s_copyloop:
|
||
testq %rcx, %rcx
|
||
jz .bn2s_done
|
||
movb (%rdi), %r8b
|
||
movb %r8b, (%rdx)
|
||
incq %rdi
|
||
incq %rdx
|
||
decq %rcx
|
||
jmp .bn2s_copyloop
|
||
.bn2s_done:
|
||
movq %rbx, %rax
|
||
orq $TAG_STRING, %rax
|
||
RET_VAL
|
||
|
||
bi_strtonum:
|
||
GETARG %rax
|
||
andq $-8, %rax
|
||
movq (%rax), %rcx # length
|
||
leaq 8(%rax), %rdi # chars
|
||
# Parse integer
|
||
xorq %rax, %rax
|
||
xorq %rdx, %rdx # sign flag
|
||
cmpb $'-', (%rdi)
|
||
jne .bs2n_loop
|
||
movq $1, %rdx
|
||
incq %rdi
|
||
decq %rcx
|
||
.bs2n_loop:
|
||
testq %rcx, %rcx
|
||
jz .bs2n_done
|
||
movzbl (%rdi), %esi
|
||
subb $'0', %sil
|
||
cmpb $9, %sil
|
||
ja .bs2n_fail
|
||
imulq $10, %rax
|
||
addq %rsi, %rax
|
||
incq %rdi
|
||
decq %rcx
|
||
jmp .bs2n_loop
|
||
.bs2n_done:
|
||
testq %rdx, %rdx
|
||
jz .bs2n_pos
|
||
negq %rax
|
||
.bs2n_pos:
|
||
movq %rax, %rdi
|
||
call make_int
|
||
RET_VAL
|
||
.bs2n_fail:
|
||
movq $VAL_FALSE, %rax
|
||
RET_VAL
|
||
|
||
bi_chartoint:
|
||
GETARG %rax
|
||
# char is stored as a 1-char string
|
||
andq $-8, %rax
|
||
movzbl 8(%rax), %edi
|
||
call make_int
|
||
RET_VAL
|
||
|
||
bi_inttochar:
|
||
GETARG %rax
|
||
sarq $3, %rax
|
||
# Create 1-char string
|
||
movq %r15, %rcx
|
||
movq $1, (%r15)
|
||
movb %al, 8(%r15)
|
||
addq $16, %r15
|
||
movq %rcx, %rax
|
||
orq $TAG_STRING, %rax
|
||
RET_VAL
|
||
|
||
bi_charalphap:
|
||
GETARG %rax
|
||
andq $-8, %rax
|
||
movzbl 8(%rax), %eax
|
||
# Check a-z, A-Z
|
||
cmpb $'a', %al
|
||
jl .bca_upper
|
||
cmpb $'z', %al
|
||
jle .cmp_true
|
||
.bca_upper:
|
||
cmpb $'A', %al
|
||
jl .cmp_false
|
||
cmpb $'Z', %al
|
||
jle .cmp_true
|
||
jmp .cmp_false
|
||
|
||
bi_charnump:
|
||
GETARG %rax
|
||
andq $-8, %rax
|
||
movzbl 8(%rax), %eax
|
||
cmpb $'0', %al
|
||
jl .cmp_false
|
||
cmpb $'9', %al
|
||
jle .cmp_true
|
||
jmp .cmp_false
|
||
|
||
bi_charp:
|
||
# char? — true if it's a 1-char string
|
||
GETARG %rax
|
||
movq %rax, %rcx
|
||
andq $TAG_MASK, %rcx
|
||
cmpq $TAG_STRING, %rcx
|
||
jne .cmp_false
|
||
andq $-8, %rax
|
||
cmpq $1, (%rax)
|
||
je .cmp_true
|
||
jmp .cmp_false
|
||
|
||
bi_listp:
|
||
GETARG %rdi
|
||
.blistp_loop:
|
||
cmpq $VAL_NIL, %rdi
|
||
je .cmp_true
|
||
movq %rdi, %rax
|
||
andq $TAG_MASK, %rax
|
||
cmpq $TAG_PAIR, %rax
|
||
jne .cmp_false
|
||
andq $-8, %rdi
|
||
movq 8(%rdi), %rdi
|
||
jmp .blistp_loop
|
||
|
||
bi_integerp:
|
||
GETARG %rax
|
||
andq $TAG_MASK, %rax
|
||
cmpq $TAG_INT, %rax
|
||
je .cmp_true
|
||
jmp .cmp_false
|
||
|
||
bi_expt:
|
||
GETARG %rax
|
||
sarq $3, %rax
|
||
pushq %rax # save untagged base
|
||
GETARG %rcx
|
||
sarq $3, %rcx
|
||
popq %rax # restore untagged base
|
||
# base^exp by repeated multiplication
|
||
movq $1, %rdx
|
||
.bexpt_loop:
|
||
testq %rcx, %rcx
|
||
jz .bexpt_done
|
||
imulq %rax, %rdx
|
||
decq %rcx
|
||
jmp .bexpt_loop
|
||
.bexpt_done:
|
||
movq %rdx, %rdi
|
||
call make_int
|
||
RET_VAL
|
||
|
||
bi_gcd:
|
||
GETARG %rax
|
||
sarq $3, %rax
|
||
GETARG %rcx
|
||
sarq $3, %rcx
|
||
# Euclidean GCD
|
||
testq %rax, %rax
|
||
jns 1f
|
||
negq %rax
|
||
1: testq %rcx, %rcx
|
||
jns 2f
|
||
negq %rcx
|
||
2:
|
||
.bgcd_loop:
|
||
testq %rcx, %rcx
|
||
jz .bgcd_done
|
||
xorq %rdx, %rdx
|
||
divq %rcx
|
||
movq %rcx, %rax
|
||
movq %rdx, %rcx
|
||
jmp .bgcd_loop
|
||
.bgcd_done:
|
||
movq %rax, %rdi
|
||
call make_int
|
||
RET_VAL
|
||
|
||
bi_vector:
|
||
# (vector e1 e2 ...) — build from remaining args in %r12
|
||
# Count args
|
||
movq %r12, %rdi
|
||
xorq %rcx, %rcx
|
||
movq %rdi, %rax
|
||
.bvec_count:
|
||
cmpq $VAL_NIL, %rax
|
||
je .bvec_alloc
|
||
incq %rcx
|
||
movq %rax, %rdx
|
||
andq $-8, %rdx
|
||
movq 8(%rdx), %rax
|
||
jmp .bvec_count
|
||
.bvec_alloc:
|
||
# Allocate via heap_alloc so GC build gets a header + type byte.
|
||
pushq %rdi # save arg list ptr
|
||
pushq %rcx # save count
|
||
leaq 8(,%rcx,8), %rdi # 8 (length) + count * 8
|
||
call heap_alloc
|
||
.ifdef GC_NAIVE
|
||
orq $(HT_VECTOR << 8), -8(%rax)
|
||
.endif
|
||
popq %rcx
|
||
popq %rdi # restore arg list
|
||
movq %rcx, (%rax) # length
|
||
# Fill elements from arg list
|
||
movq %rdi, %rdx # arg list
|
||
leaq 8(%rax), %rdi # elements start
|
||
.bvec_fill:
|
||
cmpq $VAL_NIL, %rdx
|
||
je .bvec_done2
|
||
movq %rdx, %rcx
|
||
andq $-8, %rcx
|
||
movq (%rcx), %rsi # car = element
|
||
movq %rsi, (%rdi)
|
||
addq $8, %rdi
|
||
movq 8(%rcx), %rdx # cdr
|
||
jmp .bvec_fill
|
||
.bvec_done2:
|
||
# Tag vector — use tag 7 (available)
|
||
orq $7, %rax
|
||
# Override r12 to empty (we consumed all args)
|
||
movq $VAL_NIL, %r12
|
||
RET_VAL
|
||
|
||
bi_makevec:
|
||
# (make-vector n fill) — allocate n-slot vector filled with `fill`.
|
||
GETARG %rax
|
||
sarq $3, %rax # n (untagged)
|
||
movq %rax, %rdx # save n in %rdx — survives next GETARG
|
||
GETARG %rcx # fill value (tagged)
|
||
# Route through heap_alloc so GC build gets header + type.
|
||
pushq %rdx # n
|
||
pushq %rcx # fill value
|
||
leaq 8(,%rdx,8), %rdi # bytes: 8 (length) + n*8
|
||
call heap_alloc
|
||
.ifdef GC_NAIVE
|
||
orq $(HT_VECTOR << 8), -8(%rax)
|
||
.endif
|
||
popq %rcx # fill
|
||
popq %rdx # n
|
||
movq %rdx, (%rax) # store length
|
||
leaq 8(%rax), %rdi # elements start
|
||
movq %rdx, %rsi # count = n
|
||
.bmv_fill:
|
||
testq %rsi, %rsi
|
||
jz .bmv_done
|
||
movq %rcx, (%rdi)
|
||
addq $8, %rdi
|
||
decq %rsi
|
||
jmp .bmv_fill
|
||
.bmv_done:
|
||
orq $7, %rax # tag as vector
|
||
RET_VAL
|
||
|
||
bi_vecref:
|
||
GETARG %rdi # vector (tagged)
|
||
andq $-8, %rdi # untag — use %rdi (not clobbered by GETARG)
|
||
GETARG %rcx # index (tagged int)
|
||
sarq $3, %rcx # untag index
|
||
movq 8(%rdi,%rcx,8), %rax # element
|
||
RET_VAL
|
||
|
||
bi_vecset:
|
||
GETARG %rdi # vector (tagged)
|
||
andq $-8, %rdi # untag — use %rdi (not clobbered by GETARG)
|
||
GETARG %rcx # index (tagged int)
|
||
sarq $3, %rcx # untag index
|
||
GETARG %rdx # value
|
||
movq %rdx, 8(%rdi,%rcx,8)
|
||
movq $VAL_VOID, %rax
|
||
RET_VAL
|
||
|
||
bi_veclen:
|
||
GETARG %rax
|
||
andq $-8, %rax
|
||
movq (%rax), %rdi # length
|
||
call make_int
|
||
RET_VAL
|
||
|
||
bi_vecp:
|
||
GETARG %rax
|
||
movq %rax, %rcx
|
||
andq $TAG_MASK, %rcx
|
||
cmpq $7, %rcx # vector tag
|
||
jne .cmp_false
|
||
# Distinguish hash-table (first word -1) / hash-set (-2) from real vector (>= 0)
|
||
andq $-8, %rax
|
||
movq (%rax), %rax
|
||
testq %rax, %rax
|
||
js .cmp_false # negative first word => hash-* container
|
||
jmp .cmp_true
|
||
|
||
bi_vectolist:
|
||
GETARG %rax
|
||
andq $-8, %rax
|
||
movq (%rax), %rcx # length
|
||
leaq 8(%rax,%rcx,8), %rdi # end pointer
|
||
movq $VAL_NIL, %rsi # acc
|
||
.bv2l_loop:
|
||
testq %rcx, %rcx
|
||
jz .bv2l_done
|
||
subq $8, %rdi
|
||
pushq %rcx
|
||
pushq %rdi
|
||
movq (%rdi), %rdi # element
|
||
call make_pair
|
||
movq %rax, %rsi
|
||
popq %rdi
|
||
popq %rcx
|
||
decq %rcx
|
||
jmp .bv2l_loop
|
||
.bv2l_done:
|
||
movq %rsi, %rax
|
||
RET_VAL
|
||
|
||
bi_listtovec:
|
||
# Count list, then allocate and fill
|
||
GETARG %rdi
|
||
movq %rdi, %rsi # save list
|
||
xorq %rcx, %rcx
|
||
movq %rdi, %rax
|
||
.bl2v_count:
|
||
cmpq $VAL_NIL, %rax
|
||
je .bl2v_alloc
|
||
incq %rcx
|
||
movq %rax, %rdx
|
||
andq $-8, %rdx
|
||
movq 8(%rdx), %rax
|
||
jmp .bl2v_count
|
||
.bl2v_alloc:
|
||
pushq %rsi # save list ptr
|
||
pushq %rcx # save count
|
||
leaq 8(,%rcx,8), %rdi # 8 + count*8
|
||
call heap_alloc
|
||
.ifdef GC_NAIVE
|
||
orq $(HT_VECTOR << 8), -8(%rax)
|
||
.endif
|
||
popq %rcx
|
||
popq %rsi
|
||
movq %rcx, (%rax) # length
|
||
leaq 8(%rax), %rdi # element cursor
|
||
movq %rsi, %rdx # list cursor
|
||
.bl2v_fill:
|
||
cmpq $VAL_NIL, %rdx
|
||
je .bl2v_done
|
||
movq %rdx, %rcx
|
||
andq $-8, %rcx
|
||
movq (%rcx), %rsi
|
||
movq %rsi, (%rdi)
|
||
addq $8, %rdi
|
||
movq 8(%rcx), %rdx
|
||
jmp .bl2v_fill
|
||
.bl2v_done:
|
||
orq $7, %rax
|
||
RET_VAL
|
||
|
||
bi_substr:
|
||
# (substring s start end)
|
||
GETARG %rax # string
|
||
andq $-8, %rax
|
||
movq %rax, %rdi # string ptr
|
||
GETARG %rax # start
|
||
sarq $3, %rax
|
||
movq %rax, %rcx # start
|
||
GETARG %rax # end
|
||
sarq $3, %rax
|
||
subq %rcx, %rax # length = end - start
|
||
# Allocate via heap_alloc: 8 (length word) + length bytes.
|
||
pushq %rdi # src base
|
||
pushq %rcx # start offset
|
||
pushq %rax # length
|
||
movq %rax, %rdi
|
||
addq $8, %rdi # total payload
|
||
call heap_alloc
|
||
.ifdef GC_NAIVE
|
||
orq $(HT_STRING << 8), -8(%rax)
|
||
.endif
|
||
popq %rdx # length (restore)
|
||
popq %rcx # start
|
||
popq %rdi # src base
|
||
movq %rdx, (%rax) # write length
|
||
leaq 8(%rax), %rsi # dest cursor
|
||
leaq 8(%rdi,%rcx,1), %rdi # src cursor
|
||
movq %rdx, %rcx # bytes to copy
|
||
movq %rax, %rdx # save result base
|
||
.bsub_copy:
|
||
testq %rcx, %rcx
|
||
jz .bsub_done
|
||
movb (%rdi), %al
|
||
movb %al, (%rsi)
|
||
incq %rdi
|
||
incq %rsi
|
||
decq %rcx
|
||
jmp .bsub_copy
|
||
.bsub_done:
|
||
movq %rdx, %rax
|
||
orq $TAG_STRING, %rax
|
||
RET_VAL
|
||
|
||
# ============================================================
|
||
# Portal: save/resume machine state to/from file
|
||
# Binary format: magic(8) + heap_size(8) + heap_base(8) +
|
||
# r14(8) + r15(8) + reserved(8) + heap_bytes
|
||
# Carry on USB to air-gapped machine. Resume from exact state.
|
||
# ============================================================
|
||
|
||
bi_portal_save:
|
||
# (portal-save "filename") — dump heap + state to file
|
||
GETARG %rdi # filename (string value)
|
||
andq $-8, %rdi # untag
|
||
movq (%rdi), %rcx # string length
|
||
leaq 8(%rdi), %rdi # string bytes
|
||
|
||
# Need null-terminated filename for sys_open
|
||
# Copy to stack
|
||
subq $256, %rsp
|
||
movq %rsp, %rsi # dest
|
||
pushq %rcx
|
||
.ps_copy_name:
|
||
testq %rcx, %rcx
|
||
jz .ps_name_done
|
||
movb (%rdi), %al
|
||
movb %al, (%rsi)
|
||
incq %rdi
|
||
incq %rsi
|
||
decq %rcx
|
||
jmp .ps_copy_name
|
||
.ps_name_done:
|
||
movb $0, (%rsi) # null terminate
|
||
popq %rcx
|
||
|
||
# Open file for writing
|
||
movq $SYS_OPEN, %rax
|
||
movq %rsp, %rdi # filename on stack
|
||
movq $(O_WRONLY | O_CREAT | O_TRUNC), %rsi
|
||
movq $0644, %rdx # mode
|
||
syscall
|
||
addq $256, %rsp # restore stack
|
||
testq %rax, %rax
|
||
js .ps_fail
|
||
movq %rax, %rbx # fd
|
||
|
||
# Write header to stack, then write it
|
||
subq $PORTAL_HDR_SIZE, %rsp
|
||
|
||
# Magic
|
||
leaq portal_magic(%rip), %rsi
|
||
movq (%rsi), %rax
|
||
movq %rax, (%rsp)
|
||
|
||
# Heap size = r15 - heap_base
|
||
movq heap_base(%rip), %rax
|
||
movq %r15, %rcx
|
||
subq %rax, %rcx # heap used bytes
|
||
movq %rcx, 8(%rsp) # heap_size
|
||
|
||
# Heap base
|
||
movq %rax, 16(%rsp) # heap_base
|
||
|
||
# r14 (global env)
|
||
movq %r14, 24(%rsp)
|
||
|
||
# r15 (bump pointer)
|
||
movq %r15, 32(%rsp)
|
||
|
||
# Reserved
|
||
movq $0, 40(%rsp)
|
||
|
||
# Write header
|
||
movq $SYS_WRITE, %rax
|
||
movq %rbx, %rdi # fd
|
||
movq %rsp, %rsi # header
|
||
movq $PORTAL_HDR_SIZE, %rdx
|
||
syscall
|
||
|
||
addq $PORTAL_HDR_SIZE, %rsp
|
||
|
||
# Write heap
|
||
movq $SYS_WRITE, %rax
|
||
movq %rbx, %rdi # fd
|
||
movq heap_base(%rip), %rsi # heap start
|
||
movq %r15, %rdx
|
||
subq %rsi, %rdx # heap used bytes
|
||
syscall
|
||
|
||
# Close
|
||
movq $SYS_CLOSE, %rax
|
||
movq %rbx, %rdi
|
||
syscall
|
||
|
||
movq $VAL_VOID, %rax
|
||
RET_VAL
|
||
|
||
.ps_fail:
|
||
movq $VAL_FALSE, %rax
|
||
RET_VAL
|
||
|
||
bi_portal_resume:
|
||
# (portal-resume "filename") — restore heap + state from file
|
||
GETARG %rdi # filename string
|
||
andq $-8, %rdi
|
||
movq (%rdi), %rcx
|
||
leaq 8(%rdi), %rdi
|
||
|
||
# Copy filename to stack (null-terminated)
|
||
subq $256, %rsp
|
||
movq %rsp, %rsi
|
||
pushq %rcx
|
||
.pr_copy_name:
|
||
testq %rcx, %rcx
|
||
jz .pr_name_done
|
||
movb (%rdi), %al
|
||
movb %al, (%rsi)
|
||
incq %rdi
|
||
incq %rsi
|
||
decq %rcx
|
||
jmp .pr_copy_name
|
||
.pr_name_done:
|
||
movb $0, (%rsi)
|
||
popq %rcx
|
||
|
||
# Open file for reading
|
||
movq $SYS_OPEN, %rax
|
||
movq %rsp, %rdi
|
||
movq $O_RDONLY, %rsi
|
||
xorq %rdx, %rdx
|
||
syscall
|
||
addq $256, %rsp
|
||
testq %rax, %rax
|
||
js .pr_fail
|
||
movq %rax, %rbx # fd
|
||
|
||
# Read header — must get full PORTAL_HDR_SIZE bytes
|
||
subq $PORTAL_HDR_SIZE, %rsp
|
||
movq $SYS_READ, %rax
|
||
movq %rbx, %rdi
|
||
movq %rsp, %rsi
|
||
movq $PORTAL_HDR_SIZE, %rdx
|
||
syscall
|
||
cmpq $PORTAL_HDR_SIZE, %rax
|
||
jne .pr_bad_magic # short read → file is not a portal
|
||
|
||
# Verify magic
|
||
leaq portal_magic(%rip), %rdi
|
||
movq (%rsp), %rax
|
||
cmpq (%rdi), %rax
|
||
jne .pr_bad_magic
|
||
|
||
# Sanity check header fields before committing
|
||
movq 8(%rsp), %rcx # heap_size
|
||
testq %rcx, %rcx
|
||
jle .pr_bad_magic # zero or negative heap size → corrupt
|
||
movq 16(%rsp), %rdx # heap_base (must match our mmap)
|
||
testq %rdx, %rdx
|
||
jz .pr_bad_magic # null heap base → corrupt
|
||
|
||
# Header looks valid — commit to r14/r15 restore
|
||
movq 24(%rsp), %r14 # restore global env
|
||
movq 32(%rsp), %r15 # restore bump pointer
|
||
|
||
addq $PORTAL_HDR_SIZE, %rsp
|
||
|
||
# Remap heap at the saved base address so pointers are valid
|
||
pushq %rcx # save heap_size
|
||
pushq %rbx # save fd
|
||
movq $SYS_MMAP, %rax
|
||
movq %rdx, %rdi # saved heap_base as fixed addr
|
||
movq $HEAP_SIZE, %rsi # full heap size
|
||
movq $3, %rdx # PROT_READ|PROT_WRITE
|
||
movq $0x32, %r10 # MAP_PRIVATE|MAP_ANONYMOUS|MAP_FIXED
|
||
movq $-1, %r8
|
||
xorq %r9, %r9
|
||
syscall
|
||
movq %rax, heap_base(%rip) # update heap_base
|
||
popq %rbx # restore fd
|
||
popq %rcx # restore heap_size
|
||
|
||
# Read heap data into the fixed-address heap
|
||
movq $SYS_READ, %rax
|
||
movq %rbx, %rdi # fd
|
||
movq heap_base(%rip), %rsi # heap at saved address
|
||
movq %rcx, %rdx # heap_size bytes
|
||
syscall
|
||
|
||
# Close
|
||
movq $SYS_CLOSE, %rax
|
||
movq %rbx, %rdi
|
||
syscall
|
||
|
||
movq $VAL_TRUE, %rax
|
||
RET_VAL
|
||
|
||
.pr_bad_magic:
|
||
addq $PORTAL_HDR_SIZE, %rsp
|
||
movq $SYS_CLOSE, %rax
|
||
movq %rbx, %rdi
|
||
syscall
|
||
.pr_fail:
|
||
movq $VAL_FALSE, %rax
|
||
RET_VAL
|
||
|
||
# ============================================================
|
||
# bi_load: (load "path") — read file, eval every form in r14 env
|
||
# Mmaps file into memory, swaps input_buf_ptr, loops scheme_read+eval,
|
||
# restores input state. Nestable — prior state saved on stack.
|
||
# ============================================================
|
||
bi_load:
|
||
GETARG %rdi # filename (string value)
|
||
andq $-8, %rdi
|
||
movq (%rdi), %rcx # length
|
||
leaq 8(%rdi), %rdi # bytes
|
||
|
||
# Null-terminate filename on stack (256-byte slot)
|
||
subq $256, %rsp
|
||
movq %rsp, %rsi
|
||
pushq %rcx
|
||
.ld_copy:
|
||
testq %rcx, %rcx
|
||
jz .ld_copy_done
|
||
movb (%rdi), %al
|
||
movb %al, (%rsi)
|
||
incq %rdi
|
||
incq %rsi
|
||
decq %rcx
|
||
jmp .ld_copy
|
||
.ld_copy_done:
|
||
movb $0, (%rsi)
|
||
popq %rcx
|
||
|
||
# Open file
|
||
movq $SYS_OPEN, %rax
|
||
movq %rsp, %rdi
|
||
movq $O_RDONLY, %rsi
|
||
xorq %rdx, %rdx
|
||
syscall
|
||
addq $256, %rsp
|
||
testq %rax, %rax
|
||
js .ld_fail
|
||
movq %rax, %rbx # fd
|
||
|
||
# Size via lseek(fd, 0, SEEK_END)
|
||
movq $SYS_LSEEK, %rax
|
||
movq %rbx, %rdi
|
||
xorq %rsi, %rsi
|
||
movq $SEEK_END, %rdx
|
||
syscall
|
||
testq %rax, %rax
|
||
js .ld_close_fail
|
||
pushq %rax # save size at 0(%rsp)
|
||
|
||
# Empty file — nothing to eval, just close and return
|
||
testq %rax, %rax
|
||
jz .ld_empty
|
||
|
||
# Rewind: lseek(fd, 0, SEEK_SET)
|
||
movq $SYS_LSEEK, %rax
|
||
movq %rbx, %rdi
|
||
xorq %rsi, %rsi
|
||
movq $SEEK_SET, %rdx
|
||
syscall
|
||
|
||
# mmap(NULL, size, PROT_READ, MAP_PRIVATE, fd, 0)
|
||
movq $SYS_MMAP, %rax
|
||
xorq %rdi, %rdi
|
||
movq 0(%rsp), %rsi # size
|
||
movq $1, %rdx # PROT_READ
|
||
movq $0x02, %r10 # MAP_PRIVATE
|
||
movq %rbx, %r8 # fd
|
||
xorq %r9, %r9 # offset
|
||
syscall
|
||
cmpq $-1, %rax
|
||
je .ld_mmap_fail
|
||
movq %rax, %rbp # mmap addr
|
||
|
||
# Close fd — mmap keeps page mapping
|
||
movq $SYS_CLOSE, %rax
|
||
movq %rbx, %rdi
|
||
syscall
|
||
|
||
# Save current input state
|
||
movq input_buf_ptr(%rip), %rax
|
||
pushq %rax
|
||
movq input_pos(%rip), %rax
|
||
pushq %rax
|
||
movq input_end(%rip), %rax
|
||
pushq %rax
|
||
movq input_is_file(%rip), %rax
|
||
pushq %rax
|
||
# Stack layout now: [is_file][end][pos][buf_ptr][size]
|
||
# 0 8 16 24 32
|
||
|
||
# Install file as new input source
|
||
movq %rbp, input_buf_ptr(%rip)
|
||
movq $0, input_pos(%rip)
|
||
movq 32(%rsp), %rax # size
|
||
movq %rax, input_end(%rip)
|
||
movq $1, input_is_file(%rip)
|
||
|
||
# Loop: scheme_read + eval
|
||
.ld_loop:
|
||
call scheme_read
|
||
testq %rax, %rax
|
||
jz .ld_loop_done
|
||
movq %rax, %rdi # expr
|
||
movq %r14, %rsi # global env
|
||
call eval
|
||
jmp .ld_loop
|
||
|
||
.ld_loop_done:
|
||
# Restore input state
|
||
popq %rax
|
||
movq %rax, input_is_file(%rip)
|
||
popq %rax
|
||
movq %rax, input_end(%rip)
|
||
popq %rax
|
||
movq %rax, input_pos(%rip)
|
||
popq %rax
|
||
movq %rax, input_buf_ptr(%rip)
|
||
|
||
# munmap(addr, size)
|
||
popq %rsi # size
|
||
movq $SYS_MUNMAP, %rax
|
||
movq %rbp, %rdi
|
||
syscall
|
||
|
||
movq $VAL_VOID, %rax
|
||
RET_VAL
|
||
|
||
.ld_empty:
|
||
# File was size 0 — discard size from stack, close, return void
|
||
addq $8, %rsp
|
||
movq $SYS_CLOSE, %rax
|
||
movq %rbx, %rdi
|
||
syscall
|
||
movq $VAL_VOID, %rax
|
||
RET_VAL
|
||
|
||
.ld_mmap_fail:
|
||
addq $8, %rsp # discard size
|
||
.ld_close_fail:
|
||
movq $SYS_CLOSE, %rax
|
||
movq %rbx, %rdi
|
||
syscall
|
||
.ld_fail:
|
||
movq $VAL_FALSE, %rax
|
||
RET_VAL
|
||
|
||
# ============================================================
|
||
# Ports: output ports encoded as SPECIAL values ≥ PORT_SPECIAL_BASE.
|
||
# fd extraction: (val >> 3) - PORT_SPECIAL_BASE.
|
||
# ============================================================
|
||
|
||
# copy_fname_to_stack: %rdi=str_bytes, %rcx=len, %rsi=dest (256 bytes).
|
||
# Copies + null-terminates; advances registers. Preserves %rbx.
|
||
copy_fname_to_stack:
|
||
.cfs_loop:
|
||
testq %rcx, %rcx
|
||
jz .cfs_done
|
||
movb (%rdi), %al
|
||
movb %al, (%rsi)
|
||
incq %rdi
|
||
incq %rsi
|
||
decq %rcx
|
||
jmp .cfs_loop
|
||
.cfs_done:
|
||
movb $0, (%rsi)
|
||
ret
|
||
|
||
# bi_open_output_file: (open-output-file "path") → port value or #f on fail
|
||
bi_open_output_file:
|
||
GETARG %rdi
|
||
andq $-8, %rdi
|
||
movq (%rdi), %rcx # len
|
||
leaq 8(%rdi), %rdi # bytes
|
||
|
||
subq $256, %rsp
|
||
movq %rsp, %rsi
|
||
call copy_fname_to_stack
|
||
|
||
movq $SYS_OPEN, %rax
|
||
movq %rsp, %rdi
|
||
movq $(O_WRONLY | O_CREAT | O_TRUNC), %rsi
|
||
movq $0644, %rdx
|
||
syscall
|
||
addq $256, %rsp
|
||
|
||
testq %rax, %rax
|
||
js .bof_fail
|
||
# Encode port: ((PORT_SPECIAL_BASE + fd) << 3) | TAG_SPECIAL
|
||
addq $PORT_SPECIAL_BASE, %rax
|
||
shlq $3, %rax
|
||
orq $TAG_SPECIAL, %rax
|
||
RET_VAL
|
||
.bof_fail:
|
||
movq $VAL_FALSE, %rax
|
||
RET_VAL
|
||
|
||
# bi_close_port: (close-port port) → void
|
||
bi_close_port:
|
||
GETARG %rax
|
||
movq %rax, %rcx
|
||
andq $TAG_MASK, %rcx
|
||
cmpq $TAG_SPECIAL, %rcx
|
||
jne .bcp_done
|
||
shrq $3, %rax
|
||
cmpq $PORT_SPECIAL_BASE, %rax
|
||
jl .bcp_done
|
||
subq $PORT_SPECIAL_BASE, %rax
|
||
movq %rax, %rdi # fd
|
||
movq $SYS_CLOSE, %rax
|
||
syscall
|
||
.bcp_done:
|
||
movq $VAL_VOID, %rax
|
||
RET_VAL
|
||
|
||
# bi_portp: (port? x) → #t or #f
|
||
bi_portp:
|
||
GETARG %rax
|
||
movq %rax, %rcx
|
||
andq $TAG_MASK, %rcx
|
||
cmpq $TAG_SPECIAL, %rcx
|
||
jne .bpp_false
|
||
shrq $3, %rax
|
||
cmpq $PORT_SPECIAL_BASE, %rax
|
||
jl .bpp_false
|
||
movq $VAL_TRUE, %rax
|
||
RET_VAL
|
||
.bpp_false:
|
||
movq $VAL_FALSE, %rax
|
||
RET_VAL
|
||
|
||
# bi_write_file: (write-file "path" "content") → #t or #f
|
||
bi_write_file:
|
||
GETARG %rdi
|
||
andq $-8, %rdi
|
||
movq (%rdi), %rcx # filename len
|
||
leaq 8(%rdi), %rdi # filename bytes
|
||
|
||
subq $256, %rsp
|
||
movq %rsp, %rsi
|
||
call copy_fname_to_stack
|
||
|
||
# Open for writing (truncate)
|
||
movq $SYS_OPEN, %rax
|
||
movq %rsp, %rdi
|
||
movq $(O_WRONLY | O_CREAT | O_TRUNC), %rsi
|
||
movq $0644, %rdx
|
||
syscall
|
||
addq $256, %rsp
|
||
testq %rax, %rax
|
||
js .bwf_fail
|
||
movq %rax, %rbx # fd
|
||
|
||
# Second arg: content string
|
||
GETARG %rdi
|
||
andq $-8, %rdi
|
||
movq (%rdi), %rdx # length
|
||
leaq 8(%rdi), %rsi # bytes
|
||
movq $SYS_WRITE, %rax
|
||
movq %rbx, %rdi
|
||
syscall
|
||
|
||
movq $SYS_CLOSE, %rax
|
||
movq %rbx, %rdi
|
||
syscall
|
||
|
||
movq $VAL_TRUE, %rax
|
||
RET_VAL
|
||
.bwf_fail:
|
||
movq $VAL_FALSE, %rax
|
||
RET_VAL
|
||
|
||
# bi_file_to_string: (file->string "path") → string or #f
|
||
# Reads whole file into a heap-allocated string object.
|
||
bi_file_to_string:
|
||
GETARG %rdi
|
||
andq $-8, %rdi
|
||
movq (%rdi), %rcx # filename len
|
||
leaq 8(%rdi), %rdi # filename bytes
|
||
|
||
subq $256, %rsp
|
||
movq %rsp, %rsi
|
||
call copy_fname_to_stack
|
||
|
||
movq $SYS_OPEN, %rax
|
||
movq %rsp, %rdi
|
||
movq $O_RDONLY, %rsi
|
||
xorq %rdx, %rdx
|
||
syscall
|
||
addq $256, %rsp
|
||
testq %rax, %rax
|
||
js .bfs_fail
|
||
movq %rax, %rbx # fd
|
||
|
||
# Size via lseek(fd, 0, SEEK_END)
|
||
movq $SYS_LSEEK, %rax
|
||
movq %rbx, %rdi
|
||
xorq %rsi, %rsi
|
||
movq $SEEK_END, %rdx
|
||
syscall
|
||
movq %rax, %rbp # file size
|
||
testq %rax, %rax
|
||
js .bfs_close_fail
|
||
|
||
# Rewind
|
||
movq $SYS_LSEEK, %rax
|
||
movq %rbx, %rdi
|
||
xorq %rsi, %rsi
|
||
movq $SEEK_SET, %rdx
|
||
syscall
|
||
|
||
# Allocate string cell [length | bytes...] on heap
|
||
# Heap object = 8 (length) + size bytes, aligned to 8
|
||
movq %rbp, %rdi
|
||
addq $8, %rdi
|
||
call heap_alloc # %rax = ptr
|
||
.ifdef GC_NAIVE
|
||
orq $(HT_STRING << 8), -8(%rax)
|
||
.endif
|
||
movq %rax, %r12 # save heap pointer
|
||
movq %rbp, (%r12) # store length
|
||
|
||
# Read file bytes into cell
|
||
leaq 8(%r12), %rsi
|
||
movq %rbp, %rdx
|
||
movq $SYS_READ, %rax
|
||
movq %rbx, %rdi
|
||
syscall
|
||
|
||
movq $SYS_CLOSE, %rax
|
||
movq %rbx, %rdi
|
||
syscall
|
||
|
||
# Tag and return
|
||
movq %r12, %rax
|
||
orq $TAG_STRING, %rax
|
||
RET_VAL
|
||
|
||
.bfs_close_fail:
|
||
movq $SYS_CLOSE, %rax
|
||
movq %rbx, %rdi
|
||
syscall
|
||
.bfs_fail:
|
||
movq $VAL_FALSE, %rax
|
||
RET_VAL
|
||
|
||
# ============================================================
|
||
# Heap snapshot/restore: UNSAFE escape hatch for long-running loops.
|
||
# asm has no GC. A server that bump-allocates every request leaks
|
||
# ~64 MB per heap_grow forever. heap-snapshot captures r15; a later
|
||
# heap-restore rewinds r15 to that point, reclaiming everything
|
||
# allocated since.
|
||
#
|
||
# DANGER: any Scheme value that lives past the restore point but was
|
||
# allocated after the snapshot becomes a dangling pointer. Use only
|
||
# when the programmer can prove no such references exist — the
|
||
# canonical pattern is a per-request scope in a server loop:
|
||
#
|
||
# (let ((snap (heap-snapshot)))
|
||
# (loop ...)
|
||
# (heap-restore snap))
|
||
#
|
||
# Top-level bindings stay alive because they allocate before the snap.
|
||
# ============================================================
|
||
|
||
bi_heap_snapshot:
|
||
# Return r15 as a tagged int (61-bit payload fits a 64-bit pointer
|
||
# because all asm heap addresses have 0 in the low 3 bits already).
|
||
movq %r15, %rax
|
||
# Low 3 bits of r15 are 0 (8-aligned). TAG_INT = 0, so no OR needed.
|
||
RET_VAL
|
||
|
||
bi_heap_restore:
|
||
GETARG %rax
|
||
# Untag: caller passed a heap-snapshot int. Clear tag bits just in case.
|
||
andq $-8, %rax
|
||
# Sanity: don't rewind past heap_base or forward past current r15.
|
||
cmpq heap_base(%rip), %rax
|
||
jl .hr_noop
|
||
cmpq %r15, %rax
|
||
ja .hr_noop
|
||
movq %rax, %r15
|
||
.hr_noop:
|
||
movq $VAL_VOID, %rax
|
||
RET_VAL
|
||
|
||
# bi_read_from_string: (read-from-string "sexp") → value
|
||
# Saves the current input-buffer state, swaps in the caller's string
|
||
# as the input source, reads one expression, restores input state.
|
||
bi_read_from_string:
|
||
GETARG %rdi
|
||
andq $-8, %rdi
|
||
movq (%rdi), %rcx # length
|
||
leaq 8(%rdi), %r8 # pointer to string bytes
|
||
|
||
# Save input state (buf_ptr, pos, end, is_file) to stack
|
||
movq input_buf_ptr(%rip), %rax
|
||
pushq %rax
|
||
movq input_pos(%rip), %rax
|
||
pushq %rax
|
||
movq input_end(%rip), %rax
|
||
pushq %rax
|
||
movq input_is_file(%rip), %rax
|
||
pushq %rax
|
||
|
||
# Swap input to the string. Mark as "file" so no stdin refill.
|
||
movq %r8, input_buf_ptr(%rip)
|
||
movq $0, input_pos(%rip)
|
||
movq %rcx, input_end(%rip)
|
||
movq $1, input_is_file(%rip)
|
||
|
||
call scheme_read # rax = value (or 0 for EOF)
|
||
movq %rax, %rbx # stash result in callee-save
|
||
|
||
# Restore input state (pop reversed order of push)
|
||
popq %rax
|
||
movq %rax, input_is_file(%rip)
|
||
popq %rax
|
||
movq %rax, input_end(%rip)
|
||
popq %rax
|
||
movq %rax, input_pos(%rip)
|
||
popq %rax
|
||
movq %rax, input_buf_ptr(%rip)
|
||
|
||
# Translate EOF (0) into VAL_FALSE so callers can distinguish
|
||
movq %rbx, %rax
|
||
testq %rax, %rax
|
||
jnz .brfs_done
|
||
movq $VAL_FALSE, %rax
|
||
.brfs_done:
|
||
RET_VAL
|
||
|
||
# bi_eval: (eval expr) → value (evaluates in global env r14)
|
||
bi_eval:
|
||
GETARG %rdi # expr
|
||
movq %r14, %rsi # env
|
||
call eval
|
||
RET_VAL
|
||
|
||
# bi_symbol_to_string: (symbol->string 'foo) → "foo"
|
||
# Symbols are stored as [length-byte, bytes...] at ptr (low 3 bits = TAG_SYM).
|
||
# Return a fresh string cell [8-byte length, bytes...].
|
||
bi_symbol_to_string:
|
||
GETARG %rdi # symbol value
|
||
andq $-8, %rdi # untag
|
||
movzbq (%rdi), %rcx # length (one byte)
|
||
leaq 1(%rdi), %r8 # byte pointer
|
||
|
||
pushq %rcx
|
||
pushq %r8
|
||
movq %rcx, %rdi
|
||
addq $8, %rdi # cell size: 8-byte length + bytes
|
||
call heap_alloc
|
||
.ifdef GC_NAIVE
|
||
orq $(HT_STRING << 8), -8(%rax)
|
||
.endif
|
||
popq %r8
|
||
popq %rcx
|
||
|
||
movq %rcx, (%rax) # store length as 8 bytes
|
||
movq %rax, %rbx # save result pointer
|
||
leaq 8(%rax), %rdx # dest
|
||
.b_s2s_copy:
|
||
testq %rcx, %rcx
|
||
jz .b_s2s_done
|
||
movb (%r8), %r9b
|
||
movb %r9b, (%rdx)
|
||
incq %r8
|
||
incq %rdx
|
||
decq %rcx
|
||
jmp .b_s2s_copy
|
||
.b_s2s_done:
|
||
movq %rbx, %rax
|
||
orq $TAG_STRING, %rax
|
||
RET_VAL
|
||
|
||
# ============================================================
|
||
# Hash-table (shares tag 7 with vectors; distinguished by -1 sentinel
|
||
# at offset 0. Vector length is always >= 0, so no ambiguity.)
|
||
#
|
||
# Layout (24 + 64*8 = 536 bytes, fixed size — no growth):
|
||
# offset 0 : sentinel = -1 (disambiguates from vector)
|
||
# offset 8 : count (entries)
|
||
# offset 16 : nbuckets = 64 (power of 2, modulo via AND)
|
||
# offset 24..: bucket0..bucket63 (each is an alist: VAL_NIL or
|
||
# (cons (cons key val) rest))
|
||
# ============================================================
|
||
.equ HT_SENTINEL, -1
|
||
.equ HT_NBUCKETS, 64
|
||
.equ HT_BUCKET_MASK, 63
|
||
.equ HT_HEADER_BYTES, 24
|
||
.equ HT_TOTAL_BYTES, 536 # 24 + 64*8
|
||
|
||
# hash_value: %rdi = tagged value -> %rax = 64-bit hash
|
||
# INT: untagged value. STRING: djb2 over bytes. Else: raw tagged bits.
|
||
hash_value:
|
||
movq %rdi, %rax
|
||
andq $TAG_MASK, %rax
|
||
cmpq $TAG_INT, %rax
|
||
je .hv_int
|
||
cmpq $TAG_STRING, %rax
|
||
je .hv_str
|
||
movq %rdi, %rax
|
||
ret
|
||
.hv_int:
|
||
movq %rdi, %rax
|
||
sarq $3, %rax
|
||
ret
|
||
.hv_str:
|
||
movq %rdi, %rcx
|
||
andq $-8, %rcx # string struct ptr
|
||
movq (%rcx), %rdx # length
|
||
leaq 8(%rcx), %rsi # bytes start
|
||
movq $5381, %rax # djb2 seed
|
||
.hv_str_loop:
|
||
testq %rdx, %rdx
|
||
jz .hv_str_done
|
||
movq %rax, %rcx
|
||
shlq $5, %rcx
|
||
addq %rcx, %rax # rax *= 33 (really +32, plus the add below)
|
||
movzbq (%rsi), %rcx
|
||
addq %rcx, %rax
|
||
incq %rsi
|
||
decq %rdx
|
||
jmp .hv_str_loop
|
||
.hv_str_done:
|
||
ret
|
||
|
||
# ht_chain_find: walk alist for matching key.
|
||
# Input: %rdi = bucket head (tagged list), %rsi = key (tagged)
|
||
# Output: %rax = matching (key . val) pair cell (tagged), or VAL_NIL
|
||
# Clobbers: %rax, %rcx, %rdx, %rdi, %rsi, %r8, %r9, %r10, %r11
|
||
ht_chain_find:
|
||
pushq %r12
|
||
pushq %rbx
|
||
movq %rdi, %rbx # current bucket cell (tagged)
|
||
movq %rsi, %r12 # key
|
||
.htcf_loop:
|
||
cmpq $VAL_NIL, %rbx
|
||
je .htcf_notfound
|
||
# car(rbx) = (key . val) pair; cdr(rbx) = rest
|
||
movq %rbx, %rax
|
||
andq $-8, %rax
|
||
movq (%rax), %rcx # (k . v) entry pair (tagged)
|
||
# car(entry) = k
|
||
movq %rcx, %rax
|
||
andq $-8, %rax
|
||
movq (%rax), %rdi # k
|
||
pushq %rcx
|
||
movq %r12, %rsi
|
||
call deep_equal
|
||
popq %rcx
|
||
cmpq $VAL_TRUE, %rax
|
||
je .htcf_found
|
||
# advance: rbx = cdr(rbx)
|
||
movq %rbx, %rax
|
||
andq $-8, %rax
|
||
movq 8(%rax), %rbx
|
||
jmp .htcf_loop
|
||
.htcf_found:
|
||
movq %rcx, %rax
|
||
popq %rbx
|
||
popq %r12
|
||
ret
|
||
.htcf_notfound:
|
||
movq $VAL_NIL, %rax
|
||
popq %rbx
|
||
popq %r12
|
||
ret
|
||
|
||
# bi_make_hash_table: () -> fresh empty hash-table
|
||
bi_make_hash_table:
|
||
movq $HT_TOTAL_BYTES, %rdi
|
||
call heap_alloc
|
||
.ifdef GC_NAIVE
|
||
orq $(HT_HASHTABLE << 8), -8(%rax)
|
||
.endif
|
||
movq $HT_SENTINEL, (%rax)
|
||
movq $0, 8(%rax) # count
|
||
movq $HT_NBUCKETS, 16(%rax)
|
||
leaq HT_HEADER_BYTES(%rax), %rcx
|
||
movq $HT_NBUCKETS, %rdx
|
||
.bmht_fill:
|
||
movq $VAL_NIL, (%rcx)
|
||
addq $8, %rcx
|
||
decq %rdx
|
||
jnz .bmht_fill
|
||
orq $7, %rax # tag as vector-family
|
||
RET_VAL
|
||
|
||
# bi_hash_table_p: (hash-table? x) -> bool
|
||
bi_hash_table_p:
|
||
GETARG %rax
|
||
movq %rax, %rcx
|
||
andq $TAG_MASK, %rcx
|
||
cmpq $7, %rcx
|
||
jne .cmp_false
|
||
andq $-8, %rax
|
||
movq (%rax), %rax
|
||
cmpq $HT_SENTINEL, %rax
|
||
je .cmp_true
|
||
jmp .cmp_false
|
||
|
||
# bi_hash_table_set: (hash-table-set! ht key val) -> void
|
||
bi_hash_table_set:
|
||
GETARG %rax
|
||
andq $-8, %rax
|
||
movq %rax, %rbx # %rbx = untagged ht
|
||
GETARG %rbp # %rbp = key
|
||
GETARG %r12 # %r12 = val
|
||
# bucket index = hash(key) & mask
|
||
movq %rbp, %rdi
|
||
call hash_value
|
||
andq $HT_BUCKET_MASK, %rax
|
||
leaq HT_HEADER_BYTES(%rbx,%rax,8), %rdx # slot addr
|
||
movq %rdx, %rcx # preserve slot addr
|
||
movq (%rdx), %rdi # bucket head
|
||
movq %rbp, %rsi
|
||
pushq %rcx
|
||
call ht_chain_find
|
||
popq %rcx
|
||
cmpq $VAL_NIL, %rax
|
||
jne .bhts_update
|
||
# Insert: cons(cons(key,val), old_head)
|
||
movq %rbp, %rdi
|
||
movq %r12, %rsi
|
||
pushq %rcx
|
||
call make_pair # (k . v)
|
||
popq %rcx
|
||
movq (%rcx), %rsi # old head
|
||
movq %rax, %rdi # (k . v)
|
||
pushq %rcx
|
||
call make_pair # cons((k.v), old)
|
||
popq %rcx
|
||
movq %rax, (%rcx) # install new head
|
||
incq 8(%rbx) # count++
|
||
movq $VAL_VOID, %rax
|
||
RET_VAL
|
||
.bhts_update:
|
||
# %rax = (k . v) pair tagged; update its cdr.
|
||
andq $-8, %rax
|
||
movq %r12, 8(%rax)
|
||
movq $VAL_VOID, %rax
|
||
RET_VAL
|
||
|
||
# bi_hash_table_ref: (hash-table-ref ht key) -> val or error
|
||
bi_hash_table_ref:
|
||
GETARG %rax
|
||
andq $-8, %rax
|
||
movq %rax, %rbx
|
||
GETARG %rbp # key
|
||
movq %rbp, %rdi
|
||
call hash_value
|
||
andq $HT_BUCKET_MASK, %rax
|
||
movq HT_HEADER_BYTES(%rbx,%rax,8), %rdi # bucket head
|
||
movq %rbp, %rsi
|
||
call ht_chain_find
|
||
cmpq $VAL_NIL, %rax
|
||
je .bhtr_missing
|
||
andq $-8, %rax
|
||
movq 8(%rax), %rax # v
|
||
RET_VAL
|
||
.bhtr_missing:
|
||
movq $SYS_WRITE, %rax
|
||
movq $2, %rdi
|
||
leaq err_ht_miss(%rip), %rsi
|
||
movq $err_ht_miss_len, %rdx
|
||
syscall
|
||
movq $SYS_EXIT, %rax
|
||
movq $1, %rdi
|
||
syscall
|
||
|
||
# bi_hash_table_ref_default: (hash-table-ref/default ht key default)
|
||
bi_hash_table_ref_default:
|
||
GETARG %rax
|
||
andq $-8, %rax
|
||
movq %rax, %rbx
|
||
GETARG %rbp # key
|
||
GETARG %r12 # default
|
||
movq %rbp, %rdi
|
||
call hash_value
|
||
andq $HT_BUCKET_MASK, %rax
|
||
movq HT_HEADER_BYTES(%rbx,%rax,8), %rdi
|
||
movq %rbp, %rsi
|
||
call ht_chain_find
|
||
cmpq $VAL_NIL, %rax
|
||
je .bhtrd_default
|
||
andq $-8, %rax
|
||
movq 8(%rax), %rax
|
||
RET_VAL
|
||
.bhtrd_default:
|
||
movq %r12, %rax
|
||
RET_VAL
|
||
|
||
# bi_hash_table_exists: (hash-table-exists? ht key) -> bool
|
||
bi_hash_table_exists:
|
||
GETARG %rax
|
||
andq $-8, %rax
|
||
movq %rax, %rbx
|
||
GETARG %rbp # key
|
||
movq %rbp, %rdi
|
||
call hash_value
|
||
andq $HT_BUCKET_MASK, %rax
|
||
movq HT_HEADER_BYTES(%rbx,%rax,8), %rdi
|
||
movq %rbp, %rsi
|
||
call ht_chain_find
|
||
cmpq $VAL_NIL, %rax
|
||
je .cmp_false
|
||
jmp .cmp_true
|
||
|
||
# bi_hash_table_size: (hash-table-size ht) -> int
|
||
bi_hash_table_size:
|
||
GETARG %rax
|
||
andq $-8, %rax
|
||
movq 8(%rax), %rdi
|
||
call make_int
|
||
RET_VAL
|
||
|
||
# bi_hash_table_delete: (hash-table-delete! ht key) -> void
|
||
# Rebuilds bucket chain excluding matching key. Old cells leak (no GC).
|
||
bi_hash_table_delete:
|
||
GETARG %rax
|
||
andq $-8, %rax
|
||
movq %rax, %rbx # ht (untagged)
|
||
GETARG %rbp # key
|
||
movq %rbp, %rdi
|
||
call hash_value
|
||
andq $HT_BUCKET_MASK, %rax
|
||
leaq HT_HEADER_BYTES(%rbx,%rax,8), %rdi # slot addr
|
||
pushq %rdi # save slot addr on stack
|
||
movq (%rdi), %r12 # %r12 = current walker (tagged)
|
||
movq $VAL_NIL, %rcx # new head
|
||
xorq %r8, %r8 # deleted flag
|
||
.bhtd_walk:
|
||
cmpq $VAL_NIL, %r12
|
||
je .bhtd_done
|
||
movq %r12, %rax
|
||
andq $-8, %rax
|
||
movq (%rax), %rdx # entry (k . v)
|
||
movq 8(%rax), %r9 # next
|
||
# compare entry.key to %rbp
|
||
movq %rdx, %rax
|
||
andq $-8, %rax
|
||
movq (%rax), %rdi # k
|
||
movq %rbp, %rsi
|
||
pushq %rcx
|
||
pushq %r8
|
||
pushq %r9
|
||
pushq %rdx
|
||
call deep_equal
|
||
popq %rdx
|
||
popq %r9
|
||
popq %r8
|
||
popq %rcx
|
||
cmpq $VAL_TRUE, %rax
|
||
jne .bhtd_keep
|
||
# Matched — skip
|
||
movq $1, %r8
|
||
movq %r9, %r12
|
||
jmp .bhtd_walk
|
||
.bhtd_keep:
|
||
# Prepend entry to new head
|
||
pushq %r9
|
||
pushq %r8
|
||
movq %rdx, %rdi
|
||
movq %rcx, %rsi
|
||
call make_pair
|
||
popq %r8
|
||
popq %r9
|
||
movq %rax, %rcx
|
||
movq %r9, %r12
|
||
jmp .bhtd_walk
|
||
.bhtd_done:
|
||
popq %rdi # slot addr
|
||
testq %r8, %r8
|
||
jz .bhtd_nochange
|
||
movq %rcx, (%rdi)
|
||
decq 8(%rbx)
|
||
.bhtd_nochange:
|
||
movq $VAL_VOID, %rax
|
||
RET_VAL
|
||
|
||
# bi_hash_table_keys: (hash-table-keys ht) -> list
|
||
bi_hash_table_keys:
|
||
GETARG %rax
|
||
andq $-8, %rax
|
||
movq %rax, %rbx # untagged ht
|
||
movq $VAL_NIL, %r12 # result list
|
||
movq $HT_NBUCKETS, %rbp # remaining buckets
|
||
leaq HT_HEADER_BYTES(%rbx), %rcx # bucket slot ptr
|
||
pushq %rcx
|
||
.bhtk_bucket:
|
||
testq %rbp, %rbp
|
||
jz .bhtk_finish
|
||
popq %rcx
|
||
movq (%rcx), %rax # bucket chain
|
||
addq $8, %rcx
|
||
pushq %rcx
|
||
.bhtk_chain:
|
||
cmpq $VAL_NIL, %rax
|
||
je .bhtk_next
|
||
movq %rax, %rdx
|
||
andq $-8, %rdx
|
||
movq (%rdx), %rdi # entry (k . v)
|
||
movq 8(%rdx), %rax # next
|
||
pushq %rax
|
||
pushq %rbp
|
||
movq %rdi, %rdx
|
||
andq $-8, %rdx
|
||
movq (%rdx), %rdi # k
|
||
movq %r12, %rsi
|
||
call make_pair
|
||
popq %rbp
|
||
movq %rax, %r12
|
||
popq %rax
|
||
jmp .bhtk_chain
|
||
.bhtk_next:
|
||
decq %rbp
|
||
jmp .bhtk_bucket
|
||
.bhtk_finish:
|
||
addq $8, %rsp # drop saved slot ptr
|
||
movq %r12, %rax
|
||
RET_VAL
|
||
|
||
# bi_hash_table_values: (hash-table-values ht) -> list
|
||
bi_hash_table_values:
|
||
GETARG %rax
|
||
andq $-8, %rax
|
||
movq %rax, %rbx
|
||
movq $VAL_NIL, %r12
|
||
movq $HT_NBUCKETS, %rbp
|
||
leaq HT_HEADER_BYTES(%rbx), %rcx
|
||
pushq %rcx
|
||
.bhtv_bucket:
|
||
testq %rbp, %rbp
|
||
jz .bhtv_finish
|
||
popq %rcx
|
||
movq (%rcx), %rax
|
||
addq $8, %rcx
|
||
pushq %rcx
|
||
.bhtv_chain:
|
||
cmpq $VAL_NIL, %rax
|
||
je .bhtv_next
|
||
movq %rax, %rdx
|
||
andq $-8, %rdx
|
||
movq (%rdx), %rdi # (k . v)
|
||
movq 8(%rdx), %rax
|
||
pushq %rax
|
||
pushq %rbp
|
||
movq %rdi, %rdx
|
||
andq $-8, %rdx
|
||
movq 8(%rdx), %rdi # v
|
||
movq %r12, %rsi
|
||
call make_pair
|
||
popq %rbp
|
||
movq %rax, %r12
|
||
popq %rax
|
||
jmp .bhtv_chain
|
||
.bhtv_next:
|
||
decq %rbp
|
||
jmp .bhtv_bucket
|
||
.bhtv_finish:
|
||
addq $8, %rsp
|
||
movq %r12, %rax
|
||
RET_VAL
|
||
|
||
# bi_hash_table_to_alist: (hash-table->alist ht) -> list of pairs
|
||
bi_hash_table_to_alist:
|
||
GETARG %rax
|
||
andq $-8, %rax
|
||
movq %rax, %rbx
|
||
movq $VAL_NIL, %r12
|
||
movq $HT_NBUCKETS, %rbp
|
||
leaq HT_HEADER_BYTES(%rbx), %rcx
|
||
pushq %rcx
|
||
.bhta_bucket:
|
||
testq %rbp, %rbp
|
||
jz .bhta_finish
|
||
popq %rcx
|
||
movq (%rcx), %rax
|
||
addq $8, %rcx
|
||
pushq %rcx
|
||
.bhta_chain:
|
||
cmpq $VAL_NIL, %rax
|
||
je .bhta_next
|
||
movq %rax, %rdx
|
||
andq $-8, %rdx
|
||
movq (%rdx), %rdi # (k . v) — already a pair, reuse as-is
|
||
movq 8(%rdx), %rax
|
||
pushq %rax
|
||
pushq %rbp
|
||
movq %r12, %rsi
|
||
call make_pair
|
||
popq %rbp
|
||
movq %rax, %r12
|
||
popq %rax
|
||
jmp .bhta_chain
|
||
.bhta_next:
|
||
decq %rbp
|
||
jmp .bhta_bucket
|
||
.bhta_finish:
|
||
addq $8, %rsp
|
||
movq %r12, %rax
|
||
RET_VAL
|
||
|
||
# ============================================================
|
||
# Hash-set (tag 7; sentinel -2 at offset 0 distinguishes from
|
||
# hash-table (-1) and plain vector (>= 0)).
|
||
#
|
||
# Layout (same 24 + 64*8 = 536 bytes as hash-table):
|
||
# offset 0 : sentinel = -2
|
||
# offset 8 : count
|
||
# offset 16 : nbuckets = 64
|
||
# offset 24..: bucket0..bucket63 (each is a list of raw keys)
|
||
#
|
||
# One cons cell per entry (vs two for hash-table) — this is the
|
||
# speedup vs the portable ht-* lib (Scheme-level alist over vector).
|
||
# ============================================================
|
||
.equ HS_SENTINEL, -2
|
||
|
||
# hs_chain_find: walk key list.
|
||
# Input: %rdi = bucket head (tagged list), %rsi = key (tagged)
|
||
# Output: %rax = VAL_TRUE if found, VAL_FALSE otherwise
|
||
hs_chain_find:
|
||
pushq %r12
|
||
pushq %rbx
|
||
movq %rdi, %rbx # current
|
||
movq %rsi, %r12 # key
|
||
.hscf_loop:
|
||
cmpq $VAL_NIL, %rbx
|
||
je .hscf_notfound
|
||
movq %rbx, %rax
|
||
andq $-8, %rax
|
||
movq (%rax), %rdi # entry key
|
||
movq %r12, %rsi
|
||
call deep_equal
|
||
cmpq $VAL_TRUE, %rax
|
||
je .hscf_found
|
||
movq %rbx, %rax
|
||
andq $-8, %rax
|
||
movq 8(%rax), %rbx # cdr
|
||
jmp .hscf_loop
|
||
.hscf_found:
|
||
movq $VAL_TRUE, %rax
|
||
popq %rbx
|
||
popq %r12
|
||
ret
|
||
.hscf_notfound:
|
||
movq $VAL_FALSE, %rax
|
||
popq %rbx
|
||
popq %r12
|
||
ret
|
||
|
||
# bi_make_hash_set: () -> fresh empty hash-set
|
||
bi_make_hash_set:
|
||
movq $HT_TOTAL_BYTES, %rdi
|
||
call heap_alloc
|
||
.ifdef GC_NAIVE
|
||
orq $(HT_HASHSET << 8), -8(%rax)
|
||
.endif
|
||
movq $HS_SENTINEL, (%rax)
|
||
movq $0, 8(%rax)
|
||
movq $HT_NBUCKETS, 16(%rax)
|
||
leaq HT_HEADER_BYTES(%rax), %rcx
|
||
movq $HT_NBUCKETS, %rdx
|
||
.bmhs_fill:
|
||
movq $VAL_NIL, (%rcx)
|
||
addq $8, %rcx
|
||
decq %rdx
|
||
jnz .bmhs_fill
|
||
orq $7, %rax
|
||
RET_VAL
|
||
|
||
# bi_hash_set_p: (hash-set? x) -> bool
|
||
bi_hash_set_p:
|
||
GETARG %rax
|
||
movq %rax, %rcx
|
||
andq $TAG_MASK, %rcx
|
||
cmpq $7, %rcx
|
||
jne .cmp_false
|
||
andq $-8, %rax
|
||
movq (%rax), %rax
|
||
cmpq $HS_SENTINEL, %rax
|
||
je .cmp_true
|
||
jmp .cmp_false
|
||
|
||
# bi_hash_set_add: (hash-set-add! hs key) -> #t if inserted, #f if already present
|
||
bi_hash_set_add:
|
||
GETARG %rax
|
||
andq $-8, %rax
|
||
movq %rax, %rbx # untagged hs
|
||
GETARG %rbp # key
|
||
movq %rbp, %rdi
|
||
call hash_value
|
||
andq $HT_BUCKET_MASK, %rax
|
||
leaq HT_HEADER_BYTES(%rbx,%rax,8), %rcx # slot addr
|
||
movq %rcx, %r12 # preserve slot addr across calls
|
||
movq (%rcx), %rdi # bucket head
|
||
movq %rbp, %rsi
|
||
call hs_chain_find
|
||
cmpq $VAL_TRUE, %rax
|
||
je .bhsa_already
|
||
# Insert: prepend key to bucket
|
||
movq %rbp, %rdi
|
||
movq (%r12), %rsi # old head
|
||
call make_pair
|
||
movq %rax, (%r12)
|
||
incq 8(%rbx) # count++
|
||
movq $VAL_TRUE, %rax
|
||
RET_VAL
|
||
.bhsa_already:
|
||
movq $VAL_FALSE, %rax
|
||
RET_VAL
|
||
|
||
# bi_hash_set_contains: (hash-set-contains? hs key) -> bool
|
||
bi_hash_set_contains:
|
||
GETARG %rax
|
||
andq $-8, %rax
|
||
movq %rax, %rbx
|
||
GETARG %rbp
|
||
movq %rbp, %rdi
|
||
call hash_value
|
||
andq $HT_BUCKET_MASK, %rax
|
||
movq HT_HEADER_BYTES(%rbx,%rax,8), %rdi
|
||
movq %rbp, %rsi
|
||
call hs_chain_find
|
||
# Already VAL_TRUE or VAL_FALSE
|
||
RET_VAL
|
||
|
||
# bi_hash_set_size: (hash-set-size hs) -> int
|
||
bi_hash_set_size:
|
||
GETARG %rax
|
||
andq $-8, %rax
|
||
movq 8(%rax), %rdi
|
||
call make_int
|
||
RET_VAL
|
||
|
||
# bi_hash_set_to_list: (hash-set->list hs) -> list of keys
|
||
bi_hash_set_to_list:
|
||
GETARG %rax
|
||
andq $-8, %rax
|
||
movq %rax, %rbx
|
||
movq $VAL_NIL, %r12
|
||
movq $HT_NBUCKETS, %rbp
|
||
leaq HT_HEADER_BYTES(%rbx), %rcx
|
||
pushq %rcx
|
||
.bhsl_bucket:
|
||
testq %rbp, %rbp
|
||
jz .bhsl_finish
|
||
popq %rcx
|
||
movq (%rcx), %rax
|
||
addq $8, %rcx
|
||
pushq %rcx
|
||
.bhsl_chain:
|
||
cmpq $VAL_NIL, %rax
|
||
je .bhsl_next
|
||
movq %rax, %rdx
|
||
andq $-8, %rdx
|
||
movq (%rdx), %rdi # key
|
||
movq 8(%rdx), %rax # next
|
||
pushq %rax
|
||
pushq %rbp
|
||
movq %r12, %rsi
|
||
call make_pair
|
||
popq %rbp
|
||
movq %rax, %r12
|
||
popq %rax
|
||
jmp .bhsl_chain
|
||
.bhsl_next:
|
||
decq %rbp
|
||
jmp .bhsl_bucket
|
||
.bhsl_finish:
|
||
addq $8, %rsp
|
||
movq %r12, %rax
|
||
RET_VAL
|
||
|
||
.ifdef GC_NAIVE
|
||
# ============================================================
|
||
# Meta-GC: arena (fast bulk-free) + verifier-gated reset.
|
||
#
|
||
# (with-arena thunk) — calls thunk with no args, then attempts
|
||
# to reset %r15 to where it was at arena entry. Succeeds iff:
|
||
# (a) no implicit GC fired during the thunk (that would have
|
||
# rebuilt the free list and invalidated the snapshot), AND
|
||
# (b) verifier's mark phase finds no live block above the
|
||
# snapshot's %r15 after adding the thunk's return value as
|
||
# an extra root.
|
||
# On success: bulk-reset, bytes freed = (pre_r15 - snap_r15).
|
||
# On failure: fall through to the existing naive mark-sweep.
|
||
#
|
||
# Free-list reuse is disabled while arena_active != 0 so the chain
|
||
# stays pristine for a verbatim restore; heap_alloc enforces this.
|
||
# ============================================================
|
||
|
||
# bi_with_arena: (with-arena thunk) -> thunk's return value.
|
||
# Meta-GC dispatch with adaptive policy:
|
||
# 1. Run thunk. Zero volatile regs so conservative scan is clean.
|
||
# 2. If implicit GC fired mid-thunk (arena_active cleared) ->
|
||
# abort. EMA += escape.
|
||
# 3. If adaptive mode on AND escape_rate > threshold AND probe
|
||
# countdown > 0: SKIP verify, run sweep directly (faster than
|
||
# verify+sweep on a hostile workload). EMA += escape.
|
||
# 4. Otherwise (greedy mode, low escape rate, or probe fires):
|
||
# call arena_verify_and_commit. Its return value (0/1) feeds
|
||
# the EMA update.
|
||
bi_with_arena:
|
||
GETARG %rbx # thunk
|
||
movq %r15, %rax
|
||
movq %rax, arena_r15_snap(%rip)
|
||
movq $1, arena_active(%rip)
|
||
incq arena_calls(%rip)
|
||
movq %rbx, %rdi
|
||
movq $VAL_NIL, %rsi
|
||
call apply_proc_raw
|
||
movq %rax, %rbx # result (tagged)
|
||
# Zero volatile regs so the conservative stack scan in verify
|
||
# doesn't pick up stale tagged pointers apply_proc_raw leaves
|
||
# behind (would look like live roots pointing into the arena).
|
||
# DO NOT zero %rbp — the interpreter keeps the caller's local
|
||
# env there, and wiping it loses the binding for the variable
|
||
# that friendly-loop / any user-closure caller was resolving.
|
||
xorq %rax, %rax
|
||
xorq %rcx, %rcx
|
||
xorq %rdx, %rdx
|
||
xorq %rsi, %rsi
|
||
xorq %rdi, %rdi
|
||
xorq %r8, %r8
|
||
xorq %r9, %r9
|
||
xorq %r10, %r10
|
||
xorq %r11, %r11
|
||
xorq %r12, %r12
|
||
|
||
# (a) implicit-GC abort?
|
||
cmpq $0, arena_active(%rip)
|
||
je .bwa_abort_gc
|
||
|
||
# (b) adaptive skip?
|
||
cmpq $0, arena_adaptive_mode(%rip)
|
||
je .bwa_verify # greedy mode, always verify
|
||
movq arena_escape_rate(%rip), %rax
|
||
cmpq $ARENA_SKIP_THRESHOLD, %rax
|
||
jbe .bwa_verify # rate low -> verify
|
||
cmpq $0, arena_probe_countdown(%rip)
|
||
je .bwa_probe # countdown 0 -> probe
|
||
# Skip verify entirely. Don't call gc_sweep either — sweep
|
||
# without a mark phase would reclaim live data. Leave the heap
|
||
# as-is; the arena's allocations stay bumped. Correctness: all
|
||
# live data remains reachable via normal roots. Cost: no verify,
|
||
# no sweep. When bump eventually overflows, gc_collect fires
|
||
# naturally and reclaims dead blocks with a proper mark pass.
|
||
decq arena_probe_countdown(%rip)
|
||
incq arena_verifies_skipped(%rip)
|
||
incq arena_escapes(%rip)
|
||
movq $0, arena_active(%rip)
|
||
movq $1, %rdi # escape sample for EMA
|
||
call arena_update_ema
|
||
jmp .bwa_done
|
||
|
||
.bwa_probe:
|
||
# Probe: reset countdown and run verify as a sample.
|
||
movq $ARENA_PROBE_EVERY, %rax
|
||
movq %rax, arena_probe_countdown(%rip)
|
||
jmp .bwa_verify
|
||
|
||
.bwa_verify:
|
||
movq %rbx, %rdi
|
||
call arena_verify_and_commit # returns 0 (reset) or 1 (escape)
|
||
movq %rax, %rdi
|
||
call arena_update_ema
|
||
jmp .bwa_done
|
||
|
||
.bwa_abort_gc:
|
||
incq arena_escapes(%rip)
|
||
movq $1, %rdi
|
||
call arena_update_ema
|
||
|
||
.bwa_done:
|
||
movq %rbx, %rax
|
||
RET_VAL
|
||
|
||
# arena_update_ema: %rdi = sample (0 for reset, 1 for escape).
|
||
# rate = (rate*7 + sample*256) / 8
|
||
arena_update_ema:
|
||
movq arena_escape_rate(%rip), %rax
|
||
shlq $3, %rax # rate * 8
|
||
subq arena_escape_rate(%rip), %rax # rate * 7
|
||
testq %rdi, %rdi
|
||
jz .aue_zero
|
||
addq $256, %rax # escape sample = 256
|
||
.aue_zero:
|
||
shrq $3, %rax # / 8
|
||
movq %rax, arena_escape_rate(%rip)
|
||
ret
|
||
|
||
.equ ARENA_SKIP_THRESHOLD, 128 # 50% escape rate
|
||
.equ ARENA_PROBE_EVERY, 16 # force a verify every 16 skipped
|
||
|
||
# bi_arena_set_mode: (arena-set-mode 0|1) -> void. 0 = greedy (always
|
||
# verify), 1 = adaptive (skip verify when escape rate is high).
|
||
bi_arena_set_mode:
|
||
GETARG %rax
|
||
sarq $3, %rax # untag int
|
||
movq %rax, arena_adaptive_mode(%rip)
|
||
# Reset EMA and countdown so the mode change starts clean.
|
||
movq $0, arena_escape_rate(%rip)
|
||
movq $0, arena_probe_countdown(%rip)
|
||
movq $VAL_VOID, %rax
|
||
RET_VAL
|
||
|
||
# bi_arena_stats: (arena-stats) -> (list calls resets escapes bytes-reclaimed)
|
||
bi_arena_stats:
|
||
# Build right-to-left: NIL -> (rate) -> (skipped rate) -> ...
|
||
# Final order: (calls resets escapes skipped bytes rate)
|
||
movq arena_escape_rate(%rip), %rdi
|
||
call make_int
|
||
movq %rax, %rdi
|
||
movq $VAL_NIL, %rsi
|
||
call make_pair # (rate)
|
||
movq %rax, %rbx
|
||
movq arena_bytes_reclaimed(%rip), %rdi
|
||
call make_int
|
||
movq %rax, %rdi
|
||
movq %rbx, %rsi
|
||
call make_pair # (bytes rate)
|
||
movq %rax, %rbx
|
||
movq arena_verifies_skipped(%rip), %rdi
|
||
call make_int
|
||
movq %rax, %rdi
|
||
movq %rbx, %rsi
|
||
call make_pair # (skipped bytes rate)
|
||
movq %rax, %rbx
|
||
movq arena_escapes(%rip), %rdi
|
||
call make_int
|
||
movq %rax, %rdi
|
||
movq %rbx, %rsi
|
||
call make_pair # (escapes skipped bytes rate)
|
||
movq %rax, %rbx
|
||
movq arena_resets(%rip), %rdi
|
||
call make_int
|
||
movq %rax, %rdi
|
||
movq %rbx, %rsi
|
||
call make_pair # (resets escapes skipped bytes rate)
|
||
movq %rax, %rbx
|
||
movq arena_calls(%rip), %rdi
|
||
call make_int
|
||
movq %rax, %rdi
|
||
movq %rbx, %rsi
|
||
call make_pair # (calls resets escapes skipped bytes rate)
|
||
RET_VAL
|
||
|
||
# arena_verify_and_commit: %rdi = thunk result (tagged).
|
||
# Runs mark phase, detects escape, commits reset or falls through
|
||
# to naive sweep. Updates arena_resets / arena_escapes counters.
|
||
# Returns %rax = 0 if reset succeeded, 1 if escape (for EMA update).
|
||
arena_verify_and_commit:
|
||
pushq %rbx
|
||
pushq %rcx
|
||
pushq %rdx
|
||
pushq %rsi
|
||
pushq %rdi
|
||
pushq %rbp
|
||
pushq %r8
|
||
pushq %r9
|
||
pushq %r10
|
||
pushq %r11
|
||
pushq %r12
|
||
movq %rdi, %r12 # stash result across calls
|
||
# Clear mark stack.
|
||
movq $0, gc_mark_depth(%rip)
|
||
# Root 1: global env.
|
||
movq %r14, %rdi
|
||
call gc_mark_env
|
||
# Root 2: sym_else_val.
|
||
movq sym_else_val(%rip), %rdi
|
||
call gc_push_if_heap
|
||
# Root 3: sym_table.
|
||
movq sym_count(%rip), %rcx
|
||
leaq sym_table(%rip), %rsi
|
||
.avc_r_sym:
|
||
testq %rcx, %rcx
|
||
jz .avc_r_sym_done
|
||
pushq %rcx
|
||
pushq %rsi
|
||
movq (%rsi), %rdi
|
||
testq %rdi, %rdi
|
||
jz 1f
|
||
call gc_mark_untagged
|
||
1:
|
||
popq %rsi
|
||
popq %rcx
|
||
addq $8, %rsi
|
||
decq %rcx
|
||
jmp .avc_r_sym
|
||
.avc_r_sym_done:
|
||
# Root 4: sym_hash_buckets.
|
||
movq $SYM_HASH_SIZE, %rcx
|
||
leaq sym_hash_buckets(%rip), %rsi
|
||
.avc_r_bkt:
|
||
testq %rcx, %rcx
|
||
jz .avc_r_bkt_done
|
||
movq (%rsi), %rdi
|
||
.avc_r_chain:
|
||
testq %rdi, %rdi
|
||
jz .avc_r_bkt_next
|
||
pushq %rcx
|
||
pushq %rsi
|
||
pushq %rdi
|
||
call gc_mark_untagged
|
||
popq %rdi
|
||
movq (%rdi), %r8
|
||
pushq %rdi
|
||
testq %r8, %r8
|
||
jz 2f
|
||
movq %r8, %rdi
|
||
call gc_mark_untagged
|
||
2:
|
||
popq %rdi
|
||
movq 8(%rdi), %rdi
|
||
popq %rsi
|
||
popq %rcx
|
||
jmp .avc_r_chain
|
||
.avc_r_bkt_next:
|
||
addq $8, %rsi
|
||
decq %rcx
|
||
jmp .avc_r_bkt
|
||
.avc_r_bkt_done:
|
||
# Root 5: stack scan (two tries per word: tagged then env-walk).
|
||
movq %rsp, %rsi
|
||
movq stack_top(%rip), %rdx
|
||
.avc_r_stk:
|
||
cmpq %rdx, %rsi
|
||
jae .avc_r_stk_done
|
||
pushq %rsi
|
||
pushq %rdx
|
||
movq (%rsi), %rdi
|
||
call gc_push_if_heap
|
||
popq %rdx
|
||
popq %rsi
|
||
pushq %rsi
|
||
pushq %rdx
|
||
movq (%rsi), %rdi
|
||
call gc_mark_env
|
||
popq %rdx
|
||
popq %rsi
|
||
addq $8, %rsi
|
||
jmp .avc_r_stk
|
||
.avc_r_stk_done:
|
||
# Root 6 (extra): thunk result.
|
||
movq %r12, %rdi
|
||
call gc_push_if_heap
|
||
# Drain mark stack.
|
||
call gc_mark_drain
|
||
# Now scan the arena range for any marked block. We only allow
|
||
# single-chunk arenas (enforced because heap_grow clears arena),
|
||
# so snapshot and current %r15 share a chunk. Walk from
|
||
# arena_r15_snap up to %r15 by block headers.
|
||
movq arena_r15_snap(%rip), %rbx
|
||
.avc_scan:
|
||
cmpq %r15, %rbx
|
||
jae .avc_safe
|
||
movq (%rbx), %rax
|
||
testq $1, %rax
|
||
jnz .avc_escape
|
||
shrq $16, %rax
|
||
leaq 8(%rbx,%rax), %rbx
|
||
jmp .avc_scan
|
||
.avc_safe:
|
||
# Commit the reset: bulk-free everything above the snapshot.
|
||
movq %r15, %rax
|
||
subq arena_r15_snap(%rip), %rax
|
||
addq %rax, arena_bytes_reclaimed(%rip)
|
||
movq arena_r15_snap(%rip), %rax
|
||
movq %rax, %r15
|
||
movq $0, arena_active(%rip)
|
||
incq arena_resets(%rip)
|
||
call gc_sweep
|
||
xorq %rax, %rax # return 0 (reset)
|
||
jmp .avc_done
|
||
.avc_escape:
|
||
movq $0, arena_active(%rip)
|
||
incq arena_escapes(%rip)
|
||
call gc_sweep
|
||
movq $1, %rax # return 1 (escape)
|
||
.avc_done:
|
||
popq %r12
|
||
popq %r11
|
||
popq %r10
|
||
popq %r9
|
||
popq %r8
|
||
popq %rbp
|
||
popq %rdi
|
||
popq %rsi
|
||
popq %rdx
|
||
popq %rcx
|
||
popq %rbx
|
||
ret
|
||
.endif
|
||
|
||
# bi_current_time_ms: (current-time-ms) → int ms since epoch
|
||
# struct timespec is { int64_t tv_sec; int64_t tv_nsec; } — 16 bytes.
|
||
bi_current_time_ms:
|
||
subq $16, %rsp
|
||
movq $SYS_CLOCK_GETTIME, %rax
|
||
movq $CLOCK_REALTIME, %rdi
|
||
movq %rsp, %rsi
|
||
syscall
|
||
movq (%rsp), %rax # tv_sec
|
||
movq 8(%rsp), %rcx # tv_nsec
|
||
addq $16, %rsp
|
||
imulq $1000, %rax # sec * 1000
|
||
movq %rax, %r8 # stash
|
||
movq %rcx, %rax # rax = tv_nsec
|
||
xorq %rdx, %rdx
|
||
movq $1000000, %rcx
|
||
divq %rcx # rax = tv_nsec / 1e6
|
||
addq %r8, %rax # total ms
|
||
shlq $3, %rax # tag as int
|
||
RET_VAL
|
||
|
||
# ============================================================
|
||
# TCP sockets: fd encoded as port (same as file ports).
|
||
# tcp-recv = sys_read, tcp-send = sys_write, tcp-close = close-port.
|
||
# ============================================================
|
||
|
||
# encode_port: %rdi = fd → %rax = port value
|
||
encode_port:
|
||
movq %rdi, %rax
|
||
addq $PORT_SPECIAL_BASE, %rax
|
||
shlq $3, %rax
|
||
orq $TAG_SPECIAL, %rax
|
||
ret
|
||
|
||
# decode_port: %rdi = port value → %rax = fd (or -1 if not a port)
|
||
decode_port:
|
||
movq %rdi, %rax
|
||
andq $TAG_MASK, %rax
|
||
cmpq $TAG_SPECIAL, %rax
|
||
jne .dp_bad
|
||
movq %rdi, %rax
|
||
shrq $3, %rax
|
||
cmpq $PORT_SPECIAL_BASE, %rax
|
||
jl .dp_bad
|
||
subq $PORT_SPECIAL_BASE, %rax
|
||
ret
|
||
.dp_bad:
|
||
movq $-1, %rax
|
||
ret
|
||
|
||
# bi_tcp_listen: (tcp-listen port) → port or #f
|
||
bi_tcp_listen:
|
||
GETARG %rax
|
||
sarq $3, %rax # untag int → port number
|
||
movq %rax, %rbp # save port
|
||
|
||
# socket(AF_INET, SOCK_STREAM, 0)
|
||
movq $SYS_SOCKET, %rax
|
||
movq $AF_INET, %rdi
|
||
movq $SOCK_STREAM, %rsi
|
||
xorq %rdx, %rdx
|
||
syscall
|
||
testq %rax, %rax
|
||
js .tl_fail
|
||
movq %rax, %rbx # fd
|
||
|
||
# setsockopt(fd, SOL_SOCKET, SO_REUSEADDR, &one, 4)
|
||
subq $16, %rsp
|
||
movl $1, (%rsp)
|
||
movq $SYS_SETSOCKOPT, %rax
|
||
movq %rbx, %rdi
|
||
movq $SOL_SOCKET, %rsi
|
||
movq $SO_REUSEADDR, %rdx
|
||
movq %rsp, %r10
|
||
movq $4, %r8
|
||
syscall
|
||
addq $16, %rsp
|
||
|
||
# Build sockaddr_in on stack (16 bytes):
|
||
# [0:2] sin_family = AF_INET = 2
|
||
# [2:4] sin_port = htons(port)
|
||
# [4:8] sin_addr = 0 (INADDR_ANY)
|
||
# [8:16] padding = 0
|
||
subq $16, %rsp
|
||
movw $AF_INET, (%rsp)
|
||
# htons(port): swap bytes of lower 16 bits
|
||
movq %rbp, %rax
|
||
movw %ax, %cx
|
||
rolw $8, %cx
|
||
movw %cx, 2(%rsp)
|
||
movl $0, 4(%rsp)
|
||
movq $0, 8(%rsp)
|
||
|
||
# bind(fd, &addr, 16)
|
||
movq $SYS_BIND, %rax
|
||
movq %rbx, %rdi
|
||
movq %rsp, %rsi
|
||
movq $16, %rdx
|
||
syscall
|
||
addq $16, %rsp
|
||
testq %rax, %rax
|
||
js .tl_close_fail
|
||
|
||
# listen(fd, 128)
|
||
movq $SYS_LISTEN, %rax
|
||
movq %rbx, %rdi
|
||
movq $128, %rsi
|
||
syscall
|
||
testq %rax, %rax
|
||
js .tl_close_fail
|
||
|
||
movq %rbx, %rdi
|
||
call encode_port
|
||
RET_VAL
|
||
.tl_close_fail:
|
||
movq $SYS_CLOSE, %rax
|
||
movq %rbx, %rdi
|
||
syscall
|
||
.tl_fail:
|
||
movq $VAL_FALSE, %rax
|
||
RET_VAL
|
||
|
||
# bi_tcp_accept: (tcp-accept server) → port or #f
|
||
bi_tcp_accept:
|
||
GETARG %rdi
|
||
call decode_port
|
||
cmpq $0, %rax
|
||
jl .ta_fail
|
||
movq %rax, %rbx # server fd
|
||
|
||
# accept(fd, &addr, &addrlen); reserve 32 bytes:
|
||
# [0..4] addrlen (in: 16, out: 16)
|
||
# [8..24] sockaddr_in (16 bytes)
|
||
subq $32, %rsp
|
||
movl $16, (%rsp)
|
||
movq $SYS_ACCEPT, %rax
|
||
movq %rbx, %rdi
|
||
leaq 8(%rsp), %rsi # sockaddr buffer (16 bytes)
|
||
movq %rsp, %rdx # addrlen ptr
|
||
syscall
|
||
addq $32, %rsp
|
||
testq %rax, %rax
|
||
js .ta_fail
|
||
movq %rax, %rdi
|
||
call encode_port
|
||
RET_VAL
|
||
.ta_fail:
|
||
movq $VAL_FALSE, %rax
|
||
RET_VAL
|
||
|
||
# bi_tcp_connect: (tcp-connect host port) → port or #f
|
||
# Only supports dotted-quad IPv4 addresses (no DNS).
|
||
bi_tcp_connect:
|
||
GETARG %rdi # host string
|
||
GETARG %rax # port int
|
||
sarq $3, %rax
|
||
movq %rax, %rbp # port number
|
||
|
||
# Parse dotted quad into 4-byte addr on stack
|
||
subq $8, %rsp # buf
|
||
movl $0, (%rsp)
|
||
andq $-8, %rdi
|
||
movq (%rdi), %rcx # length
|
||
leaq 8(%rdi), %rdi # bytes
|
||
xorq %r8, %r8 # octet value
|
||
xorq %r9, %r9 # octet index (0..3)
|
||
.tc_parse:
|
||
testq %rcx, %rcx
|
||
jz .tc_store
|
||
movzbq (%rdi), %rax
|
||
cmpb $'.', %al
|
||
je .tc_dot
|
||
subb $'0', %al
|
||
cmpb $9, %al
|
||
ja .tc_fail_parse
|
||
imulq $10, %r8
|
||
addq %rax, %r8
|
||
incq %rdi
|
||
decq %rcx
|
||
jmp .tc_parse
|
||
.tc_dot:
|
||
movq %r9, %rax
|
||
movb %r8b, (%rsp,%rax)
|
||
incq %r9
|
||
cmpq $4, %r9
|
||
jge .tc_fail_parse
|
||
xorq %r8, %r8
|
||
incq %rdi
|
||
decq %rcx
|
||
jmp .tc_parse
|
||
.tc_store:
|
||
movq %r9, %rax
|
||
movb %r8b, (%rsp,%rax)
|
||
|
||
# socket()
|
||
movq $SYS_SOCKET, %rax
|
||
movq $AF_INET, %rdi
|
||
movq $SOCK_STREAM, %rsi
|
||
xorq %rdx, %rdx
|
||
syscall
|
||
testq %rax, %rax
|
||
js .tc_fail
|
||
movq %rax, %rbx # fd
|
||
|
||
# Build sockaddr_in
|
||
subq $16, %rsp
|
||
movw $AF_INET, (%rsp)
|
||
movq %rbp, %rax
|
||
movw %ax, %cx
|
||
rolw $8, %cx
|
||
movw %cx, 2(%rsp)
|
||
movl 16(%rsp), %eax # the parsed IP (dword at original buf)
|
||
movl %eax, 4(%rsp)
|
||
movq $0, 8(%rsp)
|
||
|
||
movq $SYS_CONNECT, %rax
|
||
movq %rbx, %rdi
|
||
movq %rsp, %rsi
|
||
movq $16, %rdx
|
||
syscall
|
||
addq $16, %rsp
|
||
addq $8, %rsp # discard parse buf
|
||
testq %rax, %rax
|
||
js .tc_close_fail
|
||
|
||
movq %rbx, %rdi
|
||
call encode_port
|
||
RET_VAL
|
||
|
||
.tc_close_fail:
|
||
movq $SYS_CLOSE, %rax
|
||
movq %rbx, %rdi
|
||
syscall
|
||
jmp .tc_fail_noparsebuf
|
||
.tc_fail_parse:
|
||
.tc_fail:
|
||
addq $8, %rsp
|
||
.tc_fail_noparsebuf:
|
||
movq $VAL_FALSE, %rax
|
||
RET_VAL
|
||
|
||
# bi_tcp_recv: (tcp-recv sock max) → string or #f
|
||
bi_tcp_recv:
|
||
GETARG %rdi
|
||
call decode_port
|
||
cmpq $0, %rax
|
||
jl .tr_fail
|
||
movq %rax, %rbx # fd
|
||
GETARG %rax # max bytes
|
||
sarq $3, %rax
|
||
cmpq $65536, %rax
|
||
jle .tr_ok
|
||
movq $65536, %rax # cap at 64 KB
|
||
.tr_ok:
|
||
movq %rax, %rbp # size
|
||
|
||
# Allocate string cell: 8-byte length + size bytes
|
||
movq %rbp, %rdi
|
||
addq $8, %rdi
|
||
call heap_alloc
|
||
.ifdef GC_NAIVE
|
||
orq $(HT_STRING << 8), -8(%rax)
|
||
.endif
|
||
movq %rax, %r12 # string object base
|
||
|
||
# read(fd, cell+8, size)
|
||
movq $SYS_READ, %rax
|
||
movq %rbx, %rdi
|
||
leaq 8(%r12), %rsi
|
||
movq %rbp, %rdx
|
||
syscall
|
||
testq %rax, %rax
|
||
js .tr_fail
|
||
movq %rax, (%r12) # actual length
|
||
|
||
movq %r12, %rax
|
||
orq $TAG_STRING, %rax
|
||
RET_VAL
|
||
.tr_fail:
|
||
movq $VAL_FALSE, %rax
|
||
RET_VAL
|
||
|
||
# bi_tcp_send: (tcp-send sock string) → int bytes written or #f
|
||
bi_tcp_send:
|
||
GETARG %rdi
|
||
call decode_port
|
||
cmpq $0, %rax
|
||
jl .ts_fail
|
||
movq %rax, %rbx # fd
|
||
|
||
GETARG %rdi # string
|
||
andq $-8, %rdi
|
||
movq (%rdi), %rdx # length
|
||
leaq 8(%rdi), %rsi # bytes
|
||
|
||
movq $SYS_WRITE, %rax
|
||
movq %rbx, %rdi
|
||
syscall
|
||
testq %rax, %rax
|
||
js .ts_fail
|
||
shlq $3, %rax # tag as int
|
||
RET_VAL
|
||
.ts_fail:
|
||
movq $VAL_FALSE, %rax
|
||
RET_VAL
|
||
|
||
# ============================================================
|
||
# list_reverse: %rdi = list -> %rax = reversed list
|
||
# ============================================================
|
||
list_reverse:
|
||
pushq %rbx
|
||
movq $VAL_NIL, %rbx # acc
|
||
.lr_loop:
|
||
cmpq $VAL_NIL, %rdi
|
||
je .lr_done
|
||
movq %rdi, %rax
|
||
andq $-8, %rax
|
||
movq 8(%rax), %rcx # cdr
|
||
movq (%rax), %rdi # car
|
||
pushq %rcx
|
||
movq %rbx, %rsi
|
||
call make_pair
|
||
movq %rax, %rbx
|
||
popq %rdi # continue with cdr
|
||
jmp .lr_loop
|
||
.lr_done:
|
||
movq %rbx, %rax
|
||
popq %rbx
|
||
ret
|
||
|
||
# ============================================================
|
||
# Initialization
|
||
# ============================================================
|
||
|
||
init_special_forms:
|
||
pushq %rbx
|
||
|
||
leaq sf_quote(%rip), %rdi
|
||
call intern_static
|
||
movq %rax, sym_quote_val(%rip)
|
||
|
||
leaq sf_if(%rip), %rdi
|
||
call intern_static
|
||
movq %rax, sym_if_val(%rip)
|
||
|
||
leaq sf_define(%rip), %rdi
|
||
call intern_static
|
||
movq %rax, sym_define_val(%rip)
|
||
|
||
leaq sf_setbang(%rip), %rdi
|
||
call intern_static
|
||
movq %rax, sym_setbang_val(%rip)
|
||
|
||
leaq sf_lambda(%rip), %rdi
|
||
call intern_static
|
||
movq %rax, sym_lambda_val(%rip)
|
||
|
||
leaq sf_begin(%rip), %rdi
|
||
call intern_static
|
||
movq %rax, sym_begin_val(%rip)
|
||
|
||
leaq sf_let(%rip), %rdi
|
||
call intern_static
|
||
movq %rax, sym_let_val(%rip)
|
||
|
||
leaq sf_cond(%rip), %rdi
|
||
call intern_static
|
||
movq %rax, sym_cond_val(%rip)
|
||
|
||
leaq sf_and(%rip), %rdi
|
||
call intern_static
|
||
movq %rax, sym_and_val(%rip)
|
||
|
||
leaq sf_or(%rip), %rdi
|
||
call intern_static
|
||
movq %rax, sym_or_val(%rip)
|
||
|
||
leaq sf_else(%rip), %rdi
|
||
call intern_static
|
||
movq %rax, sym_else_val(%rip)
|
||
|
||
popq %rbx
|
||
ret
|
||
|
||
init_builtins:
|
||
pushq %rbx
|
||
pushq %r12
|
||
|
||
leaq bi_names(%rip), %rbx
|
||
xorq %r12, %r12 # index
|
||
|
||
.ib_loop:
|
||
cmpq $BI_COUNT, %r12
|
||
jge .ib_done
|
||
|
||
movq (%rbx,%r12,8), %rdi # name pointer
|
||
call intern_static
|
||
pushq %rax # save symbol
|
||
|
||
movq %r12, %rdi
|
||
call make_builtin
|
||
movq %rax, %rsi # builtin val
|
||
|
||
popq %rdi # symbol
|
||
movq %r14, %rdx
|
||
call env_define
|
||
movq %rax, %r14
|
||
|
||
incq %r12
|
||
jmp .ib_loop
|
||
|
||
.ib_done:
|
||
popq %r12
|
||
popq %rbx
|
||
ret
|