; -*- Mode: Scheme; Syntax: Scheme; Package: data; -*-

; This is file gc.scm.

;;;; Garbage collector

(declare (do-not-integrate read-descriptor write-descriptor))

(define *root* (enter-fixnum 0))	;What the GC roots from
(define *finished* (unassigned))	;Where the GC returns to
(define *filename* "s48.image")

(define *newspace-begin* 0)
(define *newspace-end* 0)
(define *oldspace-begin* 0)
(define *oldspace-end* 0)

; MARGIN is the amount of space that can be safely allocated
; before checking to see whether space is available.

(define *margin* (cells->a-units 258))

(define (initialize-heap)
  ;; Divide all of memory into two parts.
  (let ((semisize (addr/ (addr- *memory-end* *memory-begin*) 2)))
    (set! *newspace-begin* *memory-begin*)
    (set! *newspace-end* (addr+ *memory-begin* semisize))
    (set! *oldspace-begin* *newspace-end*)
    (set! *oldspace-end* (addr+ *oldspace-begin* semisize))
    (reset-heap-pointer)
    (set! *root* quiescent)
    (set! *stack* quiescent)))

(define (reset-heap-pointer)
  (set! *hp* (addr1+ *newspace-begin*))
  (set! *limit* (addr- *newspace-end* *margin*)))

(define (in-oldspace? descriptor)
  (and (stob? descriptor)
       (let ((a (address-after-header descriptor)))
         (and (addr>= a *oldspace-begin*)
              (addr< a *oldspace-end*)))))

; The following is used in exactly one place, namely the main dispatch
; of the evaluator.  That's the only place from which the garbage
; collector can be called.

(define (time-to-collect?)
  (addr>= *hp* *limit*))

; Collector

(define *scan* 0)

(define (store-next! descriptor)
  (store! *hp* descriptor)
  (set! *hp* (addr1+ *hp*)))

(define (scan-next)
  (let ((x (fetch *scan*)))
    (set! *scan* (addr1+ *scan*))
    x))

; Roots from *root* and *stack*.

(define (collect)
  ;; Flip
  (let ((b *newspace-begin*))
    (set! *newspace-begin* *oldspace-begin*)
    (set! *oldspace-begin* b))
  (let ((e *newspace-end*))
    (set! *newspace-end* *oldspace-end*)
    (set! *oldspace-end* e))
  (set! *limit* (addr- *newspace-end* *margin*))
  (set! *hp* *newspace-begin*)
  ;; Root
  (store-next! *root*)
  (store-next! *stack*)
  (set! *scan* *newspace-begin*)
  (goto scan))

(define (scan)
  (cond ((addr< *scan* *hp*)
	 (let ((thing (fetch *scan*)))
	   (cond ((b-vector-header? thing)
		  (set! *scan*
			(addr+ (addr1+ *scan*) (header-a-units thing)))
		  (goto scan))
		 ((in-oldspace? thing)
		  (let ((h (stob-header thing)))
		    (cond ((stob? h)		;***Broken heart
			   ;; (assert (in-newspace? h))
			   (store! *scan* h)
			   (set! *scan* (addr1+ *scan*))
			   (goto scan))
			  (else
			   ;; Copy an object
			   (store-next! h)
			   (let ((new (make-stob-descriptor *hp*)))
			     (stob-header-set! thing new) ;***Break heart
			     (store! *scan* new)
			     (set! *scan* (addr1+ *scan*)))
			   (let ((new-hp (addr+ *hp* (header-a-units h))))
			     (do ((o (address-after-header thing)
				     (addr1+ o)))
				 ((addr>= *hp* new-hp)
				  (goto scan))
			       (let ((p (fetch o)))
				 (assert (or (b-vector-header? h)
					     (not (stob? p))
					     (in-oldspace? p)))
				 (store-next! p))))))))
		 (else
		  (set! *scan* (addr1+ *scan*))
		  (goto scan)))))
	((addr>= *hp* *limit*)
	 (error "out of memory"))
	(else
	 (set! *root* (fetch *newspace-begin*))
	 (set! *stack* (fetch (addr1+ *newspace-begin*)))
	 (map-over-open-ports!
	   (lambda (port)
	     (if (stob? (stob-header port))
		 (stob-header port)
		 (begin (close-port-noisily port)
			false))))
	 (computed-goto *finished*))))


;;;; Write-image and read-image

(define level 5)

(define (write-image)
  (call-with-output-file *filename*
    (lambda (port)
      (map-over-open-ports!
	(lambda (port)
	  ;; Don't let the restored image get confused by open ports.
	  (close-port-noisily port)
	  false))
      (write-descriptor (if little-endian? 1 2) port)
      (write-descriptor bits-per-byte    port)
      (write-descriptor level            port)
      (write-descriptor *newspace-begin* port)
      (write-descriptor *hp*             port)
      (write-descriptor *root*           port)
      (set! *scan* *newspace-begin*)
      (let loop ()
        (cond ((addr>= *scan* *hp*)
	       (computed-goto *finished*))
	      (else
	       (let ((d (scan-next)))
		 (write-descriptor d port)
		 (cond ;;((eq? d the-primitive-header)
			;; Write out symbolic name of label.
			;;(write (label->name (fixnum->label (scan-next))) port))
		       ((b-vector-header? d)
			(let ((z (addr+ *scan* (header-a-units d))))
			  (do ()
			      ((addr>= *scan* z))
			    (write-descriptor (scan-next) port))))))))))))

(define (write-descriptor thing port)
  (write thing port)
  (newline port))

(define (read-image)
  (call-with-input-file *filename*
    (lambda (port)
      (let* ((old-l-e? (let ((n (read-descriptor port)))
			 (cond ((=& n 1) #t)
			       ((=& n 2) #f)
			       (else (error "bogus image file")))))
	     (old-level (read-descriptor port))
	     (old-bits-per-byte (read-descriptor port))
	     (old-bytes-per-cell (read-descriptor port))
	     (old-begin (read-descriptor port))
	     (old-hp    (read-descriptor port))
	     (old-root  (read-descriptor port)))
	(if (not (=& old-level level))
	    (error "format of image is incompatible with this version of system"
		   old-level level))
	(if (not (=& old-bits-per-byte bits-per-byte))
	    (error "incompatible bits-per-byte"
		   old-bits-per-byte bits-per-byte))
	(if (not (=& old-bytes-per-cell bytes-per-cell))
	    (error "incompatible bytes-per-cell"
		   old-bytes-per-cell bytes-per-cell))

	(initialize-heap)

	(let* ((delta (-& *newspace-begin* old-begin))
	       (new-hp (+& old-hp delta))
	       (new-limit (-& *newspace-end* *margin*)))
	  (cond ((addr>= new-hp new-limit)
		 (error "heap not big enough to restore this image"
			new-hp new-limit))
		(else
		 (initialize-i/o-system)  ;clear out port vectors
		 (set! *root* (adjust old-root delta))
		 (let loop ()
		   (cond ((addr>= *hp* new-hp)
			  (computed-goto *finished*))
			 (else
			  (let ((d (adjust (read-descriptor port) delta)))
			    (store-next! d)
			    (cond ;;((eq? d the-primitive-header)
				   ;; Read symbolic label name.
				   ;;(store-next!
				   ;;  (label->fixnum (name->label (read port)))))
				  ((b-vector-header? d)
				   (let ((z (addr+ *hp* (header-a-units d))))
				     (do ()
					 ((addr>= *hp* z))
				       (let ((thing (read-descriptor port)))
					 (store-next!
					   (maybe-reverse-bytes thing old-l-e?)))))))
			    (loop))))))))))))

(define (adjust descriptor delta)
  (cond ((stob? descriptor)
         (make-stob-descriptor
	   (addr+ (address-after-header descriptor) delta)))
        (else descriptor)))

(define (maybe-reverse-bytes thing l-e?)
  ;; 1 = little, 2 = big
  (if (if l-e? (not little-endian?) little-endian?)
      ;; This loop hasn't been tested, so I don't expect it to work.
      (do ((x thing (high-bits x bits-per-byte))
	   (y 0 (adjoin-bits (low-bits x bits-per-byte) y bits-per-byte))
	   (n bytes-per-cell (- n 1)))
	  ((= n 0) y))
      thing))

(define (read-descriptor port)
  (let ((thing (read port)))
    (if (eof-object? thing)
	(error "premature end of file!" *scan*)
	thing)))