commit a703b305fce34cd774525725b4803cf187147954 parent 47e13ea04f3c6287b8aab1f6d125a7596d309047 Author: Ryan Sepassi <rsepassi@gmail.com> Date: Fri, 17 Jul 2026 09:22:19 -0700 scheme1: replace arenas with mark-sweep GC Diffstat:
29 files changed, 1307 insertions(+), 1713 deletions(-)
diff --git a/cc/cc.scm b/cc/cc.scm @@ -97,10 +97,8 @@ ;; ;; Every buf owns one bytevector of `cap` bytes, plus a write `offset`. ;; buf-push! is bytevector-copy! into storage — zero allocation per -;; push, no chunks list to chase. This is what makes per-function -;; heap-mark/heap-rewind! safe in cg: the destination buf is fixed- -;; storage (allocated once, lives pre-mark), so byte-level mutations -;; survive a rewind that discards the parse/cg scratch. +;; push, no chunks list to chase. The destination storage has stable +;; identity, so byte-level mutations survive collection. ;; ;; Sizing knobs live in one place so they're easy to tune as inputs ;; grow. cg-init picks per-buf caps; the per-fn bufs are reused @@ -108,7 +106,7 @@ ;; -------------------------------------------------------------------- ;; Tuning constants — total fixed pre-allocation ≈ 12.27 MiB on a -;; 64 MiB heap. Bump these when a workload overflows; the buf-overflow +;; managed heap. Bump these when a workload overflows; the buf-overflow ;; die() reports off/len/cap so misses are easy to diagnose. ;; ;; Each cap is a power of two. scheme1's bv_capacity_for rounds the @@ -225,6 +223,19 @@ ((zero? (cdr r)) (sys-exit 1)) (else (loop (+ off (cdr r)))))))))) +(define (write-bv-range-fd fd bv start len) + ;; Write exactly LEN bytes starting at START without first copying the + ;; range into a right-sized bytevector. This is important for the large, + ;; fixed-capacity codegen buffers: their used prefixes can be streamed + ;; without requiring another contiguous managed allocation. + (let loop ((off start) (left len)) + (if (= left 0) + #t + (let ((r (sys-write fd bv off left))) + (cond ((not (car r)) (sys-exit 1)) + ((zero? (cdr r)) (sys-exit 1)) + (else (loop (+ off (cdr r)) (- left (cdr r))))))))) + ;; -------------------------------------------------------------------- ;; debug logging ;; @@ -359,9 +370,7 @@ ;; ;; sym is immutable — no `sym-*-set!` accessor exists. scope-bind!'s ;; merge logic constructs a fresh sym rather than mutating in place. -;; Promotion (Phase 3 of CC-SCRATCH) relies on this: a deep-copied -;; sym in main heap is guaranteed structurally identical to its -;; scratch original. +;; Keeping it immutable also makes shared world bindings straightforward. ;; -------------------------------------------------------------------- (define-record-type sym (%sym name kind storage type slot defined?) @@ -412,8 +421,7 @@ ;; is shared by pstate and cg so its slots — scope (var/typedef ;; bindings), tags (struct/union/enum tags), str-pool (interned string ;; literals), tentatives (file-scope tentative defs awaiting end-of-TU -;; BSS emission) — can be reasoned about as one boundary contract. -;; Phase 3's promote walkers deep-copy from this single root. +;; BSS emission) — can be reasoned about as one persistent root graph. ;; -------------------------------------------------------------------- (define-record-type world (%world scope tags str-pool tentatives) @@ -452,10 +460,8 @@ ;; -------------------------------------------------------------------- ;; fn-buf and prologue-buf are pre-allocated (cg-init) and reused across ;; functions — cg-fn-begin/v calls buf-reset! on them, cg-fn-end drains -;; them into cg-text via buf-drain!. No per-fn allocation, which lets -;; the parse-decl-or-fn boundary (Phase 3, scratch heap) discard -;; everything the body allocated wholesale — fixed-storage byte writes -;; survive scratch reset because the buf storage was allocated in main. +;; them into cg-text via buf-drain!. Fixed-storage byte writes remain +;; stable while ordinary transient parser data is reclaimed by the GC. ;; ;; in-fn? discriminates "currently inside a function body" so ;; %cg-emit-buf can route emits to fn-buf during the body and cg-text @@ -601,63 +607,8 @@ ;; same level as whitespace. NL tokens are emitted at every physical ;; newline so pp can use them to terminate directives. ;; -;; Heap discipline (per tests/scheme1/093-heap-mark-rewind.scm): -;; token-producing helpers wrap their inner work in call-with-heap- -;; rewind. Slots that must survive the rewind (start-loc and the -;; integer holders for npos/nline/ncol) are bound by an outer let -;; *before* the call-with-heap-rewind invocation, so the let's env -;; extensions live below the mark. The byte-run scanners' tail-call -;; env frames and any %lex-peek 4-lists are above the mark and get -;; reclaimed. For helpers that produce a fresh bytevector (ident, -;; string), the bv is allocated between the two calls so it persists -;; into the parent arena. Numeric digit runs accumulate inline via -;; %accum-int-while. -;; -;; %lex-iter-pull wraps each token-emitting iteration in an outer -;; call-with-heap-rewind. The helper allocates its own tok+loc+bv -;; above this outer mark; the driver reads the scalar fields and -;; copies any bv contents into %lex-scratch (sticky, pre-mark) before -;; the wrapper rewinds. Post-rewind it rebuilds a fresh tok+loc and a -;; fresh bv (for IDENT/STR) sized to the actual content. - -;; -------------------------------------------------------------------- -;; Cross-rewind transport for IDENT / STR bv values. -;; -;; %lex-scratch is a single sticky bytevector allocated below any -;; lex-tokenize heap-mark. The driver copies bv data here *before* the -;; rewind, then post-rewind allocates a fresh bv (sized exactly to the -;; ident/string content) by copying back out of scratch. The whole -;; lex run shares this one buffer. -;; -;; Why scratch, not a deduplicating intern pool: under scheme1's -;; interpreter, walking a cons-list pool per lookup costs ~50–150 B -;; per step in bind_params/eval_args/named-let env-extension -;; overhead. Even 16-way bucketing has the walk cost outpace the -;; bv-allocation savings until scheme1 grows a vector primitive -;; (an O(1) bucket lookup without interpreter overhead). -;; -------------------------------------------------------------------- -(define %lex-scratch-cap 65536) -(define %lex-scratch (make-bytevector %lex-scratch-cap 0)) - (define (%lex-init!) #t) -(define (%lex-scratch<- bv len) - (cond ((> len %lex-scratch-cap) - (die #f "lex: token exceeds scratch cap" len))) - (let loop ((i 0)) - (cond ((< i len) - (bytevector-u8-set! %lex-scratch i (bytevector-u8-ref bv i)) - (loop (+ i 1)))))) - -(define (%lex-scratch->bv len) - ;; Allocate a fresh bv (exact size) and copy scratch[0..len) into it. - (let ((bv (make-bytevector len 0))) - (let copy ((i 0)) - (cond ((< i len) - (bytevector-u8-set! bv i (bytevector-u8-ref %lex-scratch i)) - (copy (+ i 1))))) - bv)) - ;; -------------------------------------------------------------------- ;; Byte-class predicates (raw u8 values, not chars). ;; -------------------------------------------------------------------- @@ -867,8 +818,8 @@ ;; ;; Tail-recursive walkers used by ident/number/string readers. None ;; allocate per scanned byte on the fast path (only %lex-peek 4-lists -;; on trigraph/splice/newline); the per-iteration env frames allocated -;; by tail recursion are reclaimed by the caller's heap-rewind!. +;; on trigraph/splice/newline); tail recursion keeps the native call path +;; bounded and unreachable Scheme environments are collected normally. ;; ;; - %scan-while: count bytes that satisfy pred. (count npos nline ncol) ;; - %fill-while-bv: write matching bytes into a pre-sized bv. @@ -976,11 +927,8 @@ ;; Returns (tok npos nline ncol). Caller has already verified that the ;; first byte at `pos` satisfies %ident-start?. ;; -;; Two-pass with call-with-heap-rewind: pass 1 (%scan-while) sizes the -;; run, then between the two calls we allocate `name` bv so it survives -;; the second rewind, then pass 2 (%fill-while-bv) writes into it. The -;; integer slots count/npos/nline/ncol are bound by the outer let so -;; they survive both rewinds. +;; Two-pass: pass 1 (%scan-while) sizes the run, then pass 2 +;; (%fill-while-bv) writes directly into the exact-size bytevector. ;; -------------------------------------------------------------------- (define (lex-read-ident src pos file) ;; Public for tests. Threads line/col from a fresh start. @@ -989,17 +937,13 @@ (define (%lex-read-ident src pos line col file) (let ((start-loc (%loc file line col)) (count 0) (npos 0) (nline 0) (ncol 0)) - (call-with-heap-rewind - (lambda () - (let ((sres (%scan-while %ident-cont? src pos line col))) - (set! count (car sres)) - (set! npos (car (cdr sres))) - (set! nline (car (cdr (cdr sres)))) - (set! ncol (car (cdr (cdr (cdr sres)))))))) + (let ((sres (%scan-while %ident-cont? src pos line col))) + (set! count (car sres)) + (set! npos (car (cdr sres))) + (set! nline (car (cdr (cdr sres)))) + (set! ncol (car (cdr (cdr (cdr sres)))))) (let ((name (make-bytevector count 0))) - (call-with-heap-rewind - (lambda () - (%fill-while-bv %ident-cont? src pos line col name 0))) + (%fill-while-bv %ident-cont? src pos line col name 0) (let ((kw (alist-ref name %keyword-alist))) (cons (if kw (make-tok 'KW kw start-loc) @@ -1188,8 +1132,8 @@ ;; (tok npos nline ncol) with the raw decoded bytes (no NUL appended). ;; ;; Two-pass: %string-pass with bv=#f counts effective bytes (escapes -;; collapse to 1 byte each); after rewind we allocate the final bv and -;; rerun with bv set so the bytes are written directly into it. +;; collapse to 1 byte each); then allocate the final bv and rerun with +;; bv set so the bytes are written directly into it. ;; -------------------------------------------------------------------- (define (lex-read-string src pos file) (%lex-read-string src pos 1 (+ pos 1) file)) @@ -1204,18 +1148,14 @@ (not (= (bytevector-u8-ref src pos) 34))) (die start-loc "internal: string reader on non-quote")) (else - (call-with-heap-rewind - (lambda () - (let ((sres (%string-pass src (+ pos 1) line (+ col 1) - file start-loc #f))) - (set! cnt (car sres)) - (set! npos (car (cdr sres))) - (set! nline (car (cdr (cdr sres)))) - (set! ncol (car (cdr (cdr (cdr sres)))))))) + (let ((sres (%string-pass src (+ pos 1) line (+ col 1) + file start-loc #f))) + (set! cnt (car sres)) + (set! npos (car (cdr sres))) + (set! nline (car (cdr (cdr sres)))) + (set! ncol (car (cdr (cdr (cdr sres)))))) (let ((bv (make-bytevector cnt 0))) - (call-with-heap-rewind - (lambda () - (%string-pass src (+ pos 1) line (+ col 1) file start-loc bv))) + (%string-pass src (+ pos 1) line (+ col 1) file start-loc bv) (cons (make-tok 'STR bv start-loc) (list npos nline ncol))))))) @@ -1500,24 +1440,13 @@ ;; -------------------------------------------------------------------- ;; lex-iter — streaming lexer. Steady state: pos/line/col + bol? in -;; lex-state; per-token allocation reclaimed via heap-mark/rewind. +;; lex-state; discarded per-token allocation is reclaimed by the GC. ;; -------------------------------------------------------------------- ;; bol? — `#t` when no token has been emitted on the current physical ;; line yet (start of file, or only NL + whitespace seen since the last ;; line break). pp recognizes a directive only when its leading `#` is ;; at line-start; we forward that decision into the token stream by ;; emitting `HASH` instead of `(PUNCT hash …)` for a line-leading `#`. -;; -;; Heap discipline: each call to %lex-iter-pull is wrapped in a -;; call-with-heap-rewind. All scratch the helper allocates (the -;; helper's own tok/loc, the `(cons tok 4-list)` it returns, every -;; bind_params / let* / eval_args env-cons consumed getting in and out) -;; lives above the mark and is reclaimed before returning. Per-token -;; scratch (kind/val/vlen/loc-line/loc-col/npos/nline/ncol/nbol?) is -;; allocated in the outer `let` BEFORE the wrapper call — set! mutates -;; those cells in place across the rewind. Bv contents survive via the -;; sticky %lex-scratch buffer + %lex-scratch->bv (allocated post-rewind). -;; The survivors per token are tok (48 B) + loc (40 B) + bv if any. (define-record-type lex-state (%lex-state src file pos line col bol? done?) lex-state? @@ -1551,15 +1480,10 @@ (line (lex-state-line st)) (col (lex-state-col st)) (bol? (lex-state-bol? st)) - ;; Per-iteration scratch — must be allocated BEFORE the call to - ;; call-with-heap-rewind so that set!s issued from inside the - ;; thunk still find live cells after the rewind. - (kind #f) (val #f) (vlen 0) + (kind #f) (val #f) (loc-line 1) (loc-col 1) (npos 0) (nline 1) (ncol 1) (nbol? #f)) - (call-with-heap-rewind - (lambda () - (let* ((sw (%skip-ws-and-comments src pos line col file)) + (let* ((sw (%skip-ws-and-comments src pos line col file)) (pos1 (car sw)) (line1 (car (cdr sw))) (col1 (car (cdr (cdr sw)))) @@ -1567,7 +1491,7 @@ (b (%pk-byte p))) (set! loc-line line1) (set! loc-col col1) - (set! val #f) (set! vlen 0) (set! nbol? #f) + (set! val #f) (set! nbol? #f) (cond ;; EOF ((not b) @@ -1605,10 +1529,7 @@ (set! kind (tok-kind tok)) (cond ((eq? (tok-kind tok) 'KW) (set! val (tok-value tok))) - (else - (let ((bv (tok-value tok))) - (set! vlen (bytevector-length bv)) - (%lex-scratch<- bv vlen)))) + (else (set! val (tok-value tok)))) (set! npos (car rest)) (set! nline (car (cdr rest))) (set! ncol (car (cdr (cdr rest)))))) @@ -1641,8 +1562,7 @@ (tok (car r)) (rest (cdr r)) (bv (tok-value tok))) (set! kind 'STR) - (set! vlen (bytevector-length bv)) - (%lex-scratch<- bv vlen) + (set! val bv) (set! npos (car rest)) (set! nline (car (cdr rest))) (set! ncol (car (cdr (cdr rest)))))) @@ -1666,21 +1586,18 @@ (set! kind 'PUNCT) (set! val (tok-value tok)))) (set! npos (car rest)) (set! nline (car (cdr rest))) - (set! ncol (car (cdr (cdr rest)))))))))) - ;; Reconstruct the survivor below the mark and advance state. + (set! ncol (car (cdr (cdr rest)))))))) + ;; Advance the iterator state and return the token. (cond ((eq? kind 'EOF) (lex-state-done?-set! st #t) (make-tok 'EOF #f (%loc file loc-line loc-col))) (else - (let ((tok-val (cond ((eq? kind 'IDENT) (%lex-scratch->bv vlen)) - ((eq? kind 'STR) (%lex-scratch->bv vlen)) - (else val)))) - (lex-state-pos-set! st npos) - (lex-state-line-set! st nline) - (lex-state-col-set! st ncol) - (lex-state-bol?-set! st nbol?) - (make-tok kind tok-val (%loc file loc-line loc-col))))))) + (lex-state-pos-set! st npos) + (lex-state-line-set! st nline) + (lex-state-col-set! st ncol) + (lex-state-bol?-set! st nbol?) + (make-tok kind val (%loc file loc-line loc-col)))))) ;; Drain a lex-iter into a list ending in EOF, for the cc-lex test ;; runner. Production callers chain make-lex-iter directly. @@ -2534,12 +2451,6 @@ ;; pstate (empty scope, no cg). sizeof(type) works as an extension; ;; sizeof(expr) dies with a clear message. ;; -;; Arena boundary (test 093 A→B→C pattern). Everything inside the -;; call-with-heap-rewind thunk is scratch: `s1`/`s2`/`s3` plus the -;; parse-const-* (value . ctype) cells at every level. parse-const-int -;; returns the integer via `car`, which is a fixnum immediate and -;; survives the rewind. The error path goes through `die` (sys-exits), -;; so no rewind there. (define (%pp-make-const-ps toks) (%pstate (make-list-iter toks) (%world (list '()) (list '()) '() '()) @@ -2549,22 +2460,20 @@ ;; `outer` is the live %pp-state. We mint a fresh state for #if ;; evaluation but inherit cur-file and line-delta so __FILE__ / ;; __LINE__ inside the expression reflect any preceding #line. - (call-with-heap-rewind - (lambda () - (let* ((state (%pp-state (pps-macros outer) '() - (pps-cur-file outer) - (pps-line-delta outer) - #f '() '())) - (s1 (%pp-resolve-defined toks state)) - (s2 (%pp-expand-line s1 state)) - (s3 (%pp-idents-as-zero s2)) - (ps (%pp-make-const-ps s3)) - (val (parse-const-int ps)) - (t (peek ps))) - (cond - ((eq? (tok-kind t) 'EOF) val) - (else (die (tok-loc t) "#if: garbage at end of expression" - (tok-kind t)))))))) + (let* ((state (%pp-state (pps-macros outer) '() + (pps-cur-file outer) + (pps-line-delta outer) + #f '() '())) + (s1 (%pp-resolve-defined toks state)) + (s2 (%pp-expand-line s1 state)) + (s3 (%pp-idents-as-zero s2)) + (ps (%pp-make-const-ps s3)) + (val (parse-const-int ps)) + (t (peek ps))) + (cond + ((eq? (tok-kind t) 'EOF) val) + (else (die (tok-loc t) "#if: garbage at end of expression" + (tok-kind t)))))) (define (%pp-expand-line toks state) (let ((out (make-buf-list))) @@ -2893,7 +2802,7 @@ lib? ; lib? (skip entry stub + :ELF_end) str-prefix)) ; str-prefix (cc__str_N namespacing) -(define (cg-finish cg) +(define (cg-finalize! cg) ;; Tentative file-scope defs (`int x;` / `static int x;` with no ;; initializer and not later defined with `=`) get their .bss slot ;; here at end of TU. C 6.9.2 — see cg-flush-tentatives!. @@ -2916,12 +2825,36 @@ (buf-push! tb "%fn(p1_main, 16, {\n") (buf-push! tb "%call(&main)\n") (buf-push! tb "})\n")))) + #t) + +(define (cg-output-size cg) + (+ (buf-offset (cg-text cg)) + (buf-offset (cg-data cg)) + (buf-offset (cg-bss cg)) + (cond ((cg-lib? cg) 0) + (else (bytevector-length ":ELF_end\n"))))) + +(define (cg-finish cg) + ;; In-memory form retained for tests and small callers. Production uses + ;; %cg-write-finalized-fd below so a fragmented non-moving heap need not + ;; provide several multi-megabyte snapshot allocations at once. + (cg-finalize! cg) (bv-cat (list (buf-flush (cg-text cg)) (buf-flush (cg-data cg)) (buf-flush (cg-bss cg)) (cond ((cg-lib? cg) "") (else ":ELF_end\n"))))) +(define (%cg-write-finalized-fd cg fd) + (let ((text (cg-text cg)) + (data (cg-data cg)) + (bss (cg-bss cg))) + (write-bv-range-fd fd (buf-storage text) 0 (buf-offset text)) + (write-bv-range-fd fd (buf-storage data) 0 (buf-offset data)) + (write-bv-range-fd fd (buf-storage bss) 0 (buf-offset bss)) + (cond ((not (cg-lib? cg)) (write-bv-fd fd ":ELF_end\n"))) + #t)) + (define (cg-fn-begin cg name params return-type) (cg-fn-begin/v cg name params return-type #f)) @@ -3065,10 +2998,8 @@ (define (cg-fn-end cg) ;; Drain prologue-buf and fn-buf directly into cg-text via buf-drain! ;; (memcpy, no allocation). Header/footer pieces go through buf-push! - ;; on cg-text — also memcpy. Net result: zero net heap allocation in - ;; cg-fn-end other than the small (%n N) bvs for staging-bytes / - ;; frame-size, which the enclosing parse-decl-or-fn boundary's - ;; reset-scratch-heap! reclaims. + ;; on cg-text — also memcpy. The only fresh objects here are the small + ;; (%n N) bytevectors for staging-bytes / frame-size. (let* ((name (%cg-fn-get cg '%fn-name)) (ret-slot (%cg-fn-get cg '%fn-ret-slot)) (ret-type (%cg-fn-get cg '%fn-ret-type)) @@ -4670,15 +4601,7 @@ (else (align-up last ma))))) (ctype-size-set! ct sz) (ctype-align-set! ct ma) - (ctype-ext-set! ct (list tag #t fs)) - ;; Phase 3: if `ct` is a forward-declared struct/union that lived in - ;; main from a prior decl, its newly-set ext lives in scratch and - ;; would dangle on reset-scratch-heap!. Track it so promote-roots! - ;; can rewrite ext in main before the boundary fires. Scratch-resident - ;; ct (defined and completed in this decl) is promoted normally via - ;; the tag walker. - (set! %promote-pending-completions - (cons ct %promote-pending-completions)))) + (ctype-ext-set! ct (list tag #t fs)))) (define (parse-enum-spec ps) (advance ps) @@ -5345,90 +5268,20 @@ (values (reverse (cons (cons nm ty2) acc)) #f)) (else (die (tok-loc (peek ps)) "param"))))))))))) -;; ==================================================================== -;; Phase 3: parse-decl-or-fn boundary — scratch by default, promote -;; surviving roots into main and reset scratch at each top-level decl. -;; -;; Promotion uses the prelude's generic deep-copy via -;; call-with-scratch-cycle; the per-decl identity-preserving map is -;; folded into a single deep-copy context shared across all roots. -;; -;; Per-decl mutable state retained on the cc side: -;; %promote-pending-completions: list of struct/union ctypes that -;; complete-agg! mutated during the current decl. These are -;; pre-existing main-heap records whose ext now points at scratch; -;; ext is rewritten via deep-copy before the scratch reset. -;; ==================================================================== - -(define %promote-pending-completions '()) - -(define (rewrite-pending-completions! ctx) - (for-each - (lambda (c) - (cond ((heap-in-main? c) - (ctype-ext-set! c (deep-copy ctx (ctype-ext c)))))) - %promote-pending-completions) - (set! %promote-pending-completions '())) - -;; Deep-copy each top-level world alist into main. The world-tags / -;; world-scope stacks contain only the file-scope frame at decl -;; boundaries (nested frames popped by scope-leave!); rebuild that head -;; frame and preserve the (always-empty) tail. world-str-pool is a flat -;; alist. deep-copy short-circuits prior-decl entries via heap-in-current?, -;; so this is linear in the new entries only. -(define (promote-roots! w ctx) - (rewrite-pending-completions! ctx) - (let ((tn (world-tags w))) - (world-tags-set! w (cons (deep-copy ctx (car tn)) (cdr tn)))) - (let ((sn (world-scope w))) - (world-scope-set! w (cons (deep-copy ctx (car sn)) (cdr sn)))) - (world-str-pool-set! w (deep-copy ctx (world-str-pool w))) - (world-tentatives-set! w (deep-copy ctx (world-tentatives w)))) - -;; Iter-buffer carryover. The pp-iter / lex-iter records themselves -;; live in main from cc-init; only their tok-iter-buf slots and the -;; pp-state's pending / out / cur-file / macros slots can hold -;; scratch-allocated content. Rewrite each in place via deep-copy. -(define (promote-iter-buffers! pp-it ctx) - (let* ((st (tok-iter-state pp-it)) - (lex-it (pps-lex-iter st))) - (tok-iter-buf-set! pp-it (deep-copy ctx (tok-iter-buf pp-it))) - (cond (lex-it - (tok-iter-buf-set! lex-it - (deep-copy ctx (tok-iter-buf lex-it))))) - (pps-up-pending-set! st (deep-copy ctx (pps-up-pending st))) - (pps-out-buf-set! st (deep-copy ctx (pps-out-buf st))) - (pps-cur-file-set! st (deep-copy ctx (pps-cur-file st))) - (pps-cond-stack-set! st (deep-copy ctx (pps-cond-stack st))) - (pps-macros-set! st (deep-copy ctx (pps-macros st))))) - (define (parse-translation-unit ps) (let loop () - (let ((at-eof? #f)) - (call-with-scratch-cycle - (lambda () - (cond - ((eq? (tok-kind (peek ps)) 'EOF) (set! at-eof? #t)) - (else - (cond - ((debug-log?) - (let ((loc (tok-loc (peek ps)))) - (debug-log "decl" "line" (loc-line loc) - "heap" (heap-usage))))) - (parse-decl-or-fn ps)))) - (lambda () - (cond - ((not at-eof?) - (let ((ctx (make-deep-copy-context))) - (promote-roots! (ps-world ps) ctx) - (promote-iter-buffers! (ps-iter ps) ctx)) - ;; cg-fn-meta may hold scratch alist conses left over from - ;; the just-finished function; cg-fn-begin would reset it, - ;; but a trailing fn means it'd dangle past the reset. - (cg-fn-meta-set! (ps-cg ps) '()))))) - (cond - (at-eof? #t) - (else (loop)))))) + (cond + ((eq? (tok-kind (peek ps)) 'EOF) #t) + (else + (cond + ((debug-log?) + (let ((loc (tok-loc (peek ps)))) + (debug-log "decl" "line" (loc-line loc) + "heap" (heap-usage))))) + (parse-decl-or-fn ps) + ;; Function-local metadata is not part of the persistent world. + (cg-fn-meta-set! (ps-cg ps) '()) + (loop))))) (define (parse-decl-or-fn ps) (let-values (((sto b) (parse-decl-spec ps))) @@ -5874,52 +5727,14 @@ (define (%pad-piece nbytes) (make-bytevector nbytes 0)) -;; Static aggregate init streaming support. parse-translation-unit runs -;; declarations in scratch, but a large file-scope array initializer can -;; contain hundreds of independent elements. Parse one array element -;; past a heap mark, promote the element pieces and parser lookahead into -;; main, rewind that element's transient lexer/pp/const-expr scratch, and -;; keep the outer pieces list in main as well. -(define (%init-promote-unit ps thunk) - (let ((mark (heap-mark))) - (let ((scratch-result (thunk))) - (use-main-heap!) - (let ((ctx (make-deep-copy-context))) - (promote-roots! (ps-world ps) ctx) - (promote-iter-buffers! (ps-iter ps) ctx) - (let ((main-result (deep-copy ctx scratch-result))) - (use-scratch-heap!) - (heap-rewind! mark) - main-result))))) - -(define (%init-main-cons x xs) - (use-main-heap!) - (let ((r (cons x xs))) - (use-scratch-heap!) - r)) - -(define (%init-main-reverse xs) - (use-main-heap!) - (let ((r (reverse xs))) - (use-scratch-heap!) - r)) - -(define (%init-main-prepend-reversed xs acc) - (use-main-heap!) +;; Prepend XS in reverse order without allocating an intermediate list. +(define (%init-prepend-reversed xs acc) (let loop ((ys xs) (out acc)) (cond - ((null? ys) - (use-scratch-heap!) - out) + ((null? ys) out) (else (loop (cdr ys) (cons (car ys) out)))))) -(define (%init-main-pad-piece nbytes) - (use-main-heap!) - (let ((p (%pad-piece nbytes))) - (use-scratch-heap!) - p)) - ;; ----- Global initializers --------------------------------------------- ;; Returns (values pieces final-ty). For inferred-length array `ty`, ;; final-ty is a freshly-built array ctype with the resolved length; @@ -6000,44 +5815,34 @@ (pad (- final count))) (values (cond - ((> pad 0) - (%init-main-reverse - (%init-main-cons (%init-main-pad-piece (* pad esize)) acc))) - (else (%init-main-reverse acc))) + ((> pad 0) (reverse (cons (%pad-piece (* pad esize)) acc))) + (else (reverse acc))) count))) (else (let ((piece - (%init-promote-unit - ps - (lambda () - ;; The trailing inter-element comma must be consumed - ;; *inside* the mark/rewind window: advance loads pp/lex - ;; lookahead into iter buffers, which promote-iter-buffers! - ;; then deep-copies into main. Consuming it after the - ;; rewind would leave that lookahead leaking on scratch. - (let ((p - (cond - ((at-punct? ps 'lbrace) - (advance ps) - (%global-init-elem ps elem #f)) - (else - (%global-init-elem ps elem #t))))) - ;; Inter-item comma: consume except for the comma - ;; following our LAST item in no-brace mode — that - ;; one belongs to the enclosing parent. + (let ((p + (cond + ((at-punct? ps 'lbrace) + (advance ps) + (%global-init-elem ps elem #f)) + (else + (%global-init-elem ps elem #t))))) + ;; Inter-item comma: consume except for the comma + ;; following our LAST item in no-brace mode — that + ;; one belongs to the enclosing parent. + (cond + (brace? + (cond ((at-punct? ps 'comma) (advance ps)))) + (else + ;; no-brace: consume comma only if more items + ;; remain in our quota. (cond - (brace? - (cond ((at-punct? ps 'comma) (advance ps)))) - (else - ;; no-brace: consume comma only if more items - ;; remain in our quota. - (cond - ((and (< (+ count 1) - (cond ((< decl 0) 0) (else decl))) - (at-punct? ps 'comma)) - (advance ps))))) - p))))) - (lp (%init-main-prepend-reversed piece acc) (+ count 1)))))))) + ((and (< (+ count 1) + (cond ((< decl 0) 0) (else decl))) + (at-punct? ps 'comma)) + (advance ps))))) + p))) + (lp (%init-prepend-reversed piece acc) (+ count 1)))))))) (define (%piece-bytesize p) ;; Output width of one piece (cf. %cg-init-piece->bv): a bv emits @@ -6399,11 +6204,8 @@ ;; parse-fn-body: bind the fn-sym for recursive lookup, then parse the -;; body. Heap discipline is handled at the parse-decl-or-fn boundary — -;; the body runs in scratch like the rest of the decl, and surviving -;; roots (block-statics, string literals, block-scope tags that escape -;; via the global tables) are promoted en masse there. See the Phase 3 -;; section above parse-translation-unit. +;; body. Persistent entries remain reachable through the world graph; +;; function-local parser state becomes collectible after the body. (define (parse-fn-body ps sto name dt) (scope-bind! ps name (%sym name 'fn (or sto 'extern) dt #f #t)) (%parse-fn-body-inner ps name dt)) @@ -7260,6 +7062,15 @@ (close p) 0))) +(define (%cc-write-cg path cg) + (let ((r (open-output path))) + (cond ((not (car r)) + (die #f "cannot open output" path))) + (let ((p (cdr r))) + (%cg-write-finalized-fd cg (port-fd p)) + (close p) + 0))) + ;; CC_DEBUG=1 in the env doesn't fly here (no getenv); instead, scan ;; argv for a sentinel "--cc-debug" flag. When present, debug-log ;; prints heap usage between phases to fd 2. @@ -7331,8 +7142,8 @@ (ps (make-pstate pp-iter cg))) (parse-translation-unit ps) (debug-log "phase=parse" "heap" (heap-usage)) - (let ((out (cg-finish cg))) - (debug-log "phase=cg-finish" "heap" (heap-usage) - "out-bytes" (bytevector-length out)) - (%cc-write out-path out)) + (cg-finalize! cg) + (debug-log "phase=cg-finish" "heap" (heap-usage) + "out-bytes" (cg-output-size cg)) + (%cc-write-cg out-path cg) 0))))) diff --git a/docs/CCSCM.md b/docs/CCSCM.md @@ -2,7 +2,7 @@ ## Overview -`cc.scm` is a complete C compiler (7219 lines) written in Scheme (scheme1 dialect) that compiles C source to P1pp assembly. It implements a streaming pipeline: **lexer → preprocessor → parser → codegen**. Designed for minimal memory use with fixed pre-allocated buffers and a scratch/main heap discipline that resets per declaration. Targets the P1 64-bit RISC ISA via libp1pp macros; output is consumed directly by the M1pp expander and hex2++ assembler/linker (see [docs/M1PP.md](../docs/M1PP.md), [docs/HEX2pp.md](../docs/HEX2pp.md)). +`cc.scm` is a complete C compiler written in Scheme (scheme1 dialect) that compiles C source to P1pp assembly. It implements a streaming pipeline: **lexer → preprocessor → parser → codegen**. It uses fixed pre-allocated output buffers while ordinary compiler objects live in scheme1's garbage-collected heap. Targets the P1 64-bit RISC ISA via libp1pp macros; output is consumed directly by the M1pp expander and hex2++ assembler/linker (see [docs/M1PP.md](../docs/M1PP.md), [docs/HEX2pp.md](../docs/HEX2pp.md)). --- @@ -79,12 +79,18 @@ Source file → lex-iter (make-lex-iter) — streaming tokenizer → pp-iter (make-pp-iter) — macro expansion + directives → parse-translation-unit (pstate/cg) — recursive descent + Pratt - per-decl: call-with-scratch-cycle — scratch heap reset per declaration + automatic GC reclaims unreachable per-declaration state function bodies: cg-fn-begin → parse-fn-body → cg-fn-end - → cg-finish — tentatives → .bss, entry stub, combine sections + → cg-finalize! — tentatives → .bss, entry stub + → %cc-write-cg — stream section-buffer prefixes to the output → write output file ``` +`cg-finish` remains available to tests and small in-memory callers. The +production driver streams the used prefixes of the fixed section buffers so +the non-moving heap does not need contiguous snapshot and combined-output +allocations at the end of a large translation unit. + **Per-function code path:** 1. `cg-fn-begin` — emit param spills, sret setup, allocate prologue-buf 2. `parse-fn-body` — emits P1pp directly into fn-buf via cg ops @@ -105,13 +111,13 @@ Source file | **216–286** | Diagnostics: `die` with loc formatting, `slurp-fd`, `write-bv-fd`; debug logging: `debug-log-on!/off!`, `trace-emit` flags; fresh name generator: `make-namer` | | **287–528** | Record type definitions: `loc`, `tok`, `macro`, `ctype`, `sym`, `opnd`, `loop-ctx`, `fn-ctx`, `world`, `pstate`, `cg`; interned primitive ctypes (`%t-void`, `%t-i8`…`%t-u64`, `%t-bool`, `%t-flt`, `%t-dbl`, `%t-ldbl`); ctype predicates: `%ctype-ptr?`, `%ctype-pointee`, `%ctype-unsigned?`, `%ctype-arith?`, `%ctype-fp?`; ctype accessors | | **530–595** | `%keyword-alist` — storage/qualifiers/type specifiers/statements/operators/reserved; `%punct-alist` — punctuators longest-first, digraphs | -| **596–660** | Lexer byte-class predicates: `%digit?`, `%hex?`, `%alpha?`, `%ident-start?`, `%ident-cont?`, `%hspace?`, `%newline?`; `%lex-scratch` buffer | +| **596–660** | Lexer byte-class predicates: `%digit?`, `%hex?`, `%alpha?`, `%ident-start?`, `%ident-cont?`, `%hspace?`, `%newline?` | | **661–790** | Logical byte access: `%lex-peek` with trigraph translation + line splice | | **791–940** | Comment stripping: `%skip-ws-and-comments`, `%skip-line-comment`, `%skip-block-comment` | | **941–1090** | Byte-run scanners: `%scan-while`, `%fill-while-bv`, `%accum-int-while`, `%accum-octal-bounded` | | **1091–1290** | Token readers: `lex-read-ident`, `%lex-read-number` (hex/octal/decimal), `%lex-read-string` (with escapes), `lex-read-char` | | **1291–1370** | `%lex-read-punct` with longest-match bucketing; `%punct-buckets` | -| **1371–1700** | `lex-iter` streaming token source: `make-lex-iter`, `%lex-iter-pull` with heap-rewind discipline; `list-iter` wrapper; `lex-tokenize` test driver | +| **1371–1700** | `lex-iter` streaming token source: `make-lex-iter`, `%lex-iter-pull`; `list-iter` wrapper; `lex-tokenize` test driver | | **1701–1820** | Preprocessor state (`pp-state`), token classification helpers (`%pp-eof?`, `%pp-nl?`, `%pp-hash?`, etc.) | | **1821–1920** | Built-in macros: `__FILE__`, `__LINE__`, `__STDC__`, `__LISPCC__`, `__DATE__`, `__TIME__`, `__STDC_VERSION__`, `__STDC_HOSTED__`, `__VA_ARGS__` | | **1921–2020** | Streaming pp-iter: `make-pp-iter`, `%pp-iter-pull` with out-buf stashing | @@ -146,11 +152,10 @@ Source file | **4970–4985** | `%tok-decl-start?` — single canonical "does TOK begin a type-name?" predicate. Used by `%const-tok-is-decl?`, `%const-paren-is-cast?`, `token-is-decl?`, `stmt-starts-decl?` (which adds storage classes), and `parse-cast-or-unary` (which adds `__attribute__`) | | **4940–5120** | offsetof support: `%const-parse-addrof-postfix`, `%const-parse-addrof-primary` — recognizes `&((T*)0)->field` chains; reuses `%cg-find-field` | | **5120–5290** | `parse-const-int`; declarators: `parse-declarator`, `parse-decl-cont`, `parse-decl-suf-cont`, `parse-fn-params` | -| **5290–5320** | Phase 3 promotion: `%promote-pending-completions`, `rewrite-pending-completions!`, `promote-roots!`, `promote-iter-buffers!` (main/scratch boundary) | -| **5294–5420** | Translation unit: `parse-translation-unit` with `call-with-scratch-cycle` per decl; `parse-decl-or-fn` | +| **5290–5420** | Translation unit: `parse-translation-unit`; `parse-decl-or-fn` | | **5426–5705** | Declarations/definitions: `handle-decl` (typedef/fn/var/static/file-scope/block-scope with tentatives) | | **5706–5770** | Initializer support helpers: `%init-drop-thru-field` (designator drop), `%global-init-elem` / `%local-init-elem` (brace-vs-elision element/field dispatch shared by the four `parse-init-*-list/mode` walkers) | -| **5816–6065** | Global initializers: `parse-init-global` (string/brace/scalar with inferred-length arrays), `%parse-init-array-list` with element promotion, `%parse-init-struct-list` with designated designators and padding | +| **5816–6065** | Global initializers: `parse-init-global` (string/brace/scalar with inferred-length arrays), `%parse-init-array-list`, `%parse-init-struct-list` with designated designators and padding | | **6070–6290** | Local initializers: `parse-init-local-aggregate` (string/brace), `%parse-init-local-array-list`, `%parse-init-local-struct-list` (zero-pass); compound literals as frame lvalues | | **6296–6320** | Function body: `parse-fn-body`, `%parse-fn-body-inner` (param binding, scope enter/leave) | | **6316–6610** | Statements: `parse-stmt` dispatch, `parse-cstmt`, `parse-if-stmt`, `parse-while-stmt`, `parse-do-stmt` (`.scope` with `:.body` / `:.top` for `continue`-to-cond semantics), `parse-for-stmt` (`.scope` with deferred condition/step), `parse-switch-stmt`, `parse-case-stmt`, `parse-default-stmt`, `parse-return-stmt`, `parse-goto-stmt`, `parse-labelled-stmt`, `parse-expr-stmt`, `parse-local-decl` | @@ -158,7 +163,7 @@ Source file | **6656–6900** | Expression parser: `parse-expr` (`expr-bp(0)`), `parse-expr-bp` (Pratt climbing), `parse-binary-rhs` (comma/assign/compound-assign/ternary/logical/bitwise) | | **6903–7065** | Unary/cast/postfix: `parse-unary` (prefix ops, sizeof), `parse-cast-or-unary` (paren disambiguation via `%tok-decl-start?` + `__attribute__` check), `parse-compound-literal`, `parse-postfix` (`[]`/call/`.`/`->`/post-inc/post-dec) | | **6965–7180** | Call parsing: `call-fn-type`, `parse-call-args` (param casting, variadic promotion); builtins: `parse-builtin-va-start/va-arg/va-end`; primary: `parse-primary` (literals/idents/strings/parens/enum-consts); rvalue: `rval!`, `rval-not-fn!` | -| **7186–7219** | Driver: `%cc-slurp`, `%cc-write`, CLI flag parsing (`--cc-debug`, `--cc-trace-emit`, `--lib=PFX`), `%cc-initial-defines` (CCSCM sentinel), `cc-main` (pipeline init + `parse-translation-unit` + `cg-finish` + write) | +| **7186–7219** | Driver: `%cc-slurp`, `%cc-write-cg`, CLI flag parsing (`--cc-debug`, `--cc-trace-emit`, `--lib=PFX`), `%cc-initial-defines` (CCSCM sentinel), `cc-main` (pipeline init + `parse-translation-unit` + streamed finalization) | --- @@ -166,7 +171,7 @@ Source file - **Streaming pipeline** — no materialized token list; each stage pulls one token at a time - **Fixed buffers** — pre-allocated per section (text/data/bss); no growth; tuned by `%BUF-CAP-*` -- **Heap discipline** — scratch heap reset at declaration boundaries via `call-with-scratch-cycle`; live roots deep-copied to main heap before reset +- **Managed lifetime** — persistent state is reachable from the world/parser/codegen graph; unreachable transient state is reclaimed by scheme1's GC - **Vstack-based codegen** — expression evaluation pushes/pops `opnd` records; values optionally spilled to frame slots - **Macro hide-sets** — `tok` carries hide set to prevent recursive expansion (C11 §6.10.3.4) - **Shared constant-expression evaluator** — `parse-const-*` serves both the parser (typed, with sizeof/cast/offsetof) and the preprocessor `#if` evaluator (`%pp-make-const-ps` wraps a token list as a minimal pstate with empty scope and `ps-cg = #f`); `%const-binl` is the generic left-associative binary-level pattern, fed by combiners (`%const-arith-op`, `%const-div-op`, `%const-cmp-op`, `%const-shift-op`) for every level from `||` down to `*` / `/` / `%` diff --git a/docs/MACROS.md b/docs/MACROS.md @@ -98,8 +98,8 @@ Cached symbol slots and `intern_special_forms` updated alongside. binding mechanism as `define`.) 4. Return UNSPEC. -`alloc_hdr_main` is the right allocator: the macro outlives any -scratch-heap reset, just like `define-record-type`'s TD. +The macro is allocated in the managed heap and remains reachable through +its binding, just like `define-record-type`'s type descriptor. ### `eval_let_syntax` / `eval_letrec_syntax` diff --git a/docs/SCHEME1-GC.md b/docs/SCHEME1-GC.md @@ -1,427 +1,114 @@ -# scheme1 GC +# scheme1 garbage collector -Spec for adding a Cheney-style semispace copying garbage collector to -`scheme1/scheme1.P1pp`. Replaces the main heap's bump-only allocator -with a moving collector; leaves the scratch heap and the -`heap-mark` / `heap-rewind!` family alone. +`scheme1` uses a non-moving, stop-the-world mark-and-sweep collector. +All pairs, headered Scheme objects, and raw byte buffers share one 256 MiB +managed heap. Object addresses never change, so `eq?`, mutation, record +identity, and unsafe address-inspection behavior remain stable across a +collection. -## Goals & non-goals +## Managed block layout -Goals: -- Reclaim unreachable main-heap objects automatically. Programs no - longer depend on `heap-mark` / `heap-rewind!` discipline to stay - within the 256 MiB main-heap reservation. -- Preserve every observable semantic of the existing interpreter - (`eq?`, mutation through `set-car!` / `set-cdr!` / `bytevector-u8-set!`, - closure capture, record identity). -- Keep the scratch-heap, `heap-mark`, `heap-rewind!`, `use-scratch-heap!` - surface working unchanged. `cc.scm` must run with no source change. -- Roots are unambiguous: every Scheme value live across an allocation - point lives in a place the collector explicitly knows how to find. - -Non-goals: -- Generational, incremental, or concurrent collection. -- Collection of the scratch heap. -- Reducing the worst-case pause time. (Stop-the-world is fine.) -- Collection of the symbol table (it stays append-only and pinned; - see [Roots](#roots)). -- Finalizers, weak references, ephemerons. - -## Algorithm - -Stop-the-world Cheney semispace copy. The 256 MiB main heap is split -into two equal **semispaces** of 128 MiB each. At any moment one is -the active *from-space* (allocations bump into it) and the other is -the idle *to-space*. - -A collection: -1. Swap the role of the two spaces. The old from-space becomes the - new to-space's source; the old to-space becomes the new - from-space (initially empty, `next == start`). -2. **Forward roots.** For each root word holding a tagged pointer - into the old from-space, copy the pointee into the new - from-space and overwrite the root with the new tagged pointer. -3. **Scan.** Walk the new from-space from the start to the - advancing `next` pointer with a cursor `scan`. For each object - between `scan` and `next`, forward each of its tagged-pointer - fields. `next` advances as new objects are appended; - `scan == next` is the termination condition. -4. The old from-space is now garbage in bulk. No per-object sweep. - -Forwarding is in-place: when an object is copied, its old header -word is overwritten with a forwarding tag carrying the new address -(see [Forwarding](#forwarding)). A second visit to the same object -sees the forwarding tag and just reuses the recorded new address. - -Why Cheney over mark-sweep-with-free-list (the original ask): the -existing allocator is bump-and-pointer. Cheney keeps it that way -post-collection (no free list, no fragmentation), and the collector -itself is short — copy + scan, no separate mark and sweep passes. - -## Heap layout - -Current main-heap region (`HEAP_CAP_BYTES = 0x10000000`, 256 MiB) -is replaced by two regions of 128 MiB each in BSS, sized via two new -constants: +Every allocation has a 16-byte collector header immediately before its +unchanged payload: ``` -%macro SEMISPACE_CAP_BYTES() 0x08000000 %endm # 128 MiB -%macro SCHEME_STACK_CAP_BYTES() 0x00100000 %endm # 1 MiB; see Roots +header + 0: (total block bytes << 8) | kind | mark +header + 8: intrusive link +payload: existing PAIR, HEAP, or raw-byte layout ``` -New global pointer slots (replacing `heap_buf_ptr` / -`heap_next` / `heap_end`): - -| Slot | Meaning | -|---------------------|----------------------------------------------------| -| `space_a_ptr` | base of semispace A (set by `init_arenas`) | -| `space_b_ptr` | base of semispace B (set by `init_arenas`) | -| `from_space_start` | base of the active from-space | -| `from_space_end` | end of the active from-space | -| `from_space_next` | bump pointer into active from-space | -| `to_space_start` | base of the idle to-space | -| `to_space_end` | end of the idle to-space | - -`current_heap_next_ptr` / `current_heap_end_ptr` continue to exist -unchanged. When the current heap is "main," they point at -`from_space_next` / `from_space_end`. When the current heap is -"scratch," they point at the scratch slots (unchanged from today). -After a collection, the slots `from_space_next` / -`from_space_end` are updated to refer to the *new* from-space, -and `current_heap_next_ptr` is repointed if main is current. - -The scratch heap, the symtab arena, and the readbuf are unaffected. - -## Roots - -Roots are split into three closed sets: - -### 1. Symbol table - -Every `SYMENT.global_val` slot in the symbol-table BSS array is a -potential root. Iteration is bounded by `symtab_count`. The table -itself never moves; entries are pinned and only their `global_val` -field is forwarded. - -### 2. Scheme value stack - -A new dedicated stack, allocated in BSS (`SCHEME_STACK_CAP_BYTES`), -that holds **every Scheme value live across a call site**. The P1 -call stack (`sp`) continues to hold raw machine state — return -addresses, raw integer locals, scratch — and is *not* scanned. - -Two new globals: -- `scheme_stack_base` — set at init to the start of the stack region. -- `scheme_sp` — current top; grows upward. - -A frame on the Scheme stack is a contiguous array of N tagged -values. A function reserves N slots on entry, accesses them by -displacement off `scheme_sp`-at-entry (saved as the function's -"sfp"), and releases them on exit. New macros: - -| Macro | Effect | -|------------------------|-----------------------------------------------------------| -| `%senter(n)` | bump `scheme_sp` by `n*8`; save old in current P1 frame | -| `%sleave(n)` | drop `n*8` from `scheme_sp` | -| `%sst(reg, slot)` | store `reg` into Scheme-frame `slot` | -| `%sld(reg, slot)` | load Scheme-frame `slot` into `reg` | -| `%spush(reg)` | push `reg` onto Scheme stack (1-slot bump) | -| `%spop(reg)` | pop one slot into `reg` | - -A new `%fn3(name, scheme_locals, raw_locals, body)` form parallels -`%fn2`: it builds two frames simultaneously, one on the P1 stack -(raw locals — cursors, byte counts, pointers into BSS) and one on -the Scheme value stack (every tagged Scheme value). The collector -walks only the Scheme stack. - -Functions that hold zero Scheme values across calls keep using -`%fn2` / `%fn` and need no Scheme-stack frame at all (e.g. `memcpy`, -`strlen`, low-level syscall trampolines, the writer's byte -emitters). - -`scheme_sp` itself is the only stack-side root pointer the GC needs; -the live region is `[scheme_stack_base, scheme_sp)`. - -### 3. In-flight argument-passing registers +The allocation kinds are `PAIR`, `HEAP`, `RAW`, and `FREE`. The low-byte +mark bit is `0x80`; kind occupies the low three bits. Total size includes +the collector header and alignment padding. An unmarked allocated block +keeps its own header address in the second word, validating object-start +candidates. That word is reused by the mark worklist while collecting and +by the free list after sweeping. -At every potential GC point — that is, at every allocation — -arguments / temporaries already-live in `a0`–`a3` and `t0`–`t3` may -hold tagged values. The protocol is: **never call into the -allocator with a live tagged value held only in a register**. Either -spill to the Scheme frame first, or pass it through `a0` / `a1` to -the allocator (which the allocator itself preserves across -collection by treating its inputs as roots — see -[Allocation hooks](#allocation-hooks)). +Scheme-level layouts and tags are unchanged. A pair payload is still two +words and receives `TAG.PAIR`; a headered object still starts with its +`HDR` word and receives `TAG.HEAP`; bytevector data and symbol-name copies +are untagged `RAW` payload pointers. -This is a hard discipline; violating it produces use-after-free that -silently survives until the next collection. We mitigate by: -- Treating `a0` and `a1` of the allocator entry points (`cons`, - `alloc_hdr`, `alloc_bytes`) as additional roots during a - collection that fires from inside the allocator. They get - forwarded along with everything else and the allocator returns - with the updated values. -- Forbidding any other register from holding a tagged value across - a `%call` to a function that may allocate. (Audit pass; this is - already mostly true because of the existing spill discipline.) +## Allocation -## Object headers and tracing - -Every heap object — without exception — begins with an 8-byte -header word whose low byte is one of the `HDR` enum values. After -this change there are no headerless allocations: the existing -`alloc_bytes` is replaced by a header-emitting variant. - -### New tags - -``` -%enum HDR { BV CLOSURE PRIM TD REC MV RAW FWD } -``` - -- `HDR.RAW` — opaque byte buffer with no internal tagged refs. - Used for BV data, symtab name copies (when those move into the - GC heap; they currently live in main but are pinned — see - [Pinned allocations](#pinned-allocations)), and any other raw - payload that needs to participate in the parsable-heap walk. - Header word: `(raw_size_bytes << 8) | HDR.RAW`. -- `HDR.FWD` — forwarding sentinel (only valid in from-space during - a collection). Header word: `(new_addr << 8) | HDR.FWD`. Because - every heap object is 8-byte aligned, `new_addr` shifted left 8 - loses no information for any address representable in our memory - layout. - -### Per-type trace and size - -The collector dispatches on `hdr.low_byte` and produces (a) the -total size in bytes of the allocation including the 8-byte header, -and (b) a list of slot offsets containing tagged pointer fields. - -| HDR | Total size | Pointer-bearing slots | -|-------------|-----------------------------------------|-------------------------------------------| -| `BV` | 24 (hdr, len, cap), data via `BV.data` | `BV.data` (points to a `RAW` block) | -| `CLOSURE` | 32 | `CLOSURE.params`, `CLOSURE.body`, `CLOSURE.env` | -| `PRIM` | 24 | `PRIM.data` (only if entry is a parameterized prim — see below) | -| `TD` | 32 | `TD.name`, `TD.fields` | -| `REC` | `16 + nfields*8` (read `nfields` from `td`) | `td` slot + each field slot | -| `MV` | `8 + count*8` (read `count` from header high bytes) | each value slot | -| `RAW` | `8 + align8(size)` (read `size` from header high bytes) | none | -| `FWD` | (must not be visited; precondition violation if seen during scan) | n/a | - -PAIRs are **not** in this table because they are tagged with -`TAG.PAIR`, not `TAG.HEAP`. Their layout is fixed: -`[car | cdr]`, no header byte. PAIR copy is special-cased: 16 -bytes, two tagged-pointer slots (car at offset 0, cdr at +8). - -Because PAIRs have no header byte, the collector also can't store -a forwarding sentinel at offset 0 the same way it does for HEAP -objects. Instead we use the convention: for a forwarded PAIR, -overwrite the **car** slot with `(new_addr << 3) | TAG.PAIR` (a -self-tagged forward) and set the **cdr** slot to a sentinel -`IMM.UNBOUND`. To detect: a from-space pair is forwarded iff its -cdr slot equals the `UNBOUND` immediate. (We pick `UNBOUND` -because it is an immediate that user code never legitimately stores -into a cdr — it is reserved for "symbol unbound" lookups.) - -For PRIM, the `data` slot is *only* a tagged pointer when the prim -is a parameterized prim (record accessor / mutator / ctor / -predicate). For plain prims it's zero. Trace logic: read the slot; -if `tagof != TAG.FIXNUM && tagof != 0`, treat as a pointer. -Equivalent and simpler: always trace `PRIM.data` — fixnum-tagged -words and zero will fail the tag check inside the forwarding -routine and pass through unchanged. - -### Allocation hooks - -`cons` and `alloc_hdr` and `alloc_bytes` (which now emits a -`RAW` header) gain an OOM check that triggers a collection -instead of aborting: - -``` -:cons - load from_space_next, from_space_end - if next + 16 <= end: bump, write, return - else: - save a0, a1 to a known location (Scheme stack push) - call gc_collect - pop a0, a1 (now forwarded if they were heap pointers) - retry: this time it must succeed, else abort with msg_heap_full -``` - -The save-restore around `gc_collect` is exactly the in-flight -register protocol: the allocator's inputs are spilled onto the -Scheme stack so they participate as roots during the collection. - -## Forwarding - -`forward(tagged_ptr)` is the core operation, called by both root -forwarding and the scan loop: - -``` -case tagof(p): - FIXNUM, IMM, SYM: return p unchanged # not a heap ref - PAIR: - raw = p - 1 - if cdr(raw) == imm_val(UNBOUND): # already forwarded - return car(raw) # holds new tagged ptr - new = bump to-space by 16 - new[0] = car(raw); new[8] = cdr(raw) - car(raw) = (new << 3) | TAG.PAIR # write forward - cdr(raw) = imm_val(UNBOUND) # forward marker - return car(raw) - HEAP: - raw = p - 3 - hdr = ld(raw, 0) - if (hdr & 0xff) == HDR.FWD: - return ((hdr >> 8) | TAG.HEAP-untagged-arith) # extract new - size = size_of(hdr) - new = bump to-space by size - memcpy(new, raw, size) - st(raw, 0, (new << 8) | HDR.FWD) - return new + 3 -``` +`cons`, `alloc_hdr`, and `alloc_bytes` all use the managed allocator. It: -The scan loop walks to-space byte-by-byte using `size_of` to skip -over each copied object, calling `forward` on each tagged-pointer -slot listed by the per-type tracer. +1. Searches the address-ordered free list using first fit. +2. Splits a free block when at least a header and one aligned payload word + remain. +3. Otherwise allocates from the unused heap tail. +4. On failure, performs one collection and retries. +5. Reports `scheme1: heap exhausted` if no contiguous block is large enough. -## Pinned allocations +PAIR and HEAP payloads are cleared before publication so an object under +construction is safe to trace if a later allocation triggers collection. +RAW payloads are opaque and callers initialize the bytes they require. -Some interpreter-owned allocations must not move: -- Symtab name buffers (`alloc_bytes_main` from `intern`). -- TD objects that hold field-name lists (`alloc_hdr_main` / - `cons_main` from `eval_define_record_type`). -- Pre-allocated MACRO objects, special-form name strings, etc. +`heap-usage` returns the currently allocated physical bytes, including all +collector headers. `(collect-garbage)` requests a synchronous collection +and returns the unspecified value. -Today these live in the main heap, distinguished from user -allocations only by their use of the `*_main` allocator suffix. -After GC introduction, they need to live in a region the collector -**doesn't** sweep. Two options: +## Exact roots -1. **Move pinned allocations to a separate "perm" region.** Rename - `alloc_*_main` to `alloc_*_perm`, point them at a third BSS arena - (perm) sized for ~1 MiB. Collector treats perm as a root region - (scans every word, forwards heap pointers) but never moves perm - objects. Cleaner. -2. **Keep pinned allocations in from-space and special-case them - during copy.** Tag a "pinned" bit in the header; collector copies - the *contents* into to-space conceptually but actually leaves - them in place and just forwards their internal references. - Complicates the moving invariant. +The native P1 stack is never scanned conservatively. Allocation-capable +runtime functions use bounded shadow-root frames. Each descriptor records: -Recommend option 1. Perm region is small, write-once, scan-only. -The handful of `*_main` call sites in the interpreter all become -`*_perm`. +- the native-local base address; +- a bitmap of slots holding tagged Scheme references; +- a bitmap of slots holding managed `RAW` pointers. -## Collection lifecycle +Root slots are zero-initialized on frame entry. GC-aware return and tail-call +macros pop the descriptor on every exit path. Overflow of the 8192-frame +descriptor area terminates deterministically with +`scheme1: shadow root stack overflow`. -Init (called from `heap_init`): -1. Reserve both semispaces and the perm region in BSS. -2. `from_space = space_a`, `to_space = space_b`, - `from_space_next = from_space_start`. -3. `scheme_sp = scheme_stack_base`. +The complete root set is: -Trigger: -- Only on alloc-fail in the from-space. No proactive trigger, no - threshold-based trigger. -- A collection that fails to free enough space for the pending - allocation aborts with `msg_heap_full`. (No heap growth.) +- active slots described by the shadow-root stack; +- both arguments saved by `cons` while its allocator may collect; +- every symbol table entry's stable RAW name and global Scheme binding. -Collection body (`gc_collect`): -1. Swap from/to roles. Set `to_space_next = to_space_start`. -2. Forward all roots: - - Walk `[scheme_stack_base, scheme_sp)`: for each word, replace - in place with `forward(word)`. - - Walk `[symtab[0], symtab[symtab_count])`: for each entry, replace - `global_val` with `forward(global_val)`. - - Walk perm region's tagged-pointer fields (via the same - header-driven trace dispatch). - - Forward the allocator's spilled `a0`/`a1` if a collection - fired from inside an allocator. -3. Scan: cursor walks new from-space until it catches `next`. - For each object, forward each pointer-bearing slot per the - per-type trace. -4. Optionally zero the old from-space (debug only — helps catch - stale pointers; off by default for speed). +Pointers obtained through unsafe inspection primitives are not roots. -Post-conditions: -- All live objects copied to the new from-space; all forwarding - pointers consumed. -- `from_space_next` reflects the new occupancy. -- The old from-space is logically free. +## Marking and tracing -## Test posture +Marking does not allocate. A newly marked block is pushed onto an intrusive +worklist through its collector link word. Tagged references are dispatched +by tag to the expected allocation kind; raw roots require `RAW`. -A debug build flag (compile-time `%macro GC_DEBUG_FILL_FROM() %endm`) -that, when defined, fills the old from-space with a poison byte -after collection. Any surviving raw pointer to a copied object will -read poisoned bytes on its next dereference and crash visibly. +The tracer follows: -Test scaffolding (under `tests/scheme1/`): -- `gc-stress.scm`: allocate ~10 MiB of garbage in a loop with a - small live set; assert the heap doesn't grow. -- `gc-identity.scm`: pre-collection vs post-collection `eq?` on - pairs / records / closures should keep its answer. -- `gc-mutation.scm`: `set-car!` on a pair forwarded mid-collection - is observed correctly. -- `gc-cons-main.scm`: pinned objects survive collections without - changing identity. -- `gc-during-bv.scm`: trigger collection during `bv-grow`; verify - the BV's `RAW` data block is correctly forwarded. -- `gc-during-parser.scm`: large input program forces collection - during parsing; verify reader-built lists end up correct. -- `gc-during-cc.scm`: run `cc.scm` on a small input end-to-end - with an artificially shrunken from-space (e.g. 4 MiB) so - collection is exercised at every phase. Output must be - byte-identical to the un-shrunken run. +| Allocation | Outgoing managed references | +|---|---| +| Pair | `car`, `cdr` | +| Bytevector | RAW data payload | +| Closure | parameters, body, environment | +| Primitive | parameter data (type descriptor or fixnum) | +| Type descriptor | field-name list | +| Record | type descriptor and every field | +| Multiple-values pack | every value slot | +| RAW | none | -## Migration plan +Symbols, fixnums, and immediates contain no managed pointer. Type-descriptor +names are symbols, so they need no additional traversal. -The change is large enough to land in stages. Each stage is -independently testable; stages 1–4 are pure refactors that change -no observable behavior. +## Sweeping -1. **Add the perm region.** Introduce `*_perm` allocators and - migrate every `*_main` call site to `*_perm`. The "main" name - is freed up to mean "GC-managed" later. No semantic change. -2. **Add HDR.RAW.** Replace `alloc_bytes` with a variant that - emits a `RAW` header. Update `bv_alloc`, `bv_grow`, and the - single other `alloc_bytes` call site (string allocator) to - accept the new offset of the data buffer (now `+8` past the - raw allocation start). Heap is now parsable. -3. **Add the Scheme value stack.** Build the BSS region, the - `scheme_sp` global, and the `%senter` / `%sleave` / `%sst` / - `%sld` / `%spush` / `%spop` / `%fn3` macros. No callers yet. -4. **Migrate frames.** Convert every `%fn2` whose locals hold - tagged Scheme values to `%fn3`, splitting locals into Scheme - vs raw. Order: leaves first (`bind_params`, `eval_args`, - `apply_build_args`), then `eval` and the `eval_*` family, - then primitives, then the parser's value-producing leaves - (`parse_atom`, `parse_string`, `parse_char`, `parse_list`, - `parse_u8_body`, `parse_one`), then the writer - (`write_to_bv`, `write_pair_to_bv`, `value_to_bv`). -5. **Wire the collector.** Add `gc_collect`, `forward`, - `size_of`, and the per-type trace dispatch. Hook into - `cons` / `alloc_hdr` / `alloc_bytes` OOM paths. -6. **Shrink the heap and validate.** Cut the from-space from - 128 MiB to 4 MiB temporarily and run the full - `tests/scheme1/` and `tests/cc-pp/` suites. Restore. +Sweep walks the physical block chain from `heap_base` to `heap_tail`. +Marked allocations survive and have their mark cleared. Unmarked allocations +and prior free blocks become address-ordered free runs; adjacent runs are +coalesced immediately. A final free run is trimmed from `heap_tail` instead +of being retained on the free list. The pass also recomputes `heap-usage`. -After stage 4 the interpreter still works exactly as today (Scheme -values just live in a different stack), so each stage can be -landed and tested independently. Stage 5 is where new behavior -appears. +Collection is synchronous and occurs only after allocation failure or an +explicit `collect-garbage` call. Fragmentation can still exhaust the heap +when total free space is sufficient but no single run satisfies a request. -## Open items +## Compiler integration -- **Pinned cons cells.** `cons_main` produces PAIRs in main; with - GC, those PAIRs must instead live in perm. Need to confirm - every existing `cons_main` caller is fine with that. -- **Multi-value packs as roots in mid-flight.** `prim_call_with_values` - and friends pass MV-packs through registers. Audit to ensure no - MV-pack is held only in a register across an allocation. -- **`apply` with deep arg lists.** `apply_build_args` already builds - the arg list incrementally; verify that the head/tail pointers - are spilled to the Scheme stack across each `cons`. -- **Statistics.** A `(gc-stats)` primitive returning collection - count, bytes copied, last pause length. Useful for the test - scaffolding and for `cc.scm` self-instrumentation. Defer until - after stage 5 lands. +`cc.scm` builds translation units directly in the managed heap. Persistent +compiler data stays reachable through the parser/world/codegen graph; +discarded lexer, preprocessor, parser, and evaluator objects are reclaimed +automatically. There is no main/scratch heap selection, promotion cycle, or +arena rewind API. Generic `deep-copy` remains available as an ordinary +identity-preserving graph clone. diff --git a/docs/SCHEME1.md b/docs/SCHEME1.md @@ -203,16 +203,13 @@ single-value context; 0 or 2+ args produce an MV-pack consumable by `sys-argv` (no args; returns the process's argv as a list of bvs), `sys-exit code` (does not return). -**Heap control** (used by the cc compiler for arena-style allocation) -`heap-usage`, `heap-mark`, `heap-rewind!`, `use-scratch-heap!`, -`use-main-heap!`, `reset-scratch-heap!`, `heap-in-main?`. -`heap-mark` / `heap-rewind!` discard everything allocated after the -mark on whichever heap is current; the scratch heap can be reset -wholesale. UNSAFE: the runtime does not track liveness, so any -surviving reference into a freed region becomes dangling. Most callers -should reach for the prelude wrappers `call-with-heap-rewind`, -`call-with-scratch-deep-copy`, and `call-with-scratch-cycle` rather -than driving these primitives directly. +**Garbage collection** +`heap-usage`, `collect-garbage`. +`heap-usage` reports currently allocated managed bytes, including the +16-byte header on each allocation. `collect-garbage` performs a synchronous +collection and returns unspecified. Collection also runs automatically when +an allocation cannot be satisfied without reclaiming garbage. See +[SCHEME1-GC.md](SCHEME1-GC.md) for the heap and exact-rooting design. ## Error semantics diff --git a/scheme1/prelude.scm b/scheme1/prelude.scm @@ -362,16 +362,13 @@ (loop (cdr xs) (+ i 1))))))) ;; --- Generic deep-copy --------------------------------------------- -;; Structural clone of pair / bytevector / record graphs in the -;; currently-selected heap. Preserves eq? identity across shared -;; substructure and tolerates cycles via an eager stand-in registered -;; before recursion. +;; Structural clone of pair / bytevector / record graphs. Preserves eq? +;; identity across shared substructure and tolerates cycles via an eager +;; stand-in registered before recursion. ;; ;; The ctx is a one-cell box around an (orig . copy) alist; lookups ;; key off pointer identity (assq) so two structurally-equal but -;; physically-distinct objects are treated separately. Cells leak into -;; whichever heap is current when ctx is created — typically main -;; during cc.scm's parse-decl-or-fn promotion. +;; physically-distinct objects are treated separately. ;; ;; Strict positive-list dispatch: pair / bytevector / record. Anything ;; else that masquerades as heap-allocated (closures, prims, MV-packs) @@ -389,7 +386,6 @@ (define (deep-copy ctx obj) (cond ((symbol? obj) obj) - ((heap-in-current? obj) obj) ((pair? obj) (let ((c (%dcc-lookup ctx obj))) (cond @@ -425,51 +421,6 @@ (error "deep-copy: cannot copy procedure" obj)) (else obj))) -;; --- Heap arena wrappers ------------------------------------------- -;; Two-pattern API on top of the raw heap-mark / heap-rewind! / scratch -;; primitives. Most callers should reach for these instead of driving -;; the primitives directly. See tests/scheme1/093-heap-mark-rewind.scm -;; and tests/scheme1/115-two-heap.scm for the underlying contract. - -;; Pattern 1 — mark/rewind. Run thunk inside a heap-mark/rewind arena -;; on the current heap. All heap allocations performed by thunk are -;; reclaimed on return; thunk's return value MUST be either an immediate -;; (fixnum, boolean, symbol, '()) or a cell allocated by the caller -;; *before* call-with-heap-rewind ran. The classic A→B→C shape pre- -;; allocates an `out` cell, calls this with a thunk that mutates `out`, -;; and returns `out` to its own caller. -(define (call-with-heap-rewind thunk) - (let ((mark (heap-mark))) - (let ((r (thunk))) - (heap-rewind! mark) - r))) - -;; Pattern 2a — scratch + deep-copy of a single root. Run thunk with -;; the scratch heap selected, switch back to main, deep-copy thunk's -;; result into main, reset scratch, return the main-heap copy. Use for -;; the common case of "build a graph in scratch, hand the caller a -;; main-heap clone, reclaim scratch". -(define (call-with-scratch-deep-copy thunk) - (use-scratch-heap!) - (let ((s (thunk))) - (use-main-heap!) - (let ((m (deep-copy (make-deep-copy-context) s))) - (reset-scratch-heap!) - m))) - -;; Pattern 2b — scratch + multi-root promote. Lower-level cycle: select -;; scratch, run (in-scratch), select main, run (promote), reset scratch. -;; The (promote) thunk is responsible for deep-copying every survivor -;; root from scratch into main (typically across several caller-owned -;; slots, sharing a single deep-copy context). Returns unspec; survivors -;; must reach the caller via slots that promote rewrites in place. -(define (call-with-scratch-cycle in-scratch promote) - (use-scratch-heap!) - (in-scratch) - (use-main-heap!) - (promote) - (reset-scratch-heap!)) - ;; --- Vector <-> list -- need make-vector / vector-ref / vector-set! / ;; vector-length, none of which are yet primitives. ------------------ ; (define (vector->list-helper v i acc) diff --git a/scheme1/scheme1.P1pp b/scheme1/scheme1.P1pp @@ -14,6 +14,15 @@ %enum TAG { FIXNUM PAIR SYM HEAP IMM } %enum IMM { FALSE TRUE NIL UNSPEC UNBOUND EOF } %enum HDR { BV CLOSURE PRIM TD REC MV } +%enum GCKIND { FREE PAIR HEAP RAW } + +# Each managed block begins with two machine words. The first word is +# (total_block_bytes << 8) | kind | mark +# and the second is an intrusive link, reused by the free list and mark +# worklist. Payloads retain their historical layouts and tags. +%macro GC_HEADER_BYTES() 16 %endm +%macro GC_MARK_BIT() 128 %endm +%macro GC_KIND_MASK() 7 %endm # imm_val(idx) -> integer-expression for the tagged immediate at IMM index # `idx`. Used both at %li sites (loaded into a register) and at $() emission @@ -31,20 +40,14 @@ # Records are variable width: header + td slot + N field slots. # BSS arenas anchored past :ELF_end. readbuf is 1 MiB (sized to fit -# the catm'd cc compiler source incl. prelude — see READBUF_CAP_BYTES), -# then symtab, then the main heap, then the scratch heap. The ELF -# p_memsz reservation (currently 512 MiB, declared in -# vendor/seed/<arch>/ELF.hex2) covers all of them with headroom. -# HEAP_CAP_BYTES (256 MiB) and SCRATCH_CAP_BYTES (16 MiB) are explicit -# caps; total bss usage = readbuf + symtab + heap + scratch and must -# fit inside p_memsz. p1_main calls libp1pp's init_arenas, which walks -# arena_table and writes &ELF_end + sum of prior sizes into each -# pointer slot. +# the catm'd cc compiler source incl. prelude), followed by the symbol +# table, the exact-root frame stack, and one 256 MiB managed heap. %macro SYMTAB_CAP_SLOTS() 8192 %endm %macro READBUF_CAP_BYTES() 1048576 %endm %macro HEAP_CAP_BYTES() 0x10000000 %endm -%macro SCRATCH_CAP_BYTES() 0x8000000 %endm +%macro GC_ROOT_CAP_FRAMES() 8192 %endm +%macro GC_ROOT_FRAME_BYTES() 24 %endm # ========================================================================= # Tag idioms @@ -183,7 +186,7 @@ %ld(a0, sp, 0) %cdr(a0, a0) %ld(a1, sp, 8) - %tail(handler) + %gctail(handler) %endm # Branch to `target` if `val` holds the NIL immediate. `scratch` is @@ -209,6 +212,88 @@ %call(&sym_set_global) %endm +# Exact shadow-root frames. Every frame records the native frame pointer +# plus two bitmaps: tagged Scheme-reference slots and temporarily live raw +# managed-allocation pointers. Bit N describes native local slot N. The +# collector dereferences only those described slots; ordinary machine +# locals and the native P1 stack are never scanned. +%macro gc_frame_push(scheme_mask, raw_mask) + %ld_global(t0, &gc_root_next) + %addi(t1, t0, %GC_ROOT_FRAME_BYTES) + %ld_global(t2, &gc_root_end) + %bltu(t2, t1, &@overflow) + %addi(t2, sp, 16) + %st(t2, t0, 0) + %li(t2, scheme_mask) + %st(t2, t0, 8) + %li(t2, raw_mask) + %st(t2, t0, 16) + %st_global(t1, &gc_root_next, t2) + %b(&@done) + :@overflow + %die(msg_gc_roots_full) + :@done +%endm + +%macro gc_frame_pop() + %ld_global(t0, &gc_root_next) + %addi(t0, t0, (- %GC_ROOT_FRAME_BYTES)) + # Clear popped descriptors so debugging an overflow never exposes + # stale native-stack addresses as apparently active slots. + %li(t1, 0) + %st(t1, t0, 0) + %st(t1, t0, 8) + %st(t1, t0, 16) + %st_global(t0, &gc_root_next, t1) +%endm + +%macro gc_frame_clear(frame_size) + %addi(t0, sp, 16) + %li(t1, frame_size) + %li(t2, 0) + :@loop + %beqz(t1, &@done) + %st(t2, t0, 0) + %addi(t0, t0, 8) + %addi(t1, t1, -8) + %b(&@loop) + :@done +%endm + +%macro gceret() + %gc_frame_pop + %eret +%endm + +%macro gctail(target) + %gc_frame_pop + %tail(target) +%endm + +%macro gctailr(target_reg) + %mov(a3, target_reg) + %gc_frame_pop + %tailr(a3) +%endm + +# GC-aware counterpart of P1pp's %fn2. Functions using this form must +# use %gceret / %gctail / %gctailr for explicit exits; fallthrough runs +# the epilogue emitted here. +%macro gcfn2(name, locals, scheme_mask, raw_mask, body) + %struct name ## _FRAME { locals } + : ## name + .scope + %frame name + %enter(% ## name ## _FRAME.SIZE) + %gc_frame_clear(% ## name ## _FRAME.SIZE) + %gc_frame_push(scheme_mask, raw_mask) + body + %gc_frame_pop + %eret + %endframe + .endscope +%endm + # car-and-untag-fixnum: rd = car(list) >> 3. %macro car_fix(rd, list) %car(rd, list) @@ -489,7 +574,7 @@ # Locals: # head NIL until first item # tail most recent cons (set-cdr! target) -%fn2(parse_list, {head tail}, { +%gcfn2(parse_list, {head tail}, 3, 0, { %li(t0, %imm_val(%IMM.NIL)) %stl(t0, head) %stl(t0, tail) @@ -548,14 +633,14 @@ %bcne(a0, -41, &.eof, a1) ; ')' %readbuf_advance(t0, t1) %ldl(a0, head) - %eret + %gceret :.close # Consume ')' and return head. %lda_global(t1, t0, &readbuf_pos) %readbuf_advance(t1, t0) %ldl(a0, head) - %eret + %gceret :.eof %die(msg_unterm_list) @@ -569,7 +654,7 @@ # Locals: # list parsed element list (cursor during fill pass) # result freshly allocated bv -%fn2(parse_u8_body, {list result}, { +%gcfn2(parse_u8_body, {list result}, 3, 0, { %call(&parse_list) %stl(a0, list) @@ -992,7 +1077,7 @@ # env # fn (head value, while args are being evaluated) # pad -%fn2(eval, {expr env fn pad}, { +%gcfn2(eval, {expr env fn pad}, 7, 0, { %stl(a0, expr) %stl(a1, env) @@ -1000,7 +1085,7 @@ %bieq(t0, %TAG.SYM, &.sym, t1) %bieq(t0, %TAG.PAIR, &.pair, t1) # FIXNUM, HEAP, IMM all self-evaluate. - %eret + %gceret :.sym # Walk the env alist. Each cell is ((sym . val) . rest). On hit, @@ -1016,13 +1101,13 @@ :.env_hit %cdr(a0, t1) - %eret + %gceret :.env_miss %untag_sym(a0, a0) %call(&sym_global) %bieq(a0, %imm_val(%IMM.UNBOUND), &.unbound, t0) - %eret + %gceret :.unbound %die(msg_unbound) @@ -1069,7 +1154,7 @@ # apply(fn, args) -- tail call %mov(a1, a0) %ldl(a0, fn) - %tail(&apply) + %gctail(&apply) :.do_quote %tail_to_handler(&eval_quote) @@ -1120,7 +1205,7 @@ # env # head (NIL until first val is appended) # tail (most recent cell; set-cdr! target) -%fn2(eval_args, {args env head tail}, { +%gcfn2(eval_args, {args env head tail}, 15, 0, { %stl(a0, args) %stl(a1, env) %li(t0, %imm_val(%IMM.NIL)) @@ -1165,7 +1250,7 @@ # Locals: # args # body (saved across bind_params for the closure path) -%fn2(apply, {args body}, { +%gcfn2(apply, {args body}, 3, 0, { %stl(a1, args) %hdr_type(t0, a0) @@ -1186,7 +1271,7 @@ %mov(a1, a0) %heap_ld(t0, a0, %PRIM.entry_w) %ldl(a0, args) - %tailr(t0) + %gctailr(t0) :.closure # Closure layout (HEAP-tagged): [hdr][params][body][env] @@ -1204,7 +1289,7 @@ # eval_body(body, new_env) -- tail call %mov(a1, a0) %ldl(a0, body) - %tail(&eval_body) + %gctail(&eval_body) }) # ========================================================================= @@ -1257,7 +1342,7 @@ # Locals: # rest # env -%fn2(eval_if, {rest env}, { +%gcfn2(eval_if, {rest env}, 3, 0, { %stl(a0, rest) %stl(a1, env) @@ -1272,7 +1357,7 @@ %cdr(a0, a0) %car(a0, a0) %ldl(a1, env) - %tail(&eval) + %gctail(&eval) :.else_branch # If cddr(rest) is NIL, this is single-arm `if` -> UNSPEC. @@ -1284,7 +1369,7 @@ # else-branch: tail-eval(car(cddr(rest)), env) %car(a0, t0) %ldl(a1, env) - %tail(&eval) + %gctail(&eval) :.no_else %li(a0, %imm_val(%IMM.UNSPEC)) @@ -1298,7 +1383,7 @@ # rest # env # closure ptr (HEAP-tagged) -%fn2(eval_lambda, {rest env closure}, { +%gcfn2(eval_lambda, {rest env closure}, 7, 0, { %stl(a0, rest) %stl(a1, env) @@ -1337,7 +1422,7 @@ # Locals: # rest # env -%fn2(eval_define, {rest env}, { +%gcfn2(eval_define, {rest env}, 3, 0, { %stl(a0, rest) %stl(a1, env) @@ -1357,7 +1442,7 @@ %car(t0, t0) %set_global(t0, a0) %li(a0, %imm_val(%IMM.UNSPEC)) - %eret + %gceret :.sugar # rest = ((name . params) . body); build (params . body) for eval_lambda. @@ -1389,7 +1474,7 @@ # rest (sym . (value-expr . ())) # env # saved value (eval'd value-expr) -%fn2(eval_setbang, {rest env saved}, { +%gcfn2(eval_setbang, {rest env saved}, 7, 0, { %stl(a0, rest) %stl(a1, env) @@ -1420,7 +1505,7 @@ %ldl(a0, saved) %set_cdr(a0, t0) ; mutate cell's cdr %li(a0, %imm_val(%IMM.UNSPEC)) - %eret + %gceret :.miss # Miss: rebind global. @@ -1442,7 +1527,7 @@ # env # test value (live across the => eval/cons calls) # proc (live across the => cons call) -%fn2(eval_cond, {clauses env test proc}, { +%gcfn2(eval_cond, {clauses env test proc}, 15, 0, { %stl(a0, clauses) %stl(a1, env) @@ -1475,7 +1560,7 @@ %mov(a0, t0) ; regular body %ldl(a1, env) - %tail(&eval_body) + %gctail(&eval_body) :.arrow %cdr(t0, t0) @@ -1488,14 +1573,14 @@ %call(&cons) %mov(a1, a0) %ldl(a0, proc) - %tail(&apply) + %gctail(&apply) :.else_clause %ldl(t0, clauses) %car(t0, t0) %cdr(a0, t0) %ldl(a1, env) - %tail(&eval_body) + %gctail(&eval_body) :.next %advance_walk(clauses) @@ -1517,7 +1602,7 @@ # env (original) # walk (bindings, advances) # new_env (built up) -%fn2(eval_let, {rest env walk new_env}, { +%gcfn2(eval_let, {rest env walk new_env}, 15, 0, { %stl(a0, rest) %stl(a1, env) @@ -1565,12 +1650,12 @@ %ldl(a0, rest) %cdr(a0, a0) ; body %ldl(a1, new_env) - %tail(&eval_body) + %gctail(&eval_body) :.named %ldl(a0, rest) %ldl(a1, env) - %tail(&eval_let_named) + %gctail(&eval_let_named) }) # eval_letstar(rest=a0, env=a1) -> value (a0). @@ -1582,7 +1667,7 @@ # env # walk # new_env -%fn2(eval_letstar, {rest env walk new_env}, { +%gcfn2(eval_letstar, {rest env walk new_env}, 15, 0, { %stl(a0, rest) %stl(a1, env) @@ -1623,7 +1708,7 @@ %ldl(a0, rest) %cdr(a0, a0) %ldl(a1, new_env) - %tail(&eval_body) + %gctail(&eval_body) }) # eval_let_values(rest=a0, env=a1) -> value (a0). @@ -1637,7 +1722,7 @@ # env (original) # walk (clauses, advances) # new_env (built up) -%fn2(eval_let_values, {rest env walk new_env}, { +%gcfn2(eval_let_values, {rest env walk new_env}, 15, 0, { %stl(a0, rest) %stl(a1, env) @@ -1680,7 +1765,7 @@ %ldl(a0, rest) %cdr(a0, a0) ; body %ldl(a1, new_env) - %tail(&eval_body) + %gctail(&eval_body) }) # eval_letstar_values(rest=a0, env=a1) -> value (a0). @@ -1692,7 +1777,7 @@ # env # walk # new_env -%fn2(eval_letstar_values, {rest env walk new_env}, { +%gcfn2(eval_letstar_values, {rest env walk new_env}, 15, 0, { %stl(a0, rest) %stl(a1, env) @@ -1733,7 +1818,7 @@ %ldl(a0, rest) %cdr(a0, a0) %ldl(a1, new_env) - %tail(&eval_body) + %gctail(&eval_body) }) # eval_and(rest=a0, env=a1) -> value (a0). @@ -1744,7 +1829,7 @@ # Locals: # rest # env -%fn2(eval_and, {rest env}, { +%gcfn2(eval_and, {rest env}, 3, 0, { %li(t0, %imm_val(%IMM.TRUE)) %if_nil(t1, a0, &.done_imm) @@ -1770,10 +1855,10 @@ %ldl(a0, rest) %car(a0, a0) %ldl(a1, env) - %tail(&eval) + %gctail(&eval) :.done - %eret + %gceret :.done_imm %mov(a0, t0) @@ -1787,7 +1872,7 @@ # Locals: # rest # env -%fn2(eval_or, {rest env}, { +%gcfn2(eval_or, {rest env}, 3, 0, { %li(t0, %imm_val(%IMM.FALSE)) %if_nil(t1, a0, &.done_imm) @@ -1810,10 +1895,10 @@ %ldl(a0, rest) %car(a0, a0) %ldl(a1, env) - %tail(&eval) + %gctail(&eval) :.done - %eret + %gceret :.done_imm %mov(a0, t0) @@ -1827,7 +1912,7 @@ # Locals: # rest # env -%fn2(eval_when, {rest env}, { +%gcfn2(eval_when, {rest env}, 3, 0, { %stl(a0, rest) %stl(a1, env) @@ -1839,7 +1924,7 @@ %ldl(a0, rest) %cdr(a0, a0) ; body %ldl(a1, env) - %tail(&eval_body) + %gctail(&eval_body) :.skip %li(a0, %imm_val(%IMM.UNSPEC)) @@ -1860,7 +1945,7 @@ # env # clauses (advances) # datums (advances within a clause) -%fn2(eval_case, {subject env clauses datums}, { +%gcfn2(eval_case, {subject env clauses datums}, 15, 0, { %stl(a1, env) # subject = eval(car(rest), env); clauses = cdr(rest). @@ -1899,14 +1984,14 @@ %car(t0, t0) %cdr(a0, t0) ; body %ldl(a1, env) - %tail(&eval_body) + %gctail(&eval_body) :.do_else %ldl(t0, clauses) %car(t0, t0) %cdr(a0, t0) ; body %ldl(a1, env) - %tail(&eval_body) + %gctail(&eval_body) :.next_clause %ldl(t0, clauses) @@ -1937,7 +2022,7 @@ # env_ext (env extended with the matched clause's bindings) # guard cursor (advances during the guard AND-fold) # body (saved across guard evals, tail-evaluated on success) -%fn2(eval_pmatch, {subject env_outer clauses env_ext guard body}, { +%gcfn2(eval_pmatch, {subject env_outer clauses env_ext guard body}, 63, 0, { %stl(a1, env_outer) # subject = eval(car(rest), env_outer); clauses = cdr(rest). @@ -2007,7 +2092,7 @@ :.body_run %ldl(a0, body) %ldl(a1, env_ext) - %tail(&eval_body) + %gctail(&eval_body) :.body_simple # tail itself is the body (no guard wrapper). Tail-call eval_body @@ -2015,14 +2100,14 @@ # is preserved. %mov(a0, t0) %ldl(a1, env_ext) - %tail(&eval_body) + %gctail(&eval_body) :.do_else %ldl(t0, clauses) %car(t0, t0) %cdr(a0, t0) ; body %ldl(a1, env_outer) ; env_outer (no bindings introduced) - %tail(&eval_body) + %gctail(&eval_body) :.next %ldl(t0, clauses) @@ -2064,7 +2149,7 @@ # body body command-forms (cddr of rest) # pair_walk cdr-cursor over pairs_head during step/update # val_walk cdr-cursor over vals_head during step/update -%fn2(eval_do, {rest env new_env walk pairs_head pairs_tail vals_head vals_tail body pair_walk val_walk}, { +%gcfn2(eval_do, {rest env new_env walk pairs_head pairs_tail vals_head vals_tail body pair_walk val_walk}, 2047, 0, { %stl(a0, rest) %stl(a1, env) @@ -2170,11 +2255,11 @@ %if_nil(t1, t0, &.no_results) %mov(a0, t0) %ldl(a1, new_env) - %tail(&eval_body) + %gctail(&eval_body) :.no_results %li(a0, %imm_val(%IMM.UNSPEC)) - %eret + %gceret :.commands %ldl(t0, body) @@ -2280,7 +2365,7 @@ # env # td (record-pattern: TD pulled from the predicate PRIM) # flw (record-pattern: cursor over remaining (fname pat) clauses) -%fn2(pmatch_match, {pat subj env td flw}, { +%gcfn2(pmatch_match, {pat subj env td flw}, 31, 0, { %stl(a0, pat) %stl(a1, subj) %stl(a2, env) @@ -2330,7 +2415,7 @@ %cdr(a0, t0) %ldl(t0, subj) %cdr(a1, t0) - %tail(&pmatch_match) + %gctail(&pmatch_match) :.binder # Validate (unquote <sym>): cdr(pat) is a pair, cdr(cdr(pat)) is NIL, @@ -2357,7 +2442,7 @@ %ldl(a1, env) %call(&cons) %li(a1, 1) - %eret + %gceret :.record_pat # pat = ($ pred-sym (f1 p1) (f2 p2) ...). Resolve pred-sym -> PRIM via @@ -2462,11 +2547,11 @@ :.ok %ldl(a0, env) %li(a1, 1) - %eret + %gceret :.no %li(a1, 0) - %eret + %gceret :.bad %die(msg_bad_unquote_pattern) @@ -2488,7 +2573,7 @@ # head (current pass's list head — params, then args) # tail (current pass's list tail) # params (saved between passes) -%fn2(eval_let_named, {rest env_orig self_binding self_env walk head tail params}, { +%gcfn2(eval_let_named, {rest env_orig self_binding self_env walk head tail params}, 255, 0, { %stl(a0, rest) %stl(a1, env_orig) @@ -2594,7 +2679,7 @@ # 6. apply(closure, args). %ldl(a1, head) - %tail(&apply) + %gctail(&apply) }) # bind_params(params=a0, args=a1, env=a2) -> extended env (a0). @@ -2606,7 +2691,7 @@ # params (advanced each iteration) # args (advanced each iteration) # env (extended each iteration) -%fn2(bind_params, {params args env}, { +%gcfn2(bind_params, {params args env}, 7, 0, { %stl(a0, params) %stl(a1, args) %stl(a2, env) @@ -2663,7 +2748,7 @@ # Locals: # body # env -%fn2(eval_body, {body env}, { +%gcfn2(eval_body, {body env}, 3, 0, { :.loop %stl(a0, body) %stl(a1, env) @@ -2697,7 +2782,7 @@ %ldl(a0, body) %car(a0, a0) %ldl(a1, env) - %tail(&eval) + %gctail(&eval) :.internal_define %die(msg_internal_define) @@ -2744,92 +2829,562 @@ }) # ========================================================================= -# Heap: cons (leaf) and alloc_hdr (leaf) +# Mark-and-sweep collector # ========================================================================= # -# Both are call-free leaves: bump *current_heap_next_ptr, write fields, -# return tagged pointer. Each allocation tests (new_next <= -# *current_heap_end_ptr) and aborts via runtime_error if the bump would -# overflow the current heap. The current heap is selected by -# (use-scratch-heap!) / (use-main-heap!); both pointer-of-pointer slots -# default to &heap_next / &heap_end at heap_init. *_next is kept 8-byte -# aligned so every PAIR/HEAP tag bit is exact: cons always bumps by a -# multiple of 8 (16); alloc_hdr / alloc_bytes round their argument up -# via %alignup(_,_,8,_). - -# cons(car=a0, cdr=a1) -> tagged pair (a0). Allocates 16 bytes. -:cons +# Marking never allocates. A marked allocation header is linked through +# word 1 onto gc_mark_worklist. Only exact shadow-frame slots and explicit +# symbol-table roots seed the traversal. + +# gc_mark_payload(raw_payload=a0, expected_kind=a1). Invalid, interior, +# free, or already-marked addresses are ignored. +:gc_mark_payload .scope - %ld_global(t2, ¤t_heap_next_ptr) - %ld(t0, t2, 0) - %addi(t1, t0, %PAIR.SIZE) - %ld_global(a3, ¤t_heap_end_ptr) - %ld(a3, a3, 0) - %bltu(a3, t1, &.oom) - %st(a0, t0, %PAIR.car) - %st(a1, t0, %PAIR.cdr) - %st(t1, t2, 0) - %addi(a0, t0, %TAG.PAIR) + %beqz(a0, &.done) + %andi(t2, a0, 7) + %bnez(t2, &.done) + %ld_global(t0, &heap_base) + %addi(t0, t0, %GC_HEADER_BYTES) + %bltu(a0, t0, &.done) + %ld_global(t1, &heap_tail) + %bltu(a0, t1, &.in_heap) + # A zero-length RAW allocation has its payload exactly at heap_tail; + # its 16-byte header is still a real managed block. + %beq(a0, t1, &.in_heap) + %b(&.done) + :.in_heap + %addi(t0, a0, (- %GC_HEADER_BYTES)) + %ld(t1, t0, 0) + %andi(t2, t1, %GC_KIND_MASK) + %bne(t2, a1, &.done) + # Validate the candidate header before putting it on the worklist. + # Exact roots should always name object starts; these checks reject + # malformed, truncated, and implausible interior candidates safely. + %shri(a2, t1, 8) + %li(a3, %GC_HEADER_BYTES) + %bltu(a2, a3, &.done) + %andi(a3, a2, 7) + %bnez(a3, &.done) + %add(a3, t0, a2) + %ld_global(t2, &heap_tail) + %bltu(t2, a3, &.done) + %andi(t2, t1, %GC_MARK_BIT) + %bnez(t2, &.done) + # An unmarked allocated block keeps its own header address in the + # intrusive word. This canary distinguishes a real object start from + # an aligned interior word without a quadratic physical-chain walk. + %ld(t2, t0, 8) + %bne(t2, t0, &.done) + %ori(t1, t1, %GC_MARK_BIT) + %st(t1, t0, 0) + %ld_global(t1, &gc_mark_worklist) + %st(t1, t0, 8) + %st_global(t0, &gc_mark_worklist, t1) + :.done %ret - :.oom - %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 +# gc_mark_scheme(value=a0). Tags select the exact managed allocation +# kind; fixnums, symbols, and immediates are not heap roots. +:gc_mark_scheme .scope - %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) + %tagof(t0, a0) + %li(t1, %TAG.PAIR) + %beq(t0, t1, &.pair) + %li(t1, %TAG.HEAP) + %beq(t0, t1, &.heap) %ret - :.oom - %die(msg_heap_full) + :.pair + %addi(a0, a0, (- %TAG.PAIR)) + %li(a1, %GCKIND.PAIR) + %b(&gc_mark_payload) + :.heap + %addi(a0, a0, (- %TAG.HEAP)) + %li(a1, %GCKIND.HEAP) + %b(&gc_mark_payload) .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 -.scope - %alignup(a0, a0, 8, t0) - %ld_global(t2, ¤t_heap_next_ptr) - %ld(t0, t2, 0) - %add(t1, t0, a0) - %ld_global(a3, ¤t_heap_end_ptr) - %ld(a3, a3, 0) - %bltu(a3, t1, &.oom) - %st(t1, t2, 0) +:gc_mark_raw + %li(a1, %GCKIND.RAW) + %b(&gc_mark_payload) + +# Mark all described native-frame slots. +%fn2(gc_mark_shadow_roots, {frame end native scheme_mask raw_mask slot}, { + %ld_global(t0, &gc_root_buf_ptr) + %stl(t0, frame) + %ld_global(t0, &gc_root_next) + %stl(t0, end) + :.frame_loop + %ldl(t0, frame) + %ldl(t1, end) + %beq(t0, t1, &.done) + %ld(t1, t0, 0) + %stl(t1, native) + %stl(t1, slot) + %ld(t1, t0, 8) + %stl(t1, scheme_mask) + %ld(t1, t0, 16) + %stl(t1, raw_mask) + :.slot_loop + %ldl(t0, scheme_mask) + %ldl(t1, raw_mask) + %or(t2, t0, t1) + %beqz(t2, &.next_frame) + %andi(t2, t0, 1) + %beqz(t2, &.maybe_raw) + %ldl(t2, slot) + %ld(a0, t2, 0) + %call(&gc_mark_scheme) + :.maybe_raw + %ldl(t0, raw_mask) + %andi(t1, t0, 1) + %beqz(t1, &.advance_slot) + %ldl(t1, slot) + %ld(a0, t1, 0) + %call(&gc_mark_raw) + :.advance_slot + %ldl(t0, scheme_mask) + %shri(t0, t0, 1) + %stl(t0, scheme_mask) + %ldl(t0, raw_mask) + %shri(t0, t0, 1) + %stl(t0, raw_mask) + %ldl(t0, slot) + %addi(t0, t0, 8) + %stl(t0, slot) + %b(&.slot_loop) + :.next_frame + %ldl(t0, frame) + %addi(t0, t0, %GC_ROOT_FRAME_BYTES) + %stl(t0, frame) + %b(&.frame_loop) + :.done +}) + +# Symbol entries are permanent roots: the stable RAW name buffers and +# every Scheme value installed in a global binding. +%fn2(gc_mark_symbol_roots, {idx count entry}, { + %li(t0, 0) + %stl(t0, idx) + %ld_global(t0, &symtab_count) + %stl(t0, count) + :.loop + %ldl(t0, idx) + %ldl(t1, count) + %beq(t0, t1, &.done) + %symtab_entry(t1, t0, t2) + %stl(t1, entry) + %ld(a0, t1, %SYMENT.name_ptr) + %call(&gc_mark_raw) + %ldl(t1, entry) + %ld(a0, t1, %SYMENT.global_val) + %call(&gc_mark_scheme) + %ldl(t0, idx) + %addi(t0, t0, 1) + %stl(t0, idx) + %b(&.loop) + :.done +}) + +# Trace one marked allocation header. The header remains marked while it +# is off the worklist, so cycles terminate naturally. +%fn2(gc_trace_header, {header payload object_hdr count cursor td}, { + %stl(a0, header) + %addi(t0, a0, %GC_HEADER_BYTES) + %stl(t0, payload) + %ld(t1, a0, 0) + %andi(t1, t1, %GC_KIND_MASK) + %li(t2, %GCKIND.PAIR) + %beq(t1, t2, &.pair) + %li(t2, %GCKIND.HEAP) + %beq(t1, t2, &.heap) + %eret ; RAW has no outgoing references + + :.pair + %ld(a0, t0, %PAIR.car) + %call(&gc_mark_scheme) + %ldl(t0, payload) + %ld(a0, t0, %PAIR.cdr) + %tail(&gc_mark_scheme) + + :.heap + %ld(t1, t0, 0) + %stl(t1, object_hdr) + %andi(t1, t1, 255) + %li(t2, %HDR.BV) + %beq(t1, t2, &.bv) + %li(t2, %HDR.CLOSURE) + %beq(t1, t2, &.closure) + %li(t2, %HDR.PRIM) + %beq(t1, t2, &.prim) + %li(t2, %HDR.TD) + %beq(t1, t2, &.td) + %li(t2, %HDR.REC) + %beq(t1, t2, &.record) + %li(t2, %HDR.MV) + %beq(t1, t2, &.mv) + %eret + + :.bv + %ld(a0, t0, %BV.data) + %tail(&gc_mark_raw) + + :.closure + %ld(a0, t0, %CLOSURE.params) + %call(&gc_mark_scheme) + %ldl(t0, payload) + %ld(a0, t0, %CLOSURE.body) + %call(&gc_mark_scheme) + %ldl(t0, payload) + %ld(a0, t0, %CLOSURE.env) + %tail(&gc_mark_scheme) + + :.prim + # Plain primitives contain zero in data; parameterized primitives + # contain their TD or tagged field index. + %ld(a0, t0, %PRIM.data) + %tail(&gc_mark_scheme) + + :.td + %ld(a0, t0, %TD.fields) + %tail(&gc_mark_scheme) + + :.record + %ld(t1, t0, %REC.td) + %stl(t1, td) + %mov(a0, t1) + %call(&gc_mark_scheme) + # A freshly published record may still have its cleared TD slot while + # its constructor is filling fields. In that state it has no outgoing + # references yet and is safe to revisit after construction. + %ldl(t0, td) + %tagof(t1, t0) + %li(t2, %TAG.HEAP) + %bne(t1, t2, &.done) + %hdr_type(t1, t0) + %li(t2, %HDR.TD) + %bne(t1, t2, &.done) + %heap_ld(t1, t0, %TD.nfields) + %stl(t1, count) + %ldl(t0, payload) + %addi(t0, t0, 16) + %stl(t0, cursor) + %b(&.slots) + + :.mv + %ldl(t0, object_hdr) + %shri(t0, t0, 8) + %stl(t0, count) + %ldl(t0, payload) + %addi(t0, t0, 8) + %stl(t0, cursor) + + :.slots + %ldl(t0, count) + %beqz(t0, &.done) + %ldl(t1, cursor) + %ld(a0, t1, 0) + %call(&gc_mark_scheme) + %ldl(t0, cursor) + %addi(t0, t0, 8) + %stl(t0, cursor) + %ldl(t0, count) + %addi(t0, t0, -1) + %stl(t0, count) + %b(&.slots) + :.done +}) + +# Sweep the physical block chain, rebuild an address-ordered free list, +# coalesce adjacent garbage, clear survivor marks, and return a trailing +# free run to the unused tail. +%fn2(gc_sweep, {cursor end free_head list_last list_prev run_free allocated size}, { + %ld_global(t0, &heap_base) + %stl(t0, cursor) + %ld_global(t0, &heap_tail) + %stl(t0, end) + %li(t0, 0) + %stl(t0, free_head) + %stl(t0, list_last) + %stl(t0, list_prev) + %stl(t0, run_free) + %stl(t0, allocated) + :.loop + %ldl(t0, cursor) + %ldl(t1, end) + %beq(t0, t1, &.finish) + %ld(t1, t0, 0) + %shri(t2, t1, 8) + %li(a0, %GC_HEADER_BYTES) + %bltu(t2, a0, &.corrupt) + %andi(a0, t2, 7) + %bnez(a0, &.corrupt) + %add(a0, t0, t2) + %ldl(a1, end) + %bltu(a1, a0, &.corrupt) + %stl(t2, size) + %andi(a0, t1, %GC_KIND_MASK) + %beqz(a0, &.garbage) + %andi(a0, t1, %GC_MARK_BIT) + %beqz(a0, &.garbage) + + # Survivor: clear mark and break any adjacent-free run. + %li(a0, -129) + %and(t1, t1, a0) + %st(t1, t0, 0) + %st(t0, t0, 8) ; restore allocated-block start canary + %ldl(a0, allocated) + %add(a0, a0, t2) + %stl(a0, allocated) + %li(a0, 0) + %stl(a0, run_free) + %b(&.advance) + + :.garbage + %ldl(a0, run_free) + %beqz(a0, &.new_run) + # Extend the preceding physical free run. + # Invalidate the absorbed block's old header so a stale exact slot + # cannot mistake this interior address for an allocated object start. + %li(a1, 0) %st(a1, t0, 0) - %addi(a0, t0, 3) - %ret - :.oom - %b(&heap_oom_die) -.endscope + %st(a1, t0, 8) + %ld(a1, a0, 0) + %shri(a1, a1, 8) + %add(a1, a1, t2) + %shli(a1, a1, 8) + %st(a1, a0, 0) + %b(&.advance) -# alloc_hdr_main(bytes=a0, hdr_word=a1) -> tagged heap obj (a0), allocated -# in main regardless of current heap selection. -:alloc_hdr_main -.scope + :.new_run + %shli(t1, t2, 8) ; FREE kind, mark clear + %st(t1, t0, 0) + %li(t1, 0) + %st(t1, t0, 8) + %ldl(t1, list_last) + %stl(t1, list_prev) + %beqz(t1, &.first_free) + %st(t0, t1, 8) + %b(&.linked) + :.first_free + %stl(t0, free_head) + :.linked + %stl(t0, list_last) + %stl(t0, run_free) + + :.advance + %ldl(t0, cursor) + %ldl(t1, size) + %add(t0, t0, t1) + %stl(t0, cursor) + %b(&.loop) + + :.finish + # A final free run is outside the physical chain after trimming. + %ldl(t0, run_free) + %beqz(t0, &.publish) + %st_global(t0, &heap_tail, t1) + %ldl(t1, list_prev) + %beqz(t1, &.trim_only) + %li(t2, 0) + %st(t2, t1, 8) + %b(&.publish) + :.trim_only + %li(t1, 0) + %stl(t1, free_head) + + :.publish + %ldl(t0, free_head) + %st_global(t0, &gc_free_list, t1) + %ldl(t0, allocated) + %st_global(t0, &heap_allocated, t1) + %eret + :.corrupt + %die(msg_heap_corrupt) +}) + +%fn(gc_collect, 0, { + %li(t0, 0) + %st_global(t0, &gc_mark_worklist, t1) + %call(&gc_mark_shadow_roots) + %call(&gc_mark_symbol_roots) + :.drain + %ld_global(t0, &gc_mark_worklist) + %beqz(t0, &.sweep) + %ld(t1, t0, 8) + %st_global(t1, &gc_mark_worklist, t2) + %mov(a0, t0) + %call(&gc_trace_header) + %b(&.drain) + :.sweep + %tail(&gc_sweep) +}) + +# ========================================================================= +# Managed heap allocation +# ========================================================================= +# +# gc_alloc_try performs coalesced-free-list first fit, then uses the +# untouched heap tail. It never collects and returns raw payload 0 on +# failure. gc_alloc collects once and retries. All managed payloads are +# 8-byte aligned; the two-word allocation header is not visible through +# existing Scheme object pointers. + +%fn2(gc_alloc_try, {total kind prev cur block_size next}, { %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) + %addi(a0, a0, %GC_HEADER_BYTES) + %stl(a0, total) + %stl(a1, kind) + %li(t0, 0) + %stl(t0, prev) + %ld_global(t0, &gc_free_list) + %stl(t0, cur) + + :.free_loop + %ldl(t0, cur) + %beqz(t0, &.tail) + %ld(t1, t0, 0) + %shri(t1, t1, 8) + %stl(t1, block_size) + %ldl(t2, total) + %bltu(t1, t2, &.free_next) + + # Found first fit. Split only when the remainder can hold a header + # plus at least one aligned payload word. + %ld(t1, t0, 8) + %stl(t1, next) + %ldl(t1, block_size) + %ldl(t2, total) + %sub(t1, t1, t2) ; remainder bytes + %li(t2, (+ %GC_HEADER_BYTES 8)) + %bltu(t1, t2, &.consume) + + # remainder_header = current + requested_total + %ldl(t0, cur) + %ldl(t2, total) + %add(t2, t0, t2) + %shli(t1, t1, 8) ; FREE kind is zero %st(t1, t2, 0) - %st(a1, t0, 0) - %addi(a0, t0, 3) - %ret + %ldl(t1, next) + %st(t1, t2, 8) + %ldl(t1, prev) + %beqz(t1, &.split_head) + %st(t2, t1, 8) + %b(&.split_done) + :.split_head + %st_global(t2, &gc_free_list, t1) + :.split_done + %ldl(t1, total) + %stl(t1, block_size) + %b(&.prepare) + + :.consume + %ldl(t1, prev) + %ldl(t2, next) + %beqz(t1, &.consume_head) + %st(t2, t1, 8) + %b(&.prepare) + :.consume_head + %st_global(t2, &gc_free_list, t1) + %b(&.prepare) + + :.free_next + %ldl(t0, cur) + %stl(t0, prev) + %ld(t0, t0, 8) + %stl(t0, cur) + %b(&.free_loop) + + :.tail + %ld_global(t0, &heap_tail) + %ldl(t1, total) + %add(t2, t0, t1) + %ld_global(a3, &heap_end) + %bltu(a3, t2, &.fail) + %st_global(t2, &heap_tail, a3) + %stl(t0, cur) + %stl(t1, block_size) + + :.prepare + # Install the allocated header and account for the entire physical + # block (including header and any unsplittable tail fragment). + %ldl(t0, cur) + %ldl(t1, block_size) + %shli(t2, t1, 8) + %ldl(a1, kind) + %or(t2, t2, a1) + %st(t2, t0, 0) + %st(t0, t0, 8) ; allocated-block start canary + %ld_global(a3, &heap_allocated) + %add(a3, a3, t1) + %st_global(a3, &heap_allocated, t2) + + # Clear traced payloads before publishing them. This makes a + # partially constructed HEAP object safe if a later field-setting + # step allocates and triggers collection. + %ldl(a1, kind) + %li(t1, %GCKIND.RAW) + %beq(a1, t1, &.return) + %addi(t1, t0, %GC_HEADER_BYTES) + %ldl(t2, block_size) + %addi(t2, t2, (- %GC_HEADER_BYTES)) + :.clear_loop + %beqz(t2, &.return) + %li(a0, 0) + %st(a0, t1, 0) + %addi(t1, t1, 8) + %addi(t2, t2, -8) + %b(&.clear_loop) + + :.return + %addi(a0, t0, %GC_HEADER_BYTES) + %eret + + :.fail + %li(a0, 0) +}) + +%fn2(gc_alloc, {bytes kind}, { + %stl(a0, bytes) + %stl(a1, kind) + %call(&gc_alloc_try) + %bnez(a0, &.done) + %call(&gc_collect) + %ldl(a0, bytes) + %ldl(a1, kind) + %call(&gc_alloc_try) + %beqz(a0, &.oom) + :.done + %eret :.oom %die(msg_heap_full) -.endscope +}) + +# cons roots both arguments inside the allocator frame because gc_alloc +# may synchronously collect before returning a payload. +%gcfn2(cons, {car_value cdr_value}, 3, 0, { + %stl(a0, car_value) + %stl(a1, cdr_value) + %li(a0, %PAIR.SIZE) + %li(a1, %GCKIND.PAIR) + %call(&gc_alloc) + %ldl(t0, car_value) + %st(t0, a0, %PAIR.car) + %ldl(t0, cdr_value) + %st(t0, a0, %PAIR.cdr) + %addi(a0, a0, %TAG.PAIR) +}) + +# alloc_hdr(bytes=a0, hdr_word=a1) -> tagged HEAP object. +%fn2(alloc_hdr, {bytes hdr_word}, { + %stl(a0, bytes) + %stl(a1, hdr_word) + %li(a1, %GCKIND.HEAP) + %call(&gc_alloc) + %ldl(t0, hdr_word) + %st(t0, a0, 0) + %addi(a0, a0, %TAG.HEAP) +}) # list_length(list=a0) -> count (a0). Linear walk; clobbers a0 (used as # the cursor). Callers that need the list afterward must save it first. @@ -2866,7 +3421,7 @@ # list (preserved across list_length + alloc_hdr) # count # mv (tagged MV-pack) -%fn2(list_to_mv, {list count mv pad}, { +%gcfn2(list_to_mv, {list count mv pad}, 5, 0, { %stl(a0, list) %call(&list_length) ; clobbers a0; returns count %stl(a0, count) @@ -2903,9 +3458,11 @@ # can uniformly reuse list-shaped destructuring. # # Locals: +# mv original MV-pack, rooted while fresh list cells are allocated # ptr (raw cursor into MV slots, walked backward) # count (remaining slot count) -%fn2(mv_to_list, {ptr count}, { +%gcfn2(mv_to_list, {mv ptr count}, 1, 0, { + %stl(a0, mv) %tagof(t0, a0) %bine(t0, %TAG.HEAP, &.single, t1) %hdr_type(t0, a0) @@ -2945,12 +3502,12 @@ %b(&.loop) :.done - %eret + %gceret :.single # Non-MV: return (val . NIL). %li(a1, %imm_val(%IMM.NIL)) - %tail(&cons) + %gctail(&cons) }) # ========================================================================= @@ -2962,7 +3519,7 @@ # name_len (input) # idx (loop counter / found index) # entry_ptr (spilled across memcmp) -%fn2(intern, {name_ptr name_len idx entry_ptr}, { +%gcfn2(intern, {name_ptr name_len idx entry_ptr}, 0, 1, { %stl(a0, name_ptr) %stl(a1, name_len) @@ -3006,12 +3563,11 @@ %die(msg_symtab_full) :.append_ok - # 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. + # Copy the name into a stable managed RAW buffer. The caller-provided + # ptr may live in readbuf_buf (parse_atom), so symtab names must + # outlive source-buffer reuse. The collector roots each name explicitly. %ldl(a0, name_len) - %call(&alloc_bytes_main) + %call(&alloc_bytes) %ldl(a1, name_ptr) %ldl(a2, name_len) %call(&memcpy) ; returns dst in a0 = stable copy @@ -3072,7 +3628,7 @@ # prim ptr (HEAP-tagged; spilled across intern + sym_set_global) # walk (current table cursor) # end (table_end) -%fn2(register_primitives, {prim walk end}, { +%gcfn2(register_primitives, {prim walk end}, 1, 0, { %la(t0, &prim_table) %stl(t0, walk) %la(t0, &prim_table_end) @@ -3313,7 +3869,7 @@ # Locals: # xs (cursor; advanced each iteration) # acc -%fn2(prim_reverse_entry, {xs acc}, { +%gcfn2(prim_reverse_entry, {xs acc}, 3, 0, { %car(t0, a0) ; t0 = list arg %stl(t0, xs) %li(t0, %imm_val(%IMM.NIL)) @@ -3348,7 +3904,7 @@ # total length (raw) # result bv # write offset (raw, into result.data) -%fn2(prim_bv_append_entry, {args total result write}, { +%gcfn2(prim_bv_append_entry, {args total result write}, 5, 0, { %stl(a0, args) %li(t0, 0) @@ -3412,7 +3968,7 @@ # memcpy fills the data. Frame holds the (ptr, len) pair across # str_alloc and the resulting bv across memcpy. -%fn2(prim_symbol_to_string_entry, {ptr len bv}, { +%gcfn2(prim_symbol_to_string_entry, {ptr len bv}, 4, 0, { %car(a0, a0) %sari(a0, a0, 3) ; raw sym idx %call(&sym_name) ; -> ptr (a0), len (a1) @@ -3866,45 +4422,12 @@ # then doubles by repeatedly shifting until cap ≥ requested. Bytevectors # are raw u8[] and need no headroom for a NUL terminator -- callers that # build "strings" use the str_* writers, which reserve cap > len AND -# explicitly zero data[len] (the heap is reused via heap-mark/heap-rewind!, -# so BSS-zero cannot be assumed). +# explicitly zero data[len] (reused GC blocks are not assumed zeroed). -# alloc_bytes(size=a0) -> raw addr (a0). Untagged data buffer; size is -# rounded up to 8 to keep the next bump 8-byte-aligned. +# alloc_bytes(size=a0) -> managed RAW payload address (a0). :alloc_bytes -.scope - %alignup(a0, a0, 8, t0) - %ld_global(t2, ¤t_heap_next_ptr) - %ld(t1, t2, 0) - %add(t0, t1, a0) - %ld_global(a3, ¤t_heap_end_ptr) - %ld(a3, a3, 0) - %bltu(a3, t0, &.oom) - %st(t0, t2, 0) - %mov(a0, t1) - %ret - :.oom - %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 - %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 + %li(a1, %GCKIND.RAW) + %b(&gc_alloc) # bv_capacity_for(n=a0) -> smallest power-of-two ≥ n, minimum 16. Pure # bytevector sizing -- no NUL slack. Callers building "strings" call @@ -3929,7 +4452,7 @@ # raw_len # capacity # data_ptr (raw) -%fn2(bv_alloc, {raw_len capacity data_ptr}, { +%gcfn2(bv_alloc, {raw_len capacity data_ptr}, 0, 4, { %stl(a0, raw_len) %call(&bv_capacity_for) @@ -3958,14 +4481,14 @@ # min_cap (input) / new_cap (during loop) # new_data_ptr # raw length -%fn2(bv_grow, {bv min_cap new_data_ptr raw}, { +%gcfn2(bv_grow, {bv min_cap new_data_ptr raw}, 1, 4, { %stl(a0, bv) %stl(a1, min_cap) %ld(t0, a0, 13) ; bv.cap (raw offset 16; not in BV struct) %bltu(t0, a1, &.need) %ldl(a0, bv) - %eret + %gceret :.need :.loop @@ -3997,7 +4520,7 @@ # (make-bytevector len) or (make-bytevector len fill) -%fn2(prim_make_bytevector_entry, {args fill wrapper}, { +%gcfn2(prim_make_bytevector_entry, {args fill wrapper}, 5, 0, { %stl(a0, args) %li(t2, 0) @@ -4030,7 +4553,7 @@ :.fill_done %ldl(a0, wrapper) - %eret + %gceret :.bad_len %die(msg_bv_oob) @@ -4100,7 +4623,7 @@ # args # src tagged # wrapper (saved after bv_alloc) -%fn2(prim_bv_copy_entry, {args src wrapper}, { +%gcfn2(prim_bv_copy_entry, {args src wrapper}, 7, 0, { %stl(a0, args) %args3(t0, t2, t1, a0) ; src, start, end @@ -4143,7 +4666,7 @@ :.copy_done %ldl(a0, wrapper) - %eret + %gceret :.oob %die(msg_bv_oob) @@ -4432,7 +4955,7 @@ # re-derives a1 from the callee fn it dispatches on. Outer convention # stays intact end-to-end. -%fn2(prim_apply_entry, {args pad}, { +%gcfn2(prim_apply_entry, {args pad}, 1, 0, { %stl(a0, args) %cdr(a0, a0) %call(&apply_build_args) @@ -4440,7 +4963,7 @@ %ldl(a0, args) %car(a0, a0) %mov(a1, t0) - %tail(&apply) + %gctail(&apply) }) # apply_build_args(rest=a0) -> assembled args list. @@ -4454,7 +4977,7 @@ # walk (advances; current cell of rest) # head (NIL until first leading arg appended) # tail (most recent cell; set-cdr! target) -%fn2(apply_build_args, {walk head tail}, { +%gcfn2(apply_build_args, {walk head tail}, 7, 0, { %stl(a0, walk) %li(t0, %imm_val(%IMM.NIL)) %stl(t0, head) @@ -4507,17 +5030,16 @@ # into the same TD via the prim's data slot. # make_param_prim(entry=a0, data=a1) -> prim (a0). Allocates a 24-byte -# 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. +# PRIM and sets the entry label and data word. Generated primitives stay +# reachable through their global bindings. -%fn2(make_param_prim, {entry data}, { +%gcfn2(make_param_prim, {entry data}, 2, 0, { %stl(a0, entry) %stl(a1, data) %li(a0, 24) %li(a1, %HDR.PRIM) - %call(&alloc_hdr_main) + %call(&alloc_hdr) %ldl(t0, entry) %heap_st(t0, a0, %PRIM.entry_w) @@ -4537,7 +5059,7 @@ # ctor: prim.data = TD (HEAP); args = (f0 f1 ...). Inlines the # %make-record body so we don't have to cons (TD . args) first. -%fn2(prim_ctor_entry, {args td record}, { +%gcfn2(prim_ctor_entry, {args td record}, 7, 0, { %stl(a0, args) %heap_ld(t0, a1, %PRIM.data) %stl(t0, td) @@ -4627,7 +5149,7 @@ # fl_head (head of field-name list under construction) # fl_tail (tail cell of field-name list under construction) # fl_cur (cursor walking clauses for field-name pre-pass) -%fn2(eval_define_record_type, {rest env td walk idx nfields fl_head fl_tail fl_cur}, { +%gcfn2(eval_define_record_type, {rest env td walk idx nfields fl_head fl_tail fl_cur}, 463, 0, { %stl(a0, rest) %stl(a1, env) @@ -4640,12 +5162,11 @@ %call(&list_length) %stl(a0, nfields) - # 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. + # td = alloc_hdr(TD.SIZE, HDR.TD); td.name = type-name; + # td.nfields = nfields; td.fields = NIL (filled below). %li(a0, %TD.SIZE) %li(a1, %HDR.TD) - %call(&alloc_hdr_main) + %call(&alloc_hdr) %stl(a0, td) %ldl(t0, rest) %car(t0, t0) @@ -4672,7 +5193,7 @@ %car(t1, t0) %car(a0, t1) %li(a1, %imm_val(%IMM.NIL)) - %call(&cons_main) + %call(&cons) # Splice into list: if head is NIL, head = tail = cell. # Else set-cdr!(tail, cell); tail = cell. %ldl(t1, fl_head) @@ -4793,7 +5314,7 @@ # growing the data buffer when capacity falls short. Raw u8[] semantics: # the byte at index `length` after append is unspecified. -%fn2(bv_putn, {bv src n old_len}, { +%gcfn2(bv_putn, {bv src n old_len}, 1, 2, { %stl(a0, bv) %stl(a1, src) %stl(a2, n) @@ -4828,7 +5349,7 @@ # bv_putc(bv=a0, byte=a1) -> bv (a0). Append a single byte (low 8 bits # of a1). Same growth + length-update protocol as bv_putn; no NUL. -%fn2(bv_putc, {bv byte}, { +%gcfn2(bv_putc, {bv byte}, 1, 0, { %stl(a0, bv) %stl(a1, byte) @@ -4856,7 +5377,7 @@ # untagged) value. Uses :writer_num_buf as a 24-byte scratch buffer # (fmt_dec writes at most 20 bytes for a 64-bit signed integer). -%fn2(bv_putint, {bv pad}, { +%gcfn2(bv_putint, {bv pad}, 1, 0, { %stl(a0, bv) %la(a0, &writer_num_buf) @@ -4865,19 +5386,18 @@ %mov(a2, a0) %la(a1, &writer_num_buf) %ldl(a0, bv) - %tail(&bv_putn) + %gctail(&bv_putn) }) # String writers: identical to bv_putn / bv_putc / bv_putint except they # guarantee cap > length AND data[length] == 0 on return. Required for # any bv whose data_ptr is later read as a C string (syscall paths, -# runtime_error). The explicit zero is necessary -- the heap is reused -# via heap-mark / heap-rewind!, so a fresh data buffer from alloc_bytes -# may carry stale bytes. +# runtime_error). The explicit zero is necessary because a fresh data +# buffer may come from a reused block carrying stale bytes. # str_alloc(raw_len=a0) -> tagged bv (a0). Like bv_alloc, but cap > # raw_len and data[raw_len] = 0. -%fn2(str_alloc, {raw_len bv}, { +%gcfn2(str_alloc, {raw_len bv}, 2, 0, { %stl(a0, raw_len) %addi(a0, a0, 1) ; reserve a NUL slot %call(&bv_alloc) @@ -4900,7 +5420,7 @@ # str_putn(bv=a0, src=a1, n=a2) -> bv (a0). Append n bytes; on return # cap > new_len and data[new_len] == 0. -%fn2(str_putn, {bv src n}, { +%gcfn2(str_putn, {bv src n}, 1, 2, { %stl(a0, bv) %stl(a1, src) %stl(a2, n) @@ -4929,7 +5449,7 @@ # str_putc(bv=a0, byte=a1) -> bv (a0). Append one byte; cap > new_len # and data[new_len] == 0 on return. -%fn2(str_putc, {bv byte}, { +%gcfn2(str_putc, {bv byte}, 1, 0, { %stl(a0, bv) %stl(a1, byte) @@ -4952,7 +5472,7 @@ # str_putint(bv=a0, value=a1) -> bv (a0). Like bv_putint but tails into # str_putn, so the result is NUL-terminated. -%fn2(str_putint, {bv pad}, { +%gcfn2(str_putint, {bv pad}, 1, 0, { %stl(a0, bv) %la(a0, &writer_num_buf) @@ -4961,14 +5481,14 @@ %mov(a2, a0) %la(a1, &writer_num_buf) %ldl(a0, bv) - %tail(&str_putn) + %gctail(&str_putn) }) # str_puthex(bv=a0, value=a1) -> bv (a0). Signed hex: emits a leading # '-' for negatives, then unsigned hex of |value| via fmt_hex. The bv # wrapper pointer is stable across str_putc / str_putn (only the # internal data buffer can move), so we reload it from the local. -%fn2(str_puthex, {bv value}, { +%gcfn2(str_puthex, {bv value}, 1, 0, { %stl(a0, bv) %stl(a1, value) @@ -4992,7 +5512,7 @@ %mov(a2, a0) %la(a1, &writer_num_buf) %ldl(a0, bv) - %tail(&str_putn) + %gctail(&str_putn) }) # sym_name(idx=a0) -> (ptr=a0, len=a1). Leaf. idx is the untagged sym @@ -5013,7 +5533,7 @@ # format), so all internal append calls go through the str_* family -- # the result has cap > length and a trailing NUL. -%fn2(write_to_bv, {val bv mode pad}, { +%gcfn2(write_to_bv, {val bv mode pad}, 3, 0, { %stl(a0, val) %stl(a1, bv) %stl(a2, mode) @@ -5028,7 +5548,7 @@ %ldl(a0, bv) %ldl(a1, val) %sari(a1, a1, 3) - %tail(&str_putint) + %gctail(&str_putint) :.sym %ldl(a0, val) @@ -5037,13 +5557,13 @@ %mov(a2, a1) %mov(a1, a0) %ldl(a0, bv) - %tail(&str_putn) + %gctail(&str_putn) :.pair %ldl(a0, val) %ldl(a1, bv) %ldl(a2, mode) - %tail(&write_pair_to_bv) + %gctail(&write_pair_to_bv) :.heap %hdr_type(t0, a0) @@ -5067,7 +5587,7 @@ %shri(a2, a2, 8) %call(&str_putn) %li(a1, 34) - %tail(&str_putc) + %gctail(&str_putc) :.heap_bv_raw %ldl(t0, val) @@ -5075,37 +5595,37 @@ %heap_ld(a2, t0, %BV.hdr) %shri(a2, a2, 8) %ldl(a0, bv) - %tail(&str_putn) + %gctail(&str_putn) :.heap_closure %la(a1, &str_closure) %li(a2, 10) %ldl(a0, bv) - %tail(&str_putn) + %gctail(&str_putn) :.heap_prim %la(a1, &str_prim) %li(a2, 7) %ldl(a0, bv) - %tail(&str_putn) + %gctail(&str_putn) :.heap_td %la(a1, &str_td) %li(a2, 11) %ldl(a0, bv) - %tail(&str_putn) + %gctail(&str_putn) :.heap_rec %la(a1, &str_rec) %li(a2, 9) %ldl(a0, bv) - %tail(&str_putn) + %gctail(&str_putn) :.heap_unknown %la(a1, &str_unknown) %li(a2, 10) %ldl(a0, bv) - %tail(&str_putn) + %gctail(&str_putn) :.imm %ldl(a0, val) @@ -5123,37 +5643,37 @@ %la(a1, &str_eof) %li(a2, 5) %ldl(a0, bv) - %tail(&str_putn) + %gctail(&str_putn) :.imm_false %la(a1, &str_false) %li(a2, 2) %ldl(a0, bv) - %tail(&str_putn) + %gctail(&str_putn) :.imm_true %la(a1, &str_true) %li(a2, 2) %ldl(a0, bv) - %tail(&str_putn) + %gctail(&str_putn) :.imm_nil %la(a1, &str_nil) %li(a2, 2) %ldl(a0, bv) - %tail(&str_putn) + %gctail(&str_putn) :.imm_unspec %la(a1, &str_unspec) %li(a2, 8) %ldl(a0, bv) - %tail(&str_putn) + %gctail(&str_putn) :.imm_unbound %la(a1, &str_unbound) %li(a2, 9) %ldl(a0, bv) - %tail(&str_putn) + %gctail(&str_putn) }) # write_pair_to_bv(pair=a0, bv=a1, mode=a2) -> bv (a0). Emits `(elt elt @@ -5167,7 +5687,7 @@ # bv (stable wrapper; reused across recursive calls) # mode # pad -%fn2(write_pair_to_bv, {pair bv mode pad}, { +%gcfn2(write_pair_to_bv, {pair bv mode pad}, 3, 0, { %stl(a0, pair) %stl(a1, bv) %stl(a2, mode) @@ -5217,7 +5737,7 @@ :.done %ldl(a0, bv) %li(a1, 41) - %tail(&str_putc) + %gctail(&str_putc) }) # value_to_bv(val=a0, mode=a1) -> bv (a0). Allocate an empty NUL- @@ -5226,7 +5746,7 @@ # has cap > length and a trailing NUL -- safe to hand to syscalls or # runtime_error as a C string. -%fn2(value_to_bv, {val mode}, { +%gcfn2(value_to_bv, {val mode}, 1, 0, { %stl(a0, val) %stl(a1, mode) %li(a0, 0) @@ -5234,7 +5754,7 @@ %mov(a1, a0) %ldl(a0, val) %ldl(a2, mode) - %tail(&write_to_bv) + %gctail(&write_to_bv) }) # (display val) and (write val): build the printed representation in a @@ -5275,7 +5795,7 @@ # Locals: # walk (initially args; advances over irritants) # bv -%fn2(prim_error_entry, {walk bv}, { +%gcfn2(prim_error_entry, {walk bv}, 3, 0, { %stl(a0, walk) %li(a0, 0) @@ -5320,7 +5840,7 @@ :.done %ldl(t0, bv) %heap_ld(a0, t0, %BV.data) - %tail(&runtime_error) + %gctail(&runtime_error) }) # (format template-bv arg ...). Walks the template bv byte by byte; @@ -5335,7 +5855,7 @@ # template bv # args walk # idx (current byte offset into template) -%fn2(prim_format_entry, {out template args idx}, { +%gcfn2(prim_format_entry, {out template args idx}, 7, 0, { %stl(a0, args) ; spill incoming args while we set up %li(a0, 0) @@ -5586,7 +6106,7 @@ # list # count # array ptr (raw) -%fn2(build_execve_argv, {list count array}, { +%gcfn2(build_execve_argv, {list count array}, 1, 0, { %stl(a0, list) %call(&list_length) ; clobbers a0 -> count %stl(a0, count) @@ -5680,7 +6200,7 @@ # (sys-execve path argv-list) -%fn2(prim_sys_execve_entry, {path pad}, { +%gcfn2(prim_sys_execve_entry, {path pad}, 1, 0, { %args2(t0, a0, a0) ; t0 = path bv, a0 = argv-list %stl(t0, path) %call(&build_execve_argv) @@ -5689,7 +6209,7 @@ %heap_ld(a0, a0, %BV.data) ; path data ptr %li(a2, 0) %call(&sys_execve) - %tail(&wrap_syscall_result) + %gctail(&wrap_syscall_result) }) # (sys-spawn path argv-list). Same calling convention as sys-execve, but @@ -5697,7 +6217,7 @@ # after the child has exit_grouped (the kernel suspends the parent for # the lifetime of the child), or (#f . -errno) on failure (notably # -ENOSYS=38 on Linux, which the prelude probes for at init time). -%fn2(prim_sys_spawn_entry, {path pad}, { +%gcfn2(prim_sys_spawn_entry, {path pad}, 1, 0, { %args2(t0, a0, a0) ; t0 = path bv, a0 = argv-list %stl(t0, path) %call(&build_execve_argv) @@ -5705,7 +6225,7 @@ %ldl(a0, path) %heap_ld(a0, a0, %BV.data) ; path data ptr %call(&sys_spawn) - %tail(&wrap_syscall_result) + %gctail(&wrap_syscall_result) }) # (sys-waitid idtype id infop options) @@ -5732,7 +6252,7 @@ # head # tail # bv -%fn2(prim_sys_argv_entry, {argv count head tail bv}, { +%gcfn2(prim_sys_argv_entry, {argv count head tail bv}, 28, 0, { %ld_global(t0, &saved_argv) %stl(t0, argv) %ld_global(t0, &saved_argc) @@ -5807,139 +6327,25 @@ %ret .endscope -# (heap-usage) -> tagged fixnum: bytes consumed since heap_init -# (heap_next - heap_buf_ptr). Used by cc to instrument per-phase -# allocation cost. Args list ignored. +# (heap-usage) -> tagged fixnum: currently allocated managed bytes, +# including the 16-byte header of every live allocation. :prim_heap_usage_entry - %ld_global(t0, &heap_next) - %ld_global(t1, &heap_buf_ptr) - %sub(a0, t0, t1) + %ld_global(a0, &heap_allocated) %mkfix(a0, a0) %ret -# (heap-mark) -> tagged fixnum: absolute current_*_next pointer. -# Capture before transient allocations; pass to (heap-rewind! m) to -# discard everything allocated after the mark. UNSAFE: any pointer -# referencing the rewound region becomes dangling. Caller must keep only -# fixnums / symbols / pointers into surviving (pre-mark) heap across the -# rewind. Operates on whichever heap is current; mark and rewind must -# pair within the same heap context. -:prim_heap_mark_entry - %ld_global(t0, ¤t_heap_next_ptr) - %ld(t0, t0, 0) - %mkfix(a0, t0) - %ret - -# (heap-rewind! mark) -> unspec. Restores current_*_next to mark. -# UNSAFE: subsequent allocations overwrite the freed region; any -# surviving reference into it is dangling. No bounds check -- caller -# passes a value previously returned by (heap-mark) on the same heap. -:prim_heap_rewind_bang_entry - %car(t0, a0) - %untag_fix(t0, t0) - %ld_global(t1, ¤t_heap_next_ptr) - %st(t0, t1, 0) - %li(a0, %imm_val(%IMM.UNSPEC)) - %ret - -# (use-scratch-heap!) -> unspec. Repoints current_heap_*_ptr at the -# scratch heap's next/end slots. Subsequent cons / alloc_hdr / -# alloc_bytes bump scratch_next; alloc that would cross scratch_end -# dies via heap_oom_die ("scratch exhausted"). -:prim_use_scratch_heap_bang_entry - %la(t0, &scratch_next) - %st_global(t0, ¤t_heap_next_ptr, t1) - %la(t0, &scratch_end) - %st_global(t0, ¤t_heap_end_ptr, t1) +# (collect-garbage) -> unspecified. The primitive's argument list is +# intentionally ignored, so it does not retain otherwise unreachable data. +%fn(prim_collect_garbage_entry, 0, { + %call(&gc_collect) %li(a0, %imm_val(%IMM.UNSPEC)) - %ret - -# (use-main-heap!) -> unspec. Repoints current_heap_*_ptr at the main -# heap's next/end slots. Default at heap_init. -:prim_use_main_heap_bang_entry - %la(t0, &heap_next) - %st_global(t0, ¤t_heap_next_ptr, t1) - %la(t0, &heap_end) - %st_global(t0, ¤t_heap_end_ptr, t1) - %li(a0, %imm_val(%IMM.UNSPEC)) - %ret - -# (reset-scratch-heap!) -> unspec. Resets scratch_next to the start of -# the scratch arena (8-byte aligned). UNSAFE: any reference into scratch -# becomes dangling. Caller is responsible for having promoted survivors -# to main first. -:prim_reset_scratch_heap_bang_entry - %ld_global(t0, &scratch_buf_ptr) - %alignup(t0, t0, 8, t1) - %st_global(t0, &scratch_next, t1) - %li(a0, %imm_val(%IMM.UNSPEC)) - %ret - -# (heap-in-main? obj) -> bool. True iff obj's masked pointer falls -# inside the main heap arena [heap_buf_ptr, heap_buf_ptr + -# HEAP_CAP_BYTES). Used by promote walkers to skip already-promoted / -# scratch-resident objects. Tag bits are masked off so callers can pass -# tagged pointers directly. Non-pointer objects (fixnums, immediates, -# small sym indices) yield false because their masked values are far -# below heap_buf_ptr. -:prim_heap_in_main_q_entry -.scope - %car(t0, a0) - %li(t1, -8) - %and(t0, t0, t1) - %ld_global(t1, &heap_buf_ptr) - %bltu(t0, t1, &.false) - %li(t2, %HEAP_CAP_BYTES) - %add(t1, t1, t2) - %bltu(t0, t1, &.true) - :.false - %li(a0, %imm_val(%IMM.FALSE)) - %ret - :.true - %li(a0, %imm_val(%IMM.TRUE)) - %ret -.endscope - -# (heap-in-current? obj) -> bool. True iff obj's masked pointer falls -# inside whichever heap is currently selected (main or scratch). -# Generalizes heap-in-main? -- the two agree when main is current, and -# heap-in-current? returns #t for scratch-resident objects iff scratch -# is current. Tag bits are masked off; non-pointer values yield #f. -# Used by deep-copy as the "already in target arena" short-circuit. -:prim_heap_in_current_q_entry -.scope - %car(t0, a0) - %li(t1, -8) - %and(t0, t0, t1) - %ld_global(t1, ¤t_heap_next_ptr) - %la(t2, &heap_next) - %bne(t1, t2, &.scratch) - %ld_global(t1, &heap_buf_ptr) - %bltu(t0, t1, &.false) - %li(t2, %HEAP_CAP_BYTES) - %add(t1, t1, t2) - %bltu(t0, t1, &.true) - %b(&.false) - :.scratch - %ld_global(t1, &scratch_buf_ptr) - %bltu(t0, t1, &.false) - %li(t2, %SCRATCH_CAP_BYTES) - %add(t1, t1, t2) - %bltu(t0, t1, &.true) - :.false - %li(a0, %imm_val(%IMM.FALSE)) - %ret - :.true - %li(a0, %imm_val(%IMM.TRUE)) - %ret -.endscope +}) # Record introspection. Surfaces the unsafe %record-* helpers (heap # layout: [HDR.REC][td][f0..fN-1], field i at tagged + 13 + 8*i; # nfields lives at TD's offset 13 raw). All primitives below trust # their inputs -- no bounds check, no kind check on record-ref / -# record-set! / record-td. Same unsafe-by-convention status as -# heap-rewind! / reset-scratch-heap!. See docs/DEEP-COPY.md. +# record-set! / record-td. # (record? obj) -> bool. True iff obj is HEAP-tagged with HDR.REC. :prim_recordq_entry @@ -5999,7 +6405,7 @@ # Locals: # td (the TD pointer; saved across alloc_hdr) # record (the new record pointer) -%fn2(prim_make_record_td_entry, {td record}, { +%gcfn2(prim_make_record_td_entry, {td record}, 3, 0, { %car(t0, a0) ; td %stl(t0, td) @@ -6070,29 +6476,6 @@ %mkfix(a0, a0) %ret -# (current-heap-next) -> fixnum. Returns the current heap's bump -# pointer (raw byte address) as a tagged fixnum. Used to inspect where -# the next allocation will land. -:prim_current_heap_next_entry - %ld_global(t0, ¤t_heap_next_ptr) - %ld(t0, t0, 0) - %mkfix(a0, t0) - %ret - -# heap_oom_die() -> never returns. Reached from cons / alloc_hdr / -# alloc_bytes when current_*_next would pass current_*_end. Selects -# msg_heap_full vs msg_scratch_full by comparing current_heap_next_ptr -# against &heap_next, then tails into runtime_error via %die. -:heap_oom_die -.scope - %ld_global(t0, ¤t_heap_next_ptr) - %la(t1, &heap_next) - %beq(t0, t1, &.main) - %die(msg_scratch_full) - :.main - %die(msg_heap_full) -.endscope - # (values . xs) -- multiple-values producer. Single-arg case returns the # arg unchanged so (values x) is interchangeable with x in any 1-value # context; 0 or 2+ args materialize an MV-pack. @@ -6114,7 +6497,7 @@ # # Locals: # consumer (saved across apply(producer) and mv_to_list) -%fn2(prim_call_with_values_entry, {consumer pad}, { +%gcfn2(prim_call_with_values_entry, {consumer pad}, 1, 0, { %args2(t0, t1, a0) ; t0 = producer, t1 = consumer %stl(t1, consumer) @@ -6126,44 +6509,36 @@ %mov(a1, a0) %ldl(a0, consumer) - %tail(&apply) + %gctail(&apply) }) # ========================================================================= # Startup -- heap_init # ========================================================================= -# heap_init() -> none. Initializes the main heap (heap_next / -# heap_end), the scratch heap (scratch_next / scratch_end), and points -# current_heap_*_ptr at the main slots so cons / alloc_hdr / -# alloc_bytes default to allocating in main. Both _next slots are -# rounded up to 8-byte alignment so every PAIR/HEAP tag bit is exact; -# &ELF_end's alignment depends on the data section above it. cons / -# alloc_hdr / alloc_bytes test (*current_next + bytes <= *current_end) -# on every allocation and abort via runtime_error on overflow. Leaf. +# heap_init() -> none. Initializes the physical heap chain, free list, +# accounting, and bounded exact-root stack. Leaf. :heap_init %ld_global(t0, &heap_buf_ptr) %alignup(t0, t0, 8, t1) - %st_global(t0, &heap_next, t1) + %st_global(t0, &heap_base, t1) + %st_global(t0, &heap_tail, t1) %ld_global(t0, &heap_buf_ptr) %li(t1, %HEAP_CAP_BYTES) %add(t0, t0, t1) %st_global(t0, &heap_end, t1) - %ld_global(t0, &scratch_buf_ptr) - %alignup(t0, t0, 8, t1) - %st_global(t0, &scratch_next, t1) + %li(t0, 0) + %st_global(t0, &gc_free_list, t1) + %st_global(t0, &gc_mark_worklist, t1) + %st_global(t0, &heap_allocated, t1) - %ld_global(t0, &scratch_buf_ptr) - %li(t1, %SCRATCH_CAP_BYTES) + %ld_global(t0, &gc_root_buf_ptr) + %st_global(t0, &gc_root_next, t1) + %li(t1, (* %GC_ROOT_CAP_FRAMES %GC_ROOT_FRAME_BYTES)) %add(t0, t0, t1) - %st_global(t0, &scratch_end, t1) - - %la(t0, &heap_next) - %st_global(t0, ¤t_heap_next_ptr, t1) - %la(t0, &heap_end) - %st_global(t0, ¤t_heap_end_ptr, t1) + %st_global(t0, &gc_root_end, t1) %ret @@ -6242,14 +6617,8 @@ :name_write %cstr8("write") :name_error %cstr8("error") :name_format %cstr8("format") -:name_heap_mark %cstr8("heap-mark") -:name_heap_rewind_bang %cstr8("heap-rewind!") :name_heap_usage %cstr8("heap-usage") -:name_use_scratch_heap_bang %cstr8("use-scratch-heap!") -:name_use_main_heap_bang %cstr8("use-main-heap!") -:name_reset_scratch_heap_bang %cstr8("reset-scratch-heap!") -:name_heap_in_main_q %cstr8("heap-in-main?") -:name_heap_in_current_q %cstr8("heap-in-current?") +:name_collect_garbage %cstr8("collect-garbage") :name_recordq %cstr8("record?") :name_record_td %cstr8("record-td") :name_record_ref %cstr8("record-ref") @@ -6259,7 +6628,6 @@ :name_td_name %cstr8("td-name") :name_tagged_value %cstr8("tagged-value") :name_peek_u8 %cstr8("peek-u8") -:name_current_heap_next %cstr8("current-heap-next") # Writer string constants. Lengths are hard-coded at the str_putn call # sites (write_to_bv branches). They are emitted through cstr8 so the @@ -6344,13 +6712,7 @@ &name_error %(0) $(5) &prim_error_entry %(0) &name_format %(0) $(6) &prim_format_entry %(0) &name_heap_usage %(0) $(10) &prim_heap_usage_entry %(0) -&name_heap_mark %(0) $(9) &prim_heap_mark_entry %(0) -&name_heap_rewind_bang %(0) $(12) &prim_heap_rewind_bang_entry %(0) -&name_use_scratch_heap_bang %(0) $(17) &prim_use_scratch_heap_bang_entry %(0) -&name_use_main_heap_bang %(0) $(14) &prim_use_main_heap_bang_entry %(0) -&name_reset_scratch_heap_bang %(0) $(19) &prim_reset_scratch_heap_bang_entry %(0) -&name_heap_in_main_q %(0) $(13) &prim_heap_in_main_q_entry %(0) -&name_heap_in_current_q %(0) $(16) &prim_heap_in_current_q_entry %(0) +&name_collect_garbage %(0) $(15) &prim_collect_garbage_entry %(0) &name_recordq %(0) $(7) &prim_recordq_entry %(0) &name_record_td %(0) $(9) &prim_record_td_entry %(0) &name_record_ref %(0) $(10) &prim_record_ref_entry %(0) @@ -6360,7 +6722,6 @@ &name_td_name %(0) $(7) &prim_td_name_entry %(0) &name_tagged_value %(0) $(12) &prim_tagged_value_entry %(0) &name_peek_u8 %(0) $(7) &prim_peek_u8_entry %(0) -&name_current_heap_next %(0) $(17) &prim_current_heap_next_entry %(0) &name_values %(0) $(6) &prim_values_entry %(0) &name_call_with_values %(0) $(16) &prim_call_with_values_entry %(0) :prim_table_end @@ -6378,7 +6739,8 @@ :msg_unbound %cstr8("scheme1: unbound variable\n") :msg_not_proc %cstr8("scheme1: not a procedure\n") :msg_heap_full %cstr8("scheme1: heap exhausted\n") -:msg_scratch_full %cstr8("scheme1: scratch exhausted\n") +:msg_heap_corrupt %cstr8("scheme1: corrupt managed heap\n") +:msg_gc_roots_full %cstr8("scheme1: shadow root stack overflow\n") :msg_readbuf_full %cstr8("scheme1: source buffer overflow\n") :msg_bv_oob %cstr8("scheme1: bytevector index out of range\n") :msg_unterm_string %cstr8("scheme1: unterminated string literal\n") @@ -6406,35 +6768,25 @@ :arena_table %arena_entry(&readbuf_buf_ptr, %READBUF_CAP_BYTES) %arena_entry(&symtab_buf_ptr, (* %SYMTAB_CAP_SLOTS %SYMENT.SIZE)) +%arena_entry(&gc_root_buf_ptr, (* %GC_ROOT_CAP_FRAMES %GC_ROOT_FRAME_BYTES)) %arena_entry(&heap_buf_ptr, %HEAP_CAP_BYTES) -%arena_entry(&scratch_buf_ptr, %SCRATCH_CAP_BYTES) :arena_table_end # ========================================================================= # Scalar BSS (file-resident, zero-initialized) # ========================================================================= -# heap_next: bump pointer; written once by p1_main, then by cons/alloc_hdr. -:heap_next $(0) - -# heap_end: one byte past the last valid heap address (= heap_buf_ptr + -# HEAP_CAP_BYTES). Read on every allocation. +# Managed-heap physical chain and accounting. +:heap_base $(0) +:heap_tail $(0) :heap_end $(0) +:heap_allocated $(0) +:gc_free_list $(0) +:gc_mark_worklist $(0) -# scratch_next / scratch_end: bump pointer and limit for the scratch -# heap (= scratch_buf_ptr .. + SCRATCH_CAP_BYTES). Selected via -# (use-scratch-heap!); reset to scratch_buf_ptr by -# (reset-scratch-heap!). -:scratch_next $(0) -:scratch_end $(0) - -# current_heap_next_ptr / current_heap_end_ptr: pointer-of-pointer -# slots holding either &heap_next/&heap_end or -# &scratch_next/&scratch_end. cons / alloc_hdr / alloc_bytes / -# heap-mark / heap-rewind! double-deref through these slots so the -# heap selection is a single store of two addresses. -:current_heap_next_ptr $(0) -:current_heap_end_ptr $(0) +# Exact shadow-root frame stack. +:gc_root_next $(0) +:gc_root_end $(0) # Source-buffer cursor and slurped length. :readbuf_pos $(0) @@ -6483,6 +6835,6 @@ :readbuf_buf_ptr $(0) :heap_buf_ptr $(0) :symtab_buf_ptr $(0) -:scratch_buf_ptr $(0) +:gc_root_buf_ptr $(0) :ELF_end diff --git a/tests/cc/134-decl-define-in-ifdef.c b/tests/cc/134-decl-define-in-ifdef.c @@ -1,12 +1,10 @@ /* Regression: decl boundary inside an open #ifdef block. * * Two top-level forms inside `#ifdef CCSCM ... #endif` — a decl - * followed by a #define — used to corrupt cc.scm's scratch heap. The - * #ifdef pushes onto pps-cond-stack; the typedef ends a top-level decl - * and triggers a scratch reset; promote-iter-buffers! deep-copies the - * surviving pp-state slots into the main heap before the reset, but - * was missing pps-cond-stack from that list. The cond-stack frame - * dangled, and the next #define's %pp-active? walk segfaulted. + * followed by a #define — historically exposed compiler heap-lifetime + * bugs. The #ifdef pushes onto pps-cond-stack; an old declaration-boundary + * lifetime scheme failed to retain that stack, so the next #define's + * %pp-active? walk segfaulted. * * The fixture also stands in for the seven `<stdarg.h>`-using * fixtures (015, 067, 076, 079, 097, 116, 131): all of them gate diff --git a/tests/scheme1/065-string-symbol.scm b/tests/scheme1/065-string-symbol.scm @@ -29,7 +29,9 @@ (symbol->string (string->symbol "banana"))) 0 (sys-exit 8)) ; Empty bytevector interns to a single canonical empty-named symbol. -(if (eq? (string->symbol "") (string->symbol "")) 0 (sys-exit 9)) -(if (bytevector=? "" (symbol->string (string->symbol ""))) 0 (sys-exit 10)) +(define empty-name (string->symbol "")) +(collect-garbage) +(if (eq? empty-name (string->symbol "")) 0 (sys-exit 9)) +(if (bytevector=? "" (symbol->string empty-name)) 0 (sys-exit 10)) (sys-exit 0) diff --git a/tests/scheme1/093-heap-mark-rewind.expected-exit b/tests/scheme1/093-gc-reclaim.expected-exit diff --git a/tests/scheme1/093-gc-reclaim.scm b/tests/scheme1/093-gc-reclaim.scm @@ -0,0 +1,32 @@ +; Manual collection reclaims unreachable managed blocks and heap-usage +; reports physical bytes, including allocation headers. + +(define (make-garbage n) + (let loop ((i n) (xs '())) + (if (= i 0) + #f + (loop (- i 1) + (cons (make-bytevector (+ 8 (remainder i 31)) i) xs))))) + +(collect-garbage) +(define baseline (heap-usage)) +(make-garbage 240) +(define peak (heap-usage)) +(collect-garbage) +(define reclaimed (heap-usage)) + +(if (> peak baseline) 0 (sys-exit 1)) +(if (< reclaimed peak) 0 (sys-exit 2)) + +; A second differently-sized allocation wave exercises first-fit splitting. +; After collection it must return to roughly the same live set rather than +; growing monotonically as a bump arena would. +(make-garbage 180) +(define peak2 (heap-usage)) +(collect-garbage) +(define reclaimed2 (heap-usage)) +(if (> peak2 reclaimed) 0 (sys-exit 3)) +(if (< reclaimed2 peak2) 0 (sys-exit 4)) +(if (< reclaimed2 (+ reclaimed 4096)) 0 (sys-exit 5)) + +(sys-exit 42) diff --git a/tests/scheme1/093-heap-mark-rewind.scm b/tests/scheme1/093-heap-mark-rewind.scm @@ -1,75 +0,0 @@ -; heap-mark / heap-rewind! — A → B → C ergonomics. -; -; A: caller. Arena-unaware; just calls (B input) and gets a value back. -; B: arena boundary. Allocates the output cell BEFORE marking, calls C -; to fill it in, rewinds, returns the output to A. -; C: worker. Arena-unaware; allocates scratch and mutates the output. -; -; Invariant for B: between (heap-rewind! mark) and the function's final -; return of out, NO heap allocation may occur. heap-rewind! only resets -; heap_next; it does not zero memory. The trailing env walk that resolves -; the bare `out` symbol reads dropped-but-intact cells, which is well- -; defined as long as nothing has allocated since the rewind. By the time -; A receives the value, all references are to `out` itself (allocated -; pre-mark, permanently safe). -; -; C is tail-recursive; proper tail calls collapse host frames, and the -; recursive heap envs all die together at the rewind. - -(define (C-loop out xs sum count rev) - (if (null? xs) - (begin - (set-car! out sum) - (set-cdr! out count)) - (C-loop out - (cdr xs) - (+ sum (car xs)) - (+ count 1) - (cons (car xs) rev)))) - -(define (C out input) - (C-loop out input 0 0 '())) - -(define (B input) - (let ((out (cons 0 0)) ; pre-mark: survives rewind - (mark (heap-mark))) ; everything past here is C's scratch - (C out input) - (heap-rewind! mark) - out)) - -(define (A) - (let ((input (cons 1 (cons 2 (cons 3 (cons 4 (cons 5 '()))))))) - (B input))) - -; A no-rewind sibling lets us assert the rewind actually saves bytes. -(define (B-noreclaim input) - (let ((out (cons 0 0))) - (C out input) - out)) - -(define (A-noreclaim) - (let ((input (cons 1 (cons 2 (cons 3 (cons 4 (cons 5 '()))))))) - (B-noreclaim input))) - -(define before (heap-mark)) -(define result (A)) -(define after (heap-mark)) -(define delta (- after before)) - -(define before2 (heap-mark)) -(define result2 (A-noreclaim)) -(define after2 (heap-mark)) -(define delta2 (- after2 before2)) - -(sys-exit - (if (= (car result) 15) - (if (= (cdr result) 5) - (if (= (car result2) 15) - (if (= (cdr result2) 5) - (if (< delta delta2) - 42 - 43) - 44) - 45) - 46) - 47)) diff --git a/tests/scheme1/115-two-heap.expected-exit b/tests/scheme1/115-gc-live-identity.expected-exit diff --git a/tests/scheme1/115-gc-live-identity.scm b/tests/scheme1/115-gc-live-identity.scm @@ -0,0 +1,26 @@ +; Live pairs, cycles, closures, and bytevector RAW storage retain identity +; and mutations across repeated collections. + +(define p (cons 1 2)) +(set-cdr! p p) +(define same p) +(define bv (bytevector 1 2 3 4 5)) +(define make-adder (lambda (x) (lambda (y) (+ x y)))) +(define add7 (make-adder 7)) + +(define (garbage n) + (if (= n 0) #f (begin (cons n (make-bytevector 24 n)) (garbage (- n 1))))) + +(garbage 120) +(collect-garbage) +(set-car! p 9) +(bytevector-u8-set! bv 2 99) +(collect-garbage) + +(if (eq? p same) 0 (sys-exit 1)) +(if (= (car p) 9) 0 (sys-exit 2)) +(if (eq? p (cdr p)) 0 (sys-exit 3)) +(if (= (bytevector-u8-ref bv 2) 99) 0 (sys-exit 4)) +(if (= (add7 35) 42) 0 (sys-exit 5)) + +(sys-exit 42) diff --git a/tests/scheme1/115-two-heap.scm b/tests/scheme1/115-two-heap.scm @@ -1,56 +0,0 @@ -; Two-heap primitives, A → B → C ergonomics. The shape Phase 3 of -; CC-SCRATCH.md will use at the parse-decl-or-fn boundary. -; -; A: caller. Heap-unaware; just calls (B input) and uses the result. -; B: boundary. Switches to scratch, runs C in scratch, switches back -; to main, *clones* C's survivor into the main heap (the "promote" -; walker), resets scratch, returns the main-heap clone. -; C: worker. Heap-unaware; allocates freely in whatever heap is -; current. Returns a freshly-allocated (sum . count) pair. -; -; The clone runs while main is current and reads from scratch via -; ordinary pointer access — neither heap selection affects loads, only -; allocations. After the clone, scratch can be wholesale reset because -; nothing in main points into it. - -(define (C input) - (let loop ((xs input) (sum 0) (count 0)) - (if (null? xs) - (cons sum count) - (loop (cdr xs) (+ sum (car xs)) (+ count 1))))) - -; Promote: read from scratch-allocated pair, allocate the clone in -; the currently-selected heap. C's result has fixnum car/cdr so a -; one-level cons is enough; real promote walkers recurse on heap- -; allocated children. -(define (promote-pair p) - (cons (car p) (cdr p))) - -(define (B input) - (use-scratch-heap!) - (let ((scratch-result (C input))) - (use-main-heap!) - (let ((main-result (promote-pair scratch-result))) - (reset-scratch-heap!) - main-result))) - -(define (A) - (let ((input (cons 1 (cons 2 (cons 3 (cons 4 (cons 5 '()))))))) - (B input))) - -; Drive B twice. A scratch leak would push the second call past the -; cap; a missed promotion would leave r1 dangling once r2's run resets. -(define r1 (A)) -(define r2 (A)) -(define r1-in-main? (heap-in-main? r1)) -(define r2-in-main? (heap-in-main? r2)) - -(sys-exit - (cond - ((not r1-in-main?) 1) ; clone landed in main - ((not r2-in-main?) 2) - ((not (= (car r1) 15)) 3) ; r1 still readable after r2's reset - ((not (= (cdr r1) 5)) 4) - ((not (= (car r2) 15)) 5) - ((not (= (cdr r2) 5)) 6) - (else 42))) diff --git a/tests/scheme1/121-record-introspection.scm b/tests/scheme1/121-record-introspection.scm @@ -1,6 +1,6 @@ ; Record introspection primitives: record?, record-td, record-ref, -; record-set!, make-record/td, td-nfields, td-name, heap-in-current?. -; Backs the generic deep-copy walker (see docs/DEEP-COPY.md). +; record-set!, make-record/td, td-nfields, and td-name. +; These operations also back the generic deep-copy walker. (define-record-type point (mk-point x y) @@ -63,25 +63,4 @@ (if (= 100 (point-x p3)) 0 (sys-exit 63)) (if (= 200 (point-y p3)) 0 (sys-exit 64)) -;; ---- heap-in-current? generalizes heap-in-main? ---- -;; Default heap is main. -(if (heap-in-current? p) 0 (sys-exit 70)) -(if (heap-in-current? "bv-in-main") 0 (sys-exit 71)) -;; Tagged non-pointers are #f. -(if (not (heap-in-current? 5)) 0 (sys-exit 72)) -(if (not (heap-in-current? 'sym)) 0 (sys-exit 73)) -(if (not (heap-in-current? #f)) 0 (sys-exit 74)) -(if (not (heap-in-current? '())) 0 (sys-exit 75)) - -;; Allocate a record in scratch, then in main; each is in-current within -;; its arena and not in-current after switching. -(use-scratch-heap!) -(define s-rec (mk-point 1 2)) -(if (heap-in-current? s-rec) 0 (sys-exit 80)) -(if (not (heap-in-main? s-rec)) 0 (sys-exit 81)) -(use-main-heap!) -(if (not (heap-in-current? s-rec)) 0 (sys-exit 82)) -(if (heap-in-current? p) 0 (sys-exit 83)) -(reset-scratch-heap!) - (sys-exit 42) diff --git a/tests/scheme1/122-deep-copy.scm b/tests/scheme1/122-deep-copy.scm @@ -1,13 +1,5 @@ -; Generic deep-copy: structural clone of pairs / bytevectors / records, -; with identity preservation across shared substructure and cycle -; tolerance via an eager stand-in registered before slot fill. Used by -; cc.scm to promote scratch-allocated parse output into main; mirror -; here in scheme1 itself to lock down the contract. See -; docs/DEEP-COPY.md. -; -; By design, deep-copy short-circuits when an object is already in the -; current heap (so re-promotion is O(1)). The structural tests below -; therefore allocate sources in scratch and copy with main current. +; Generic deep-copy is an ordinary graph clone. It preserves sharing and +; cycles within a context, without relying on heap selection. (define-record-type cell (mk-cell head tail) @@ -15,111 +7,46 @@ (head cell-head cell-head-set!) (tail cell-tail cell-tail-set!)) -;; ---- Already-in-target short-circuit returns the same object ---- -(define m-pair (cons 1 2)) (define ctx0 (make-deep-copy-context)) -(if (eq? m-pair (deep-copy ctx0 m-pair)) 0 (sys-exit 1)) +(if (eq? 'foo (deep-copy ctx0 'foo)) 0 (sys-exit 1)) +(if (= 42 (deep-copy ctx0 42)) 0 (sys-exit 2)) +(if (eq? #t (deep-copy ctx0 #t)) 0 (sys-exit 3)) -;; ---- Symbols pass through untouched (interned) ---- -(if (eq? 'foo (deep-copy ctx0 'foo)) 0 (sys-exit 2)) - -;; ---- Fixnums / immediates pass through ---- -(if (= 42 (deep-copy ctx0 42)) 0 (sys-exit 3)) -(if (eq? #t (deep-copy ctx0 #t)) 0 (sys-exit 4)) -(if (eq? '() (deep-copy ctx0 '())) 0 (sys-exit 5)) - -;; ---- Pair deep-copy from scratch -> main ---- -(use-scratch-heap!) -(define s-list (cons 1 (cons 2 (cons 3 '())))) -(use-main-heap!) +(define source-list (cons 1 (cons 2 (cons 3 '())))) (define ctx1 (make-deep-copy-context)) -(define m-list (deep-copy ctx1 s-list)) -(if (equal? s-list m-list) 0 (sys-exit 10)) -(if (not (eq? s-list m-list)) 0 (sys-exit 11)) -(if (heap-in-main? m-list) 0 (sys-exit 12)) -(if (heap-in-main? (cdr m-list)) 0 (sys-exit 13)) -(reset-scratch-heap!) -;; m-list survives scratch reset -(if (equal? m-list (cons 1 (cons 2 (cons 3 '())))) 0 (sys-exit 14)) - -;; ---- Bytevector deep-copy from scratch -> main ---- -(use-scratch-heap!) -(define s-bv (bytevector 1 2 3 4 5)) -(use-main-heap!) -(define ctx2 (make-deep-copy-context)) -(define m-bv (deep-copy ctx2 s-bv)) -(if (bytevector=? s-bv m-bv) 0 (sys-exit 20)) -(if (not (eq? s-bv m-bv)) 0 (sys-exit 21)) -(if (heap-in-main? m-bv) 0 (sys-exit 22)) -(reset-scratch-heap!) -;; main-heap copy survives scratch reset -(if (= 5 (bytevector-length m-bv)) 0 (sys-exit 23)) -(if (= 1 (bytevector-u8-ref m-bv 0)) 0 (sys-exit 24)) -(if (= 5 (bytevector-u8-ref m-bv 4)) 0 (sys-exit 25)) - -;; ---- Record deep-copy from scratch -> main ---- -(use-scratch-heap!) -(define s-cell (mk-cell 10 20)) -(use-main-heap!) -(define ctx3 (make-deep-copy-context)) -(define m-cell (deep-copy ctx3 s-cell)) -(if (cell? m-cell) 0 (sys-exit 30)) -(if (not (eq? s-cell m-cell)) 0 (sys-exit 31)) -(if (= 10 (cell-head m-cell)) 0 (sys-exit 32)) -(if (= 20 (cell-tail m-cell)) 0 (sys-exit 33)) -;; Same TD: TDs are persistent and not copied -(if (eq? (record-td s-cell) (record-td m-cell)) 0 (sys-exit 34)) -(if (heap-in-main? m-cell) 0 (sys-exit 35)) -(reset-scratch-heap!) -(if (= 10 (cell-head m-cell)) 0 (sys-exit 36)) - -;; ---- Identity preservation across shared subobjects ---- -(use-scratch-heap!) -(define s-shared (cons 'a 'b)) -(define s-x (cons s-shared s-shared)) -(use-main-heap!) -(define ctx4 (make-deep-copy-context)) -(define m-x (deep-copy ctx4 s-x)) -;; Both halves of the result reference one fresh shared cons in main. -(if (eq? (car m-x) (cdr m-x)) 0 (sys-exit 40)) -(if (not (eq? (car m-x) s-shared)) 0 (sys-exit 41)) -(if (eq? 'a (car (car m-x))) 0 (sys-exit 42)) -(if (eq? 'b (cdr (car m-x))) 0 (sys-exit 43)) -(reset-scratch-heap!) - -;; ---- Cycle handling (record points to itself) ---- -(use-scratch-heap!) -(define s-cyc (mk-cell 1 #f)) -(cell-tail-set! s-cyc s-cyc) -(use-main-heap!) -(define ctx5 (make-deep-copy-context)) -(define m-cyc (deep-copy ctx5 s-cyc)) -(if (not (eq? s-cyc m-cyc)) 0 (sys-exit 50)) -(if (= 1 (cell-head m-cyc)) 0 (sys-exit 51)) -(if (eq? m-cyc (cell-tail m-cyc)) 0 (sys-exit 52)) -(reset-scratch-heap!) -;; m-cyc still its own tail after scratch reset -(if (eq? m-cyc (cell-tail m-cyc)) 0 (sys-exit 53)) - -;; ---- Mixed pair-of-record graph ---- -(use-scratch-heap!) -(define s-rec (mk-cell 9 (cons 1 (cons 2 '())))) -(use-main-heap!) -(define ctx6 (make-deep-copy-context)) -(define m-rec (deep-copy ctx6 s-rec)) -(if (not (eq? s-rec m-rec)) 0 (sys-exit 60)) -(if (= 9 (cell-head m-rec)) 0 (sys-exit 61)) -(if (equal? (cell-tail m-rec) '(1 2)) 0 (sys-exit 62)) -(if (heap-in-main? m-rec) 0 (sys-exit 63)) -(if (heap-in-main? (cell-tail m-rec)) 0 (sys-exit 64)) -(reset-scratch-heap!) -(if (equal? (cell-tail m-rec) '(1 2)) 0 (sys-exit 65)) - -;; ---- ctx reuse: second pass over the same already-copied root is O(1) -;; via heap-in-current?, returning the main-heap object directly. -(define ctx7 (make-deep-copy-context)) -(define copy-once (deep-copy ctx7 (cons 'a (cons 'b '())))) -(define copy-again (deep-copy ctx7 copy-once)) -(if (eq? copy-once copy-again) 0 (sys-exit 70)) +(define copy-list (deep-copy ctx1 source-list)) +(if (equal? source-list copy-list) 0 (sys-exit 10)) +(if (not (eq? source-list copy-list)) 0 (sys-exit 11)) +(if (eq? copy-list (deep-copy ctx1 source-list)) 0 (sys-exit 12)) + +(define source-bv (bytevector 1 2 3 4 5)) +(define copy-bv (deep-copy (make-deep-copy-context) source-bv)) +(if (bytevector=? source-bv copy-bv) 0 (sys-exit 20)) +(if (not (eq? source-bv copy-bv)) 0 (sys-exit 21)) +(bytevector-u8-set! source-bv 0 99) +(if (= (bytevector-u8-ref copy-bv 0) 1) 0 (sys-exit 22)) + +(define source-cell (mk-cell 10 20)) +(define copy-cell (deep-copy (make-deep-copy-context) source-cell)) +(if (cell? copy-cell) 0 (sys-exit 30)) +(if (not (eq? source-cell copy-cell)) 0 (sys-exit 31)) +(if (eq? (record-td source-cell) (record-td copy-cell)) 0 (sys-exit 32)) +(if (= (cell-head copy-cell) 10) 0 (sys-exit 33)) + +; Both edges must point at one fresh clone. +(define shared (cons 'a 'b)) +(define graph (cons shared shared)) +(define graph-copy (deep-copy (make-deep-copy-context) graph)) +(if (eq? (car graph-copy) (cdr graph-copy)) 0 (sys-exit 40)) +(if (not (eq? (car graph-copy) shared)) 0 (sys-exit 41)) + +; An eager stand-in breaks cycles while recursively filling fields. +(define cycle (mk-cell 1 #f)) +(cell-tail-set! cycle cycle) +(define cycle-copy (deep-copy (make-deep-copy-context) cycle)) +(if (not (eq? cycle cycle-copy)) 0 (sys-exit 50)) +(if (eq? cycle-copy (cell-tail cycle-copy)) 0 (sys-exit 51)) +(collect-garbage) +(if (eq? cycle-copy (cell-tail cycle-copy)) 0 (sys-exit 52)) (sys-exit 42) diff --git a/tests/scheme1/123-scratch-reset-intern.expected-exit b/tests/scheme1/123-gc-symbol-roots.expected-exit diff --git a/tests/scheme1/123-gc-symbol-roots.scm b/tests/scheme1/123-gc-symbol-roots.scm @@ -0,0 +1,26 @@ +; Symbol names and global bindings are explicit collector roots. + +(define alpha-long-lived (cons 'alpha-name 17)) +(define beta-long-lived (bytevector 4 5 6)) + +(define (intern-and-drop n) + (if (= n 0) + #t + (begin + ; Parsing this program interns all of these identifiers before eval; + ; allocation pressure still exercises symbol-root tracing repeatedly. + (cons 'temporary-name (make-bytevector 32 n)) + (intern-and-drop (- n 1))))) + +(intern-and-drop 160) +(collect-garbage) +(collect-garbage) + +(if (eq? (car alpha-long-lived) 'alpha-name) 0 (sys-exit 1)) +(if (= (cdr alpha-long-lived) 17) 0 (sys-exit 2)) +(if (= (bytevector-u8-ref beta-long-lived 1) 5) 0 (sys-exit 3)) +(set! alpha-long-lived (cons 'alpha-name 42)) +(collect-garbage) +(if (= (cdr alpha-long-lived) 42) 0 (sys-exit 4)) + +(sys-exit 42) diff --git a/tests/scheme1/123-scratch-reset-intern.scm b/tests/scheme1/123-scratch-reset-intern.scm @@ -1,23 +0,0 @@ -; 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-gc-record-type.expected-exit diff --git a/tests/scheme1/124-gc-record-type.scm b/tests/scheme1/124-gc-record-type.scm @@ -0,0 +1,34 @@ +; Record instances, type descriptors, generated parameterized primitives, +; and field metadata remain live across collection. + +(define-record-type dyn + (mk-dyn x y) + dyn? + (x dyn-x dyn-x-set!) + (y dyn-y dyn-y-set!)) + +(define d (mk-dyn 7 8)) +(define td (record-td d)) +(collect-garbage) + +(if (dyn? d) 0 (sys-exit 1)) +(if (eq? td (record-td d)) 0 (sys-exit 2)) +(if (eq? (td-name td) 'dyn) 0 (sys-exit 3)) +(if (= (td-nfields td) 2) 0 (sys-exit 4)) + +(dyn-x-set! d (cons 7 10)) +(dyn-y-set! d d) +(collect-garbage) +(if (= 7 (car (dyn-x d))) 0 (sys-exit 5)) +(if (= 10 (cdr (dyn-x d))) 0 (sys-exit 6)) +(if (eq? d (dyn-y d)) 0 (sys-exit 7)) + +; pmatch reads the TD field-name list through generated accessors. +(if (= 17 + (pmatch d + (($ dyn? (x ,x) (y ,y)) (+ (car x) (cdr (dyn-x y)))) + (else 0))) + 0 + (sys-exit 8)) + +(sys-exit 42) diff --git a/tests/scheme1/124-scratch-record-type.scm b/tests/scheme1/124-scratch-record-type.scm @@ -1,30 +0,0 @@ -; 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) diff --git a/tests/scheme1/125-heap-wrappers.expected-exit b/tests/scheme1/125-gc-construction-mv.expected-exit diff --git a/tests/scheme1/125-gc-construction-mv.scm b/tests/scheme1/125-gc-construction-mv.scm @@ -0,0 +1,49 @@ +; Collection during multi-step object construction and multiple-values +; handling must preserve every in-flight reference. + +(define-record-type box + (mk-box value next) + box? + (value box-value box-value-set!) + (next box-next box-next-set!)) + +(define (build n tail) + (if (= n 0) + tail + (let ((b (mk-box n #f))) + (collect-garbage) + (box-next-set! b (build (- n 1) tail)) + b))) + +(define sentinel (cons 'end '())) +(define chain (build 40 sentinel)) +(collect-garbage) + +(define (sum-chain b acc) + (if (box? b) + (sum-chain (box-next b) (+ acc (box-value b))) + acc)) + +(if (= (sum-chain chain 0) 820) 0 (sys-exit 1)) +(if (eq? sentinel + (let loop ((b chain)) + (if (box? b) (loop (box-next b)) b))) + 0 + (sys-exit 2)) + +(define producer + (lambda () + (let ((a (cons 10 20)) + (b (bytevector 30 40))) + (collect-garbage) + (values a b 2)))) + +(define answer + (call-with-values producer + (lambda (a b n) + (+ (car a) (cdr a) (bytevector-u8-ref b 0) + (bytevector-u8-ref b 1) n)))) +(collect-garbage) +(if (= answer 102) 0 (sys-exit 3)) + +(sys-exit 42) diff --git a/tests/scheme1/125-heap-wrappers.scm b/tests/scheme1/125-heap-wrappers.scm @@ -1,109 +0,0 @@ -; Prelude heap-arena wrappers built on top of heap-mark / heap-rewind! -; and the two-heap primitives. See scheme1/prelude.scm for the contract. - -(define-record-type cell - (mk-cell head tail) - cell? - (head cell-head) - (tail cell-tail)) - -;; ---- call-with-heap-rewind: A→B→C with the wrapper ---------------- -;; B pre-allocates `out`, calls the wrapper to run C in scratch, returns -;; out. The thunk's return value is dropped — survivors travel via -;; mutation of the pre-mark `out` cell. -(define (sum-and-count-into out xs) - (let loop ((xs xs) (sum 0) (count 0)) - (cond - ((null? xs) - (set-car! out sum) - (set-cdr! out count)) - (else (loop (cdr xs) (+ sum (car xs)) (+ count 1)))))) - -(define (sum-and-count xs) - (let ((out (cons 0 0))) - (call-with-heap-rewind - (lambda () (sum-and-count-into out xs))) - out)) - -(define input (cons 1 (cons 2 (cons 3 (cons 4 (cons 5 '())))))) - -;; Wrapper version: scratch reclaimed. -(define m0 (heap-mark)) -(define r (sum-and-count input)) -(define m1 (heap-mark)) - -;; No-rewind sibling: same call, no wrapper. Recursion-loop env frames -;; leak. -(define out2 (cons 0 0)) -(define m2-before (heap-mark)) -(sum-and-count-into out2 input) -(define m2-after (heap-mark)) - -(if (= 15 (car r)) 0 (sys-exit 1)) -(if (= 5 (cdr r)) 0 (sys-exit 2)) -;; Wrapped delta must be strictly less than the raw delta. -(if (< (- m1 m0) (- m2-after m2-before)) 0 (sys-exit 3)) - -;; Immediate return value flows back through the wrapper. -(define v - (call-with-heap-rewind - (lambda () - ;; Allocate transient garbage that must be reclaimed. - (let* ((tmp1 (cons 1 2)) - (tmp2 (cons tmp1 tmp1))) - 99)))) -(if (= 99 v) 0 (sys-exit 4)) - -;; ---- call-with-scratch-deep-copy: scratch-build, main-clone, reset -- -(define (build-list-in-current n) - (let loop ((i n) (acc '())) - (if (= i 0) acc (loop (- i 1) (cons i acc))))) - -(define m1 (call-with-scratch-deep-copy - (lambda () (build-list-in-current 4)))) -(if (heap-in-main? m1) 0 (sys-exit 10)) -(if (equal? m1 '(1 2 3 4)) 0 (sys-exit 11)) - -;; Survives even after a fresh scratch cycle stomps the original arena. -(define m2 (call-with-scratch-deep-copy - (lambda () (mk-cell 'tag (build-list-in-current 3))))) -(if (cell? m2) 0 (sys-exit 12)) -(if (eq? 'tag (cell-head m2)) 0 (sys-exit 13)) -(if (equal? '(1 2 3) (cell-tail m2)) 0 (sys-exit 14)) -(if (heap-in-main? m2) 0 (sys-exit 15)) -(if (heap-in-main? (cell-tail m2)) 0 (sys-exit 16)) -;; m1 still readable after the second cycle's reset. -(if (equal? m1 '(1 2 3 4)) 0 (sys-exit 17)) - -;; ---- call-with-scratch-cycle: multi-root promote ------------------- -;; Caller-owned slots; each cycle parses garbage in scratch and rewrites -;; the slots in main via a shared deep-copy context. -(define slot-a #f) -(define slot-b #f) - -(define (one-cycle) - (call-with-scratch-cycle - (lambda () - ;; "Parse" output — both slots end up scratch-resident. - (set! slot-a (cons 'a (cons 1 (cons 2 '())))) - (set! slot-b (mk-cell 'b slot-a))) ; b shares slot-a's tail - (lambda () - (let ((ctx (make-deep-copy-context))) - (set! slot-a (deep-copy ctx slot-a)) - (set! slot-b (deep-copy ctx slot-b)))))) - -(one-cycle) -(if (heap-in-main? slot-a) 0 (sys-exit 20)) -(if (heap-in-main? slot-b) 0 (sys-exit 21)) -(if (eq? slot-a (cell-tail slot-b)) 0 (sys-exit 22)) ; sharing preserved -(if (equal? slot-a '(a 1 2)) 0 (sys-exit 23)) -(if (eq? 'b (cell-head slot-b)) 0 (sys-exit 24)) - -;; A second cycle resets scratch; prior slot values must remain valid. -(define old-a slot-a) -(define old-b slot-b) -(one-cycle) -(if (equal? old-a '(a 1 2)) 0 (sys-exit 25)) -(if (eq? 'b (cell-head old-b)) 0 (sys-exit 26)) - -(sys-exit 42) diff --git a/tests/scheme1/126-shadow-root-overflow.expected b/tests/scheme1/126-shadow-root-overflow.expected @@ -0,0 +1 @@ +scheme1: shadow root stack overflow diff --git a/tests/scheme1/126-shadow-root-overflow.expected-exit b/tests/scheme1/126-shadow-root-overflow.expected-exit @@ -0,0 +1 @@ +1 diff --git a/tests/scheme1/126-shadow-root-overflow.scm b/tests/scheme1/126-shadow-root-overflow.scm @@ -0,0 +1,9 @@ +; A deeply nested non-tail call chain exhausts the bounded exact root stack +; deterministically instead of silently losing roots. + +(define (descend n) + (if (= n 0) + 0 + (+ 1 (descend (- n 1))))) + +(descend 10000)