#| -*-Scheme-*-

$Id: gc.scm,v 14.23 2006/09/06 04:59:30 cph Exp $

Copyright 1986,1987,1988,1989,1990,1991 Massachusetts Institute of Technology
Copyright 1992,1993,2005,2006 Massachusetts Institute of Technology

This file is part of MIT/GNU Scheme.

MIT/GNU Scheme is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at
your option) any later version.

MIT/GNU Scheme is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with MIT/GNU Scheme; if not, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
USA.

|#

;;;; Garbage Collector
;;; package: (runtime garbage-collector)

(declare (usual-integrations))

(define (initialize-package!)
  (set! gc-boot-loading? #t)
  (set! hook/gc-flip default/gc-flip)
  (set! hook/purify default/purify)
  (set! hook/stack-overflow default/stack-overflow)
  (set! hook/hardware-trap default/hardware-trap)
  (set! default-safety-margin 4500)
  (set! pure-space-queue (list 'PURE-SPACE-QUEUE))
  (set! constant-space-queue (list 'CONSTANT-SPACE-QUEUE))
  (set! hook/gc-start default/gc-start)
  (set! hook/gc-finish default/gc-finish)
  (let ((fixed-objects (get-fixed-objects-vector)))
    (let ((interrupt-vector (vector-ref fixed-objects 1)))
      (vector-set! interrupt-vector 0 condition-handler/stack-overflow)
      (vector-set! interrupt-vector 2 condition-handler/gc))
    (vector-set! fixed-objects #x0C condition-handler/hardware-trap)
    ((ucode-primitive set-fixed-objects-vector!) fixed-objects)))

(define (condition-handler/gc interrupt-code interrupt-enables)
  interrupt-code interrupt-enables
  (hook/gc-flip default-safety-margin))

(define (condition-handler/stack-overflow interrupt-code interrupt-enables)
  interrupt-code
  (hook/stack-overflow)
  (set-interrupt-enables! interrupt-enables))

(define (condition-handler/hardware-trap escape-code)
  ((ucode-primitive set-trap-state!)
   ((ucode-primitive set-trap-state!) 2)) ; Ask.
  (hook/hardware-trap escape-code))

(define hook/gc-flip)
(define hook/purify)
(define hook/stack-overflow)
(define hook/hardware-trap)
(define default-safety-margin)

(define (default/gc-flip safety-margin)
  (let ((try-queue
	 (lambda (queue pure?)
	   (let ((items (cdr queue)))
	     (and (pair? items)
		  (let ((result
			 (purify-internal (if (pair? (cdr items))
					      items
					      (car items))
					  pure?
					  safety-margin)))
		    (and (pair? result)
			 (begin
			   (if (car result)
			       (set-cdr! queue '())
			       (begin
				 (set-cdr! queue (cdr items))
				 (queued-purification-failure)))
			   (cdr result)))))))))
    (or (try-queue pure-space-queue #t)
	(try-queue constant-space-queue #f)
	(gc-flip-internal safety-margin))))

(define (queued-purification-failure)
  (warn "Unable to purify all queued items; dequeuing one."))

(define (default/purify item pure-space? queue?)
  (if (not (if pure-space? (object-pure? item) (object-constant? item)))
      (if queue?
	  (let ((queue (if pure-space? pure-space-queue constant-space-queue)))
	    (with-absolutely-no-interrupts
	      (lambda ()
		(set-cdr! queue (cons item (cdr queue)))
		unspecific)))
	  (let loop ()
	    (let ((result
		   (purify-internal item
				    pure-space?
				    default-safety-margin)))
	      (cond ((not (pair? result))
		     ;; Wrong phase -- try again.
		     (gc-flip)
		     (loop))
		    ((not (car result))
		     (error "PURIFY: not enough room in constant space"
			    item))))))))

(define (default/stack-overflow)
  (abort->nearest "Aborting!: maximum recursion depth exceeded"))

(define (default/hardware-trap escape-code)
  escape-code
  (abort->nearest "Aborting!: the hardware trapped"))

(define pure-space-queue)
(define constant-space-queue)
(define hook/gc-start)
(define hook/gc-finish)

(define (gc-flip-internal safety-margin)
  (let ((start-value (hook/gc-start)))
    (let ((space-remaining ((ucode-primitive garbage-collect) safety-margin)))
      (gc-finish start-value space-remaining)
      space-remaining)))

(define (purify-internal item pure-space? safety-margin)
  (let ((start-value (hook/gc-start)))
    (let ((result
	   ((ucode-primitive primitive-purify) item
					       pure-space?
					       safety-margin)))
      (if result
	  (gc-finish start-value (cdr result)))
      result)))

(define (default/gc-start)
  #f)

(define (default/gc-finish start-value space-remaining)
  start-value space-remaining
  #f)

(define (gc-finish start-value space-remaining)
  (if (< space-remaining 4096)
      (if gc-boot-loading?
	  (let ((console ((ucode-primitive tty-output-channel 0))))
	    ((ucode-primitive channel-write 4)
	     console
	     gc-boot-death-message
	     0
	     ((ucode-primitive string-length 1) gc-boot-death-message))
	    ((ucode-primitive exit-with-value 1) #x14))
	  (abort->nearest
	   (cmdl-message/append
	    (cmdl-message/strings "Aborting!: out of memory")
	    ;; Clean up whatever possible to avoid a reoccurrence.
	    (cmdl-message/active
	     (lambda (port)
	       port
	       (with-gc-notification! #t gc-clean)))))))
  ((ucode-primitive request-interrupts! 1) interrupt-bit/after-gc)
  (hook/gc-finish start-value space-remaining))

(define gc-boot-loading?)
  
(define gc-boot-death-message
  "\n;; Aborting boot-load: Not enough memory to load -- Use -large option.\n")

;;;; User Primitives

(define (set-gc-safety-margin! #!optional safety-margin)
  (if (not (or (default-object? safety-margin) (not safety-margin)))
      (begin
	(set! default-safety-margin safety-margin)
	(gc-flip safety-margin)))
  default-safety-margin)

(define (gc-flip #!optional safety-margin)
  ;; Optionally overrides the GC safety margin for this flip only.
  (with-absolutely-no-interrupts
   (lambda ()
     (hook/gc-flip (if (default-object? safety-margin)
		       default-safety-margin
		       safety-margin)))))

(define (flush-purification-queue!)
  (if (or (pair? (cdr pure-space-queue))
	  (pair? (cdr constant-space-queue)))
      (begin
	(gc-flip)
	(flush-purification-queue!))))

(define (purify item #!optional pure-space? queue?)
  ;; Purify an item -- move it into pure space and clean everything by
  ;; doing a gc-flip.
  (hook/purify item
	       (if (default-object? pure-space?) #t pure-space?)
	       (if (default-object? queue?) #t queue?))
  item)

(define (constant-space/in-use)
  (let ((v (gc-space-status)))
    (- (vector-ref v 2)
       (vector-ref v 1))))