asm/lumbda-full: quasiquote + define-macro + prelude (ticket 0005)
Third asm variant — built with CL_FULL=1 GC_NAIVE=1 via new Makefile
target. Adds the macro machinery needed for cl-compat.lsp on the asm
tier, keeping every addition behind .ifdef CL_FULL so the default
(~22 KB) and -gc binaries keep their current footprint.
Landed in this drop:
* Reader: backtrack on digit-prefixed symbols. After reading digit
characters, if the next char is not a delimiter, input_pos
rewinds and control falls through to .sr_symbol. Makes 1+, 1-,
add1, abc123, and any CL-style identifier with a numeric prefix
parse as symbols instead of truncating to a bare integer.
* Reader: `` ` `` / `,` / `,@` produce (quasiquote X) / (unquote X)
/ (unquote-splicing X) forms. Same build shape as the existing
`'` quote branch.
* Evaluator: .ev_quasiquote + quasiquote_expand walk the template.
unquote evaluates its argument in the current env; unquote-
splicing evaluates then splices via a new list_append_ab helper;
other pairs recurse (cons expand-car expand-cdr). Atoms pass
through. No nested quasiquote depth (deliberate; ticket 0005
scope).
* Evaluator: .ev_define_macro + macro_env_head linked list. Each
(define-macro (name p...) body) prepends a 24-byte
(sym, closure, next) node. Dispatch in eval checks macro_lookup
after all special-form compares; on hit, the closure is applied
to the *unevaluated* argument list and the expansion re-enters
.eval_top under TCO.
* Binding: rest-arg support extended to .apr_bind inside
apply_proc_raw. Previously only .ac_bind (direct .app_closure
path) handled `(lambda (a . b) ...)` correctly; macros call
closures through apply_proc_raw, so this was required to make
variadic defun/setf macros bind correctly.
* Builtin: (gensym) — writes "g%d" for an in-BSS counter, length-
prefixes the buffer, calls intern_static. Available in every
variant (not CL_FULL-gated — useful outside macros too).
* Builtin: (cadr x), (sort lst) and the let* special form from
earlier commit stay in default asm. These are Scheme staples.
* Prelude: evaluated at _start after init_builtins / rng_seed,
before the REPL. Embedded string, input state saved + restored
around the load. Defines caar, cdar, caddr, cadddr, cddr,
cdddr, cddddr, 1+, 1-, add1, sub1, square, eq? (= eqv? for
interned symbols), memq, list-ref, assq, and `case` as a macro.
cl-compat.lsp: two small changes to work under asm's single-list
`map`:
* Added cl-zip helper. Replaced two `(map (lambda (v n) (list v n))
xs ys)` sites with `(cl-zip xs ys)` — asm's builtin map accepts
only one list, and cl-loop-emit needs a parallel walk over
state-vars and new-names.
* Added explanatory comment for cddddr at the top of the shim
(already shipped).
Tests:
* make asm-test (lumbda) — 158/158 pass.
* make asm-test-gc — 158/158 pass.
* make asm-test-full — 158/158 pass on synchronous run.
* Zoë's `examples/ursa.lisp.txt` LOADS on asm/lumbda-full.
`(expt-mod 3 7 100)` = 87.
Most simple cl-loop forms work (while + do + finally, range-to,
then-accumulator).
Known open issues documented in docs/tickets/0005-asm-cl-full.md:
* cl-loop-emit produces wrong output for inputs with `simple` iters
(`(simple a 5)` → state binding dropped). Python/C return the
correct form; asm version is missing the binding. Bug surfaces
in the emit's 30+ binding let*; could not pin down in this
session. Downstream effect: `(miller-rabin n)` and similar
defuns that depend on `cl-loop repeat k for a = ... unless ...
return nil` don't produce usable expansions, so Zoë's acceptance
suite does not run end-to-end on asm/lumbda-full yet.
* examples/ursa-scheme.lsp — `factor` crashes on asm under some
random seeds (bump-allocator exhaustion on long rhoff retry
chains). Out of CL_FULL scope; tracked in same ticket.
Next steps live in ticket 0005. This commit ships the infrastructure
so the remaining work is a debugging exercise against a reproducible
minimal case, not a feature build.
This commit is contained in:
parent
8cf6f44364
commit
4ff87920cf
10 changed files with 780 additions and 15 deletions
17
asm/Makefile
17
asm/Makefile
|
|
@ -1,4 +1,4 @@
|
||||||
all: lumbda lumbda-gc
|
all: lumbda lumbda-gc lumbda-full
|
||||||
|
|
||||||
lumbda: lumbda.s
|
lumbda: lumbda.s
|
||||||
as --64 -o lumbda.o lumbda.s
|
as --64 -o lumbda.o lumbda.s
|
||||||
|
|
@ -8,13 +8,22 @@ lumbda-gc: lumbda.s
|
||||||
as --64 --defsym GC_NAIVE=1 -o lumbda-gc.o lumbda.s
|
as --64 --defsym GC_NAIVE=1 -o lumbda-gc.o lumbda.s
|
||||||
ld -o lumbda-gc lumbda-gc.o
|
ld -o lumbda-gc lumbda-gc.o
|
||||||
|
|
||||||
|
# lumbda-full — GC + quasiquote + define-macro + case + prelude (ticket 0005).
|
||||||
|
# CL_FULL is additive; the default and -gc binaries keep their current size.
|
||||||
|
lumbda-full: lumbda.s
|
||||||
|
as --64 --defsym GC_NAIVE=1 --defsym CL_FULL=1 -o lumbda-full.o lumbda.s
|
||||||
|
ld -o lumbda-full lumbda-full.o
|
||||||
|
|
||||||
test: lumbda
|
test: lumbda
|
||||||
@bash test.sh
|
@bash test.sh
|
||||||
|
|
||||||
test-gc: lumbda-gc
|
test-gc: lumbda-gc
|
||||||
@LUMBDA_BIN=./lumbda-gc bash test.sh
|
@LUMBDA_BIN=./lumbda-gc bash test.sh
|
||||||
|
|
||||||
clean:
|
test-full: lumbda-full
|
||||||
rm -f lumbda.o lumbda lumbda-gc.o lumbda-gc
|
@LUMBDA_BIN=./lumbda-full bash test.sh
|
||||||
|
|
||||||
.PHONY: all test test-gc clean
|
clean:
|
||||||
|
rm -f lumbda.o lumbda lumbda-gc.o lumbda-gc lumbda-full.o lumbda-full
|
||||||
|
|
||||||
|
.PHONY: all test test-gc test-full clean
|
||||||
|
|
|
||||||
BIN
asm/lumbda
BIN
asm/lumbda
Binary file not shown.
BIN
asm/lumbda-full
Executable file
BIN
asm/lumbda-full
Executable file
Binary file not shown.
BIN
asm/lumbda-full.o
Normal file
BIN
asm/lumbda-full.o
Normal file
Binary file not shown.
BIN
asm/lumbda-gc
BIN
asm/lumbda-gc
Binary file not shown.
BIN
asm/lumbda-gc.o
BIN
asm/lumbda-gc.o
Binary file not shown.
BIN
asm/lumbda.o
BIN
asm/lumbda.o
Binary file not shown.
578
asm/lumbda.s
578
asm/lumbda.s
|
|
@ -202,15 +202,16 @@
|
||||||
.equ BI_RANDOMSEEDFROMOS, 114
|
.equ BI_RANDOMSEEDFROMOS, 114
|
||||||
.equ BI_CADR, 115
|
.equ BI_CADR, 115
|
||||||
.equ BI_SORT, 116
|
.equ BI_SORT, 116
|
||||||
|
.equ BI_GENSYM, 117
|
||||||
.ifdef GC_NAIVE
|
.ifdef GC_NAIVE
|
||||||
.equ BI_GC_COLLECT, 117
|
.equ BI_GC_COLLECT, 118
|
||||||
.equ BI_GC_STATS, 118
|
.equ BI_GC_STATS, 119
|
||||||
.equ BI_WITH_ARENA, 119
|
.equ BI_WITH_ARENA, 120
|
||||||
.equ BI_ARENA_STATS, 120
|
.equ BI_ARENA_STATS, 121
|
||||||
.equ BI_ARENA_SET_MODE, 121
|
.equ BI_ARENA_SET_MODE, 122
|
||||||
.equ BI_COUNT, 122
|
.equ BI_COUNT, 123
|
||||||
.else
|
.else
|
||||||
.equ BI_COUNT, 117
|
.equ BI_COUNT, 118
|
||||||
.endif
|
.endif
|
||||||
|
|
||||||
# ============================================================
|
# ============================================================
|
||||||
|
|
@ -233,6 +234,12 @@ sf_begin: .byte 5; .ascii "begin"
|
||||||
sf_let: .byte 3; .ascii "let"
|
sf_let: .byte 3; .ascii "let"
|
||||||
sf_let_star: .byte 4; .ascii "let*"
|
sf_let_star: .byte 4; .ascii "let*"
|
||||||
sf_cond: .byte 4; .ascii "cond"
|
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_and: .byte 3; .ascii "and"
|
||||||
sf_or: .byte 2; .ascii "or"
|
sf_or: .byte 2; .ascii "or"
|
||||||
sf_else: .byte 4; .ascii "else"
|
sf_else: .byte 4; .ascii "else"
|
||||||
|
|
@ -355,6 +362,7 @@ bn_hssize: .byte 13; .ascii "hash-set-size"
|
||||||
bn_hslist: .byte 14; .ascii "hash-set->list"
|
bn_hslist: .byte 14; .ascii "hash-set->list"
|
||||||
bn_cadr: .byte 4; .ascii "cadr"
|
bn_cadr: .byte 4; .ascii "cadr"
|
||||||
bn_sort: .byte 4; .ascii "sort"
|
bn_sort: .byte 4; .ascii "sort"
|
||||||
|
bn_gensym: .byte 6; .ascii "gensym"
|
||||||
.ifdef GC_NAIVE
|
.ifdef GC_NAIVE
|
||||||
bn_gccollect: .byte 10; .ascii "gc-collect"
|
bn_gccollect: .byte 10; .ascii "gc-collect"
|
||||||
bn_gcstats: .byte 8; .ascii "gc-stats"
|
bn_gcstats: .byte 8; .ascii "gc-stats"
|
||||||
|
|
@ -371,6 +379,49 @@ s_hashset: .ascii "#<hash-set>"
|
||||||
err_ht_miss: .ascii "Error: hash-table-ref: missing key\n"
|
err_ht_miss: .ascii "Error: hash-table-ref: missing key\n"
|
||||||
.equ err_ht_miss_len, . - err_ht_miss
|
.equ err_ht_miss_len, . - err_ht_miss
|
||||||
|
|
||||||
|
.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 (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
|
||||||
|
|
||||||
portal_magic: .ascii "LUMBDAB2"
|
portal_magic: .ascii "LUMBDAB2"
|
||||||
.equ PORTAL_MAGIC_LEN, 8
|
.equ PORTAL_MAGIC_LEN, 8
|
||||||
# magic(8) + heap_size(8) + heap_base(8) + r14(8) + r15(8)
|
# magic(8) + heap_size(8) + heap_base(8) + r14(8) + r15(8)
|
||||||
|
|
@ -412,7 +463,7 @@ bi_names:
|
||||||
.quad bn_isqrt
|
.quad bn_isqrt
|
||||||
.quad bn_randomseed, bn_randomint, bn_randomstate, bn_randomstateset
|
.quad bn_randomseed, bn_randomint, bn_randomstate, bn_randomstateset
|
||||||
.quad bn_randomseedfromos
|
.quad bn_randomseedfromos
|
||||||
.quad bn_cadr, bn_sort
|
.quad bn_cadr, bn_sort, bn_gensym
|
||||||
.ifdef GC_NAIVE
|
.ifdef GC_NAIVE
|
||||||
.quad bn_gccollect, bn_gcstats, bn_witharena, bn_arenastats, bn_arenamode
|
.quad bn_gccollect, bn_gcstats, bn_witharena, bn_arenastats, bn_arenamode
|
||||||
.endif
|
.endif
|
||||||
|
|
@ -474,6 +525,12 @@ sym_begin_val: .quad 0
|
||||||
sym_let_val: .quad 0
|
sym_let_val: .quad 0
|
||||||
sym_let_star_val: .quad 0
|
sym_let_star_val: .quad 0
|
||||||
sym_cond_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_and_val: .quad 0
|
||||||
sym_or_val: .quad 0
|
sym_or_val: .quad 0
|
||||||
sym_else_val: .quad 0
|
sym_else_val: .quad 0
|
||||||
|
|
@ -505,6 +562,17 @@ g_rng_state: .skip 32
|
||||||
.equ SYM_HASH_SIZE, 1024
|
.equ SYM_HASH_SIZE, 1024
|
||||||
sym_hash_buckets: .skip 8192 # 1024 * 8 bytes
|
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
|
||||||
|
|
||||||
|
.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
|
.ifdef GC_NAIVE
|
||||||
# ───────────────────────────────────────────────────────────
|
# ───────────────────────────────────────────────────────────
|
||||||
# Naive mark-and-sweep GC state (control group for bench).
|
# Naive mark-and-sweep GC state (control group for bench).
|
||||||
|
|
@ -642,6 +710,12 @@ _start:
|
||||||
xorq %rdi, %rdi
|
xorq %rdi, %rdi
|
||||||
call rng_seed
|
call rng_seed
|
||||||
|
|
||||||
|
.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
|
||||||
|
|
||||||
# Set up a generous stack area (16 KB stack frame for deep recursion)
|
# 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.
|
# Actually the OS already gave us a stack, so we're fine.
|
||||||
|
|
||||||
|
|
@ -1764,6 +1838,12 @@ scheme_read:
|
||||||
je .sr_rparen
|
je .sr_rparen
|
||||||
cmpb $'\'', %al
|
cmpb $'\'', %al
|
||||||
je .sr_quote
|
je .sr_quote
|
||||||
|
.ifdef CL_FULL
|
||||||
|
cmpb $'`', %al
|
||||||
|
je .sr_quasiquote
|
||||||
|
cmpb $',', %al
|
||||||
|
je .sr_unquote
|
||||||
|
.endif
|
||||||
cmpb $'"', %al
|
cmpb $'"', %al
|
||||||
je .sr_string
|
je .sr_string
|
||||||
cmpb $'#', %al
|
cmpb $'#', %al
|
||||||
|
|
@ -1804,6 +1884,50 @@ scheme_read:
|
||||||
popq %rbx
|
popq %rbx
|
||||||
ret
|
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:
|
.sr_hash:
|
||||||
call read_char # eat #
|
call read_char # eat #
|
||||||
call read_char
|
call read_char
|
||||||
|
|
@ -1866,6 +1990,10 @@ scheme_read:
|
||||||
ret
|
ret
|
||||||
|
|
||||||
.sr_number:
|
.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
|
call read_char
|
||||||
subq $'0', %rax
|
subq $'0', %rax
|
||||||
movq %rax, %rbx # accumulator
|
movq %rax, %rbx # accumulator
|
||||||
|
|
@ -1883,6 +2011,27 @@ scheme_read:
|
||||||
addq %rax, %rbx
|
addq %rax, %rbx
|
||||||
jmp .sr_num_loop
|
jmp .sr_num_loop
|
||||||
.sr_num_done:
|
.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
|
movq %rbx, %rdi
|
||||||
call make_int
|
call make_int
|
||||||
popq %r12
|
popq %r12
|
||||||
|
|
@ -2484,6 +2633,21 @@ eval:
|
||||||
je .ev_and
|
je .ev_and
|
||||||
cmpq sym_or_val(%rip), %rbx
|
cmpq sym_or_val(%rip), %rbx
|
||||||
je .ev_or
|
je .ev_or
|
||||||
|
.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
|
# Not special form -> application
|
||||||
jmp .ev_app
|
jmp .ev_app
|
||||||
|
|
@ -3175,6 +3339,243 @@ env_set_both:
|
||||||
popq %rbx
|
popq %rbx
|
||||||
ret
|
ret
|
||||||
|
|
||||||
|
.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 ----
|
# ---- application ----
|
||||||
.ev_app:
|
.ev_app:
|
||||||
# %rbx = operator expr (in car position), %r12 = arg exprs
|
# %rbx = operator expr (in car position), %r12 = arg exprs
|
||||||
|
|
@ -3488,6 +3889,8 @@ eval_list:
|
||||||
je bi_cadr
|
je bi_cadr
|
||||||
cmpq $BI_SORT, %rax
|
cmpq $BI_SORT, %rax
|
||||||
je bi_sort
|
je bi_sort
|
||||||
|
cmpq $BI_GENSYM, %rax
|
||||||
|
je bi_gensym
|
||||||
cmpq $BI_INTEGERP, %rax
|
cmpq $BI_INTEGERP, %rax
|
||||||
je bi_integerp
|
je bi_integerp
|
||||||
cmpq $BI_PORTALSAVE, %rax
|
cmpq $BI_PORTALSAVE, %rax
|
||||||
|
|
@ -4091,6 +4494,12 @@ apply_proc_raw:
|
||||||
.apr_bind:
|
.apr_bind:
|
||||||
cmpq $VAL_NIL, %rcx
|
cmpq $VAL_NIL, %rcx
|
||||||
je .apr_eval_body
|
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
|
cmpq $VAL_NIL, %rsi
|
||||||
je .apr_eval_body
|
je .apr_eval_body
|
||||||
|
|
||||||
|
|
@ -4117,6 +4526,18 @@ apply_proc_raw:
|
||||||
popq %rsi # restore rest args
|
popq %rsi # restore rest args
|
||||||
jmp .apr_bind
|
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:
|
.apr_eval_body:
|
||||||
# Body is already wrap_begin'd: single expr or (begin ...) form.
|
# Body is already wrap_begin'd: single expr or (begin ...) form.
|
||||||
# Eval it directly.
|
# Eval it directly.
|
||||||
|
|
@ -4224,6 +4645,80 @@ bi_reverse:
|
||||||
call list_reverse
|
call list_reverse
|
||||||
RET_VAL
|
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<counter>" 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
|
||||||
|
|
||||||
# (cadr x) — second element. Shortcut: (car (cdr x)).
|
# (cadr x) — second element. Shortcut: (car (cdr x)).
|
||||||
bi_cadr:
|
bi_cadr:
|
||||||
GETARG %rdi
|
GETARG %rdi
|
||||||
|
|
@ -5830,6 +6325,55 @@ bi_portal_resume:
|
||||||
.endif
|
.endif
|
||||||
|
|
||||||
# ============================================================
|
# ============================================================
|
||||||
|
.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
|
# bi_load: (load "path") — read file, eval every form in r14 env
|
||||||
# Mmaps file into memory, swaps input_buf_ptr, loops scheme_read+eval,
|
# Mmaps file into memory, swaps input_buf_ptr, loops scheme_read+eval,
|
||||||
# restores input state. Nestable — prior state saved on stack.
|
# restores input state. Nestable — prior state saved on stack.
|
||||||
|
|
@ -7706,6 +8250,24 @@ init_special_forms:
|
||||||
call intern_static
|
call intern_static
|
||||||
movq %rax, sym_else_val(%rip)
|
movq %rax, sym_else_val(%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
|
popq %rbx
|
||||||
ret
|
ret
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -157,6 +157,15 @@
|
||||||
;; lumbda ships cadddr but not cddddr — supply the missing accessor.
|
;; lumbda ships cadddr but not cddddr — supply the missing accessor.
|
||||||
(define (cddddr x) (cdr (cdddr x)))
|
(define (cddddr x) (cdr (cdddr x)))
|
||||||
|
|
||||||
|
;; Two-list zip: (cl-zip '(a b c) '(1 2 3)) → ((a 1) (b 2) (c 3)).
|
||||||
|
;; asm's built-in `map` is single-list only; cl-loop-emit needs a
|
||||||
|
;; parallel walk over state-vars and their gensymed new-names, so
|
||||||
|
;; the emit uses cl-zip instead of `(map (lambda (v n) ...) xs ys)`.
|
||||||
|
(define (cl-zip as bs)
|
||||||
|
(cond ((or (null? as) (null? bs)) '())
|
||||||
|
(else (cons (list (car as) (car bs))
|
||||||
|
(cl-zip (cdr as) (cdr bs))))))
|
||||||
|
|
||||||
;; ── declare — ignored no-op ──────────────────────────────────────
|
;; ── declare — ignored no-op ──────────────────────────────────────
|
||||||
;; CL code sprinkles `(declare (optimize (speed 3)) (type integer x))`
|
;; CL code sprinkles `(declare (optimize (speed 3)) (type integer x))`
|
||||||
;; inside function bodies. These are compile-time directives in SBCL.
|
;; inside function bodies. These are compile-time directives in SBCL.
|
||||||
|
|
@ -400,7 +409,7 @@
|
||||||
;; bindings (so the finalizer keeps access to current-iter values).
|
;; bindings (so the finalizer keeps access to current-iter values).
|
||||||
(new-names
|
(new-names
|
||||||
(map (lambda (v) (gensym)) state-vars))
|
(map (lambda (v) (gensym)) state-vars))
|
||||||
(var->new (map (lambda (v n) (list v n)) state-vars new-names))
|
(var->new (cl-zip state-vars new-names))
|
||||||
|
|
||||||
;; Build sequential step bindings. Each binding's expr substitutes
|
;; Build sequential step bindings. Each binding's expr substitutes
|
||||||
;; references to EARLIER state vars with their new-names; later
|
;; references to EARLIER state vars with their new-names; later
|
||||||
|
|
@ -535,8 +544,7 @@
|
||||||
(cons (list temp init-sub) acc)))))))
|
(cons (list temp init-sub) acc)))))))
|
||||||
(named-let
|
(named-let
|
||||||
`(let* ,init-bindings
|
`(let* ,init-bindings
|
||||||
(let ,lp-name ,(map (lambda (v t) (list v t))
|
(let ,lp-name ,(cl-zip state-vars init-temps)
|
||||||
state-vars init-temps)
|
|
||||||
,loop-body))))
|
,loop-body))))
|
||||||
(if (null? withs)
|
(if (null? withs)
|
||||||
named-let
|
named-let
|
||||||
|
|
|
||||||
186
docs/tickets/0005-asm-cl-full.md
Normal file
186
docs/tickets/0005-asm-cl-full.md
Normal file
|
|
@ -0,0 +1,186 @@
|
||||||
|
# 0005 — `asm/lumbda-full`: CL compat on the asm tier
|
||||||
|
|
||||||
|
**Status:** partially resolved — infrastructure landed, cl-loop-emit
|
||||||
|
edge case open
|
||||||
|
**Reporter:** fox (via blackops)
|
||||||
|
**Implementer:** blackops
|
||||||
|
**Opened:** 2026-04-24
|
||||||
|
|
||||||
|
## Problem
|
||||||
|
|
||||||
|
Ticket 0004 landed Common Lisp compatibility on the Python and C
|
||||||
|
tiers. Zoë Trout's favorites at `examples/ursa.lisp.txt` load via
|
||||||
|
`cl-compat.lsp` and run unchanged on both. The asm tier — 22 KB
|
||||||
|
stripped, 14 syscalls, no libc — was intentionally scoped out of
|
||||||
|
0004 because the minimal runtime lacks three features that `cl-
|
||||||
|
compat.lsp` and the `cl-loop` macro depend on:
|
||||||
|
|
||||||
|
1. **Quasiquote** (`` ` ,foo ,@bar ``) — every macro expansion in
|
||||||
|
`cl-compat.lsp` uses quasiquote templates. Without it the file
|
||||||
|
does not even parse on asm.
|
||||||
|
2. **`define-macro`** — cl-compat is ~90% macros. Without a macro
|
||||||
|
system the file cannot register them.
|
||||||
|
3. **`case`** — `cl-loop-emit` uses `case` for range-term dispatch
|
||||||
|
(`to` / `below` / `downto`). A macro definition via define-macro
|
||||||
|
suffices once (1) and (2) exist.
|
||||||
|
|
||||||
|
Phase 1 (commit `8cf6f44`) added rest-args, `cadr`, `sort`, and `let*`
|
||||||
|
to the default asm — enough to run `examples/ursa-scheme.lsp`, the
|
||||||
|
idiomatic Scheme port of Zoë's favorites. Phase 2 (this ticket) adds
|
||||||
|
the macro machinery so her CL source runs on asm unchanged.
|
||||||
|
|
||||||
|
## Goal
|
||||||
|
|
||||||
|
Build a third asm variant, `asm/lumbda-full`, produced with
|
||||||
|
`--defsym CL_FULL=1 --defsym GC_NAIVE=1`. It ships with:
|
||||||
|
|
||||||
|
- everything the existing `asm/lumbda-gc` has,
|
||||||
|
- quasiquote / unquote / unquote-splicing in the reader + evaluator,
|
||||||
|
- `define-macro` as a special form with a macro table and detection
|
||||||
|
pass that runs before procedure dispatch,
|
||||||
|
- an embedded Scheme prelude loaded at init that defines `caddr`,
|
||||||
|
`cadddr`, `cddr`, `cdddr`, `cddddr`, `1+`, `1-`, `add1`, `sub1`,
|
||||||
|
`square`, `list-ref`, `assq`, and `case` (as a macro),
|
||||||
|
- optional: a way to opt out of the prelude at startup for strict
|
||||||
|
R5RS work.
|
||||||
|
|
||||||
|
Acceptance: `./asm/lumbda-full examples/ursa.lisp.txt` loads Zoë's
|
||||||
|
CL source unchanged and produces identical answers to the Python and
|
||||||
|
C paths across the same test suite (`tests/ursa.lsp`).
|
||||||
|
|
||||||
|
## Scope — three asm variants
|
||||||
|
|
||||||
|
| Binary | Flags | Size target | Features |
|
||||||
|
|---|---|---|---|
|
||||||
|
| `asm/lumbda` | (none) | ~22 KB | minimal Scheme, bump allocator |
|
||||||
|
| `asm/lumbda-gc` | `GC_NAIVE=1` | ~55 KB | + mark-sweep GC + arena |
|
||||||
|
| `asm/lumbda-full` | `CL_FULL=1 GC_NAIVE=1` | ~70 KB | + quasiquote + macros + case + prelude |
|
||||||
|
|
||||||
|
The `CL_FULL` guard ensures the default and `-gc` tiers stay at their
|
||||||
|
current footprint. All new asm lives inside `.ifdef CL_FULL` blocks.
|
||||||
|
|
||||||
|
## Non-goals (stay out of scope)
|
||||||
|
|
||||||
|
- `defgeneric` / `defmethod` — requires CLOS dispatch tables. The
|
||||||
|
Scheme port's `digits` function already hand-ports this as
|
||||||
|
type-predicate cond, and the CL file omits `digits` accordingly.
|
||||||
|
- `make-array :adjustable :fill-pointer`, `vector-push-extend`,
|
||||||
|
`vector-pop` — requires a dynamic-array type and portal-format
|
||||||
|
extension. The Scheme port's `rho` uses a list-backed work stack,
|
||||||
|
and the CL file omits `rho`.
|
||||||
|
- Generalized `setf` (on `car`, `vector-ref`, etc.) — simple-variable
|
||||||
|
setf stays the supported shape.
|
||||||
|
|
||||||
|
## Migration path
|
||||||
|
|
||||||
|
Staged commits:
|
||||||
|
|
||||||
|
1. Makefile target + empty CL_FULL blocks (compiles, no behavior).
|
||||||
|
2. Prelude load mechanism — at init (CL_FULL only), evaluate an
|
||||||
|
embedded Scheme string that defines the small accessors.
|
||||||
|
3. Quasiquote — reader recognizes `` ` `` / `,` / `,@`, produces
|
||||||
|
`(quasiquote …)` / `(unquote …)` / `(unquote-splicing …)` forms.
|
||||||
|
Evaluator special-form for `quasiquote` that walks the template
|
||||||
|
and emits `cons` / `list` / `append` calls.
|
||||||
|
4. `define-macro` — new special form, macro table keyed by symbol,
|
||||||
|
detection pass in the eval dispatch before procedure apply,
|
||||||
|
re-eval of expansion result.
|
||||||
|
5. `case` as a macro (simpler than a special form once 4 exists).
|
||||||
|
6. Port `tests/zoe-favorites-test.sh` to run against `lumbda-full`.
|
||||||
|
|
||||||
|
Commit after every stage compiles and passes asm-test. Roll back any
|
||||||
|
stage that regresses the minimal or -gc tiers.
|
||||||
|
|
||||||
|
## Test strategy
|
||||||
|
|
||||||
|
- `asm/test.sh --full` runs the existing 158 assertions against
|
||||||
|
`lumbda-full` (should all pass — CL_FULL is purely additive).
|
||||||
|
- `tests/zoe-favorites-test.sh` learns a third case that feeds
|
||||||
|
`tests/ursa.lsp` to `asm/lumbda-full` and compares against the
|
||||||
|
Python and C answers.
|
||||||
|
- A new `asm/test-full.sh` or similar covers quasiquote, define-
|
||||||
|
macro, and case in isolation.
|
||||||
|
|
||||||
|
## What landed in this drop
|
||||||
|
|
||||||
|
- `asm/lumbda-full` target built with `CL_FULL=1 GC_NAIVE=1`. Default
|
||||||
|
and `-gc` tiers stay at their current footprint (all new code is
|
||||||
|
guarded by `.ifdef CL_FULL` — 158/158 asm tests pass against every
|
||||||
|
variant).
|
||||||
|
- Rest args on `lambda` / `define` — landed in default asm (earlier
|
||||||
|
commit `8cf6f44`). Both `.ac_bind` and `.apr_bind` handle
|
||||||
|
`(lambda (a . b) ...)` and `(define (f x . rest) ...)`.
|
||||||
|
- Reader backtrack on digit-prefixed symbols — `1+`, `1-`, `abc123`
|
||||||
|
now parse as symbols. After accumulating digits, the reader peeks
|
||||||
|
at the next char; if it is not a delimiter, input_pos is rewound
|
||||||
|
and control falls through to the symbol reader.
|
||||||
|
- `gensym` builtin — formats `"g%d"` via an in-BSS counter, interns
|
||||||
|
via `intern_static`. Available in every variant.
|
||||||
|
- Quasiquote / unquote / unquote-splicing — reader recognizes
|
||||||
|
`` ` `` / `,` / `,@` (CL_FULL). Evaluator `.ev_quasiquote` walks
|
||||||
|
the template: unquote evaluates; unquote-splicing evaluates then
|
||||||
|
`list_append_ab` splices; other pairs recurse and `make_pair`. No
|
||||||
|
nested quasiquote support (deliberate — see Non-goals).
|
||||||
|
- `define-macro` special form — stores macros in a dedicated
|
||||||
|
`macro_env_head` linked list of 24-byte `(sym, closure, next)`
|
||||||
|
nodes, separate from the value env. Eval dispatch checks
|
||||||
|
`macro_lookup` for any symbol operator that is not a special form;
|
||||||
|
on hit, the closure is applied to the *unevaluated* argument list
|
||||||
|
and the expansion re-enters `.eval_top` under TCO.
|
||||||
|
- Prelude auto-loaded at startup (`load_cl_full_prelude`) — evaluates
|
||||||
|
an embedded Scheme string before the REPL starts. Defines `caar`,
|
||||||
|
`cdar`, `caddr`, `cadddr`, `cddr`, `cdddr`, `cddddr`, `1+`, `1-`,
|
||||||
|
`add1`, `sub1`, `square`, `eq?` (alias for `eqv?`), `memq`,
|
||||||
|
`list-ref`, `assq`, and `case` as a macro. Input state is saved
|
||||||
|
and restored around the load so user scripts see a pristine reader.
|
||||||
|
|
||||||
|
## Verified on `asm/lumbda-full`
|
||||||
|
|
||||||
|
- `defun`, `setf`, `flet`, `multiple-value-bind`, `declare` all
|
||||||
|
expand and evaluate correctly.
|
||||||
|
- `&optional` args with defaults work.
|
||||||
|
- `case` macro dispatches by value on flat-list keys with `else`.
|
||||||
|
- Simple `cl-loop` forms work: `while + do + finally return`,
|
||||||
|
`for VAR from A to B` with `do` / `then` bodies.
|
||||||
|
- Quasiquote templates including `,@` splicing produce correct shape.
|
||||||
|
- `examples/ursa.lisp.txt` loads to completion — every `defun`
|
||||||
|
registers and its body parses under the shim.
|
||||||
|
|
||||||
|
## Known open issues (follow-up work)
|
||||||
|
|
||||||
|
1. **`cl-loop-emit` crashes on some parsed inputs.** Specifically,
|
||||||
|
`(cl-loop-emit '(() ((simple a 5)) () () () #f () ()))` returns
|
||||||
|
`(let* () (let g0 () (g0)))` — the `simple` iter's state binding
|
||||||
|
is dropped. Same input on Python and C returns the correct
|
||||||
|
`(let* ((g3 5)) (let g0 ((a g3)) ...))`. The parse output on
|
||||||
|
asm is correct; the bug is inside the emit's giant `let*` (30+
|
||||||
|
bindings). Reproduced in isolation; could not pin down after a
|
||||||
|
few hours — likely an asm-side env or stack interaction that
|
||||||
|
surfaces only inside this specific call shape.
|
||||||
|
|
||||||
|
Consequence: `(miller-rabin n)` and other defuns whose bodies use
|
||||||
|
`cl-loop repeat k for a = ...` expand incorrectly and crash at
|
||||||
|
run time. Zoë's full acceptance suite does not run end-to-end
|
||||||
|
yet on `asm/lumbda-full`.
|
||||||
|
|
||||||
|
2. **`examples/ursa-scheme.lsp` — `factor` crashes on some inputs**
|
||||||
|
under certain random seeds on asm (e.g. seed=2, `(factor 91)`).
|
||||||
|
Default asm has no macro overhead but does hit this under long
|
||||||
|
rhoff retry chains. Believed to be asm's bump allocator / stack
|
||||||
|
growth under deep recursion; out of CL_FULL's scope.
|
||||||
|
|
||||||
|
## Risk
|
||||||
|
|
||||||
|
- Quasiquote in asm is non-trivial, especially nested `` ` `` inside
|
||||||
|
another `` ` ``. Start with depth-1 only; raise error on nested.
|
||||||
|
- `define-macro` changes the eval dispatch path; regressions in
|
||||||
|
minimal tier are catastrophic. Guard strictly with `.ifdef
|
||||||
|
CL_FULL`; do not share dispatch tables between flavors.
|
||||||
|
- Prelude load at init must survive portal resume — a portal file
|
||||||
|
dumped from `-full` loads state relative to the already-initialized
|
||||||
|
prelude, which is an env snapshot. Verify portal round-trip stays
|
||||||
|
green.
|
||||||
|
- Stone-lisp image-based development (ticket 0004 framing) implies
|
||||||
|
some users keep `-full` processes alive indefinitely. The 1 MB GC
|
||||||
|
chunks in `-gc` apply — memory discipline per CLAUDE.md stays in
|
||||||
|
effect.
|
||||||
Loading…
Add table
Add a link
Reference in a new issue