boot2

115-two-heap.scm (2074B)

---

 ; 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)))