DataMuseum.dk

top - metrics - download

    Length: 5049 (0x13b9)
    Types: TextFile
    Names: »gc.scm.77«

└─⟦a0efdde77⟧ Bits:30001252 EUUGD11 Tape, 1987 Spring Conference Helsinki
    └─⟦this⟧ »EUUGD11/gnu-31mar87/scheme/scm/gc.scm.77« 

TextFile

;;; -*-Scheme-*-
;;;
;;;	Copyright (c) 1984 Massachusetts Institute of Technology
;;;
;;;	This material was developed by the Scheme project at the
;;;	Massachusetts Institute of Technology, Department of
;;;	Electrical Engineering and Computer Science.  Permission to
;;;	copy this software, to redistribute it, and to use it for any
;;;	purpose is granted, subject to the following restrictions and
;;;	understandings.
;;;
;;;	1. Any copy made of this software must include this copyright
;;;	notice in full.
;;;
;;;	2. Users of this software agree to make their best efforts (a)
;;;	to return to the MIT Scheme project any improvements or
;;;	extensions that they make, so that these may be included in
;;;	future releases; and (b) to inform MIT of noteworthy uses of
;;;	this software.
;;;
;;;	3.  All materials developed as a consequence of the use of
;;;	this software shall duly acknowledge such use, in accordance
;;;	with the usual standards of acknowledging credit in academic
;;;	research.
;;;
;;;	4. MIT has made no warrantee or representation that the
;;;	operation of this software will be error-free, and MIT is
;;;	under no obligation to provide any services, by way of
;;;	maintenance, update, or otherwise.
;;;
;;;	5.  In conjunction with products arising from the use of this
;;;	material, there shall be no use of the name of the
;;;	Massachusetts Institute of Technology nor of any adaptation
;;;	thereof in any advertising, promotional, or sales literature
;;;	without prior written consent from MIT in each case.
;;;

;;;; Garbage Collector
\f


(declare (usual-integrations)
	 (compilable-primitive-functions
	  garbage-collect
	  primitive-purify
	  primitive-impurify
	  primitive-fasdump
	  set-interrupt-enables!
	  enable-interrupts!
	  with-interrupt-mask
	  primitive-gc-type
	  pure?
	  get-next-constant
	  call-with-current-continuation
	  hunk3-cons
	  get-fixed-objects-vector
	  set-fixed-objects-vector!))

(define add-gc-daemon!)
(define gc-flip)
(define purify)
(define impurify)
(define fasdump)
(define suspend-world)
(define set-default-gc-safety-margin!)

(let ((Default-Safety-Margin 4096))

  ;; SET-DEFAULT-GC-SAFETY-MARGIN! changes the amount of memory
  ;; saved from the heap to allow the GC handler to run
  (set! set-default-gc-safety-margin!
    (named-lambda (set-default-gc-safety-margin! margin)
      (if (null? margin)
	  Default-Safety-Margin
          (set! Default-Safety-Margin margin))))

\f


;;;; Cold Load GC

  (define (reset)
    (enable-interrupts! INTERRUPT-MASK-NONE))

  ;; User call -- optionally overrides the default GC safety
  ;; margin for this flip only

  (set! gc-flip
	(named-lambda (gc-flip #!Optional New-Safety-Margin)
	  (with-interrupt-mask INTERRUPT-MASK-NONE
	   (lambda (old-interrupt-mask)
	     (garbage-collect
	      (if (unassigned? New-Safety-Margin)
		  Default-Safety-Margin
		  New-Safety-Margin))))))

  (vector-set!
   (vector-ref (get-fixed-objects-vector) 1)
   2	; Local Garbage Collection Interrupt
   (named-lambda (gc-interrupt interrupt-code interrupt-enables)
     (gc-flip Default-Safety-Margin)))

;;; The GC daemon is invoked by the microcode whenever there is a need.
;;; All we provide here is a trivial extension mechanism.

(vector-set! (get-fixed-objects-vector)
	     11
	     (named-lambda (gc-daemon)
	       (let loop ((daemons gc-daemons))
		 (if (not (null? daemons))
		     (sequence ((car daemons))
			       (loop (cdr daemons)))))))

(set-fixed-objects-vector! (get-fixed-objects-vector))

(define gc-daemons '())

(set! add-gc-daemon!
      (named-lambda (add-gc-daemon! daemon)
	(if (not (memq daemon gc-daemons))
	    (set! gc-daemons (cons daemon gc-daemons)))))

(reset)
\f


;;;; "GC-like" Primitives

  ;; Purify an item -- move it into pure space and clean everything
  ;; by doing a gc-flip

  (set! purify
    (named-lambda (purify item #!optional really-pure?)
      (if (primitive-purify item
			    (if (unassigned? really-pure?)
				#!FALSE
				really-pure?))
	  item
	  (error "Not enough room in constant space"
		 'PURIFY item))))
	      
  (set! impurify
    (named-lambda (impurify object)
      (if (zero? (primitive-gc-type object))
	  object
	  (if (pure? object)
	      (primitive-impurify object)
	      object))))

  (set! fasdump
    (named-lambda (fasdump object filename)
      (if (primitive-fasdump object filename #!FALSE)
	  object
	  (error "Object is too large to be dumped"
		 'FASDUMP object))))
\f


;;;; Suspension

(set! suspend-world
      (named-lambda (suspend-world suspender after-suspend after-restore)
	(with-interrupt-mask INTERRUPT-MASK-GC-OK
	  (lambda (ie)
            ((call-with-current-continuation
	      (lambda (cont)
	        (let ((fixed-objects-vector (get-fixed-objects-vector)))
		  (call-with-current-continuation
		   (lambda (restart)
		     (gc-flip)
		     (suspender restart)
		     (cont after-suspend)))
		  (set-fixed-objects-vector! fixed-objects-vector)
		  (reset)
		  ((access snarf-version microcode-system))
		  after-restore)))
	     ie)))))

;;; end LET.
)