diff --git a/asm/Makefile b/asm/Makefile index dae0c71..c5ba7d1 100644 --- a/asm/Makefile +++ b/asm/Makefile @@ -1,4 +1,4 @@ -all: lumbda lumbda-gc +all: lumbda lumbda-gc lumbda-full lumbda: 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 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 @bash test.sh test-gc: lumbda-gc @LUMBDA_BIN=./lumbda-gc bash test.sh -clean: - rm -f lumbda.o lumbda lumbda-gc.o lumbda-gc +test-full: lumbda-full + @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 diff --git a/asm/lumbda b/asm/lumbda index 0b13320..e1634d6 100755 Binary files a/asm/lumbda and b/asm/lumbda differ diff --git a/asm/lumbda-full b/asm/lumbda-full new file mode 100755 index 0000000..a059cb1 Binary files /dev/null and b/asm/lumbda-full differ diff --git a/asm/lumbda-full.o b/asm/lumbda-full.o new file mode 100644 index 0000000..a82c17b Binary files /dev/null and b/asm/lumbda-full.o differ diff --git a/asm/lumbda-gc b/asm/lumbda-gc index e51bc00..6f79623 100755 Binary files a/asm/lumbda-gc and b/asm/lumbda-gc differ diff --git a/asm/lumbda-gc.o b/asm/lumbda-gc.o index 2d4f19f..f7e4e29 100644 Binary files a/asm/lumbda-gc.o and b/asm/lumbda-gc.o differ diff --git a/asm/lumbda.o b/asm/lumbda.o index fe2a98c..e674896 100644 Binary files a/asm/lumbda.o and b/asm/lumbda.o differ diff --git a/asm/lumbda.s b/asm/lumbda.s index 1d04d5d..957ed3e 100644 --- a/asm/lumbda.s +++ b/asm/lumbda.s @@ -202,15 +202,16 @@ .equ BI_RANDOMSEEDFROMOS, 114 .equ BI_CADR, 115 .equ BI_SORT, 116 +.equ BI_GENSYM, 117 .ifdef GC_NAIVE -.equ BI_GC_COLLECT, 117 -.equ BI_GC_STATS, 118 -.equ BI_WITH_ARENA, 119 -.equ BI_ARENA_STATS, 120 -.equ BI_ARENA_SET_MODE, 121 -.equ BI_COUNT, 122 +.equ BI_GC_COLLECT, 118 +.equ BI_GC_STATS, 119 +.equ BI_WITH_ARENA, 120 +.equ BI_ARENA_STATS, 121 +.equ BI_ARENA_SET_MODE, 122 +.equ BI_COUNT, 123 .else -.equ BI_COUNT, 117 +.equ BI_COUNT, 118 .endif # ============================================================ @@ -233,6 +234,12 @@ 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" @@ -355,6 +362,7 @@ 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" .ifdef GC_NAIVE bn_gccollect: .byte 10; .ascii "gc-collect" bn_gcstats: .byte 8; .ascii "gc-stats" @@ -371,6 +379,49 @@ s_hashset: .ascii "#" err_ht_miss: .ascii "Error: hash-table-ref: missing key\n" .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" .equ PORTAL_MAGIC_LEN, 8 # magic(8) + heap_size(8) + heap_base(8) + r14(8) + r15(8) @@ -412,7 +463,7 @@ bi_names: .quad bn_isqrt .quad bn_randomseed, bn_randomint, bn_randomstate, bn_randomstateset .quad bn_randomseedfromos - .quad bn_cadr, bn_sort + .quad bn_cadr, bn_sort, bn_gensym .ifdef GC_NAIVE .quad bn_gccollect, bn_gcstats, bn_witharena, bn_arenastats, bn_arenamode .endif @@ -474,6 +525,12 @@ 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 @@ -505,6 +562,17 @@ g_rng_state: .skip 32 .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 + +.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). @@ -642,6 +710,12 @@ _start: xorq %rdi, %rdi 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) # Actually the OS already gave us a stack, so we're fine. @@ -1764,6 +1838,12 @@ scheme_read: 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 @@ -1804,6 +1884,50 @@ scheme_read: 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 @@ -1866,6 +1990,10 @@ scheme_read: 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 @@ -1883,6 +2011,27 @@ scheme_read: 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 @@ -2484,6 +2633,21 @@ eval: je .ev_and cmpq sym_or_val(%rip), %rbx 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 jmp .ev_app @@ -3175,6 +3339,243 @@ env_set_both: popq %rbx 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 ---- .ev_app: # %rbx = operator expr (in car position), %r12 = arg exprs @@ -3488,6 +3889,8 @@ eval_list: je bi_cadr cmpq $BI_SORT, %rax je bi_sort + cmpq $BI_GENSYM, %rax + je bi_gensym cmpq $BI_INTEGERP, %rax je bi_integerp cmpq $BI_PORTALSAVE, %rax @@ -4091,6 +4494,12 @@ apply_proc_raw: .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 @@ -4117,6 +4526,18 @@ apply_proc_raw: 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. @@ -4224,6 +4645,80 @@ bi_reverse: 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 + # (cadr x) — second element. Shortcut: (car (cdr x)). bi_cadr: GETARG %rdi @@ -5830,6 +6325,55 @@ bi_portal_resume: .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 # Mmaps file into memory, swaps input_buf_ptr, loops scheme_read+eval, # restores input state. Nestable — prior state saved on stack. @@ -7706,6 +8250,24 @@ init_special_forms: call intern_static 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 ret diff --git a/cl-compat.lsp b/cl-compat.lsp index 3bf0560..f25801e 100644 --- a/cl-compat.lsp +++ b/cl-compat.lsp @@ -157,6 +157,15 @@ ;; lumbda ships cadddr but not cddddr — supply the missing accessor. (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 ────────────────────────────────────── ;; CL code sprinkles `(declare (optimize (speed 3)) (type integer x))` ;; inside function bodies. These are compile-time directives in SBCL. @@ -400,7 +409,7 @@ ;; bindings (so the finalizer keeps access to current-iter values). (new-names (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 ;; references to EARLIER state vars with their new-names; later @@ -535,8 +544,7 @@ (cons (list temp init-sub) acc))))))) (named-let `(let* ,init-bindings - (let ,lp-name ,(map (lambda (v t) (list v t)) - state-vars init-temps) + (let ,lp-name ,(cl-zip state-vars init-temps) ,loop-body)))) (if (null? withs) named-let diff --git a/docs/tickets/0005-asm-cl-full.md b/docs/tickets/0005-asm-cl-full.md new file mode 100644 index 0000000..24abcf5 --- /dev/null +++ b/docs/tickets/0005-asm-cl-full.md @@ -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.