commit 4ab05cbfc275848a6b7b04ce814bc4390e1ce666
parent b25bf2dc25aeea993c644a0ec47dad2e7887a58d
Author: Ryan Sepassi <rsepassi@gmail.com>
Date: Tue, 28 Apr 2026 13:01:25 -0700
Keep scheme1 global metadata on main heap
Diffstat:
5 files changed, 125 insertions(+), 10 deletions(-)
diff --git a/scheme1/scheme1.P1pp b/scheme1/scheme1.P1pp
@@ -2938,6 +2938,25 @@
%b(&heap_oom_die)
%endscope
+# cons_main(car=a0, cdr=a1) -> tagged pair (a0). Allocates in main
+# regardless of current heap selection. Used for process-global
+# interpreter metadata that is represented as Scheme pairs.
+:cons_main
+%scope cons_main
+ %la(t2, &heap_next)
+ %ld(t0, t2, 0)
+ %addi(t1, t0, %PAIR.SIZE)
+ %ld_global(a3, &heap_end)
+ %bltu(a3, t1, &::oom)
+ %st(a0, t0, %PAIR.car)
+ %st(a1, t0, %PAIR.cdr)
+ %st(t1, t2, 0)
+ %addi(a0, t0, %TAG.PAIR)
+ %ret
+ ::oom
+ %die(msg_heap_full)
+%endscope
+
# alloc_hdr(bytes=a0, hdr_word=a1) -> tagged heap obj (a0)
# Rounds bytes up to a multiple of 8 and writes hdr_word at offset 0.
:alloc_hdr
@@ -2957,6 +2976,24 @@
%b(&heap_oom_die)
%endscope
+# alloc_hdr_main(bytes=a0, hdr_word=a1) -> tagged heap obj (a0), allocated
+# in main regardless of current heap selection.
+:alloc_hdr_main
+%scope alloc_hdr_main
+ %alignup(a0, a0, 8, t0)
+ %la(t2, &heap_next)
+ %ld(t0, t2, 0)
+ %add(t1, t0, a0)
+ %ld_global(a3, &heap_end)
+ %bltu(a3, t1, &::oom)
+ %st(t1, t2, 0)
+ %st(a1, t0, 0)
+ %addi(a0, t0, 3)
+ %ret
+ ::oom
+ %die(msg_heap_full)
+%endscope
+
# list_length(list=a0) -> count (a0). Linear walk; clobbers a0 (used as
# the cursor). Callers that need the list afterward must save it first.
:list_length
@@ -3134,11 +3171,12 @@
%die(msg_symtab_full)
::append_ok
- # Copy the name into a stable heap buffer. The caller-provided ptr
- # may live in readbuf_buf (parse_atom), which gets overwritten when
- # the next source is loaded; symtab entries must outlive that.
+ # Copy the name into a stable main-heap buffer. The caller-provided
+ # ptr may live in readbuf_buf (parse_atom), and the current heap may
+ # be scratch while user code is being read/evaluated. Symtab names
+ # must outlive both source-buffer reuse and scratch resets.
%ldl(a0, name_len)
- %call(&alloc_bytes)
+ %call(&alloc_bytes_main)
%ldl(a1, name_ptr)
%ldl(a2, name_len)
%call(&memcpy) ; returns dst in a0 = stable copy
@@ -3998,6 +4036,25 @@
%b(&heap_oom_die)
%endscope
+# alloc_bytes_main(size=a0) -> raw addr (a0). Untagged data buffer in the
+# main heap regardless of current heap selection. Used for interpreter-
+# owned stable storage such as symtab names, which must survive scratch
+# resets even when user code is currently allocating in scratch.
+:alloc_bytes_main
+%scope alloc_bytes_main
+ %alignup(a0, a0, 8, t0)
+ %la(t2, &heap_next)
+ %ld(t1, t2, 0)
+ %add(t0, t1, a0)
+ %ld_global(a3, &heap_end)
+ %bltu(a3, t0, &::oom)
+ %st(t0, t2, 0)
+ %mov(a0, t1)
+ %ret
+ ::oom
+ %die(msg_heap_full)
+%endscope
+
# bv_capacity_for(n=a0) -> smallest power-of-two ≥ n, minimum 16. Pure
# bytevector sizing -- no NUL slack. Callers building "strings" call
# bv_capacity_for(raw_len + 1) to reserve room for the trailing NUL.
@@ -4603,7 +4660,9 @@
# 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.
+# PRIM in main, sets the entry label and data word. These PRIMs are
+# installed in global bindings by define-record-type, so they must not
+# be reclaimed by scratch reset.
%fn2(make_param_prim, {entry data}, {
%stl(a0, entry)
@@ -4611,7 +4670,7 @@
%li(a0, 24)
%li(a1, %HDR.PRIM)
- %call(&alloc_hdr)
+ %call(&alloc_hdr_main)
%ldl(t0, entry)
%heap_st(t0, a0, %PRIM.entry_w)
@@ -4736,11 +4795,12 @@
%call(&list_length)
%stl(a0, nfields)
- # td = alloc_hdr(TD.SIZE, HDR.TD); td.name = type-name;
- # td.nfields = nfields; td.fields = NIL (filled below).
+ # td = alloc_hdr_main(TD.SIZE, HDR.TD); td.name = type-name;
+ # td.nfields = nfields; td.fields = NIL (filled below). TDs are
+ # process-global record metadata, not scratch-resident instances.
%li(a0, %TD.SIZE)
%li(a1, %HDR.TD)
- %call(&alloc_hdr)
+ %call(&alloc_hdr_main)
%stl(a0, td)
%ldl(t0, rest)
%car(t0, t0)
@@ -4767,7 +4827,7 @@
%car(t1, t0)
%car(a0, t1)
%li(a1, %imm_val(%IMM.NIL))
- %call(&cons)
+ %call(&cons_main)
# Splice into list: if head is NIL, head = tail = cell.
# Else set-cdr!(tail, cell); tail = cell.
%ldl(t1, fl_head)
diff --git a/tests/scheme1/123-scratch-reset-intern.expected-exit b/tests/scheme1/123-scratch-reset-intern.expected-exit
@@ -0,0 +1 @@
+42
diff --git a/tests/scheme1/123-scratch-reset-intern.scm b/tests/scheme1/123-scratch-reset-intern.scm
@@ -0,0 +1,23 @@
+; Newly interned symbol names must not live in scratch. If they do, a
+; scratch reset can let a later symbol overwrite an earlier symtab name,
+; causing lookup to return the wrong global.
+
+(define-record-type cell
+ (mk-cell head tail)
+ cell?
+ (head cell-head cell-head-set!))
+
+(use-scratch-heap!)
+(define s-pair (cons 1 2))
+(reset-scratch-heap!)
+(define s-cell (mk-cell 10 20))
+
+;; Before the fix, parsing/evaluating s-cell here found the earlier
+;; s-pair symtab entry after its scratch-resident name bytes had been
+;; overwritten with "s-cell", so record? received the pair.
+(if (record? s-cell) 0 (sys-exit 1))
+(if (cell? s-cell) 0 (sys-exit 2))
+(if (= 10 (cell-head s-cell)) 0 (sys-exit 3))
+
+(use-main-heap!)
+(sys-exit 42)
diff --git a/tests/scheme1/124-scratch-record-type.expected-exit b/tests/scheme1/124-scratch-record-type.expected-exit
@@ -0,0 +1 @@
+42
diff --git a/tests/scheme1/124-scratch-record-type.scm b/tests/scheme1/124-scratch-record-type.scm
@@ -0,0 +1,30 @@
+; define-record-type installs process-global metadata. Defining a type
+; while scratch is current must not leave its TD / generated PRIMs /
+; field-name list in scratch.
+
+(use-scratch-heap!)
+(define-record-type dyn
+ (mk-dyn x y)
+ dyn?
+ (x dyn-x)
+ (y dyn-y dyn-y-set!))
+(reset-scratch-heap!)
+(use-main-heap!)
+
+(define d (mk-dyn 7 8))
+(if (dyn? d) 0 (sys-exit 1))
+(if (= 7 (dyn-x d)) 0 (sys-exit 2))
+(if (= 8 (dyn-y d)) 0 (sys-exit 3))
+(dyn-y-set! d 9)
+(if (= 9 (dyn-y d)) 0 (sys-exit 4))
+
+;; pmatch uses the TD.fields list, so this also checks that the field-name
+;; metadata survived the scratch reset.
+(if (= 16
+ (pmatch d
+ (($ dyn? (x ,a) (y ,b)) (+ a b))
+ (else 0)))
+ 0
+ (sys-exit 5))
+
+(sys-exit 42)
