; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
; Collector
; The interface to the GC consists of
; (S48-BEGIN-COLLECTION) ; call either this
; (BEGIN-WRITING-IMAGE) ; or this first
; (S48-TRACE-LOCATIONS! start end) ; trace all roots
; (S48-TRACE-VALUE value) => copied value
; (S48-TRACE-STOB-CONTENTS! stob)
; (S48-DO-GC) ; then do the GC
; (S48-END-COLLECTION) ; and either finish
; (ABORT-COLLECTION) ; or abort if writing an image
(define *gc-count* 0)
(define (s48-gc-count) *gc-count*)
; True if the GC is being done for the purpose of dumping an image, in which
; case we check for undumpable records.
(define *writing-image?*)
(define *undumpable-records*)
(define *undumpable-count*)
(define (s48-begin-collection)
(really-begin-collection)
(set! *writing-image?* #f)
(trace-static-areas)
(unspecific))
(define (begin-writing-image)
(really-begin-collection)
(set! *writing-image?* #t)
(set! *undumpable-records* null)
(set! *undumpable-count* 0))
(define (really-begin-collection)
(set! *from-begin* (heap-start))
(set! *from-end* (heap-limit))
(swap-spaces)
(set-heap-pointer! (heap-start))
(set! *weak-pointer-hp* null-address))
(define *from-begin*)
(define *from-end*)
(define (in-oldspace? descriptor)
(and (stob? descriptor)
(let ((a (address-after-header descriptor)))
(and (address>= a *from-begin*)
(address< a *from-end*)))))
(define (s48-trace-value stob)
(cond ((and *writing-image?*
(undumpable? stob))
(begin
(note-undumpable! stob)
(s48-trace-value (undumpable-alias stob))))
((in-oldspace? stob)
(copy-object stob))
(else
stob)))
(define (s48-end-collection)
(set! *gc-count* (+ *gc-count* 1)))
(define (s48-undumpable-records)
(values *undumpable-records*
*undumpable-count*))
; Undo the effects of the current collection (assuming that it did not
; modify any VM registers or the stack).
(define (abort-collection)
(swap-spaces)
(let loop ((addr (heap-start)))
(if (address< addr (heap-pointer))
(let* ((d (fetch addr))
(h (if (header? d)
d
(let ((h (stob-header d)))
(store! addr h) ; mend heart
h))))
(loop (address+ addr
(+ (cells->a-units stob-overhead)
(header-length-in-a-units h))))))))
; Complete a GC after all roots have been traced.
(define (trace-static-areas)
(walk-impure-areas
(lambda (start end)
(s48-trace-locations! start end)
#t)))
; Scan the heap, copying pointed to objects, starting from START. Quit once
; the scanning pointer catches up with the heap pointer.
(define (s48-do-gc)
(let loop ((start (heap-start)))
(let ((end (heap-pointer)))
(s48-trace-locations! start end)
(cond ((< (s48-available) 0)
(error "GC error: ran out of space in new heap"))
((address< end (heap-pointer))
(loop end)))))
(clean-weak-pointers)
0);; for the PreScheme compiler which otherwise will emit return statements
;; but declare the function to have return type void
(define (s48-trace-stob-contents! stob)
(let ((start (address-after-header stob))
(size (bytes->a-units (header-length-in-bytes (stob-header stob)))))
(s48-trace-locations! start (address+ start size))))
; Copy everything pointed to from somewhere between START (inclusive)
; and END (exclusive).
(define (s48-trace-locations! start end)
(let loop ((addr start) (frontier (heap-pointer)))
(if (address< addr end)
(let ((thing (fetch addr))
(next (address1+ addr)))
(cond ((header? thing)
(cond ((b-vector-header? thing)
(loop (address+ next (header-length-in-a-units thing))
frontier))
(else
(loop next frontier))))
((and *writing-image?*
(undumpable? thing))
(note-undumpable! thing)
(store! addr (undumpable-alias thing))
(loop addr frontier))
((in-oldspace? thing)
(receive (new-thing frontier)
(real-copy-object thing frontier)
(store! addr new-thing)
(loop next frontier)))
(else
(loop next frontier))))
(set-heap-pointer! frontier)))
0) ; for the type-checker
; Copy THING if it has not already been copied.
(define (copy-object thing)
(receive (new-thing new-hp)
(real-copy-object thing (heap-pointer))
(set-heap-pointer! new-hp)
new-thing))
; Non-heap-pointer version for better code in TRACE-LOCATIONS
(define (real-copy-object thing frontier)
(let ((h (stob-header thing)))
(cond ((stob? h) ;***Broken heart
;; (assert (in-newspace? h))
(values h frontier))
((and (vm-eq? weak-pointer-header h)
(in-oldspace? (fetch (address-after-header thing))))
(copy-weak-pointer thing frontier))
(else
(store! frontier h)
(let* ((data-addr (address+ frontier (cells->a-units stob-overhead)))
(new (address->stob-descriptor data-addr)))
(stob-header-set! thing new) ;***Break heart
(copy-memory! (address-after-header thing)
data-addr
(header-length-in-bytes h))
(values new
(address+ data-addr (header-length-in-a-units h))))))))
(define (s48-extant? thing)
(or (not (stob? thing))
(not (in-oldspace? thing))
(stob? (stob-header thing))))
;----------------
; Weak pointers
;
; Weak pointers are copied into contiguous blocks so that they can be
; scanned after the main GC has finished. They have their own heap pointer
; and heap limit.
(define *weak-pointer-hp*)
(define *weak-pointer-limit*)
; header + one slot
(define weak-pointer-size 2)
; The number of weak pointers in each block.
(define weak-pointer-alloc-count 128)
; The size of a block of weak pointers.
(define weak-pointer-alloc-quantum
(cells->a-units (* weak-pointer-alloc-count weak-pointer-size)))
; Used both to detect weak pointers and for setting the headers when the
; weak-pointer blocks are scanned.
(define weak-pointer-header
(make-header (enum stob weak-pointer) (cells->bytes (- weak-pointer-size 1))))
; A header used to stop the GC from scanning weak-pointer blocks.
(define weak-alloc-area-header
(make-header (enum stob byte-vector)
(cells->bytes (- (* weak-pointer-alloc-count weak-pointer-size)
1)))) ; don't count the header
(define (copy-weak-pointer weak frontier)
(let ((frontier (if (or (null-address? *weak-pointer-hp*)
(address>= *weak-pointer-hp* *weak-pointer-limit*))
(allocate-more-weak-pointer-space frontier)
frontier)))
(let ((new (address->stob-descriptor
(address+ *weak-pointer-hp* (cells->a-units stob-overhead)))))
(store! (address1+ *weak-pointer-hp*) (fetch (address-after-header weak)))
(set! *weak-pointer-hp* (address2+ *weak-pointer-hp*))
(stob-header-set! weak new) ;***Break heart
(values new frontier))))
; The weak pointer blocks are linked in their third slot (= the header space
; of the second weak pointer). The header for the first weak pointer contains
; a header for the block, and the value slots contain the (untraced) values.
(define (allocate-more-weak-pointer-space frontier)
(let ((old *weak-pointer-hp*)
(new-frontier (address+ frontier weak-pointer-alloc-quantum)))
(set! *weak-pointer-hp* frontier)
(set! *weak-pointer-limit* new-frontier)
(store! *weak-pointer-hp* weak-alloc-area-header)
(store! (address2+ *weak-pointer-hp*) (address->integer old))
new-frontier))
; If any weak pointers were found, then get the limits of the most recently
; allocated block and scan it and the rest of the blocks. Put a string header
; on the unused portion of the block the most recent block.
(define (clean-weak-pointers)
(if (not (null-address? *weak-pointer-hp*))
(let ((start (address- *weak-pointer-limit* weak-pointer-alloc-quantum))
(end *weak-pointer-hp*))
(scan-weak-pointer-blocks start end)
(if (not (address>= end *weak-pointer-limit*))
(let ((unused-portion (address-difference *weak-pointer-limit*
(address1+ end))))
(store! end (make-header (enum stob byte-vector)
(cells->bytes
(a-units->cells unused-portion)))))))))
(define (scan-weak-pointer-blocks start end)
(let loop ((start start) (end end))
(let ((next (integer->address (fetch (address2+ start)))))
(scan-weak-pointer-block start end)
(if (not (null-address? next))
(loop (address- next weak-pointer-alloc-quantum) next)))))
; Go from START to END putting headers on the weak pointers and seeing if
; their contents were traced.
(define (scan-weak-pointer-block start end)
(do ((scan start (address2+ scan)))
((address>= scan end))
(store! scan weak-pointer-header)
(let ((value (fetch (address1+ scan))))
(if (and (in-oldspace? value)
(stob? value))
(store! (address1+ scan)
(let ((h (stob-header value)))
(if (stob? h) h false)))))))
;----------------
; Undumpable records
;
; Record types may be marked as `undumpable', in which case they are replaced in
; images by the value of their first slot.
(define (undumpable? x)
(and (gc-record? x)
(let ((type (record-ref x 0)))
(and (gc-record? type)
(= false (record-ref type 1))))))
(define (gc-record? x)
(and (stob? x)
(let ((header (stob-header x)))
(if (stob? header)
(record? header)
(record? x)))))
(define (undumpable-alias record)
(record-ref record 1))
; This is a bit weird.
;
; We want to cons a list of undumpable records that the user is trying to dump.
; The list is used by the write-image instruction after the image is written out,
; so it needs to be in what is currently oldspace. We swap the spaces, cons
; onto the list, and then swap back.
;
; We only return the first one-thousand undumpable objects because:
; A. It is unlikely anyone will want more.
; B. We don't want to get hung up in MEMQ? in pathological cases.
; C. Using an NlogN algorithm would be too much work for this.
(define (note-undumpable! thing)
(if (and (<= *undumpable-count* 1000)
(not (vm-memq? thing *undumpable-records*)))
(begin
(set! *undumpable-count* (+ 1 *undumpable-count*))
(swap-spaces)
(if (s48-available? vm-pair-size)
(set! *undumpable-records*
(vm-cons thing
*undumpable-records*
(s48-preallocate-space vm-pair-size))))
(swap-spaces))))
(define (vm-memq? thing list)
(let loop ((list list))
(cond ((vm-eq? null list)
#f)
((vm-eq? (vm-car list) thing)
#t)
(else
(loop (vm-cdr list))))))