commit 96f2948c410b84aa05b9e575e860141a268dc8d3
parent 7d47e3a0a957c251ad510bd88c30d306b75f2e26
Author: Ryan Sepassi <rsepassi@gmail.com>
Date: Sat, 25 Apr 2026 08:38:51 -0700
Add scheme1 arith and list primitives
register_primitives is now table-driven: prim_table holds (name_ptr,
name_len, entry_label) triples and the loop allocates one PRIM per
entry, writes the entry label into its header slot, interns the surface
name, and binds the global. Adding a primitive is now one table row plus
the entry leaf.
New primitives: cons, car, cdr, null?, pair?, zero?, not, eq?, +, -, *,
=, <, bit-and, bit-or, arithmetic-shift, apply.
Tagged-fixnum arithmetic exploits the (n << 3) representation -- +, -,
< and bit-and / bit-or work directly on the tagged words. Only * untags
one operand to avoid a stray <<6.
apply handles both `(apply fn args-list)` and `(apply fn x ... args)`
via apply_build_args, a small recursive helper that prepends leading
arguments onto the trailing list.
Diffstat:
13 files changed, 343 insertions(+), 33 deletions(-)
diff --git a/scheme1/scheme1.P1pp b/scheme1/scheme1.P1pp
@@ -1579,42 +1579,269 @@
# section was at the mercy of preceding code length and could land at
# any 4-byte alignment, producing tag bits 5 or 7 instead of 3.)
#
-# register_primitives allocates one 16-byte PRIM per builtin, writes
-# the entry-function address into the entry slot, interns the surface
-# name, and binds the symbol's global to the HEAP-tagged pointer.
+# register_primitives walks prim_table at startup. Each table entry is
+# 24 bytes: 8-byte name_ptr (4-byte label ref + 4 pad), 8-byte name_len,
+# 8-byte entry_label (4 ref + 4 pad). For each entry we alloc a 16-byte
+# PRIM, write the entry-label into the prim header's entry slot, intern
+# the surface name, and bind the symbol's global slot to the HEAP-tagged
+# prim pointer.
#
-# Frame: 16 bytes
-# +0 prim ptr (HEAP-tagged, spilled across the intern call)
+# Frame: 24 bytes
+# +0 prim ptr (HEAP-tagged; spilled across intern + sym_set_global)
+# +8 walk (current table cursor)
+# +16 end (table_end)
+
+%fn(register_primitives, 24, {
+ %la(t0, &prim_table)
+ %st(t0, sp, 8)
+ %la(t0, &prim_table_end)
+ %st(t0, sp, 16)
+
+ ::loop
+ %ld(t0, sp, 8)
+ %ld(t1, sp, 16)
+ %beq(t0, t1, &::done)
-%fn(register_primitives, 16, {
- # alloc_hdr(bytes=16, hdr_word=HDR.PRIM) -> HEAP-tagged a0
+ # alloc_hdr(16, HDR.PRIM) -> HEAP-tagged a0.
%li(a0, 16)
%li(a1, %HDR.PRIM)
%call(&alloc_hdr)
- # Entry slot is at raw+8 = HEAP+5. la-prefix loads a 32-bit address
- # into the low half of t0; the upper half of the 8-byte slot stays
- # zero from the cons-zeroed heap, so an %st covers both halves.
- %la(t0, &prim_sys_exit_entry)
- %st(t0, a0, 5)
%st(a0, sp, 0)
- %la(a0, &name_sys_exit)
- %li(a1, 8)
+ # Write entry-label into prim's entry slot (raw+8 == tagged+5).
+ %ld(t0, sp, 8)
+ %ld(t1, t0, 16)
+ %ld(t2, sp, 0)
+ %st(t1, t2, 5)
+
+ # Intern surface name; bind global to prim ptr.
+ %ld(t0, sp, 8)
+ %ld(a0, t0, 0)
+ %ld(a1, t0, 8)
%call(&intern)
- %untag_sym(a0, a0) ; idx
- %ld(a1, sp, 0) ; HEAP-tagged prim ptr
- %tail(&sym_set_global)
+ %untag_sym(a0, a0)
+ %ld(a1, sp, 0)
+ %call(&sym_set_global)
+
+ %ld(t0, sp, 8)
+ %addi(t0, t0, 24)
+ %st(t0, sp, 8)
+ %b(&::loop)
+
+ ::done
})
-# prim_sys_exit_entry(args=a0). Args is a one-element list whose car is
-# the exit code as a tagged fixnum. Untag and tail-jump to libp1pp's
-# sys_exit (a %b, not a %call -- this is a leaf with no frame, and
-# sys_exit doesn't return anyway).
+# Each primitive is a leaf reached via apply's %tailr: args list is in a0,
+# and the result goes back in a0. Most use no frame at all; the few that
+# need recursion (apply) carry a small one via %fn.
+#
+# Two-arg arithmetic on tagged fixnums takes advantage of the (n << 3)
+# representation: + / - / signed compare / bit-and / bit-or all work
+# directly on the tagged words. Only * needs to untag one operand to
+# avoid a stray <<6.
+
+# (sys-exit code) -- libp1pp's sys_exit doesn't return; %b, not %call.
:prim_sys_exit_entry
- %car(a0, a0) ; car = fixnum
+ %car(a0, a0)
%untag_fix(a0, a0)
%b(&sys_exit)
+# (cons a b) -> tagged pair.
+:prim_cons_entry
+ %car(t0, a0)
+ %cdr(t1, a0)
+ %car(t1, t1)
+ %mov(a0, t0)
+ %mov(a1, t1)
+ %b(&cons)
+
+# (car p), (cdr p)
+:prim_car_entry
+ %car(a0, a0)
+ %car(a0, a0)
+ %ret
+
+:prim_cdr_entry
+ %car(a0, a0)
+ %cdr(a0, a0)
+ %ret
+
+# Predicate primitives. Same shape: extract the arg, compare, return one
+# of the two boolean immediates.
+
+:prim_nullq_entry
+%scope prim_nullq
+ %car(t0, a0)
+ %li(t1, %imm_val(%IMM.NIL))
+ %li(a0, %imm_val(%IMM.FALSE))
+ %bne(t0, t1, &::end)
+ %li(a0, %imm_val(%IMM.TRUE))
+ ::end
+ %ret
+%endscope
+
+:prim_pairq_entry
+%scope prim_pairq
+ %car(t0, a0)
+ %tagof(t1, t0)
+ %li(t2, %TAG.PAIR)
+ %li(a0, %imm_val(%IMM.FALSE))
+ %bne(t1, t2, &::end)
+ %li(a0, %imm_val(%IMM.TRUE))
+ ::end
+ %ret
+%endscope
+
+:prim_zeroq_entry
+%scope prim_zeroq
+ %car(t0, a0)
+ %li(a0, %imm_val(%IMM.FALSE))
+ %bnez(t0, &::end)
+ %li(a0, %imm_val(%IMM.TRUE))
+ ::end
+ %ret
+%endscope
+
+:prim_not_entry
+%scope prim_not
+ %car(t0, a0)
+ %li(t1, %imm_val(%IMM.FALSE))
+ %li(a0, %imm_val(%IMM.FALSE))
+ %bne(t0, t1, &::end)
+ %li(a0, %imm_val(%IMM.TRUE))
+ ::end
+ %ret
+%endscope
+
+:prim_eqq_entry
+%scope prim_eqq
+ %car(t0, a0)
+ %cdr(t1, a0)
+ %car(t1, t1)
+ %li(a0, %imm_val(%IMM.FALSE))
+ %bne(t0, t1, &::end)
+ %li(a0, %imm_val(%IMM.TRUE))
+ ::end
+ %ret
+%endscope
+
+# Two-arg arithmetic.
+
+:prim_plus_entry
+ %car(t0, a0)
+ %cdr(t1, a0)
+ %car(t1, t1)
+ %add(a0, t0, t1)
+ %ret
+
+:prim_minus_entry
+ %car(t0, a0)
+ %cdr(t1, a0)
+ %car(t1, t1)
+ %sub(a0, t0, t1)
+ %ret
+
+:prim_mult_entry
+ %car(t0, a0)
+ %cdr(t1, a0)
+ %car(t1, t1)
+ %untag_fix(t1, t1)
+ %mul(a0, t0, t1)
+ %ret
+
+:prim_eq_entry
+%scope prim_eq
+ %car(t0, a0)
+ %cdr(t1, a0)
+ %car(t1, t1)
+ %li(a0, %imm_val(%IMM.FALSE))
+ %bne(t0, t1, &::end)
+ %li(a0, %imm_val(%IMM.TRUE))
+ ::end
+ %ret
+%endscope
+
+:prim_lt_entry
+%scope prim_lt
+ %car(t0, a0)
+ %cdr(t1, a0)
+ %car(t1, t1)
+ %li(a0, %imm_val(%IMM.TRUE))
+ %blt(t0, t1, &::end)
+ %li(a0, %imm_val(%IMM.FALSE))
+ ::end
+ %ret
+%endscope
+
+:prim_bit_and_entry
+ %car(t0, a0)
+ %cdr(t1, a0)
+ %car(t1, t1)
+ %and(a0, t0, t1)
+ %ret
+
+:prim_bit_or_entry
+ %car(t0, a0)
+ %cdr(t1, a0)
+ %car(t1, t1)
+ %or(a0, t0, t1)
+ %ret
+
+# (arithmetic-shift n k): k > 0 means left shift; k < 0 means arith right.
+# Untag both, branch on sign of k, retag.
+:prim_arith_shift_entry
+%scope prim_arith_shift
+ %car(t0, a0)
+ %cdr(t1, a0)
+ %car(t1, t1)
+ %untag_fix(t0, t0)
+ %untag_fix(t1, t1)
+ %bltz(t1, &::right)
+ %shl(a0, t0, t1)
+ %mkfix(a0, a0)
+ %ret
+ ::right
+ %li(t2, 0)
+ %sub(t1, t2, t1)
+ %sar(a0, t0, t1)
+ %mkfix(a0, a0)
+ %ret
+%endscope
+
+# (apply fn rest...) -- the trailing element of `rest` is a list; any
+# leading elements get prepended to it. apply_build_args walks `rest` and
+# returns the assembled args list; prim_apply_entry then tail-calls apply.
+%fn(prim_apply_entry, 16, {
+ %st(a0, sp, 0)
+ %cdr(a0, a0)
+ %call(&apply_build_args)
+ %mov(t0, a0)
+ %ld(a0, sp, 0)
+ %car(a0, a0)
+ %mov(a1, t0)
+ %tail(&apply)
+})
+
+%fn(apply_build_args, 16, {
+ %st(a0, sp, 0)
+
+ %cdr(t0, a0)
+ %li(t1, %imm_val(%IMM.NIL))
+ %beq(t0, t1, &::single)
+
+ %ld(a0, sp, 0)
+ %cdr(a0, a0)
+ %call(&apply_build_args)
+ %mov(a1, a0)
+ %ld(a0, sp, 0)
+ %car(a0, a0)
+ %tail(&cons)
+
+ ::single
+ %ld(a0, sp, 0)
+ %car(a0, a0)
+})
+
# =========================================================================
# Read-only data
# =========================================================================
@@ -1622,17 +1849,59 @@
# Surface names. Length is hard-coded at the call site; no NUL needed
# because intern takes (ptr, len). Aligned padding via "\0" bytes is
# fine -- M0 emits ASCII verbatim.
-:name_quote "quote"
-:name_if "if"
-:name_lambda "lambda"
-:name_define "define"
-:name_begin "begin"
-:name_cond "cond"
-:name_else "else"
-:name_let "let"
-:name_letstar "let*"
-:name_letrec "letrec"
-:name_sys_exit "sys-exit"
+:name_quote "quote"
+:name_if "if"
+:name_lambda "lambda"
+:name_define "define"
+:name_begin "begin"
+:name_cond "cond"
+:name_else "else"
+:name_let "let"
+:name_letstar "let*"
+:name_letrec "letrec"
+
+# Primitive surface names.
+:name_sys_exit "sys-exit"
+:name_cons "cons"
+:name_car "car"
+:name_cdr "cdr"
+:name_nullq "null?"
+:name_pairq "pair?"
+:name_zeroq "zero?"
+:name_not "not"
+:name_eqq "eq?"
+:name_plus "+"
+:name_minus "-"
+:name_mult "*"
+:name_eq "="
+:name_lt "<"
+:name_bit_and "bit-and"
+:name_bit_or "bit-or"
+:name_arith_shift "arithmetic-shift"
+:name_apply "apply"
+
+# Primitive registration table. Each entry: 8-byte name_ptr (4-byte label
+# ref + 4 pad), 8-byte name_len, 8-byte entry_label (4 ref + 4 pad).
+:prim_table
+&name_sys_exit %(0) $(8) &prim_sys_exit_entry %(0)
+&name_cons %(0) $(4) &prim_cons_entry %(0)
+&name_car %(0) $(3) &prim_car_entry %(0)
+&name_cdr %(0) $(3) &prim_cdr_entry %(0)
+&name_nullq %(0) $(5) &prim_nullq_entry %(0)
+&name_pairq %(0) $(5) &prim_pairq_entry %(0)
+&name_zeroq %(0) $(5) &prim_zeroq_entry %(0)
+&name_not %(0) $(3) &prim_not_entry %(0)
+&name_eqq %(0) $(3) &prim_eqq_entry %(0)
+&name_plus %(0) $(1) &prim_plus_entry %(0)
+&name_minus %(0) $(1) &prim_minus_entry %(0)
+&name_mult %(0) $(1) &prim_mult_entry %(0)
+&name_eq %(0) $(1) &prim_eq_entry %(0)
+&name_lt %(0) $(1) &prim_lt_entry %(0)
+&name_bit_and %(0) $(7) &prim_bit_and_entry %(0)
+&name_bit_or %(0) $(6) &prim_bit_or_entry %(0)
+&name_arith_shift %(0) $(16) &prim_arith_shift_entry %(0)
+&name_apply %(0) $(5) &prim_apply_entry %(0)
+:prim_table_end
:msg_usage "scheme1: usage: scheme1 SOURCE.scm" '0a' '00'
:msg_load_fail "scheme1: failed to read source" '0a' '00'
diff --git a/tests/scheme1/23-cons-car-cdr.expected-exit b/tests/scheme1/23-cons-car-cdr.expected-exit
@@ -0,0 +1 @@
+18
diff --git a/tests/scheme1/23-cons-car-cdr.scm b/tests/scheme1/23-cons-car-cdr.scm
@@ -0,0 +1,3 @@
+; cons + car/cdr round-trip plus arithmetic.
+(define p (cons 7 11))
+(sys-exit (+ (car p) (cdr p)))
diff --git a/tests/scheme1/24-arith.expected-exit b/tests/scheme1/24-arith.expected-exit
@@ -0,0 +1 @@
+47
diff --git a/tests/scheme1/24-arith.scm b/tests/scheme1/24-arith.scm
@@ -0,0 +1,3 @@
+; +, -, * working together.
+(define x 10)
+(sys-exit (- (* x 5) 3)) ; 47
diff --git a/tests/scheme1/25-comparisons.expected-exit b/tests/scheme1/25-comparisons.expected-exit
@@ -0,0 +1 @@
+26
diff --git a/tests/scheme1/25-comparisons.scm b/tests/scheme1/25-comparisons.scm
@@ -0,0 +1,15 @@
+; <, =, zero?, not, eq?, pair?, null? interact correctly with truthiness.
+(sys-exit
+ (if (< 3 5)
+ (if (= 4 4)
+ (if (zero? 0)
+ (if (not (pair? '()))
+ (if (pair? (cons 1 2))
+ (if (null? '())
+ (if (eq? 'a 'a) 26 1)
+ 2)
+ 3)
+ 4)
+ 5)
+ 6)
+ 7))
diff --git a/tests/scheme1/26-bitwise.expected-exit b/tests/scheme1/26-bitwise.expected-exit
@@ -0,0 +1 @@
+85
diff --git a/tests/scheme1/26-bitwise.scm b/tests/scheme1/26-bitwise.scm
@@ -0,0 +1,5 @@
+; bit-and, bit-or, arithmetic-shift on tagged fixnums.
+(define x (bit-or (bit-and #x33 #x0f) #x20)) ; 0x23 = 35
+(define y (arithmetic-shift x -1)) ; 17
+(define z (arithmetic-shift y 2)) ; 68
+(sys-exit (+ y z)) ; 85
diff --git a/tests/scheme1/27-apply.expected-exit b/tests/scheme1/27-apply.expected-exit
@@ -0,0 +1 @@
+70
diff --git a/tests/scheme1/27-apply.scm b/tests/scheme1/27-apply.scm
@@ -0,0 +1,5 @@
+; apply with 2-arg ((apply fn args)) and prefixed-args ((apply fn x... args)) forms.
+(define (k a b c) (+ a (- b c)))
+(define two-arg (apply k '(10 30 5))) ; k(10,30,5) = 35
+(define prefixed (apply k 10 '(30 5))) ; same call shape
+(sys-exit (+ two-arg prefixed)) ; 70
diff --git a/tests/scheme1/28-list-recursion.expected-exit b/tests/scheme1/28-list-recursion.expected-exit
@@ -0,0 +1 @@
+15
diff --git a/tests/scheme1/28-list-recursion.scm b/tests/scheme1/28-list-recursion.scm
@@ -0,0 +1,4 @@
+; Recursive list traversal using cons/car/cdr/null?/+.
+(define (sum-list xs)
+ (if (null? xs) 0 (+ (car xs) (sum-list (cdr xs)))))
+(sys-exit (sum-list '(1 2 3 4 5))) ; 15
