scheme48/scheme/vm/gc-twospace/gc.scm

; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
; Copyright (c) 1993-2008 by Richard Kelsey and Jonathan Rees. See file COPYING.

; Collector

; (S48-TRACE-LOCATIONS! start end)	; trace all roots
; (S48-TRACE-VALUE value) => copied value
; (S48-TRACE-STOB-CONTENTS! stob)

(define *gc-count* 0)
(define (s48-gc-count) *gc-count*)

(define *gc-seconds* 0)
(define *gc-mseconds* 0)

(define (s48-gc-run-time)
  (values *gc-seconds* *gc-mseconds*))

(define (s48-collect force-major?)
  (receive (start-seconds start-mseconds) (run-time)
    (set! *from-begin* (heap-begin))
    (set! *from-end* (heap-limit))
    (swap-spaces)
    (set-heap-pointer! (heap-begin))
    (set! *weak-pointer-hp* null-address)
    (s48-gc-root)                      ; trace the interpreter's roots
    (do-gc)
    (clean-weak-pointers)
    (s48-post-gc-cleanup #t           ; it's always a major collection
                         (in-trouble?))
    (set! *gc-count* (+ *gc-count* 1))
    (receive (end-seconds end-mseconds) (run-time)
      (if (>= end-mseconds start-mseconds)
          (begin
            (set! *gc-seconds* (+ *gc-seconds*
                                  (- end-seconds start-seconds)))
            (set! *gc-mseconds* (+ *gc-mseconds*
                                   (- end-mseconds start-mseconds))))
          (begin
            (set! *gc-seconds* (+ *gc-seconds*
                                  (- (- end-seconds start-seconds) 1)))
            (set! *gc-mseconds* (+ *gc-mseconds*
                                   (- (+ 1000 end-mseconds)
                                      start-mseconds))))))))
  

(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)
  (if (in-oldspace? stob)
      (copy-object stob)
      stob))

; Scan the heap, copying pointed to objects, starting from START.  Quit once
; the scanning pointer catches up with the heap pointer.

(define (do-gc)
  (let loop ((start (heap-begin)))
    (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))))))

(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))
		       ((continuation-header? thing)
			(let ((size (header-length-in-a-units thing)))
			  (set-heap-pointer! frontier)
			  (trace-continuation next size)
			  (loop (address+ next size)
				(heap-pointer))))
		       (else
			(loop next 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)))))))