commit 6ff8a39efb43086b165a90851556c3e44e185295
parent ab60ce5e5c26d78e7328d3a8f7f99c54f3142e00
Author: Ryan Sepassi <rsepassi@gmail.com>
Date: Sat, 25 Apr 2026 09:10:26 -0700
Add scheme1 define-record-type and parameterized PRIM data slot
PRIM grows from 16 bytes to 24: header word, entry-label word, and a
new per-instance data slot (offset 13 from the tagged pointer). apply's
PRIM dispatch now passes the prim itself in a1 alongside args in a0,
so a parameterized PRIM can read the data word and dispatch on a
specific TD or field index without indirecting through s-expressions.
define-record-type allocates one TD plus one PRIM per ctor / predicate /
accessor / mutator name, binding each name's global directly:
ctor -- data = TD; allocates a fresh REC with the args inline
pred -- data = TD; checks tag + HDR.REC + matching td slot
accessor -- data = tagged field index; reads rec[idx]
mutator -- data = tagged field index; writes rec[idx]
The original `%record-*` internal primitives are also exposed in
prim_table for direct use, parallel to the parameterized entries.
Plain primitives never touch the data slot and stay zero-initialized.
Diffstat:
9 files changed, 430 insertions(+), 5 deletions(-)
diff --git a/scheme1/scheme1.P1pp b/scheme1/scheme1.P1pp
@@ -46,8 +46,10 @@
# Layout helpers. %struct stride is 8 bytes per field.
%struct PAIR { car cdr } # .SIZE = 16
%struct SYMENT { name_ptr name_len global_val pad } # .SIZE = 32
-%struct PRIM { hdr entry_w } # .SIZE = 16
+%struct PRIM { hdr entry_w data } # .SIZE = 24
%struct CLOSURE { hdr params body env } # .SIZE = 32
+%struct TD { hdr name nfields } # .SIZE = 24
+# Records are variable width: header + td slot + N field slots.
# BSS arena offsets from :ELF_end. Each arena is 64 KiB; the three are
# packed back-to-back below ELF_end + 192 KiB. p1_main's startup loop
@@ -819,6 +821,7 @@
%dispatch_form(&sym_let, &::do_let)
%dispatch_form(&sym_letstar, &::do_letstar)
%dispatch_form(&sym_letrec, &::do_letrec)
+ %dispatch_form(&sym_define_record_type, &::do_define_record_type)
# head = eval(car(expr), env)
%ld(a0, sp, 0)
@@ -861,6 +864,8 @@
%tail_to_handler(&eval_letstar)
::do_letrec
%tail_to_handler(&eval_letrec)
+ ::do_define_record_type
+ %tail_to_handler(&eval_define_record_type)
})
# eval_args(args=a0, env=a1) -> evaluated args list (cons-built).
@@ -916,8 +921,12 @@
%die(msg_not_proc, 8)
::prim
- %ld(t0, a0, 5) ; t0 = entry word (offset = -3 + 8)
- %ld(a0, sp, 0) ; args list -> a0
+ # Primitives are called with args list in a0 and the prim ptr itself
+ # in a1, so parameterized prims (eg record accessors) can read their
+ # data slot via a1+13. Plain primitives ignore a1.
+ %mov(a1, a0)
+ %ld(t0, a0, 5)
+ %ld(a0, sp, 0)
%tailr(t0)
::closure
@@ -960,6 +969,7 @@
%intern_form(&name_let, 3, &sym_let)
%intern_form(&name_letstar, 4, &sym_letstar)
%intern_form(&name_letrec, 6, &sym_letrec)
+ %intern_form(&name_define_record_type, 18, &sym_define_record_type)
})
# eval_if(rest=a0, env=a1) -> value (a0). `rest` is (test then else).
@@ -1602,8 +1612,11 @@
%ld(t1, sp, 16)
%beq(t0, t1, &::done)
- # alloc_hdr(16, HDR.PRIM) -> HEAP-tagged a0.
- %li(a0, 16)
+ # alloc_hdr(24, HDR.PRIM) -> HEAP-tagged a0. The third slot (offset 13
+ # from tagged) holds per-instance data and stays zero for the
+ # primitives registered here -- only parameterized prims (record
+ # ctor/predicate/accessor/mutator) read it.
+ %li(a0, 24)
%li(a1, %HDR.PRIM)
%call(&alloc_hdr)
%st(a0, sp, 0)
@@ -2129,6 +2142,363 @@
%car(a0, a0)
})
+# Records: TDs (type descriptors) and instances. A TD is a 24-byte heap
+# object [HDR.TD][name_sym][nfields_raw]. A record is a variable-width
+# heap object [HDR.REC][td][field_0]...[field_{n-1}], so field i lives at
+# tagged + 13 + 8*i. define-record-type allocates one TD plus one
+# parameterized PRIM per ctor/predicate/accessor/mutator, all pointing
+# into the same TD via the prim's data slot.
+
+# make_param_prim(entry=a0, data=a1) -> prim (a0). Allocates a 24-byte
+# PRIM, sets the entry label and data word.
+%fn(make_param_prim, 16, {
+ %st(a0, sp, 0)
+ %st(a1, sp, 8)
+
+ %li(a0, 24)
+ %li(a1, %HDR.PRIM)
+ %call(&alloc_hdr)
+
+ %ld(t0, sp, 0)
+ %st(t0, a0, 5)
+ %ld(t1, sp, 8)
+ %st(t1, a0, 13)
+})
+
+# (%make-record-td name nfields) -- args = (name nfields).
+%fn(prim_make_record_td_entry, 16, {
+ %st(a0, sp, 0)
+ %li(a0, 24)
+ %li(a1, %HDR.TD)
+ %call(&alloc_hdr)
+
+ %ld(t0, sp, 0)
+ %car(t1, t0) ; name sym
+ %st(t1, a0, 5)
+ %cdr(t0, t0)
+ %car(t0, t0)
+ %sari(t0, t0, 3) ; raw nfields
+ %st(t0, a0, 13)
+})
+
+# (%make-record td f0 f1 ...) -- args = (td . fields).
+%fn(prim_make_record_entry, 24, {
+ %st(a0, sp, 0)
+
+ # Count fields = length(args) - 1. We'll use the args walker for the
+ # actual fill, just count to size the allocation.
+ %cdr(t0, a0)
+ %li(t1, 0)
+ ::count_loop
+ %li(t2, %imm_val(%IMM.NIL))
+ %beq(t0, t2, &::count_done)
+ %addi(t1, t1, 1)
+ %cdr(t0, t0)
+ %b(&::count_loop)
+ ::count_done
+
+ %shli(a0, t1, 3)
+ %addi(a0, a0, 16)
+ %li(a1, %HDR.REC)
+ %call(&alloc_hdr)
+ %st(a0, sp, 8)
+
+ # td (offset +5) = car(args)
+ %ld(t0, sp, 0)
+ %car(t0, t0)
+ %st(t0, a0, 5)
+
+ # Walk fields, filling +13, +21, ...
+ %ld(t0, sp, 0)
+ %cdr(t0, t0)
+ %addi(t1, a0, 13)
+
+ ::fill_loop
+ %li(t2, %imm_val(%IMM.NIL))
+ %beq(t0, t2, &::fill_done)
+ %car(t2, t0)
+ %st(t2, t1, 0)
+ %addi(t1, t1, 8)
+ %cdr(t0, t0)
+ %b(&::fill_loop)
+
+ ::fill_done
+ %ld(a0, sp, 8)
+})
+
+# (%record-ref rec idx)
+:prim_record_ref_entry
+ %car(t0, a0) ; rec
+ %cdr(t1, a0)
+ %car(t1, t1) ; tagged idx (= idx << 3)
+ %addi(t1, t1, 13)
+ %add(t1, t1, t0)
+ %ld(a0, t1, 0)
+ %ret
+
+# (%record-set! rec idx val)
+:prim_record_set_entry
+%scope prim_record_set
+ %car(t0, a0)
+ %cdr(t1, a0)
+ %car(t2, t1) ; tagged idx
+ %cdr(t1, t1)
+ %car(t1, t1) ; val
+ %addi(t2, t2, 13)
+ %add(t2, t2, t0)
+ %st(t1, t2, 0)
+ %li(a0, %imm_val(%IMM.UNSPEC))
+ %ret
+%endscope
+
+# (%record-is-a? rec td)
+:prim_record_is_a_entry
+%scope prim_record_is_a
+ %car(t0, a0)
+ %cdr(t1, a0)
+ %car(t1, t1)
+ %tagof(t2, t0)
+ %li(a0, %imm_val(%IMM.FALSE))
+ %li(a2, %TAG.HEAP)
+ %bne(t2, a2, &::end)
+ %hdr_type(t2, t0)
+ %li(a2, %HDR.REC)
+ %bne(t2, a2, &::end)
+ %ld(t2, t0, 5)
+ %bne(t2, t1, &::end)
+ %li(a0, %imm_val(%IMM.TRUE))
+ ::end
+ %ret
+%endscope
+
+# (%record-td rec) -- returns rec's TD pointer.
+:prim_record_td_entry
+ %car(t0, a0)
+ %ld(a0, t0, 5)
+ %ret
+
+# Parameterized PRIM entries used by define-record-type. Each receives
+# args in a0 and the prim itself in a1; the prim's data slot (offset 13
+# from tagged) holds either the TD or a tagged field index.
+
+# ctor: prim.data = TD (HEAP); args = (f0 f1 ...). Inlines the
+# %make-record body so we don't have to cons (TD . args) first.
+%fn(prim_ctor_entry, 24, {
+ # +0 args
+ # +8 td (from prim.data)
+ # +16 record
+ %st(a0, sp, 0)
+ %ld(t0, a1, 13)
+ %st(t0, sp, 8)
+
+ # Count = length(args).
+ %ld(t1, sp, 0)
+ %li(t2, 0)
+ ::count_loop
+ %li(a2, %imm_val(%IMM.NIL))
+ %beq(t1, a2, &::count_done)
+ %addi(t2, t2, 1)
+ %cdr(t1, t1)
+ %b(&::count_loop)
+ ::count_done
+
+ %shli(a0, t2, 3)
+ %addi(a0, a0, 16)
+ %li(a1, %HDR.REC)
+ %call(&alloc_hdr)
+ %st(a0, sp, 16)
+
+ %ld(t0, sp, 8)
+ %st(t0, a0, 5)
+
+ %ld(t0, sp, 0)
+ %addi(t1, a0, 13)
+
+ ::fill_loop
+ %li(t2, %imm_val(%IMM.NIL))
+ %beq(t0, t2, &::fill_done)
+ %car(t2, t0)
+ %st(t2, t1, 0)
+ %addi(t1, t1, 8)
+ %cdr(t0, t0)
+ %b(&::fill_loop)
+
+ ::fill_done
+ %ld(a0, sp, 16)
+})
+
+# predicate: prim.data = TD; args = (rec).
+:prim_predicate_entry
+%scope prim_predicate
+ %car(t0, a0)
+ %ld(t1, a1, 13)
+ %tagof(t2, t0)
+ %li(a0, %imm_val(%IMM.FALSE))
+ %li(a2, %TAG.HEAP)
+ %bne(t2, a2, &::end)
+ %hdr_type(t2, t0)
+ %li(a2, %HDR.REC)
+ %bne(t2, a2, &::end)
+ %ld(t2, t0, 5)
+ %bne(t2, t1, &::end)
+ %li(a0, %imm_val(%IMM.TRUE))
+ ::end
+ %ret
+%endscope
+
+# accessor: prim.data = tagged field index; args = (rec).
+:prim_accessor_entry
+ %car(t0, a0)
+ %ld(t1, a1, 13)
+ %addi(t1, t1, 13)
+ %add(t1, t1, t0)
+ %ld(a0, t1, 0)
+ %ret
+
+# mutator: prim.data = tagged field index; args = (rec val).
+:prim_mutator_entry
+%scope prim_mutator
+ %car(t0, a0)
+ %cdr(t1, a0)
+ %car(t1, t1)
+ %ld(t2, a1, 13)
+ %addi(t2, t2, 13)
+ %add(t2, t2, t0)
+ %st(t1, t2, 0)
+ %li(a0, %imm_val(%IMM.UNSPEC))
+ %ret
+%endscope
+
+# eval_define_record_type(rest=a0, env=a1) -> UNSPEC.
+# rest = (name (ctor f1 ...) pred clause1 clause2 ...)
+# Each clause is (field-name accessor) or (field-name accessor mutator).
+# Allocates one TD + one parameterized PRIM per name introduced (ctor,
+# predicate, accessor, mutator) and binds each to the symbol's global.
+#
+# Frame: 56 bytes
+# +0 rest
+# +8 env (unused, but the dispatcher passes it)
+# +16 td
+# +24 walk (clauses, advancing)
+# +32 idx (raw counter)
+# +40 nfields
+%fn(eval_define_record_type, 56, {
+ %st(a0, sp, 0)
+ %st(a1, sp, 8)
+
+ # clauses = cdddr(rest); count them while we're at it.
+ %ld(t0, sp, 0)
+ %cdr(t0, t0)
+ %cdr(t0, t0)
+ %cdr(t0, t0)
+ %st(t0, sp, 24)
+ %li(t1, 0)
+ ::count_loop
+ %li(t2, %imm_val(%IMM.NIL))
+ %beq(t0, t2, &::count_done)
+ %addi(t1, t1, 1)
+ %cdr(t0, t0)
+ %b(&::count_loop)
+ ::count_done
+ %st(t1, sp, 40)
+
+ # td = alloc_hdr(24, HDR.TD); td.name = type-name; td.nfields = nfields.
+ %li(a0, 24)
+ %li(a1, %HDR.TD)
+ %call(&alloc_hdr)
+ %st(a0, sp, 16)
+ %ld(t0, sp, 0)
+ %car(t0, t0)
+ %st(t0, a0, 5)
+ %ld(t1, sp, 40)
+ %st(t1, a0, 13)
+
+ # ctor-prim = make_param_prim(prim_ctor_entry, td); bind ctor-name.
+ %la(a0, &prim_ctor_entry)
+ %ld(a1, sp, 16)
+ %call(&make_param_prim)
+ %ld(t0, sp, 0)
+ %cdr(t0, t0)
+ %car(t0, t0)
+ %car(t0, t0)
+ %untag_sym(t0, t0)
+ %mov(a1, a0)
+ %mov(a0, t0)
+ %call(&sym_set_global)
+
+ # pred-prim = make_param_prim(prim_predicate_entry, td); bind pred.
+ %la(a0, &prim_predicate_entry)
+ %ld(a1, sp, 16)
+ %call(&make_param_prim)
+ %ld(t0, sp, 0)
+ %cdr(t0, t0)
+ %cdr(t0, t0)
+ %car(t0, t0)
+ %untag_sym(t0, t0)
+ %mov(a1, a0)
+ %mov(a0, t0)
+ %call(&sym_set_global)
+
+ # Iterate clauses: bind accessor + optional mutator per clause.
+ %li(t0, 0)
+ %st(t0, sp, 32)
+
+ ::clause_loop
+ %ld(t0, sp, 24)
+ %li(t1, %imm_val(%IMM.NIL))
+ %beq(t0, t1, &::done)
+
+ # accessor-prim with data = tagged idx; bind cadr(clause).
+ %ld(a1, sp, 32)
+ %shli(a1, a1, 3)
+ %la(a0, &prim_accessor_entry)
+ %call(&make_param_prim)
+
+ %ld(t0, sp, 24)
+ %car(t0, t0)
+ %cdr(t0, t0)
+ %car(t0, t0)
+ %untag_sym(t0, t0)
+ %mov(a1, a0)
+ %mov(a0, t0)
+ %call(&sym_set_global)
+
+ # Mutator? If cddr(clause) is a pair, bind it.
+ %ld(t0, sp, 24)
+ %car(t0, t0)
+ %cdr(t0, t0)
+ %cdr(t0, t0)
+ %li(t1, %imm_val(%IMM.NIL))
+ %beq(t0, t1, &::no_mutator)
+
+ %ld(a1, sp, 32)
+ %shli(a1, a1, 3)
+ %la(a0, &prim_mutator_entry)
+ %call(&make_param_prim)
+
+ %ld(t0, sp, 24)
+ %car(t0, t0)
+ %cdr(t0, t0)
+ %cdr(t0, t0)
+ %car(t0, t0)
+ %untag_sym(t0, t0)
+ %mov(a1, a0)
+ %mov(a0, t0)
+ %call(&sym_set_global)
+
+ ::no_mutator
+ %ld(t0, sp, 24)
+ %cdr(t0, t0)
+ %st(t0, sp, 24)
+ %ld(t0, sp, 32)
+ %addi(t0, t0, 1)
+ %st(t0, sp, 32)
+ %b(&::clause_loop)
+
+ ::done
+ %li(a0, %imm_val(%IMM.UNSPEC))
+})
+
# =========================================================================
# Read-only data
# =========================================================================
@@ -2146,6 +2516,7 @@
:name_let "let"
:name_letstar "let*"
:name_letrec "letrec"
+:name_define_record_type "define-record-type"
# Primitive surface names.
:name_sys_exit "sys-exit"
@@ -2173,6 +2544,12 @@
:name_bv_copy "bytevector-copy"
:name_bv_copy_b "bytevector-copy!"
:name_bv_grow "bytevector-grow!"
+:name_make_rt "%make-record-td"
+:name_make_rec "%make-record"
+:name_record_ref "%record-ref"
+:name_record_set "%record-set!"
+:name_record_isa "%record-is-a?"
+:name_record_td "%record-td"
# 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).
@@ -2202,6 +2579,12 @@
&name_bv_copy %(0) $(15) &prim_bv_copy_entry %(0)
&name_bv_copy_b %(0) $(16) &prim_bv_copy_bang_entry %(0)
&name_bv_grow %(0) $(16) &prim_bv_grow_entry %(0)
+&name_make_rt %(0) $(15) &prim_make_record_td_entry %(0)
+&name_make_rec %(0) $(12) &prim_make_record_entry %(0)
+&name_record_ref %(0) $(11) &prim_record_ref_entry %(0)
+&name_record_set %(0) $(12) &prim_record_set_entry %(0)
+&name_record_isa %(0) $(13) &prim_record_is_a_entry %(0)
+&name_record_td %(0) $(10) &prim_record_td_entry %(0)
:prim_table_end
:msg_usage "scheme1: usage: scheme1 SOURCE.scm" '0a' '00'
@@ -2252,6 +2635,7 @@
:sym_let $(0)
:sym_letstar $(0)
:sym_letrec $(0)
+:sym_define_record_type $(0)
# Pointer slots for the past-:ELF_end arenas.
:readbuf_buf_ptr $(0)
diff --git a/tests/scheme1/35-record-basic.expected-exit b/tests/scheme1/35-record-basic.expected-exit
@@ -0,0 +1 @@
+18
diff --git a/tests/scheme1/35-record-basic.scm b/tests/scheme1/35-record-basic.scm
@@ -0,0 +1,9 @@
+; define-record-type with constructor and accessors.
+(define-record-type point
+ (make-point x y)
+ point?
+ (x point-x)
+ (y point-y set-point-y!))
+
+(define p (make-point 7 11))
+(sys-exit (+ (point-x p) (point-y p)))
diff --git a/tests/scheme1/36-record-mutator.expected-exit b/tests/scheme1/36-record-mutator.expected-exit
@@ -0,0 +1 @@
+38
diff --git a/tests/scheme1/36-record-mutator.scm b/tests/scheme1/36-record-mutator.scm
@@ -0,0 +1,10 @@
+; Mutators update the field in place; later accessor reads the new value.
+(define-record-type point
+ (make-point x y)
+ point?
+ (x point-x)
+ (y point-y set-point-y!))
+
+(define p (make-point 5 5))
+(set-point-y! p 33)
+(sys-exit (+ (point-x p) (point-y p)))
diff --git a/tests/scheme1/37-record-predicate.expected-exit b/tests/scheme1/37-record-predicate.expected-exit
@@ -0,0 +1 @@
+22
diff --git a/tests/scheme1/37-record-predicate.scm b/tests/scheme1/37-record-predicate.scm
@@ -0,0 +1,11 @@
+; Predicates distinguish disjoint record types; rejects non-records too.
+(define-record-type point (make-point x y) point? (x point-x) (y point-y))
+(define-record-type box (make-box w) box? (w box-w))
+
+(define p (make-point 1 2))
+(define b (make-box 99))
+(sys-exit (cond ((point? b) 1)
+ ((box? p) 2)
+ ((point? '()) 3)
+ ((point? p) 22)
+ (else 99)))
diff --git a/tests/scheme1/38-record-internal-prims.expected-exit b/tests/scheme1/38-record-internal-prims.expected-exit
@@ -0,0 +1 @@
+33
diff --git a/tests/scheme1/38-record-internal-prims.scm b/tests/scheme1/38-record-internal-prims.scm
@@ -0,0 +1,7 @@
+; Internal record primitives are accessible directly: build a TD, build
+; a record, ref/set/predicate via %record-*.
+(define td (%make-record-td 'foo 2))
+(define r (%make-record td 11 22))
+(sys-exit (if (%record-is-a? r td)
+ (+ (%record-ref r 0) (%record-ref r 1))
+ 999))
