asm: rest args, cadr, sort, let* — Scheme port of Zoë's favorites runs

Phase 1 of the asm/lumbda-full roadmap (ticket 0005, in-flight). Adds
the minimum-cost set of additions that lets examples/ursa-scheme.lsp —
the idiomatic Scheme port of ursa.lisp.txt — load and produce correct
results on the asm tier. No CL shim yet: that requires quasiquote,
define-macro, and case, all of which are Phase 2 / 0005.

Added:

  * Rest-args in lambda — (define (f x . rest) ...). .ac_bind now
    detects when the remaining param list is a raw symbol (TAG_SYM)
    and binds it to the remaining arg list. Enables variadic defuns.

  * cadr builtin — (car (cdr x)) fast path. Used by Zoë's
    repunit-value and any CL-adjacent code.

  * sort builtin — ascending insertion sort on a tagged-int list.
    Non-destructive. Matches Python/C sort contract (default numeric
    ordering). Implementation ~50 lines, recursive sort + insert
    helpers.

  * let* special form — sequential binding where each init sees the
    preceding bindings' values. Fresh sf_let_star + sym_let_star_val
    + .ev_let_star branch that's a one-line variant of .ev_let (eval
    init in the extended env rather than the original). TCO preserved.

Tests: 9 new asm assertions in asm/test.sh covering cadr, sort (empty
/ singleton / unsorted / already-sorted), let* (basic + sequential),
rest-args (tail-only + rest-only). Total asm suite now 158 passing.

Known limitation: the Scheme port's factor / rho depends on random
rhoff iteration. For some seeds on asm (e.g. seed=2, factor 91) the
process runs out of virtual memory before rho finds a factor. The
underlying math is correct — this is an asm heap-bump-allocator
behavior under long random-retry chains and will be addressed along
with the CL_FULL work in ticket 0005. Python and C paths unaffected.

make test-all stays green across every tier.
This commit is contained in:
russell@unturf.com 2026-04-24 09:01:32 -04:00
parent 192118388f
commit 8cf6f44364
6 changed files with 183 additions and 7 deletions

Binary file not shown.

Binary file not shown.

Binary file not shown.

Binary file not shown.

View file

@ -200,15 +200,17 @@
.equ BI_RANDOMSTATE, 112
.equ BI_RANDOMSTATESET, 113
.equ BI_RANDOMSEEDFROMOS, 114
.equ BI_CADR, 115
.equ BI_SORT, 116
.ifdef GC_NAIVE
.equ BI_GC_COLLECT, 115
.equ BI_GC_STATS, 116
.equ BI_WITH_ARENA, 117
.equ BI_ARENA_STATS, 118
.equ BI_ARENA_SET_MODE, 119
.equ BI_COUNT, 120
.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
.else
.equ BI_COUNT, 115
.equ BI_COUNT, 117
.endif
# ============================================================
@ -229,6 +231,7 @@ 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"
sf_and: .byte 3; .ascii "and"
sf_or: .byte 2; .ascii "or"
@ -350,6 +353,8 @@ 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"
.ifdef GC_NAIVE
bn_gccollect: .byte 10; .ascii "gc-collect"
bn_gcstats: .byte 8; .ascii "gc-stats"
@ -407,6 +412,7 @@ bi_names:
.quad bn_isqrt
.quad bn_randomseed, bn_randomint, bn_randomstate, bn_randomstateset
.quad bn_randomseedfromos
.quad bn_cadr, bn_sort
.ifdef GC_NAIVE
.quad bn_gccollect, bn_gcstats, bn_witharena, bn_arenastats, bn_arenamode
.endif
@ -466,6 +472,7 @@ 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
sym_and_val: .quad 0
sym_or_val: .quad 0
@ -2469,6 +2476,8 @@ eval:
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
@ -2829,6 +2838,57 @@ env_set_both:
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...)
@ -3206,6 +3266,13 @@ eval_list:
.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
@ -3239,6 +3306,18 @@ eval_list:
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
@ -3405,6 +3484,10 @@ eval_list:
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_INTEGERP, %rax
je bi_integerp
cmpq $BI_PORTALSAVE, %rax
@ -4141,6 +4224,86 @@ bi_reverse:
call list_reverse
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.
@ -7523,6 +7686,10 @@ init_special_forms:
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)

View file

@ -57,6 +57,15 @@ check "isqrt-1" "(isqrt 1)" "1"
check "isqrt-perfect" "(isqrt 144)" "12"
check "isqrt-floor" "(isqrt 10)" "3"
check "isqrt-big" "(isqrt 1000000000000)" "1000000"
check "cadr" "(cadr (list 1 2 3))" "2"
check "sort-empty" "(sort (list))" "()"
check "sort-one" "(sort (list 42))" "(42)"
check "sort" "(sort (list 3 1 4 1 5 9 2 6))" "(1 1 2 3 4 5 6 9)"
check "sort-sorted" "(sort (list 1 2 3))" "(1 2 3)"
check "let*" "(let* ((x 1) (y (+ x 1))) y)" "2"
check "let*-seq" "(let* ((a 1) (b a) (c (+ a b))) c)" "2"
check "rest-args" "(define (f x . r) r) (f 1 2 3 4)" "(2 3 4)"
check "rest-only" "(define (g . a) a) (g 1 2 3)" "(1 2 3)"
check "random-int-1" "(begin (random-seed! 42) (random-int 1000000))" "558742"
check "random-int-2" "(begin (random-seed! 42) (random-int 1000000) (random-int 1000000))" "543102"
check "random-reseed" "(begin (random-seed! 42) (random-int 1000000) (random-seed! 42) (random-int 1000000))" "558742"