125-heap-wrappers.scm (3845B)
1 ; Prelude heap-arena wrappers built on top of heap-mark / heap-rewind! 2 ; and the two-heap primitives. See scheme1/prelude.scm for the contract. 3 4 (define-record-type cell 5 (mk-cell head tail) 6 cell? 7 (head cell-head) 8 (tail cell-tail)) 9 10 ;; ---- call-with-heap-rewind: A→B→C with the wrapper ---------------- 11 ;; B pre-allocates `out`, calls the wrapper to run C in scratch, returns 12 ;; out. The thunk's return value is dropped — survivors travel via 13 ;; mutation of the pre-mark `out` cell. 14 (define (sum-and-count-into out xs) 15 (let loop ((xs xs) (sum 0) (count 0)) 16 (cond 17 ((null? xs) 18 (set-car! out sum) 19 (set-cdr! out count)) 20 (else (loop (cdr xs) (+ sum (car xs)) (+ count 1)))))) 21 22 (define (sum-and-count xs) 23 (let ((out (cons 0 0))) 24 (call-with-heap-rewind 25 (lambda () (sum-and-count-into out xs))) 26 out)) 27 28 (define input (cons 1 (cons 2 (cons 3 (cons 4 (cons 5 '())))))) 29 30 ;; Wrapper version: scratch reclaimed. 31 (define m0 (heap-mark)) 32 (define r (sum-and-count input)) 33 (define m1 (heap-mark)) 34 35 ;; No-rewind sibling: same call, no wrapper. Recursion-loop env frames 36 ;; leak. 37 (define out2 (cons 0 0)) 38 (define m2-before (heap-mark)) 39 (sum-and-count-into out2 input) 40 (define m2-after (heap-mark)) 41 42 (if (= 15 (car r)) 0 (sys-exit 1)) 43 (if (= 5 (cdr r)) 0 (sys-exit 2)) 44 ;; Wrapped delta must be strictly less than the raw delta. 45 (if (< (- m1 m0) (- m2-after m2-before)) 0 (sys-exit 3)) 46 47 ;; Immediate return value flows back through the wrapper. 48 (define v 49 (call-with-heap-rewind 50 (lambda () 51 ;; Allocate transient garbage that must be reclaimed. 52 (let* ((tmp1 (cons 1 2)) 53 (tmp2 (cons tmp1 tmp1))) 54 99)))) 55 (if (= 99 v) 0 (sys-exit 4)) 56 57 ;; ---- call-with-scratch-deep-copy: scratch-build, main-clone, reset -- 58 (define (build-list-in-current n) 59 (let loop ((i n) (acc '())) 60 (if (= i 0) acc (loop (- i 1) (cons i acc))))) 61 62 (define m1 (call-with-scratch-deep-copy 63 (lambda () (build-list-in-current 4)))) 64 (if (heap-in-main? m1) 0 (sys-exit 10)) 65 (if (equal? m1 '(1 2 3 4)) 0 (sys-exit 11)) 66 67 ;; Survives even after a fresh scratch cycle stomps the original arena. 68 (define m2 (call-with-scratch-deep-copy 69 (lambda () (mk-cell 'tag (build-list-in-current 3))))) 70 (if (cell? m2) 0 (sys-exit 12)) 71 (if (eq? 'tag (cell-head m2)) 0 (sys-exit 13)) 72 (if (equal? '(1 2 3) (cell-tail m2)) 0 (sys-exit 14)) 73 (if (heap-in-main? m2) 0 (sys-exit 15)) 74 (if (heap-in-main? (cell-tail m2)) 0 (sys-exit 16)) 75 ;; m1 still readable after the second cycle's reset. 76 (if (equal? m1 '(1 2 3 4)) 0 (sys-exit 17)) 77 78 ;; ---- call-with-scratch-cycle: multi-root promote ------------------- 79 ;; Caller-owned slots; each cycle parses garbage in scratch and rewrites 80 ;; the slots in main via a shared deep-copy context. 81 (define slot-a #f) 82 (define slot-b #f) 83 84 (define (one-cycle) 85 (call-with-scratch-cycle 86 (lambda () 87 ;; "Parse" output — both slots end up scratch-resident. 88 (set! slot-a (cons 'a (cons 1 (cons 2 '())))) 89 (set! slot-b (mk-cell 'b slot-a))) ; b shares slot-a's tail 90 (lambda () 91 (let ((ctx (make-deep-copy-context))) 92 (set! slot-a (deep-copy ctx slot-a)) 93 (set! slot-b (deep-copy ctx slot-b)))))) 94 95 (one-cycle) 96 (if (heap-in-main? slot-a) 0 (sys-exit 20)) 97 (if (heap-in-main? slot-b) 0 (sys-exit 21)) 98 (if (eq? slot-a (cell-tail slot-b)) 0 (sys-exit 22)) ; sharing preserved 99 (if (equal? slot-a '(a 1 2)) 0 (sys-exit 23)) 100 (if (eq? 'b (cell-head slot-b)) 0 (sys-exit 24)) 101 102 ;; A second cycle resets scratch; prior slot values must remain valid. 103 (define old-a slot-a) 104 (define old-b slot-b) 105 (one-cycle) 106 (if (equal? old-a '(a 1 2)) 0 (sys-exit 25)) 107 (if (eq? 'b (cell-head old-b)) 0 (sys-exit 26)) 108 109 (sys-exit 42)