# lumbda.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_SENDFILE, 40 .equ SYS_CLOCK_GETTIME, 228 .equ CLOCK_REALTIME, 0 .equ SYS_PIPE2, 293 .equ SYS_FORK, 57 .equ SYS_EXECVE,59 .equ SYS_DUP2, 33 .equ SYS_UNLINK, 87 .equ SYS_WAIT4, 61 .equ SYS_NANOSLEEP, 35 .equ WNOHANG, 1 .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). Bumped # from 1 MB to 4 MB on 2026-06-05 — ecdsa test-mod-inv-by at p=251 # OOM'd at 32 chunks × 1 MB even though gc was reclaiming, because # fragmented free-list couldn't satisfy the next n+1=9 sim batch. # 4 MB × 32 chunks = 128 MB cap, still well below the 512 MB # ulimit -v envelope our asm tests run under. .equ HEAP_SIZE, 0x400000 # 4 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 .equ BI_TCPSENDFILE, 108 .equ BI_ISQRT, 109 .equ BI_RANDOMSEED, 110 .equ BI_RANDOMINT, 111 .equ BI_RANDOMSTATE, 112 .equ BI_RANDOMSTATESET, 113 .equ BI_RANDOMSEEDFROMOS, 114 .equ BI_CADR, 115 .equ BI_SORT, 116 .equ BI_GENSYM, 117 .equ BI_EXIT, 118 .equ BI_VALUES, 119 .equ BI_CWV, 120 .equ BI_SPAWNPROC, 121 .equ BI_FLUSHPORT, 122 .equ BI_READLINE, 123 .ifdef GC_NAIVE .equ BI_GC_COLLECT, 124 .equ BI_GC_STATS, 125 .equ BI_WITH_ARENA, 126 .equ BI_ARENA_STATS, 127 .equ BI_ARENA_SET_MODE, 128 .equ BI_STRTOSYM, 129 .equ BI_DELETEFILE, 130 .equ BI_FORKSELF, 131 .equ BI_WAITPIDNB, 132 .equ BI_EXITIMM, 133 .equ BI_SLEEP, 134 .equ BI_COUNT, 135 .else .equ BI_STRTOSYM, 124 .equ BI_DELETEFILE, 125 .equ BI_FORKSELF, 126 .equ BI_WAITPIDNB, 127 .equ BI_EXITIMM, 128 .equ BI_SLEEP, 129 .equ BI_COUNT, 130 .endif # ============================================================ .data # ============================================================ prompt_str: .ascii "lumbda> " .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_let_star: .byte 4; .ascii "let*" sf_cond: .byte 4; .ascii "cond" .ifdef CL_FULL sf_quasiquote: .byte 10; .ascii "quasiquote" sf_unquote: .byte 7; .ascii "unquote" sf_unquote_spl: .byte 16; .ascii "unquote-splicing" sf_define_mac: .byte 12; .ascii "define-macro" .endif sf_and: .byte 3; .ascii "and" sf_or: .byte 2; .ascii "or" sf_else: .byte 4; .ascii "else" sf_when: .byte 4; .ascii "when" sf_unless: .byte 6; .ascii "unless" sf_case: .byte 4; .ascii "case" # 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_isqrt: .byte 5; .ascii "isqrt" bn_randomseed: .byte 12; .ascii "random-seed!" bn_randomint: .byte 10; .ascii "random-int" bn_randomstate: .byte 12; .ascii "random-state" bn_randomstateset: .byte 13; .ascii "random-state!" bn_randomseedfromos: .byte 20; .ascii "random-seed-from-os!" 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_tcpsendfile: .byte 12; .ascii "tcp-sendfile" bn_spawnproc: .byte 19; .ascii "spawn-process-stdio" bn_flushport: .byte 10; .ascii "flush-port" bn_readline: .byte 9; .ascii "read-line" bn_deletefile: .byte 11; .ascii "delete-file" 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_strtosym: .byte 14; .ascii "string->symbol" 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" bn_cadr: .byte 4; .ascii "cadr" bn_sort: .byte 4; .ascii "sort" bn_gensym: .byte 6; .ascii "gensym" bn_exit: .byte 4; .ascii "exit" bn_values: .byte 6; .ascii "values" bn_cwv: .byte 16; .ascii "call-with-values" bn_forkself: .byte 9; .ascii "fork-self" bn_waitpidnb: .byte 16; .ascii "waitpid-nonblock" bn_exitimm: .byte 14; .ascii "exit-immediate" bn_sleep: .byte 5; .ascii "sleep" .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 "#" .equ s_hashtable_len, . - s_hashtable s_hashset: .ascii "#" .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 # ── Default prelude — always loaded, every binary tier ─────────── # Defines the Scheme-side aliases that cross-tier .lsp code expects # to exist on the plain `lumbda` and `lumbda-gc` builds (not just # `lumbda-full`). Kept minimal: every entry here ships in every # binary, so add only universally-needed forms. (Defect #30 in our # ecdsa cross-tier validation: `eq?` was only present under CL_FULL, # leaving `lumbda` and `lumbda-gc` with `eqv?` but no `eq?`.) default_prelude: .ascii "(define eq? eqv?)\n" .equ default_prelude_len, . - default_prelude .ifdef CL_FULL # ── CL_FULL prelude — auto-loaded Scheme definitions ────────────── # Runs once at init, after builtins + RNG seed, before the REPL. # Defines the small accessors + helpers that cl-compat.lsp depends # on. Kept intentionally tight so the prelude parses in one pass # and adds only a few hundred bytes to the binary. cl_full_prelude: .ascii "(define (caar x) (car (car x)))\n" .ascii "(define (cdar x) (cdr (car x)))\n" .ascii "(define (cadar x) (car (cdr (car x))))\n" .ascii "(define (caddr x) (car (cdr (cdr x))))\n" .ascii "(define (cadddr x) (car (cdr (cdr (cdr x)))))\n" .ascii "(define (cddr x) (cdr (cdr x)))\n" .ascii "(define (cdddr x) (cdr (cdr (cdr x))))\n" .ascii "(define (cddddr x) (cdr (cdr (cdr (cdr x)))))\n" .ascii "(define (1+ n) (+ n 1))\n" .ascii "(define (1- n) (- n 1))\n" .ascii "(define (add1 n) (+ n 1))\n" .ascii "(define (sub1 n) (- n 1))\n" .ascii "(define (square x) (* x x))\n" .ascii "(define (list-ref lst i)" .ascii " (if (= i 0) (car lst) (list-ref (cdr lst) (- i 1))))\n" .ascii "(define eq? eqv?)\n" .ascii "(define (memq x lst)" .ascii " (cond ((null? lst) #f)" .ascii " ((eq? x (car lst)) lst)" .ascii " (else (memq x (cdr lst)))))\n" .ascii "(define (assq key alist)" .ascii " (cond ((null? alist) #f)" .ascii " ((eq? (car (car alist)) key) (car alist))" .ascii " (else (assq key (cdr alist)))))\n" # `case` as a macro — once define-macro is live, we can express # this in Scheme rather than carving out another special form. .ascii "(define-macro (case expr . clauses)" .ascii " (let ((tmp (gensym)))" .ascii " `(let ((,tmp ,expr))" .ascii " (cond ,@(map (lambda (c)" .ascii " (if (eq? (car c) (quote else))" .ascii " `(else ,@(cdr c))" .ascii " `((member ,tmp (quote ,(car c))) ,@(cdr c))))" .ascii " clauses)))))\n" .equ cl_full_prelude_len, . - cl_full_prelude .endif bn_mval_tag: .byte 17; .ascii "__values-marker__" portal_magic: .ascii "LUMBDAB2" .equ PORTAL_MAGIC_LEN, 8 # magic(8) + heap_size(8) + heap_base(8) + r14(8) + r15(8) # + rng_state[0..3] (32) + reserved(8) = 80 bytes # Bumped from LUMBDAB1/48 to LUMBDAB2/80 for xoshiro256** state capture. # See docs/tickets/0001-portal-rng.md. .equ PORTAL_HDR_SIZE, 80 # 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 .quad bn_tcpsendfile .quad bn_isqrt .quad bn_randomseed, bn_randomint, bn_randomstate, bn_randomstateset .quad bn_randomseedfromos .quad bn_cadr, bn_sort, bn_gensym, bn_exit, bn_values, bn_cwv .quad bn_spawnproc, bn_flushport, bn_readline .ifdef GC_NAIVE .quad bn_gccollect, bn_gcstats, bn_witharena, bn_arenastats, bn_arenamode .endif .quad bn_strtosym, bn_deletefile .quad bn_forkself, bn_waitpidnb, bn_exitimm, bn_sleep # 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 err_isqrt_neg: .ascii "Error: isqrt: negative argument\n" .equ err_isqrt_neg_len, . - err_isqrt_neg err_rng_bad_n: .ascii "Error: random-int: n must be positive\n" .equ err_rng_bad_n_len, . - err_rng_bad_n err_rng_short: .ascii "Error: random-state!: expected list of 8 integers\n" .equ err_rng_short_len, . - err_rng_short err_rng_urandom: .ascii "Error: random-seed-from-os!: /dev/urandom unavailable\n" .equ err_rng_urandom_len, . - err_rng_urandom err_str_overflow: .ascii "Error: scheme_read: string literal exceeds 4080-byte buffer\n" .equ err_str_overflow_len, . - err_str_overflow s_dev_urandom: .asciz "/dev/urandom" # Print strings s_true: .ascii "#t" s_false: .ascii "#f" s_nil: .ascii "()" s_void: .ascii "#" s_proc: .ascii "#" s_bi: .ascii "#" s_port: .ascii "#" s_lparen: .ascii "(" s_rparen: .ascii ")" s_space: .ascii " " s_pdefine: .ascii "(define " .equ s_pdefine_len, 8 s_quote_op: .ascii " (quote " .equ s_quote_op_len, 8 s_rparen2_nl: .ascii "))\n" s_rparen_nl: .ascii ")\n" s_dotsp: .ascii " . " s_minus: .ascii "-" s_hashparen: .ascii "#(" # Portal v1 header. GC-build portal-save emits this as the first # line of every output file; portal-resume reads the first bytes # and verifies the prefix before loading. A file starting with ";;" # that does NOT match is rejected as an unsupported version. A file # that does not start with ";;" at all is accepted as legacy # (pre-v1) and loaded normally for back-compat. s_portal_v1: .ascii ";; lumbda-portal v1\n" .equ s_portal_v1_len, 20 # 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_let_star_val: .quad 0 sym_cond_val: .quad 0 .ifdef CL_FULL sym_quasiquote_val: .quad 0 sym_unquote_val: .quad 0 sym_unquote_spl_val: .quad 0 sym_define_mac_val: .quad 0 .endif sym_and_val: .quad 0 sym_or_val: .quad 0 sym_else_val: .quad 0 sym_when_val: .quad 0 sym_unless_val: .quad 0 sym_case_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 # xoshiro256** state — 4 × u64 words. Portal header at LUMBDAB2 layout # offset 40 carries these; save/resume copies to/from here. # See docs/tickets/0001-portal-rng.md. .align 8 g_rng_state: .skip 32 # 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 gensym_counter: .skip 8 # bumped each call to (gensym) num_buf_lp: .skip 64 # scratch [len:byte][chars...] for intern mval_marker: .skip 8 # interned symbol; marks multi-value packets .ifdef CL_FULL # macro_env_head — linked list of (sym, closure, next) 24-byte nodes. # define-macro prepends. eval-time lookup walks the chain. Separate # from the value env because macros expand before argument evaluation; # putting them in the regular env would confuse argument dispatch. macro_env_head: .skip 8 .endif .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, 262144 # 256K tagged values; 2 MB # Bumped 16K → 256K on 2026-06-05. The original silent-drop on stack # overflow (gc_push_if_heap .gpih_end) claims "correctness preserved" # but actually loses live roots: a dropped value never gets the mark # bit set in gc_mark_drain, so gc_sweep reclaims it. Surfaced on # ecdsa task #47 — test-mod-inv-by at p=251 (n+1=9) produces enough # live registers + intermediate cons-cells across simulate to exceed # 16K tagged values, after which random heap data starts vanishing # and hash-table-ref reports "missing key" on entries we just set. # 256K covers our peak with ~2× headroom; full cost is 2 MB of .bss # (the same as one HEAP_SIZE chunk). 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 GC_MARK_STACK_CAP * 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 # Default xoshiro256** seed = 0 so (random) is deterministic and # non-zero from process start. All three impls agree on this state. xorq %rdi, %rdi call rng_seed # Always-on prelude — defines `eq?` (and any future cross-tier # aliases). Required for parity with our Python + C tiers, which # carry these via their own preludes / native builtins. call load_default_prelude .ifdef CL_FULL # Auto-load the CL_FULL prelude (caddr, 1+, list-ref, assq, …). # Runs before the REPL so user code sees the helpers immediately. call load_cl_full_prelude .endif # ─── argv script-mode handling ─────────────────────────────── # Stack layout at _start entry (preserved through here — the # only %rsp mutations above are paired sub/add 256 around ioctl): # 0(%rsp) = argc, 8(%rsp) = argv[0], 16(%rsp) = argv[1], … # For each argv[i] (i >= 1): # * Skip args starting with '-' (flag stubs, no-op for now). # * Otherwise treat as a script path: build a Scheme string, # wrap in a 1-element arg list, dispatch (load "path") via # apply_proc_raw on the BI_LOAD builtin. # If any non-flag arg was consumed, exit after processing all # args instead of entering the REPL. Mirrors c/main.c:234-252. # # %rbx = argc (callee-saved across apply_proc_raw). # %rbp = current argv index (1-based). # %r13 is the heap limit, so we cannot use it here — use a stack # slot for the "any-script-loaded" flag instead. movq 0(%rsp), %rbx # argc cmpq $1, %rbx jle .argv_done # argc <= 1 → no args, fall through pushq $0 # [rsp+0] = any-script-loaded flag (0 = none yet) movq $1, %rbp # i = 1 (skip argv[0]) .argv_loop: cmpq %rbx, %rbp jge .argv_loop_done # argv pointer table sits at 8(%rsp_orig). We pushed one qword # (the flag), so add 8 to compensate. movq 16(%rsp,%rbp,8), %rdi # argv[i] = C string pointer # Skip if starts with '-' cmpb $'-', (%rdi) je .argv_next # Compute strlen of argv[i] → %rcx movq %rdi, %rcx .argv_strlen: cmpb $0, (%rcx) je .argv_strlen_done incq %rcx jmp .argv_strlen .argv_strlen_done: subq %rdi, %rcx # %rcx = length # Allocate Scheme string: heap_alloc(8 + length) pushq %rdi # save C string pointer pushq %rcx # save length leaq 8(%rcx), %rdi call heap_alloc .ifdef GC_NAIVE movb $HT_STRING, -7(%rax) .endif popq %rcx # restore length popq %rdi # restore C string pointer movq %rcx, (%rax) # store 8-byte length header # Copy bytes from argv[i] into payload at 8(%rax) xorq %rdx, %rdx .argv_copy: cmpq %rcx, %rdx jge .argv_copy_done movb (%rdi,%rdx), %sil movb %sil, 8(%rax,%rdx) incq %rdx jmp .argv_copy .argv_copy_done: orq $TAG_STRING, %rax # tag as Scheme string # Build 1-element arg list: (cons str NIL) movq %rax, %rdi movq $VAL_NIL, %rsi call make_pair movq %rax, %rsi # args list # BI_LOAD builtin value = (BI_LOAD << 3) | TAG_BUILTIN movq $((BI_LOAD << 3) | TAG_BUILTIN), %rdi # apply_proc_raw → bi_load returns via RET_VAL, which pops # r12/rbp/rbx in an order that leaves %rbp corrupted (it gets # the pre-call %r12 instead of pre-call %rbp). Save %rbp ourselves # across the call so our loop counter survives. %rbx (argc) is # restored cleanly. pushq %rbp call apply_proc_raw popq %rbp # Mark that at least one script ran. movq $1, 0(%rsp) .argv_next: incq %rbp jmp .argv_loop .argv_loop_done: # Pop flag; if non-zero, exit (don't enter REPL). popq %rax testq %rax, %rax jnz repl_exit .argv_done: # 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: # Pin the abandoned chunk's stored end to %r15 (its high-water). # In the padded path above this is a no-op (r15 already == r13). # In the un-padded path (tail < 16) r15 sits short of r13 and the # gap holds mmap-zeros. Without this update, gc_sweep would still # walk to the original mmap end, decode the zero pages as fake # dead blocks, and on the final iteration write the free-list # next-pointer to (chunk_end - 8) + 8 == chunk_end — the first # byte of an unmapped page — and segfault in .gsw_dead. Tying # chunk_end to r15 stops the walker at the high-water mark. # Discovered while diagnosing ecdsa task #45, 2026-06-05. movq gc_chunk_count(%rip), %rdx decq %rdx leaq gc_chunk_end(%rip), %rcx movq %r15, (%rcx,%rdx,8) # Chunk size: at least HEAP_SIZE, but large enough for this one # block. A single big allocation (e.g. file->string on a ~3 MB # PDF) would otherwise loop forever because each mmap'd 1 MB # chunk still doesn't fit. Round up (8+%rbx) to HEAP_SIZE # multiples so small allocs still land in standard-sized chunks. leaq 8(%rbx), %rcx # required bytes cmpq $HEAP_SIZE, %rcx jbe .ha_grow_std # Oversize: pad up to HEAP_SIZE alignment and use that. addq $(HEAP_SIZE - 1), %rcx movq $HEAP_SIZE, %rdx negq %rdx # rdx = -HEAP_SIZE (low bits = 0-HEAP_SIZE mask) andq %rdx, %rcx jmp .ha_grow_do_mmap .ha_grow_std: movq $HEAP_SIZE, %rcx .ha_grow_do_mmap: movq %rcx, %r12 # stash size across the syscall movq $SYS_MMAP, %rax xorq %rdi, %rdi movq %r12, %rsi # chunk size movq $3, %rdx movq $0x22, %r10 movq $-1, %r8 xorq %r9, %r9 syscall cmpq $-1, %rax je die_oom movq %rax, %r15 addq %r12, %rax # chunk end movq %rax, %r13 movq %r15, %rax # restore ptr (we'll use below) 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 .ifdef CL_FULL # Root 1b: macro_env_head — same (sym, val, next) shape as the # regular env. Without this, GC collects the macro table and the # next macro lookup fails with "unbound: " after any # collection cycle. movq macro_env_head(%rip), %rdi call gc_mark_env .endif # 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: accept env if type byte is HT_ENVNODE. # Fall back to the old heuristic (size==24 + offset-0 is # TAG_SYM) if the type byte is 0 — that covers any env node # whose type-tagging path didn't set the byte (shouldn't # happen in principle, but allocation bench workloads kept # losing env bindings, so we belt-and-suspender). movzbq -7(%rdi), %rax cmpq $HT_ENVNODE, %rax je .gme_typed_ok testq %rax, %rax jnz .gme_end # non-zero non-env type -> reject # type==0 fallback path movq -8(%rdi), %rax shrq $16, %rax cmpq $24, %rax jne .gme_end movq (%rdi), %rax andq $7, %rax cmpq $TAG_SYM, %rax jne .gme_end .gme_typed_ok: # 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 die_str_overflow: movq $SYS_WRITE, %rax movq $2, %rdi leaq err_str_overflow(%rip), %rsi movq $err_str_overflow_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 movb $HT_PAIR, -7(%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 movb $HT_CLOSURE, -7(%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 movb $HT_ENVNODE, -7(%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 movb $HT_SYMBOL, -7(%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 movb $HT_CHAINNODE, -7(%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 .ifdef CL_FULL cmpb $'`', %al je .sr_quasiquote cmpb $',', %al je .sr_unquote .endif 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 .ifdef CL_FULL .sr_quasiquote: call read_char # eat ` call scheme_read movq %rax, %rdi movq $VAL_NIL, %rsi call make_pair movq %rax, %rsi movq sym_quasiquote_val(%rip), %rdi call make_pair popq %r12 popq %rbx ret .sr_unquote: call read_char # eat , call peek_char cmpb $'@', %al je .sr_unquote_splicing # plain unquote call scheme_read movq %rax, %rdi movq $VAL_NIL, %rsi call make_pair movq %rax, %rsi movq sym_unquote_val(%rip), %rdi call make_pair popq %r12 popq %rbx ret .sr_unquote_splicing: call read_char # eat @ call scheme_read movq %rax, %rdi movq $VAL_NIL, %rsi call make_pair movq %rax, %rsi movq sym_unquote_spl_val(%rip), %rdi call make_pair popq %r12 popq %rbx ret .endif .sr_hash: call read_char # eat # call read_char cmpb $'t', %al je .sr_true cmpb $'f', %al je .sr_false cmpb $'(', %al je .sr_hash_vector movq $VAL_VOID, %rax popq %r12 popq %rbx ret .sr_hash_vector: # `(` already consumed. Read list of elements, convert to vector. call .read_list_elems movq %rax, %rdi # list (tagged) call list_to_vector_reader popq %r12 popq %rbx ret # list_to_vector_reader: %rdi = tagged list -> %rax = tagged vector. # Separate from bi_listtovec (which uses GETARG) so the reader can # call it directly. list_to_vector_reader: pushq %rbx movq %rdi, %rbx # save list xorq %rcx, %rcx movq %rdi, %rax .l2vr_count: cmpq $VAL_NIL, %rax je .l2vr_alloc incq %rcx movq %rax, %rdx andq $-8, %rdx movq 8(%rdx), %rax jmp .l2vr_count .l2vr_alloc: pushq %rbx pushq %rcx leaq 8(,%rcx,8), %rdi call heap_alloc .ifdef GC_NAIVE movb $HT_VECTOR, -7(%rax) .endif popq %rcx popq %rbx movq %rcx, (%rax) leaq 8(%rax), %rdi movq %rbx, %rdx .l2vr_fill: cmpq $VAL_NIL, %rdx je .l2vr_done movq %rdx, %rcx andq $-8, %rcx movq (%rcx), %rsi movq %rsi, (%rdi) addq $8, %rdi movq 8(%rcx), %rdx jmp .l2vr_fill .l2vr_done: orq $7, %rax 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: # Save start position for backtrack — if after reading digits we # find a non-delimiter, this was actually a symbol (e.g. `1+`, # `1-`). Rewind input_pos and fall through to .sr_symbol. movq input_pos(%rip), %r12 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: # Check: is the next char a delimiter (end of lexeme)? call peek_char cmpq $-1, %rax je .sr_num_return cmpb $' ', %al jle .sr_num_return # whitespace incl. < 0x20 cmpb $'(', %al je .sr_num_return cmpb $')', %al je .sr_num_return cmpb $';', %al je .sr_num_return cmpb $'"', %al je .sr_num_return cmpb $'\'', %al je .sr_num_return # Non-delimiter after digits — this lexeme is a symbol, not a # number. Rewind and fall through to .sr_symbol. movq %r12, input_pos(%rip) jmp .sr_symbol .sr_num_return: 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: # Reads a "..." string literal into a 4080-byte stack buffer, then # heap-allocates the final string. Buffer bumped from 256B (which # smashed the saved return address on strings > 272 chars and # produced a #GP fault — see ecdsa lumbda task #34, 2026-06-04). # 4080 chosen to keep the frame size under 4096 (one page) while # bounding via cmpq below. If a string literal exceeds the cap, # exit cleanly via die_str_overflow rather than corrupting %rip. call read_char # eat opening " subq $4096, %rsp xorq %rbx, %rbx # length .sr_str_loop: cmpq $4080, %rbx jge die_str_overflow 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 movb $HT_STRING, -7(%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 $4096, %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_let_star_val(%rip), %rbx je .ev_let_star 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 cmpq sym_when_val(%rip), %rbx je .ev_when cmpq sym_unless_val(%rip), %rbx je .ev_unless cmpq sym_case_val(%rip), %rbx je .ev_case .ifdef CL_FULL cmpq sym_quasiquote_val(%rip), %rbx je .ev_quasiquote cmpq sym_define_mac_val(%rip), %rbx je .ev_define_macro # User-defined macro? Look up in macro table; on hit, expand + re-eval. movq %rbx, %rdi pushq %r12 pushq %rbp call macro_lookup popq %rbp popq %r12 testq %rax, %rax jnz .ev_macro_expand .endif # 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 # ---- let* (sequential binding — each init sees preceding bindings) ---- .ev_let_star: # (let* ((v1 e1) ...) body...) movq %r12, %rax andq $-8, %rax movq (%rax), %rbx # bindings movq 8(%rax), %r12 # body movq %rbp, %rcx # extended env starts as current env .ev_lets_binds: cmpq $VAL_NIL, %rbx je .ev_lets_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 EXTENDED env (distinguishes let* from let) pushq %rbx pushq %rcx pushq %r8 movq %rcx, %rsi # eval in extended env call eval popq %r8 popq %rcx popq %rbx pushq %rbx movq %r8, %rdi movq %rax, %rsi movq %rcx, %rdx call env_define movq %rax, %rcx popq %rbx jmp .ev_lets_binds .ev_lets_body: movq %rcx, %rbp movq %r12, %rdi 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 # ---- when ---- # (when test body...) — if test is truthy, eval body as begin; # else return void. Available on every asm tier (defect #31 in our # ecdsa cross-tier validation: when/unless are R7RS standard but # previously only reachable on tiers carrying define-macro). .ev_when: # %r12 = (test body...) cmpq $VAL_NIL, %r12 je .ev_begin_void # (when) → void (degenerate) movq %r12, %rax andq $-8, %rax movq (%rax), %rdi # test expr movq 8(%rax), %r12 # body forms pushq %r12 movq %rbp, %rsi call eval popq %r12 cmpq $VAL_FALSE, %rax je .ev_begin_void cmpq $VAL_NIL, %rax je .ev_begin_void # Truthy → run body via begin (TCO on last form) jmp .ev_begin # ---- unless ---- # (unless test body...) — inverse of when. .ev_unless: cmpq $VAL_NIL, %r12 je .ev_begin_void # (unless) → void movq %r12, %rax andq $-8, %rax movq (%rax), %rdi # test expr movq 8(%rax), %r12 # body forms pushq %r12 movq %rbp, %rsi call eval popq %r12 cmpq $VAL_FALSE, %rax je .ev_unless_run cmpq $VAL_NIL, %rax je .ev_unless_run # Truthy → skip body, return void jmp .ev_begin_void .ev_unless_run: jmp .ev_begin # ---- case ---- # (case key clause ...) where each clause is # ((datum ...) body...) or (else body...) # Evaluate `key` once, then walk clauses; for the first clause whose # datum list contains a value `eqv?` to key, evaluate body via begin # (TCO). `else` matches unconditionally and must be last. If no clause # matches, return void. R7RS standard form — Path B mirrors the just- # shipped `when`/`unless` fix (commit 865be28); previously case lived # only in cl_full_prelude as a define-macro form, leaving lumbda-gc # and bump-only lumbda unable to run ecdsa search.lsp. # eqv? on the asm tier is pointer equality (fixnums, symbols, bools, # chars, nil are all interned/unboxed to unique values). .ev_case: # %r12 = (key . clauses) cmpq $VAL_NIL, %r12 je .ev_begin_void # (case) → void (degenerate) movq %r12, %rax andq $-8, %rax movq (%rax), %rdi # key expr movq 8(%rax), %r12 # clauses pushq %r12 # save clauses movq %rbp, %rsi call eval popq %r12 # restore clauses pushq %rax # save key value on stack # Loop over clauses; key sits at (%rsp). .ev_case_loop: cmpq $VAL_NIL, %r12 je .ev_case_void movq %r12, %rax andq $-8, %rax movq (%rax), %rbx # current clause movq 8(%rax), %r12 # rest clauses # Clause shape: (datums . body) or (else . body) movq %rbx, %rax andq $-8, %rax movq (%rax), %rdx # datums (or `else` symbol) movq 8(%rax), %rcx # body forms # else clause matches unconditionally cmpq sym_else_val(%rip), %rdx je .ev_case_match # Walk datum list; key is at (%rsp) movq (%rsp), %rdi .ev_case_dloop: cmpq $VAL_NIL, %rdx je .ev_case_loop # exhausted datums → next clause movq %rdx, %rax andq $-8, %rax movq (%rax), %rsi # datum movq 8(%rax), %rdx # rest datums cmpq %rdi, %rsi # eqv? — pointer compare je .ev_case_match jmp .ev_case_dloop .ev_case_match: # %rcx = body forms. Discard saved key, run body via begin (TCO). addq $8, %rsp movq %rcx, %r12 jmp .ev_begin .ev_case_void: addq $8, %rsp # discard saved key jmp .ev_begin_void .ifdef CL_FULL # ---- quasiquote (CL_FULL only) ---- # (quasiquote template) walks `template`: # - (unquote EXPR) → evaluate EXPR in caller env # - ((unquote-splicing EXPR) # . REST) → append eval(EXPR) and expand(REST) # - other pairs → cons(expand(car), expand(cdr)) # - atoms / nil → returned as-is # Nested quasiquote is not handled at depth > 1 (matches the ticket # 0005 scope; cl-compat.lsp does not nest). .ev_quasiquote: movq %r12, %rax andq $-8, %rax movq (%rax), %rdi # template movq %rbp, %rsi # env call quasiquote_expand popq %r12 popq %rbp popq %rbx ret # quasiquote_expand: %rdi = template, %rsi = env -> %rax = expansion quasiquote_expand: # Atom? (not a pair) → return as-is. movq %rdi, %rax andq $TAG_MASK, %rax cmpq $TAG_PAIR, %rax jne .qe_atom pushq %rbx # Pair: destructure. movq %rdi, %rax andq $-8, %rax movq (%rax), %rbx # car movq 8(%rax), %rdx # cdr # (unquote X) at top of template → eval X, return. cmpq sym_unquote_val(%rip), %rbx je .qe_unquote_top # In list position: ((unquote-splicing X) . REST) → append(eval X, expand REST). # Check if car is a pair starting with 'unquote-splicing. movq %rbx, %rax andq $TAG_MASK, %rax cmpq $TAG_PAIR, %rax jne .qe_recurse_pair movq %rbx, %rax andq $-8, %rax movq (%rax), %rcx # caar cmpq sym_unquote_spl_val(%rip), %rcx je .qe_unquote_splicing .qe_recurse_pair: # Recurse on car and cdr, then cons. # %rdi free; %rbx=car, %rdx=cdr, %rsi=env. pushq %rdx # save cdr pushq %rsi # save env movq %rbx, %rdi call quasiquote_expand # rax = new car popq %rsi popq %rdx pushq %rax # save new car pushq %rsi # save env again movq %rdx, %rdi call quasiquote_expand # rax = new cdr popq %rsi popq %rdi # new car movq %rax, %rsi # new cdr call make_pair popq %rbx ret .qe_atom: movq %rdi, %rax ret .qe_unquote_top: # cdr = (X . nil); we want X = car(cdr). movq %rdx, %rax andq $-8, %rax movq (%rax), %rdi # X # %rsi env call eval popq %rbx ret .qe_unquote_splicing: # %rbx = car = (unquote-splicing X); %rdx = REST. # X = cadr(car). movq %rbx, %rax andq $-8, %rax movq 8(%rax), %rax # (X . nil) andq $-8, %rax movq (%rax), %rdi # X pushq %rdx # save REST pushq %rsi # save env call eval # rax = list to splice popq %rsi popq %rdx pushq %rax # save head list pushq %rsi # save env movq %rdx, %rdi # REST as template call quasiquote_expand popq %rsi popq %rdi # head list movq %rax, %rsi # tail list call list_append_ab popq %rbx ret # macro_lookup: %rdi = symbol (tagged) -> %rax = closure (tagged) or 0. # Linear walk over macro_env_head — acceptable because the macro table # is ~a dozen entries after cl-compat.lsp loads. macro_lookup: movq macro_env_head(%rip), %rax .ml_loop: testq %rax, %rax jz .ml_fail cmpq %rdi, (%rax) je .ml_found movq 16(%rax), %rax jmp .ml_loop .ml_found: movq 8(%rax), %rax ret .ml_fail: xorq %rax, %rax ret # (define-macro (name p...) body...) — build a closure, prepend to # macro_env_head. At eval time, any call whose operator matches `name` # takes the macro path: operator's UNEVALUATED args pass to the # closure, the returned expression is eval'd in the caller's env. .ev_define_macro: movq %r12, %rax andq $-8, %rax movq (%rax), %rbx # (name p...) movq 8(%rax), %r12 # body list movq %rbx, %rax andq $-8, %rax movq (%rax), %rcx # name movq 8(%rax), %rdx # params pushq %rcx pushq %rdx movq %r12, %rdi call wrap_begin movq %rax, %rsi # body popq %rdi # params movq %rbp, %rdx # closure env call make_closure movq %rax, %rsi # closure popq %rdi # name pushq %rdi pushq %rsi movq $24, %rdi call heap_alloc popq %rsi popq %rdi .ifdef GC_NAIVE movb $HT_ENVNODE, -7(%rax) .endif movq %rdi, (%rax) # sym movq %rsi, 8(%rax) # closure movq macro_env_head(%rip), %rcx movq %rcx, 16(%rax) # next movq %rax, macro_env_head(%rip) movq $VAL_VOID, %rax popq %r12 popq %rbp popq %rbx ret # Re-enter eval with the macro expansion — TCO preserves stack depth. .ev_macro_expand: # On entry: %rbx = macro sym, %r12 = unevaluated args, %rbp = env, # %rax = closure from the lookup above. movq %rax, %rdi # proc movq %r12, %rsi # args (unevaluated — the macro consumes them as data) pushq %rbp call apply_proc_raw # %rax = expansion popq %rbp movq %rax, %rdi # expansion as new expr jmp .eval_top # list_append_ab: %rdi=a, %rsi=b -> %rax = a++b (new copy of a with b as tail). # b is shared (not copied). If a is nil, returns b unchanged. list_append_ab: cmpq $VAL_NIL, %rdi jne 1f movq %rsi, %rax ret 1: pushq %rbx pushq %r12 movq %rsi, %r12 # save b movq $0, %rbx # head of copy (0 = none) movq $0, %rcx # tail of copy .lab_copy: cmpq $VAL_NIL, %rdi je .lab_link movq %rdi, %rax andq $-8, %rax pushq %rdi # save a pushq %rcx # save tail ptr movq (%rax), %rdi # car movq $VAL_NIL, %rsi call make_pair # new pair (car . nil) popq %rcx popq %rdi # restore a testq %rbx, %rbx jnz .lab_chain movq %rax, %rbx # head movq %rax, %rcx # tail jmp .lab_next .lab_chain: movq %rcx, %rdx andq $-8, %rdx movq %rax, 8(%rdx) # old tail.cdr = new movq %rax, %rcx # tail = new .lab_next: movq %rdi, %rax andq $-8, %rax movq 8(%rax), %rdi # a = cdr(a) jmp .lab_copy .lab_link: movq %rcx, %rax andq $-8, %rax movq %r12, 8(%rax) # tail.cdr = b movq %rbx, %rax # return head of copy popq %r12 popq %rbx ret .endif # ---- 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 # Rest-arg check: if %rdi is a raw symbol (not a pair), the param # list ended with `(. rest)` — bind rest-sym to remaining args. # Enables (define (f x . rest) ...) and (lambda (a . b) ...). movq %rdi, %rax andq $TAG_MASK, %rax cmpq $TAG_SYM, %rax je .ac_rest 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_rest: # %rdi = rest-sym (tagged), %rdx = remaining args list, %rsi = env. # env_define expects rdi=sym, rsi=val, rdx=env — shuffle. pushq %rcx # save body movq %rsi, %rcx # stash env movq %rdx, %rsi # val = remaining args list movq %rcx, %rdx # env call env_define movq %rax, %rsi # updated env popq %rcx # restore body jmp .ac_go .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_ISQRT, %rax je bi_isqrt cmpq $BI_RANDOMSEED, %rax je bi_random_seed_bang cmpq $BI_RANDOMINT, %rax je bi_random_int cmpq $BI_RANDOMSTATE, %rax je bi_random_state cmpq $BI_RANDOMSTATESET, %rax je bi_random_state_bang cmpq $BI_RANDOMSEEDFROMOS, %rax je bi_random_seed_from_os cmpq $BI_CADR, %rax je bi_cadr cmpq $BI_SORT, %rax je bi_sort cmpq $BI_GENSYM, %rax je bi_gensym cmpq $BI_EXIT, %rax je bi_exit cmpq $BI_FORKSELF, %rax je bi_forkself cmpq $BI_WAITPIDNB, %rax je bi_waitpid_nonblock cmpq $BI_EXITIMM, %rax je bi_exit_immediate cmpq $BI_SLEEP, %rax je bi_sleep cmpq $BI_VALUES, %rax je bi_values cmpq $BI_CWV, %rax je bi_call_with_values 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_STRTOSYM, %rax je bi_string_to_symbol 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 cmpq $BI_TCPSENDFILE, %rax je bi_tcp_sendfile cmpq $BI_SPAWNPROC, %rax je bi_spawn_process_stdio cmpq $BI_FLUSHPORT, %rax je bi_flush_port cmpq $BI_READLINE, %rax je bi_read_line cmpq $BI_DELETEFILE, %rax je bi_delete_file .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 $7, %rax # vector tag je .deq_vector 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 .deq_vector: # Both vectors. Compare lengths, then recurse elementwise. 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 # a elements leaq 8(%rcx), %r9 # b elements .deq_vec_loop: testq %rdx, %rdx jz .deq_true pushq %r8 pushq %r9 pushq %rdx movq (%r8), %rdi movq (%r9), %rsi call deep_equal popq %rdx popq %r9 popq %r8 cmpq $VAL_FALSE, %rax je .deq_false addq $8, %r8 addq $8, %r9 decq %rdx jmp .deq_vec_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 # Rest-args check: if %rcx (remaining params) is a raw symbol, # bind it to the remaining args list and proceed to body. movq %rcx, %rax andq $TAG_MASK, %rax cmpq $TAG_SYM, %rax je .apr_rest 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_rest: # %rcx = rest-sym, %rsi = remaining args list, %rbp = env. # env_define expects rdi=sym, rsi=val, rdx=env — shuffle. pushq %rdx # save body movq %rcx, %rdi # sym # %rsi already = args list (val) movq %rbp, %rdx # env call env_define movq %rax, %rbp popq %rdx # restore body jmp .apr_eval_body .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 # (gensym) → fresh interned symbol "gN". N starts at 0, increments # per call. Used by macro writers to avoid variable capture. bi_gensym: # Format "g" into num_buf, then intern. leaq num_buf(%rip), %rdi movb $'g', (%rdi) incq %rdi movq gensym_counter(%rip), %rax incq gensym_counter(%rip) # Convert %rax to decimal digits, written forward from %rdi. # Handle 0 specially. testq %rax, %rax jnz .bg_convert movb $'0', (%rdi) incq %rdi jmp .bg_terminate .bg_convert: # Write digits reversed into a small scratch buffer, then copy forward. pushq %rbx leaq num_buf+63(%rip), %rbx # tmp pointer — write backward movb $0, (%rbx) .bg_digits: xorq %rdx, %rdx movq $10, %rcx divq %rcx # rax=q, rdx=r addb $'0', %dl decq %rbx movb %dl, (%rbx) testq %rax, %rax jnz .bg_digits # Copy from %rbx forward into our output at %rdi. .bg_copy: movb (%rbx), %al testb %al, %al jz .bg_copy_done movb %al, (%rdi) incq %rbx incq %rdi jmp .bg_copy .bg_copy_done: popq %rbx .bg_terminate: # Compute length, build a length-prefixed buffer suitable for # intern_buffer (helper that takes [len:byte][chars...]). But # asm uses intern_static which expects ([len:byte][chars...]). # Easier: reuse the interning path by constructing a symbol in # place. Actually we just need to intern the identifier. leaq num_buf(%rip), %rsi movq %rdi, %rax subq %rsi, %rax # length movq %rax, %rdi # len # Call intern_name(%rdi=len, %rsi=chars) or similar. # Asm uses intern_buffer (a general helper); fall back to writing # to num_buf and wrapping in a length-prefixed header matching # the intern_static convention. # Build a length-prefixed buffer in num_buf_lp: [len][chars...] leaq num_buf_lp(%rip), %rcx movb %dil, (%rcx) # length byte incq %rcx movq %rdi, %rdx .bg_copy2: testq %rdx, %rdx jz .bg_intern movb (%rsi), %al movb %al, (%rcx) incq %rsi incq %rcx decq %rdx jmp .bg_copy2 .bg_intern: leaq num_buf_lp(%rip), %rdi call intern_static RET_VAL # (exit [code]) — graceful termination. Missing arg → exit 0. bi_exit: cmpq $VAL_NIL, %r12 je .bex_zero GETARG %rax sarq $3, %rax movq %rax, %rdi movq $SYS_EXIT, %rax syscall .bex_zero: xorq %rdi, %rdi movq $SYS_EXIT, %rax syscall # (fork-self) — fork() wrapper. Child sees 0, parent sees pid, -1/#f on fail. # Caller MUST use exit-immediate in child to avoid dual-cleanup hang. bi_forkself: movq $SYS_FORK, %rax syscall # %rax = -errno on fail, 0 in child, pid in parent. asm tier has # no #f-on-fail convention here; return -errno as a fixnum (will # be negative — caller can check). For our gpu-worker pattern, # success path (0/pid) is the only path we exercise. movq %rax, %rdi call make_int RET_VAL # (waitpid-nonblock) — reap one completed child non-blocking. Returns pid or 0. bi_waitpid_nonblock: movq $-1, %rdi # pid = -1 (any child) xorq %rsi, %rsi # status* = NULL movq $WNOHANG, %rdx # options xorq %r10, %r10 # rusage* = NULL movq $SYS_WAIT4, %rax syscall # %rax <= 0 means no child reaped (or error) — return 0. testq %rax, %rax jg .bwn_ok xorq %rax, %rax .bwn_ok: movq %rax, %rdi call make_int RET_VAL # (exit-immediate [code]) — _exit() wrapper, identical to bi_exit on asm # tier (no atexit handlers / stdio buffers to bypass). Present for # cross-tier API parity with c-tier / python-tier where the distinction # matters. bi_exit_immediate: cmpq $VAL_NIL, %r12 je .beim_zero GETARG %rax sarq $3, %rax movq %rax, %rdi movq $SYS_EXIT, %rax syscall .beim_zero: xorq %rdi, %rdi movq $SYS_EXIT, %rax syscall # (sleep N) — wall-clock sleep for N seconds via nanosleep. Returns void. # Uses stack-allocated timespec. bi_sleep: GETARG %rax sarq $3, %rax # untag fixnum # Build timespec on stack: tv_sec (8 bytes), tv_nsec (8 bytes) subq $16, %rsp movq %rax, 0(%rsp) # tv_sec = N xorq %rax, %rax movq %rax, 8(%rsp) # tv_nsec = 0 movq %rsp, %rdi # req timespec xorq %rsi, %rsi # rem = NULL movq $SYS_NANOSLEEP, %rax syscall addq $16, %rsp movq $VAL_VOID, %rax RET_VAL # (values . xs) — packs its args as a multi-value packet. # Calling convention: if xs has exactly one element, that element is # returned directly (so code that ignores multi-value semantics still # works). Otherwise we build a tagged pair (mval_marker . xs) that # call-with-values destructures. mval_marker is a gensymed symbol set # at init, so no user-written pair can masquerade as a packet. bi_values: cmpq $VAL_NIL, %r12 je .bv_empty movq %r12, %rax andq $-8, %rax movq 8(%rax), %rcx # cdr cmpq $VAL_NIL, %rcx je .bv_single # multi: build pair (mval_marker . args) movq mval_marker(%rip), %rdi movq %r12, %rsi call make_pair RET_VAL .bv_single: movq (%rax), %rax # car RET_VAL .bv_empty: movq mval_marker(%rip), %rdi movq $VAL_NIL, %rsi call make_pair RET_VAL # (call-with-values producer consumer) — invokes producer with no # args, destructures the multi-value packet (if any), passes the # values positionally to consumer. bi_call_with_values: GETARG %rbx # producer GETARG %rcx # consumer (save in %rcx via stack) pushq %rcx movq %rbx, %rdi # producer movq $VAL_NIL, %rsi # empty arg list call apply_proc_raw popq %rcx # consumer # Is %rax a multi-value packet? (pair whose car = mval_marker) movq %rax, %rdx andq $TAG_MASK, %rdx cmpq $TAG_PAIR, %rdx jne .bcwv_single movq %rax, %rdx andq $-8, %rdx movq (%rdx), %r8 cmpq mval_marker(%rip), %r8 jne .bcwv_single # Multi-value — args = cdr of packet movq 8(%rdx), %rsi movq %rcx, %rdi # consumer call apply_proc_raw RET_VAL .bcwv_single: # Single value — wrap in a 1-element list and apply pushq %rcx movq %rax, %rdi movq $VAL_NIL, %rsi call make_pair popq %rcx movq %rax, %rsi # (result) movq %rcx, %rdi # consumer call apply_proc_raw RET_VAL # (cadr x) — second element. Shortcut: (car (cdr x)). bi_cadr: GETARG %rdi andq $-8, %rdi movq 8(%rdi), %rdi # cdr andq $-8, %rdi movq (%rdi), %rax # car RET_VAL # (sort lst) — ascending insertion sort of a list of tagged integers. # Non-destructive; returns a new list. Comparison is `<` on untagged int # values (TAG_INT=0, so `sarq $3` yields the int). For non-integer mixed # lists the result is undefined — matches the Python/C contract that # `sort` uses the default numeric ordering. bi_sort: GETARG %rdi call list_sort_rec RET_VAL # list_sort_rec: %rdi = list (tagged) -> %rax = sorted list (tagged). # sort(nil) = nil # sort(x::rest) = insert(x, sort(rest)) list_sort_rec: cmpq $VAL_NIL, %rdi jne 1f movq $VAL_NIL, %rax ret 1: pushq %rbx movq %rdi, %rbx # save input list (tagged) andq $-8, %rbx # untagged pair ptr movq (%rbx), %rax # car pushq %rax # save x movq 8(%rbx), %rdi # cdr call list_sort_rec # %rax = sorted cdr popq %rdi # x movq %rax, %rsi # sorted cdr call list_insert_rec popq %rbx ret # list_insert_rec: %rdi = x (tagged int), %rsi = sorted list (tagged) # -> %rax = sorted list with x inserted. list_insert_rec: cmpq $VAL_NIL, %rsi jne 1f # Empty: return (cons x '()) movq $VAL_NIL, %rsi call make_pair ret 1: # Compare x < head of sorted? movq %rsi, %rax andq $-8, %rax movq (%rax), %rcx # head (tagged) movq %rdi, %rax sarq $3, %rax # x untagged movq %rcx, %rdx sarq $3, %rdx # head untagged cmpq %rdx, %rax jl .ins_prepend # x >= head: (cons head (insert x (cdr sorted))) pushq %rcx # save head pushq %rdi # save x movq %rsi, %rax andq $-8, %rax movq 8(%rax), %rsi # cdr sorted # rdi already = x (unchanged through memory loads) call list_insert_rec # %rax = tail after insert popq %rdi # discard x popq %rcx # head movq %rcx, %rdi # car = head movq %rax, %rsi # cdr = inserted tail call make_pair ret .ins_prepend: # (cons x sorted) call make_pair # rdi=x, rsi=sorted already set ret 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) — args-list is a proper list of values that # becomes f's argument list. Previous impl clobbered the list # with %rbx and passed %r12 (which is nil after two GETARGs) # as the apply args, so (apply f '(1 2 3)) silently reduced to # (f). GETARG %rbx # f (proc) GETARG %rsi # args-list movq %rbx, %rdi # proc call apply_proc_raw 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 movb $HT_STRING, -7(%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 movb $HT_STRING, -7(%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 movb $HT_STRING, -7(%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 # Guard negative exponent — asm is integer-only; return 0 rather # than loop forever. Scheme's (expt N -1) would yield 1/N, which # this tier can't represent. cl-loop's look-ahead termination # only evaluates the step if the next iter is valid, but we # have to stay safe against eager step evaluation by the emit. testq %rcx, %rcx js .bexpt_done_zero # 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 .bexpt_done_zero: xorq %rdi, %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_isqrt: floor of integer square root (bit-by-bit, no FPU). # Negative input -> error exit. Registers: %r8 = x, %r9 = res, %r10 = bit. bi_isqrt: GETARG %rax sarq $3, %rax # untag testq %rax, %rax js .bisqrt_neg cmpq $2, %rax jl .bisqrt_small # v < 2 -> result is v itself movq %rax, %r8 # x xorq %r9, %r9 # res movq $1, %r10 shlq $62, %r10 # bit = 1<<62 .bisqrt_align: cmpq %r8, %r10 jbe .bisqrt_loop shrq $2, %r10 jmp .bisqrt_align .bisqrt_loop: testq %r10, %r10 jz .bisqrt_ret movq %r9, %rcx addq %r10, %rcx # rcx = res + bit cmpq %rcx, %r8 jb .bisqrt_no subq %rcx, %r8 # x -= res + bit shrq $1, %r9 addq %r10, %r9 # res = (res>>1) + bit jmp .bisqrt_next .bisqrt_no: shrq $1, %r9 # res >>= 1 .bisqrt_next: shrq $2, %r10 # bit >>= 2 jmp .bisqrt_loop .bisqrt_ret: movq %r9, %rdi call make_int RET_VAL .bisqrt_small: movq %rax, %rdi call make_int RET_VAL .bisqrt_neg: movq $SYS_WRITE, %rax movq $2, %rdi leaq err_isqrt_neg(%rip), %rsi movq $err_isqrt_neg_len, %rdx syscall movq $SYS_EXIT, %rax movq $1, %rdi syscall # ============================================================ # xoshiro256** — deterministic, portable PRNG shared with Python # and C impls. Reference: Blackman & Vigna 2018. Portal serializes # g_rng_state so simulations continue across processes with a # bit-identical random stream. See docs/tickets/0001-portal-rng.md. # ============================================================ # rng_splitmix64_step: %rdi = pointer to z (u64). Output in %rax. # Only increments *z by the constant; mixing happens on a local copy. rng_splitmix64_step: movabs $0x9e3779b97f4a7c15, %rax addq %rax, (%rdi) movq (%rdi), %rax movq %rax, %rcx shrq $30, %rcx xorq %rcx, %rax movabs $0xbf58476d1ce4e5b9, %rcx imulq %rcx, %rax movq %rax, %rcx shrq $27, %rcx xorq %rcx, %rax movabs $0x94d049bb133111eb, %rcx imulq %rcx, %rax movq %rax, %rcx shrq $31, %rcx xorq %rcx, %rax ret # rng_seed: %rdi = seed (u64). Fills g_rng_state[0..3] via splitmix64. rng_seed: # Stack: [rsp]=z scratch, [rsp+8]=saved state base subq $16, %rsp movq %rdi, (%rsp) # z = seed leaq g_rng_state(%rip), %rax movq %rax, 8(%rsp) movq %rsp, %rdi call rng_splitmix64_step movq 8(%rsp), %rcx movq %rax, (%rcx) movq %rsp, %rdi call rng_splitmix64_step movq 8(%rsp), %rcx movq %rax, 8(%rcx) movq %rsp, %rdi call rng_splitmix64_step movq 8(%rsp), %rcx movq %rax, 16(%rcx) movq %rsp, %rdi call rng_splitmix64_step movq 8(%rsp), %rcx movq %rax, 24(%rcx) addq $16, %rsp ret # rng_next: no args. Returns raw u64 in %rax. Mutates g_rng_state. rng_next: leaq g_rng_state(%rip), %rdi # result = rotl(s[1]*5, 7) * 9 movq 8(%rdi), %rax leaq (%rax, %rax, 4), %rax # * 5 rolq $7, %rax leaq (%rax, %rax, 8), %rax # * 9 pushq %rax # save result # t = s[1] << 17 movq 8(%rdi), %rcx shlq $17, %rcx # s[2] ^= s[0] movq (%rdi), %rax xorq %rax, 16(%rdi) # s[3] ^= s[1] movq 8(%rdi), %rax xorq %rax, 24(%rdi) # s[1] ^= s[2] movq 16(%rdi), %rax xorq %rax, 8(%rdi) # s[0] ^= s[3] movq 24(%rdi), %rax xorq %rax, (%rdi) # s[2] ^= t xorq %rcx, 16(%rdi) # s[3] = rotl(s[3], 45) movq 24(%rdi), %rax rolq $45, %rax movq %rax, 24(%rdi) popq %rax # result ret # bi_random_seed_bang: (random-seed! k) -> void bi_random_seed_bang: GETARG %rax sarq $3, %rax # untag → raw int64 movq %rax, %rdi call rng_seed movq $VAL_VOID, %rax RET_VAL # bi_random_int: (random-int n) -> int in [0, n) bi_random_int: GETARG %rax sarq $3, %rax # untag → n testq %rax, %rax jle .brni_bad movq %rax, %rbx # save n call rng_next # %rax = u64 xorq %rdx, %rdx divq %rbx # %rdx = rax mod rbx (unsigned) movq %rdx, %rdi call make_int RET_VAL .brni_bad: movq $SYS_WRITE, %rax movq $2, %rdi leaq err_rng_bad_n(%rip), %rsi movq $err_rng_bad_n_len, %rdx syscall movq $SYS_EXIT, %rax movq $1, %rdi syscall # bi_random_state: () -> (w0_lo w0_hi w1_lo w1_hi w2_lo w2_hi w3_lo w3_hi) # Builds list back-to-front from i=7 down to i=0. bi_random_state: movq $VAL_NIL, %rbx # list accumulator movq $7, %rbp # i .brs_loop: leaq g_rng_state(%rip), %rdx movq %rbp, %rax shrq $1, %rax # word index = i/2 movq (%rdx, %rax, 8), %rax # word[i/2] testq $1, %rbp # i odd? jz .brs_lo shrq $32, %rax # hi half jmp .brs_have .brs_lo: movl %eax, %eax # lo half (zero-extend) .brs_have: movq %rax, %rdi call make_int movq %rax, %rdi # car movq %rbx, %rsi # cdr call make_pair movq %rax, %rbx testq %rbp, %rbp jz .brs_done decq %rbp jmp .brs_loop .brs_done: movq %rbx, %rax RET_VAL # bi_random_state_bang: (random-state! (list 8 ints)) -> void bi_random_state_bang: GETARG %rbx # list cursor leaq g_rng_state(%rip), %rcx xorq %rsi, %rsi # i = 0 .brsb_loop: cmpq $8, %rsi jge .brsb_done cmpq $VAL_NIL, %rbx je .brsb_short # car movq %rbx, %rax andq $-8, %rax movq (%rax), %rdi # car sarq $3, %rdi # untag movl %edi, %edi # mask to 32 bits # store into word[i/2]; i even → lo (overwrite); i odd → hi (OR in) movq %rsi, %rax shrq $1, %rax # word index testq $1, %rsi jz .brsb_lo shlq $32, %rdi # hi half orq %rdi, (%rcx, %rax, 8) jmp .brsb_next .brsb_lo: movq %rdi, (%rcx, %rax, 8) # lo half (overwrites previous contents) .brsb_next: # advance cursor movq %rbx, %rax andq $-8, %rax movq 8(%rax), %rbx # cdr incq %rsi jmp .brsb_loop .brsb_short: movq $SYS_WRITE, %rax movq $2, %rdi leaq err_rng_short(%rip), %rsi movq $err_rng_short_len, %rdx syscall movq $SYS_EXIT, %rax movq $1, %rdi syscall .brsb_done: movq $VAL_VOID, %rax RET_VAL # bi_random_seed_from_os: (random-seed-from-os!) -> void # Reads 8 bytes from /dev/urandom, interprets as little-endian u64, # seeds xoshiro256**. Opt-in entropy for stochastic runs; determinism # remains the default. See docs/tickets/0002-os-entropy-seed.md. bi_random_seed_from_os: # open("/dev/urandom", O_RDONLY, 0) movq $SYS_OPEN, %rax leaq s_dev_urandom(%rip), %rdi movq $O_RDONLY, %rsi xorq %rdx, %rdx syscall testq %rax, %rax js .brsfo_fail movq %rax, %rbx # fd # read 8 bytes into stack slot subq $8, %rsp movq $SYS_READ, %rax movq %rbx, %rdi movq %rsp, %rsi movq $8, %rdx syscall cmpq $8, %rax jne .brsfo_short movq (%rsp), %rdi # seed = little-endian u64 addq $8, %rsp pushq %rbx # save fd across rng_seed call call rng_seed popq %rbx # close(fd) movq $SYS_CLOSE, %rax movq %rbx, %rdi syscall movq $VAL_VOID, %rax RET_VAL .brsfo_short: addq $8, %rsp # fall through to fail with same error (urandom unavailable / short) .brsfo_fail: movq $SYS_WRITE, %rax movq $2, %rdi leaq err_rng_urandom(%rip), %rsi movq $err_rng_urandom_len, %rdx syscall movq $SYS_EXIT, %rax movq $1, %rdi syscall 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 movb $HT_VECTOR, -7(%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 movb $HT_VECTOR, -7(%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 movb $HT_VECTOR, -7(%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 movb $HT_STRING, -7(%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. # ============================================================ .ifndef GC_NAIVE 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) # xoshiro256** state: 4 × u64 at offsets 40, 48, 56, 64 leaq g_rng_state(%rip), %rdi movq (%rdi), %rax movq %rax, 40(%rsp) movq 8(%rdi), %rax movq %rax, 48(%rsp) movq 16(%rdi), %rax movq %rax, 56(%rsp) movq 24(%rdi), %rax movq %rax, 64(%rsp) # Reserved (offset 72, last 8 bytes) movq $0, 72(%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 .endif .ifdef GC_NAIVE # GC build: binary-dump portal would require serializing the chunk # list + headers + free list + pointer remapping. Instead we emit # S-expressions — walk the global env chain, write `(define # )` per binding. Works across tiers via the read-plus-eval # loop that bi_load already implements. # # Skips builtins and closures whose bodies can't round-trip through # scheme_print → scheme_read without source-level reconstruction. # Data values (pairs, strings, numbers, vectors) serialize cleanly. bi_portal_save: GETARG %rdi andq $-8, %rdi movq (%rdi), %rcx # filename length leaq 8(%rdi), %rdi # filename bytes subq $256, %rsp movq %rsp, %rsi pushq %rcx .ps_gc_copy: testq %rcx, %rcx jz .ps_gc_named movb (%rdi), %al movb %al, (%rsi) incq %rdi incq %rsi decq %rcx jmp .ps_gc_copy .ps_gc_named: movb $0, (%rsi) popq %rcx 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 .ps_gc_fail movq %rax, %rbx # fd # Emit v1 header. resume() will read this first line and bail # if it doesn't match, letting us evolve the format cleanly. movq $SYS_WRITE, %rax movq %rbx, %rdi leaq s_portal_v1(%rip), %rsi movq $s_portal_v1_len, %rdx syscall # Redirect printer to the portal file. movq output_fd(%rip), %r12 # save caller's fd movq %rbx, output_fd(%rip) # Walk env chain from %r14. Each node = [sym, val, parent]. movq %r14, %rbp # cursor .ps_gc_loop: testq %rbp, %rbp jz .ps_gc_done # Skip nodes whose val is a builtin — builtins are recreated on # resume by the target interpreter, no need to serialize. movq 8(%rbp), %rax # val movq %rax, %rcx andq $TAG_MASK, %rcx cmpq $TAG_BUILTIN, %rcx je .ps_gc_next cmpq $TAG_CLOSURE, %rcx je .ps_gc_next # can't re-read a closure from its printed form # Emit "(define " leaq s_pdefine(%rip), %rsi movq $s_pdefine_len, %rdx movq $SYS_WRITE, %rax movq output_fd(%rip), %rdi syscall # Print sym movq (%rbp), %rdi # sym (tagged) call scheme_print # " (quote " movq $SYS_WRITE, %rax movq output_fd(%rip), %rdi leaq s_quote_op(%rip), %rsi movq $s_quote_op_len, %rdx syscall # Print val movq 8(%rbp), %rdi call scheme_print # "))\n" movq $SYS_WRITE, %rax movq output_fd(%rip), %rdi leaq s_rparen2_nl(%rip), %rsi movq $3, %rdx syscall .ps_gc_next: movq 16(%rbp), %rbp # parent jmp .ps_gc_loop .ps_gc_done: # Restore printer fd. movq %r12, output_fd(%rip) # Close portal file. movq $SYS_CLOSE, %rax movq %rbx, %rdi syscall movq $VAL_VOID, %rax RET_VAL .ps_gc_fail: movq $VAL_FALSE, %rax RET_VAL .endif .ifdef GC_NAIVE # GC build: portal-resume reads the v1 header, then delegates to # bi_load for the actual form-by-form evaluation. Header check # lets us reject unknown future versions cleanly instead of # getting a mysterious parse error on new syntax. # # Policy: # file starts with ";; lumbda-portal v1\n" -> load # file starts with ";;" but different -> VAL_FALSE (reject) # file does not start with ";;" at all -> load as legacy bi_portal_resume: # Peek at arg without consuming %r12 — bi_load needs its own # GETARG to re-read the filename after we've validated the # header. movq %r12, %rax andq $-8, %rax movq (%rax), %rbx # filename (tagged string) andq $-8, %rbx movq (%rbx), %rcx # string length leaq 8(%rbx), %rsi # bytes # Null-terminate on stack (256-byte slot). subq $256, %rsp movq %rsp, %rdi movq %rcx, %rdx .prg_cp: testq %rdx, %rdx jz .prg_cp_done movb (%rsi), %al movb %al, (%rdi) incq %rsi incq %rdi decq %rdx jmp .prg_cp .prg_cp_done: movb $0, (%rdi) # Open read-only. movq $SYS_OPEN, %rax movq %rsp, %rdi movq $O_RDONLY, %rsi xorq %rdx, %rdx syscall addq $256, %rsp testq %rax, %rax js .prg_fail movq %rax, %rbx # fd # Read up to 32 bytes to inspect the header. subq $32, %rsp movq $SYS_READ, %rax movq %rbx, %rdi movq %rsp, %rsi movq $32, %rdx syscall # rax = bytes actually read. If <2 we can't tell what it is — accept. cmpq $2, %rax jl .prg_close_accept # Is this a comment line (starts with ";;")? movzwl (%rsp), %eax cmpl $0x3b3b, %eax # ";;" jne .prg_close_accept # no header marker — legacy file, accept # Header present. Must match s_portal_v1 exactly for the first # s_portal_v1_len bytes. leaq s_portal_v1(%rip), %rdi movq %rsp, %rsi movq $s_portal_v1_len, %rcx .prg_match: movb (%rdi), %al cmpb (%rsi), %al jne .prg_bad_version incq %rdi incq %rsi decq %rcx jnz .prg_match # Fall through — header matches. .prg_close_accept: addq $32, %rsp movq $SYS_CLOSE, %rax movq %rbx, %rdi syscall # Delegate to bi_load, which re-opens the file and reads every # form. The v1 header itself is a ";; comment" line the reader # already skips. jmp bi_load .prg_bad_version: addq $32, %rsp movq $SYS_CLOSE, %rax movq %rbx, %rdi syscall movq $VAL_FALSE, %rax RET_VAL .prg_fail: movq $VAL_FALSE, %rax RET_VAL .endif .ifndef GC_NAIVE 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 # Restore xoshiro256** state from header offsets 40..64 leaq g_rng_state(%rip), %rdi movq 40(%rsp), %rax movq %rax, (%rdi) movq 48(%rsp), %rax movq %rax, 8(%rdi) movq 56(%rsp), %rax movq %rax, 16(%rdi) movq 64(%rsp), %rax movq %rax, 24(%rdi) 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 .endif # ============================================================ # load_default_prelude — parse and eval the always-on prelude. # Mirrors load_cl_full_prelude but applies to every binary tier # (default, GC, FULL). Defines `eq?` and any other always-on # aliases listed at default_prelude. Saves + restores reader input # state so neither REPL nor argv scripts see the prelude bytes. # Called from _start after init_builtins / rng_seed, unconditionally. load_default_prelude: pushq %rbp # 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 # Install prelude string as input. leaq default_prelude(%rip), %rax movq %rax, input_buf_ptr(%rip) movq $0, input_pos(%rip) movq $default_prelude_len, input_end(%rip) movq $1, input_is_file(%rip) # EOF at end; do not refill .ldp_loop: call scheme_read testq %rax, %rax jz .ldp_done movq %rax, %rdi movq %r14, %rsi # global env call eval # .ev_define mutates %r14 directly; no post-eval env update needed. jmp .ldp_loop .ldp_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) popq %rbp ret # ============================================================ .ifdef CL_FULL # load_cl_full_prelude — parse and eval the embedded prelude string. # Saves + restores the reader's input source so the REPL doesn't see # the prelude text. Called from _start after init_builtins / rng_seed. load_cl_full_prelude: pushq %rbp # 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 # Install prelude string as input. leaq cl_full_prelude(%rip), %rax movq %rax, input_buf_ptr(%rip) movq $0, input_pos(%rip) movq $cl_full_prelude_len, input_end(%rip) movq $1, input_is_file(%rip) # EOF at end; do not refill .lpp_loop: call scheme_read testq %rax, %rax jz .lpp_done movq %rax, %rdi movq %r14, %rsi # global env call eval # .ev_define mutates %r14 directly; no post-eval env update needed. jmp .lpp_loop .lpp_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) popq %rbp ret .endif # 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 movb $HT_STRING, -7(%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 movb $HT_STRING, -7(%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 # bi_string_to_symbol: (string->symbol "foo") → 'foo # Strings carry an 8-byte length prefix at ptr; intern_symbol expects # (ptr, len) and returns a tagged symbol. Used by ecdsa Phase B steps 5 # + 8 for dynamic register naming (mod-inv.lsp inv-r-N, mod-inv-by.lsp # state-reg-N). Python tier defines this at lumbda.py:3279; C tier at # c/builtins.c:785. asm tier was missing it — surfaced while running # ecdsa task #47 on lumbda-full. bi_string_to_symbol: GETARG %rdi # tagged string value andq $-8, %rdi # untag (low 3 bits) movq (%rdi), %rsi # length (8-byte length field) addq $8, %rdi # bytes start at offset 8 call intern_symbol # %rax = tagged symbol 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 movb $HT_HASHTABLE, -7(%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: # %rbx keeps the TAGGED ht pointer across make_pair so the GC # stack scan (gc_collect saves rbx, then walks every stack word # via gc_push_if_heap) sees it as a live root for the bucket # chain. The earlier untagged form left the ht reachable only # via a bare pointer that gc_push_if_heap skipped (tag=0 looks # like a small int), so a GC triggered inside make_pair could # reclaim the bucket head or freshly-cons'd (k . v). Symptom # was a later hash-table-ref reporting "missing key" on entries # we just set. Discovered while running ecdsa task #47 with B-Y # mod-inv on lumbda-full, 2026-06-05. Tag-7 = TAG_MASK, so # untagged form is reached inline by subtracting 7 from %rbx. GETARG %rbx # %rbx = TAGGED ht (live across GC) 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-7(%rbx,%rax,8), %rdx # slot addr (untag inline) 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 1(%rbx) # count++ (count field at untag+8 = tag+1) 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). # Same root-keeping pattern as bi_hash_table_set: %rbx holds tagged ht # so the GC stack scan finds it across deep_equal / make_pair. bi_hash_table_delete: GETARG %rbx # %rbx = TAGGED ht (live across GC) GETARG %rbp # key movq %rbp, %rdi call hash_value andq $HT_BUCKET_MASK, %rax leaq HT_HEADER_BYTES-7(%rbx,%rax,8), %rdi # slot addr (untag inline) 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 1(%rbx) # count-- (untag+8 = tag+1) .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 movb $HT_HASHSET, -7(%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 movb $HT_STRING, -7(%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 # bi_tcp_sendfile: (tcp-sendfile socket "path") → int bytes sent or #f # Zero-copy file-to-socket via the Linux sendfile(2) syscall — the # kernel streams bytes from the file's page cache directly into # the socket buffer without ever touching userspace. Opens the # file, sizes it via lseek, loops sendfile until drained, closes. bi_tcp_sendfile: GETARG %rdi # socket call decode_port testq %rax, %rax js .tsf_fail movq %rax, %rbx # socket fd GETARG %rdi # path (tagged string) andq $-8, %rdi movq (%rdi), %rcx # string length leaq 8(%rdi), %rdi # bytes # Null-terminate the filename on a 256-byte stack slot. subq $256, %rsp movq %rsp, %rsi pushq %rcx .tsf_cp: testq %rcx, %rcx jz .tsf_cp_done movb (%rdi), %al movb %al, (%rsi) incq %rdi incq %rsi decq %rcx jmp .tsf_cp .tsf_cp_done: movb $0, (%rsi) popq %rcx # Open file read-only. movq $SYS_OPEN, %rax movq %rsp, %rdi movq $O_RDONLY, %rsi xorq %rdx, %rdx syscall addq $256, %rsp testq %rax, %rax js .tsf_fail movq %rax, %r12 # file fd # Size via lseek(fd, 0, SEEK_END). movq $SYS_LSEEK, %rax movq %r12, %rdi xorq %rsi, %rsi movq $SEEK_END, %rdx syscall testq %rax, %rax js .tsf_close_fail movq %rax, %rbp # total size # Rewind file position. movq $SYS_LSEEK, %rax movq %r12, %rdi xorq %rsi, %rsi movq $SEEK_SET, %rdx syscall # Loop: sendfile until %rcx (remaining) is 0. movq %rbp, %rcx .tsf_loop: testq %rcx, %rcx jz .tsf_ok movq $SYS_SENDFILE, %rax movq %rbx, %rdi # out_fd = socket movq %r12, %rsi # in_fd = file xorq %rdx, %rdx # offset = NULL — use file's current pos movq %rcx, %r10 # count = remaining syscall testq %rax, %rax js .tsf_close_fail # kernel error jz .tsf_ok # EOF before count satisfied subq %rax, %rcx jmp .tsf_loop .tsf_ok: movq $SYS_CLOSE, %rax movq %r12, %rdi syscall movq %rbp, %rdi # total bytes sent call make_int RET_VAL .tsf_close_fail: movq $SYS_CLOSE, %rax movq %r12, %rdi syscall .tsf_fail: movq $VAL_FALSE, %rax RET_VAL # ============================================================ # bi_spawn_process_stdio: (spawn-process-stdio "path" '("arg1" ...)) # → (stdin-port . stdout-port) or #f # # %r15 is lumbda's heap bump pointer — DO NOT clobber. # Scratch base lives in %rbp (callee-saved; RET_VAL restores it). # # Stack scratch layout (4 KB): # 0..15 = in_pipe + out_pipe (4 × int32 fds) # 16..143 = argv[] (16 ptrs × 8 B) # 144..399 = path buf (256 B, null-term) # 400..2447 = arg bufs (8 args × 256 B) # # Limits: ≤ 8 args, ≤ 255 bytes each. Strings only. # ============================================================ bi_spawn_process_stdio: pushq %r13 pushq %r14 subq $4104, %rsp # 4096 + 8 to re-align rsp to 16 movq %rsp, %rbp # %rbp = scratch base # ── arg 0: path → copy to scratch+144 ── GETARG %rdi andq $-8, %rdi movq (%rdi), %rcx leaq 8(%rdi), %rdi leaq 144(%rbp), %rsi call copy_fname_to_stack leaq 144(%rbp), %rax movq %rax, 16(%rbp) # argv[0] = path # ── arg 1: args list → argv[1..N] ── GETARG %r14 xorq %r13, %r13 incq %r13 # %r13 = arg index, start at 1 .sps_arg_loop: cmpq $VAL_NIL, %r14 je .sps_args_done cmpq $9, %r13 jge .sps_args_done movq %r14, %rax andq $-8, %rax movq (%rax), %rdi # car movq 8(%rax), %r14 # cdr andq $-8, %rdi movq (%rdi), %rcx leaq 8(%rdi), %rdi # arg buf addr = rbp + 400 + (i-1)*256 movq %r13, %rax decq %rax shlq $8, %rax addq $400, %rax addq %rbp, %rax movq %rax, %rsi pushq %r13 pushq %r14 call copy_fname_to_stack popq %r14 popq %r13 # argv[i] = arg buf addr (recomputed) movq %r13, %rax shlq $3, %rax addq $16, %rax addq %rbp, %rax movq %r13, %rdx decq %rdx shlq $8, %rdx addq $400, %rdx addq %rbp, %rdx movq %rdx, (%rax) incq %r13 jmp .sps_arg_loop .sps_args_done: movq %r13, %rax shlq $3, %rax addq $16, %rax addq %rbp, %rax movq $0, (%rax) # argv[N] = NULL # ── pipe2(in_pipe, 0) ── movq $SYS_PIPE2, %rax movq %rbp, %rdi xorq %rsi, %rsi syscall testq %rax, %rax js .sps_fail # ── pipe2(out_pipe, 0) ── movq $SYS_PIPE2, %rax leaq 8(%rbp), %rdi xorq %rsi, %rsi syscall testq %rax, %rax js .sps_close_in # ── fork() ── movq $SYS_FORK, %rax syscall testq %rax, %rax js .sps_close_both jz .sps_child # ── parent ── movl 0(%rbp), %edi # close in_pipe[0] movq $SYS_CLOSE, %rax syscall movl 12(%rbp), %edi # close out_pipe[1] movq $SYS_CLOSE, %rax syscall movl 4(%rbp), %edi # in_pipe[1] → parent writes call encode_port movq %rax, %r13 # save stdin-port movl 8(%rbp), %edi # out_pipe[0] → parent reads call encode_port movq %rax, %rsi # cdr movq %r13, %rdi # car call make_pair addq $4104, %rsp popq %r14 popq %r13 RET_VAL .sps_child: movl 0(%rbp), %edi xorq %rsi, %rsi movq $SYS_DUP2, %rax syscall movl 12(%rbp), %edi movq $1, %rsi movq $SYS_DUP2, %rax syscall movl 0(%rbp), %edi movq $SYS_CLOSE, %rax syscall movl 4(%rbp), %edi movq $SYS_CLOSE, %rax syscall movl 8(%rbp), %edi movq $SYS_CLOSE, %rax syscall movl 12(%rbp), %edi movq $SYS_CLOSE, %rax syscall leaq 144(%rbp), %rdi leaq 16(%rbp), %rsi xorq %rdx, %rdx movq $SYS_EXECVE, %rax syscall movq $127, %rdi movq $SYS_EXIT, %rax syscall .sps_close_both: movl 8(%rbp), %edi movq $SYS_CLOSE, %rax syscall movl 12(%rbp), %edi movq $SYS_CLOSE, %rax syscall .sps_close_in: movl 0(%rbp), %edi movq $SYS_CLOSE, %rax syscall movl 4(%rbp), %edi movq $SYS_CLOSE, %rax syscall .sps_fail: movq $VAL_FALSE, %rax addq $4104, %rsp popq %r14 popq %r13 RET_VAL # bi_flush_port: asm tier uses raw fds, no userspace buffering -- no-op. bi_flush_port: movq $VAL_VOID, %rax RET_VAL # bi_delete_file: (delete-file "path") -> void; ignores errors. bi_delete_file: GETARG %rdi andq $-8, %rdi movq (%rdi), %rcx # length leaq 8(%rdi), %rdi # bytes subq $256, %rsp movq %rsp, %rsi call copy_fname_to_stack movq $SYS_UNLINK, %rax movq %rsp, %rdi syscall addq $256, %rsp movq $VAL_VOID, %rax RET_VAL # ============================================================ # bi_read_line: (read-line port) → string or #f on EOF # # Reads bytes one at a time from the port's fd until '\n' or EOF. # Strips the trailing '\n'. Returns a Scheme string, or #f if no # bytes were available (peer closed / pipe drained). # # Used by gpu-worker.lsp to consume daemon responses ("ready", # "done /path", "bye") line by line. # # Max line length: 4095 bytes (fits in a 4 KB scratch). Longer lines # truncated — fine for our daemon protocol. # ============================================================ bi_read_line: pushq %r13 pushq %r14 subq $4104, %rsp movq %rsp, %rbp # %rbp = byte buffer # Get port → fd in %r13 GETARG %rdi call decode_port testq %rax, %rax js .rl_fail movq %rax, %r13 # %r13 = fd xorq %r14, %r14 # %r14 = byte count .rl_loop: cmpq $4094, %r14 # leave room for final byte jge .rl_done movq $SYS_READ, %rax movq %r13, %rdi leaq (%rbp,%r14), %rsi movq $1, %rdx syscall cmpq $1, %rax jne .rl_done # EOF or error movb (%rbp,%r14), %al incq %r14 cmpb $10, %al # '\n' je .rl_strip_nl jmp .rl_loop .rl_strip_nl: decq %r14 # exclude the newline .rl_done: testq %r14, %r14 jz .rl_eof # 0 bytes & EOF → #f # heap_alloc(8 + len) movq %r14, %rdi addq $8, %rdi call heap_alloc .ifdef GC_NAIVE movb $HT_STRING, -7(%rax) .endif movq %r14, (%rax) # length header xorq %rcx, %rcx .rl_copy: cmpq %r14, %rcx jge .rl_copy_done movb (%rbp,%rcx), %dl movb %dl, 8(%rax,%rcx) incq %rcx jmp .rl_copy .rl_copy_done: orq $TAG_STRING, %rax addq $4104, %rsp popq %r14 popq %r13 RET_VAL .rl_eof: movq $VAL_FALSE, %rax addq $4104, %rsp popq %r14 popq %r13 RET_VAL .rl_fail: movq $VAL_FALSE, %rax addq $4104, %rsp popq %r14 popq %r13 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_let_star(%rip), %rdi call intern_static movq %rax, sym_let_star_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) leaq sf_when(%rip), %rdi call intern_static movq %rax, sym_when_val(%rip) leaq sf_unless(%rip), %rdi call intern_static movq %rax, sym_unless_val(%rip) leaq sf_case(%rip), %rdi call intern_static movq %rax, sym_case_val(%rip) # Intern the multi-value marker symbol used by (values) and # (call-with-values). Stored once at init. leaq bn_mval_tag(%rip), %rdi call intern_static movq %rax, mval_marker(%rip) .ifdef CL_FULL leaq sf_quasiquote(%rip), %rdi call intern_static movq %rax, sym_quasiquote_val(%rip) leaq sf_unquote(%rip), %rdi call intern_static movq %rax, sym_unquote_val(%rip) leaq sf_unquote_spl(%rip), %rdi call intern_static movq %rax, sym_unquote_spl_val(%rip) leaq sf_define_mac(%rip), %rdi call intern_static movq %rax, sym_define_mac_val(%rip) .endif 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