From bac57b003553581a98be6108fb491bd36f1b8837 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 10 Apr 2000 18:32:39 +0000
Subject: [PATCH] Add new implementation of GC finalizers, a cleaner
 replacement for the old protection list abstraction.  Unlike protection
 lists, GC finalizers keep themselves clean, eliminating the need for the
 programmer to interact with GC daemons and events.

---
 v7/src/runtime/gcfinal.scm  | 164 ++++++++++++++++++++++++++++++++++++
 v7/src/runtime/gdbm.scm     |  27 +++---
 v7/src/runtime/io.scm       |  92 +++-----------------
 v7/src/runtime/make.scm     |  37 ++++----
 v7/src/runtime/os2graph.scm |  43 ++++------
 v7/src/runtime/runtime.pkg  |  22 +++--
 v7/src/runtime/x11graph.scm | 117 ++++++++++---------------
 7 files changed, 280 insertions(+), 222 deletions(-)
 create mode 100644 v7/src/runtime/gcfinal.scm

diff --git a/v7/src/runtime/gcfinal.scm b/v7/src/runtime/gcfinal.scm
new file mode 100644
index 000000000..8ce1e8ea4
--- /dev/null
+++ b/v7/src/runtime/gcfinal.scm
@@ -0,0 +1,164 @@
+#| -*-Scheme-*-
+
+$Id: gcfinal.scm,v 14.1 2000/04/10 18:32:17 cph Exp $
+
+Copyright (c) 2000 Massachusetts Institute of Technology
+
+This program 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.
+
+This program 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 this program; if not, write to the Free Software
+Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+|#
+
+;;;; Garbage Finalization
+;;; package: (runtime gc-finalizer)
+
+;;; These will cause problems on interpreted systems, due to the
+;;; consing of the interpreter.  For now we'll only run this compiled.
+
+(declare (usual-integrations))
+
+(define-structure (gc-finalizer (constructor %make-gc-finalizer
+					     (procedure reset-on-restore?)))
+  (procedure #f read-only #t)
+  (reset-on-restore? #f read-only #t)
+  (items '()))
+
+(define (guarantee-gc-finalizer object procedure)
+  (if (not (gc-finalizer? object))
+      (error:wrong-type-argument object "GC finalizer" procedure)))
+
+(define (make-gc-finalizer procedure #!optional reset-on-restore?)
+  (if (not (procedure? procedure))
+      (error:wrong-type-argument procedure "procedure" 'MAKE-GC-FINALIZER))
+  (if (not (procedure-arity-valid? procedure 1))
+      (error:bad-range-argument procedure 'MAKE-GC-FINALIZER))
+  (let ((finalizer
+	 (%make-gc-finalizer procedure
+			     (if (default-object? reset-on-restore?)
+				 #t
+				 reset-on-restore?))))
+    (set! gc-finalizers (weak-cons finalizer gc-finalizers))
+    finalizer))
+
+(define (add-to-gc-finalizer! finalizer object context)
+  (guarantee-gc-finalizer finalizer 'ADD-TO-GC-FINALIZER!)
+  (if (object-pointer? object)
+      (without-interrupts
+       (lambda ()
+	 (set-gc-finalizer-items!
+	  finalizer
+	  (cons (weak-cons object context)
+		(gc-finalizer-items finalizer)))))))
+
+(define (remove-from-gc-finalizer! finalizer object)
+  (guarantee-gc-finalizer finalizer 'REMOVE-FROM-GC-FINALIZER!)
+  (if (object-pointer? object)
+      (let ((procedure (gc-finalizer-procedure finalizer)))
+	(without-interrupts
+	 (lambda ()
+	   (let loop ((items (gc-finalizer-items finalizer)) (prev #f))
+	     (if (pair? items)
+		 (if (eq? object (weak-car (car items)))
+		     (let ((next (cdr items)))
+		       (if prev
+			   (set-cdr! prev next)
+			   (set-gc-finalizer-items! finalizer next))
+		       (procedure (weak-cdr (car items)))
+		       (loop next prev))
+		     (loop (cdr items) items)))))))))
+
+(define (remove-all-from-gc-finalizer! finalizer)
+  (guarantee-gc-finalizer finalizer 'REMOVE-ALL-FROM-GC-FINALIZER!)
+  (let ((procedure (gc-finalizer-procedure finalizer)))
+    (without-interrupts
+     (lambda ()
+       (let loop ()
+	 (let ((items (gc-finalizer-items finalizer)))
+	   (if (pair? items)
+	       (begin
+		 (set-gc-finalizer-items! finalizer (cdr items))
+		 (let ((object (weak-cdr (car items))))
+		   (if object
+		       (procedure object)))
+		 (loop)))))))))
+
+(define (search-gc-finalizer finalizer predicate)
+  (guarantee-gc-finalizer finalizer 'SEARCH-GC-FINALIZER)
+  (without-interrupts
+   (lambda ()
+     (let loop ((items (gc-finalizer-items finalizer)))
+       (and (pair? items)
+	    (let ((object (weak-car (car items))))
+	      (if (and object (predicate object))
+		  object
+		  (loop (cdr items)))))))))
+
+(define (gc-finalizer-elements finalizer)
+  (guarantee-gc-finalizer finalizer 'GC-FINALIZER-ELEMENTS)
+  (without-interrupts
+   (lambda ()
+     (let loop ((items (gc-finalizer-items finalizer)) (objects '()))
+       (if (pair? items)
+	   (loop (cdr items)
+		 (let ((object (weak-car (car items))))
+		   (if object
+		       (cons object objects)
+		       objects)))
+	   (reverse! objects))))))
+
+(define gc-finalizers)
+
+(define (reset-gc-finalizers)
+  (without-interrupts
+   (lambda ()
+     (walk-gc-finalizers-list
+      (lambda (finalizer)
+	(if (gc-finalizer-reset-on-restore? finalizer)
+	    (set-gc-finalizer-items! finalizer '())))))))
+
+(define (run-gc-finalizers)
+  (walk-gc-finalizers-list
+   (lambda (finalizer)
+     (let ((procedure (gc-finalizer-procedure finalizer)))
+       (let loop ((items (gc-finalizer-items finalizer)) (prev #f))
+	 (if (pair? items)
+	     (if (weak-pair/car? (car items))
+		 (loop (cdr items) items)
+		 (begin
+		   (procedure (weak-cdr (car items)))
+		   (let ((next (cdr items)))
+		     (if prev
+			 (set-cdr! prev next)
+			 (set-gc-finalizer-items! finalizer next))
+		     (loop next prev))))))))))
+
+(define (walk-gc-finalizers-list procedure)
+  (let loop ((finalizers gc-finalizers) (prev #f))
+    (if (weak-pair? finalizers)
+	(let ((finalizer (weak-car finalizers)))
+	  (if finalizer
+	      (begin
+		(procedure finalizer)
+		(loop (weak-cdr finalizers) finalizers))
+	      (let ((next (weak-cdr finalizers)))
+		(if prev
+		    (weak-set-cdr! prev next)
+		    (set! gc-finalizers next))
+		(loop next prev)))))))
+
+(define (initialize-package!)
+  (set! gc-finalizers '())
+  (add-gc-daemon! run-gc-finalizers))
+
+(define (initialize-events!)
+  (add-event-receiver! event:after-restore reset-gc-finalizers))
\ No newline at end of file
diff --git a/v7/src/runtime/gdbm.scm b/v7/src/runtime/gdbm.scm
index f87f04380..39cca8917 100644
--- a/v7/src/runtime/gdbm.scm
+++ b/v7/src/runtime/gdbm.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: gdbm.scm,v 1.2 1999/01/02 06:11:34 cph Exp $
+$Id: gdbm.scm,v 1.3 2000/04/10 18:32:32 cph Exp $
 
-Copyright (c) 1996, 1999 Massachusetts Institute of Technology
+Copyright (c) 1996, 1999, 2000 Massachusetts Institute of Technology
 
 This program is free software; you can redistribute it and/or modify
 it under the terms of the GNU General Public License as published by
@@ -43,18 +43,17 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 	      (gdbm-error ((ucode-primitive gdbm-open 4)
 			   filename block-size flags mode))))
 	 (let ((gdbf (make-gdbf descriptor filename)))
-	   (add-to-protection-list! gdbf-list gdbf descriptor)
+	   (add-to-gc-finalizer! gdbf-finalizer gdbf descriptor)
 	   gdbf))))))
 
 (define (gdbm-close gdbf)
   (if (not (gdbf? gdbf))
       (error:wrong-type-argument gdbf "gdbm handle" 'GDBM-CLOSE))
-  (let ((descriptor (gdbf-descriptor gdbf)))
-    (if descriptor
-	(without-interrupts
-	 (lambda ()
-	   ((ucode-primitive gdbm-close 1) descriptor)
-	   (remove-from-protection-list! gdbf-list gdbf)
+  (without-interrupts
+   (lambda ()
+     (if (gdbf-descriptor gdbf)
+	 (begin
+	   (remove-from-gc-finalizer! gdbf-finalizer gdbf)
 	   (set-gdbf-descriptor! gdbf #f))))))
 
 ;; Parameters to gdbm_store for simple insertion or replacement in the
@@ -120,11 +119,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
   (if (string? object) (error "gdbm error:" object))
   object)
 
-(define gdbf-list)
+(define gdbf-finalizer)
 (define (initialize-package!)
-  (set! gdbf-list (make-protection-list))
-  (add-gc-daemon!
-   (lambda ()
-     (clean-lost-protected-objects gdbf-list (ucode-primitive gdbm-close 1))))
-  (add-event-receiver! event:after-restore
-		       (lambda () (drop-all-protected-objects gdbf-list))))
\ No newline at end of file
+  (set! gdbf-finalizer (make-gc-finalizer (ucode-primitive gdbm-close 1)))
+  unspecific)
\ No newline at end of file
diff --git a/v7/src/runtime/io.scm b/v7/src/runtime/io.scm
index a81a7d745..386b1880f 100644
--- a/v7/src/runtime/io.scm
+++ b/v7/src/runtime/io.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: io.scm,v 14.60 1999/11/08 18:28:11 cph Exp $
+$Id: io.scm,v 14.61 2000/04/10 18:32:34 cph Exp $
 
-Copyright (c) 1988-1999 Massachusetts Institute of Technology
+Copyright (c) 1988-2000 Massachusetts Institute of Technology
 
 This program is free software; you can redistribute it and/or modify
 it under the terms of the GNU General Public License as published by
@@ -25,14 +25,14 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 (declare (usual-integrations))
 
 (define open-channels-list)
-(define open-directories-list)
+(define open-directories)
 (define have-select?)
 
 (define (initialize-package!)
   (set! open-channels-list (list 'OPEN-CHANNELS-LIST))
   (add-gc-daemon! close-lost-open-files-daemon)
-  (set! open-directories-list (make-protection-list))
-  (add-gc-daemon! close-lost-open-directories-daemon)
+  (set! open-directories
+	(make-gc-finalizer (ucode-primitive new-directory-close 1)))
   (set! have-select? ((ucode-primitive have-select? 0)))
   (add-event-receiver! event:after-restore primitive-io/reset!))
 
@@ -152,7 +152,6 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
   ;; This is invoked after disk-restoring.
   ;; It "cleans" the new runtime system.
   (close-all-open-channels-internal (lambda (ignore) ignore))
-  (drop-all-protected-objects open-directories-list)
   (set! have-select? ((ucode-primitive have-select? 0)))
   unspecific)
 
@@ -472,22 +471,16 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
    (lambda ()
      (let ((descriptor ((ucode-primitive new-directory-open 1) name)))
        (let ((channel (make-directory-channel descriptor)))
-	 (add-to-protection-list! open-directories-list channel descriptor)
+	 (add-to-gc-finalizer! open-directories channel descriptor)
 	 channel)))))
 
 (define (directory-channel-close channel)
   (without-interrupts
    (lambda ()
-     (let ((descriptor (directory-channel/descriptor channel)))
-       (if descriptor
-	   (begin
-	     ((ucode-primitive new-directory-close 1) descriptor)
-	     (set-directory-channel/descriptor! channel #f)
-	     (remove-from-protection-list! open-directories-list channel)))))))
-
-(define (close-lost-open-directories-daemon)
-  (clean-lost-protected-objects open-directories-list
-				(ucode-primitive new-directory-close 1)))
+     (if (directory-channel/descriptor channel)
+	 (begin
+	   (remove-from-gc-finalizer! open-directories channel)
+	   (set-directory-channel/descriptor! channel #f))))))
 
 (define (directory-channel-read channel)
   ((ucode-primitive new-directory-read 1)
@@ -498,71 +491,6 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
    (directory-channel/descriptor channel)
    prefix))
 
-;;;; Protection lists
-
-;;; These will cause problems on interpreted systems, due to the
-;;; consing of the interpreter.  For now we'll only run this compiled.
-
-(define (make-protection-list)
-  (list 'PROTECTION-LIST))
-
-;; This is used after a disk-restore, to remove invalid information.
-
-(define (drop-all-protected-objects list)
-  (set-cdr! list '()))
-
-(define (add-to-protection-list! list scheme-object microcode-object)
-  (without-interrupts
-   (lambda ()
-     (set-cdr! list
-	       (cons (weak-cons scheme-object microcode-object)
-		     (cdr list))))))
-
-(define (remove-from-protection-list! list scheme-object)
-  (without-interrupts
-   (lambda ()
-     (let loop ((associations (cdr list)) (previous list))
-       (if (not (null? associations))
-	   (if (eq? scheme-object (weak-pair/car? (car associations)))
-	       (set-cdr! previous (cdr associations))
-	       (loop (cdr associations) associations)))))))
-
-(define (clean-lost-protected-objects list cleaner)
-  ;; This assumes that interrupts are disabled.  This will normally be
-  ;; true because this should be called from a GC daemon.
-  (let loop ((associations (cdr list)) (previous list))
-    (if (not (null? associations))
-	(if (weak-pair/car? (car associations))
-	    (loop (cdr associations) associations)
-	    (begin
-	      (cleaner (weak-cdr (car associations)))
-	      (let ((next (cdr associations)))
-		(set-cdr! previous next)
-		(loop next previous)))))))
-
-(define (search-protection-list list predicate)
-  (without-interrupts
-   (lambda ()
-     (let loop ((associations (cdr list)))
-       (and (not (null? associations))
-	    (let ((scheme-object (weak-car (car associations))))
-	      (if (and scheme-object (predicate scheme-object))
-		  scheme-object
-		  (loop (cdr associations)))))))))
-
-(define (protection-list-elements list)
-  (without-interrupts
-   (lambda ()
-     (let loop ((associations (cdr list)))
-       (cond ((null? associations)
-	      '())
-	     ((weak-car (car associations))
-	      => (lambda (scheme-object)
-		   (cons scheme-object
-			 (loop (cdr associations)))))
-	     (else
-	      (loop (cdr associations))))))))
-
 ;;;; Buffered Output
 
 (define-structure (output-buffer
diff --git a/v7/src/runtime/make.scm b/v7/src/runtime/make.scm
index dc6b5d4dd..c18aaf35f 100644
--- a/v7/src/runtime/make.scm
+++ b/v7/src/runtime/make.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: make.scm,v 14.63 1999/01/02 06:06:43 cph Exp $
+$Id: make.scm,v 14.64 2000/04/10 18:32:35 cph Exp $
 
-Copyright (c) 1988-1999 Massachusetts Institute of Technology
+Copyright (c) 1988-2000 Massachusetts Institute of Technology
 
 This program is free software; you can redistribute it and/or modify
 it under the terms of the GNU General Public License as published by
@@ -200,7 +200,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 	(let ((spec (car specs)))
 	  (if (or (not (pair? spec))
 		  (symbol? (car spec)))
-	      (package-initialize spec 'INITIALIZE-PACKAGE! false)
+	      (package-initialize spec 'INITIALIZE-PACKAGE! #f)
 	      (package-initialize (car spec) (cadr spec) (caddr spec)))
 	  (loop (cdr specs))))))
 
@@ -240,7 +240,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 	  ((not optional?)
 	   (fatal-error (string-append "Could not find " filename)))
 	  (else
-	   false))))
+	   #f))))
 
 (define (eval object environment)
   (let ((value (scode-eval object environment)))
@@ -282,7 +282,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 	prim
 	(lambda (name)
 	  name				; ignored
-	  false))))
+	  #f))))
 
 (define os-name
   (intern os-name-string))
@@ -339,7 +339,8 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
       (files2
        '(("prop1d" . (RUNTIME 1D-PROPERTY))
 	 ("events" . (RUNTIME EVENT-DISTRIBUTOR))
-	 ("gdatab" . (RUNTIME GLOBAL-DATABASE))))
+	 ("gdatab" . (RUNTIME GLOBAL-DATABASE))
+	 ("gcfinal" . (RUNTIME GC-FINALIZER))))
       (load-files
        (lambda (files)
 	 (do ((files files (cdr files)))
@@ -347,24 +348,25 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 	   (eval (file->object (car (car files)) #t #f)
 		 (package-reference (cdr (car files))))))))
   (load-files files1)
-  (package-initialize '(RUNTIME GC-DAEMONS) 'INITIALIZE-PACKAGE! true)
-  (package-initialize '(RUNTIME GARBAGE-COLLECTOR) 'INITIALIZE-PACKAGE! true)
+  (package-initialize '(RUNTIME GC-DAEMONS) 'INITIALIZE-PACKAGE! #t)
+  (package-initialize '(RUNTIME GARBAGE-COLLECTOR) 'INITIALIZE-PACKAGE! #t)
   (lexical-assignment (package-reference '(RUNTIME GARBAGE-COLLECTOR))
 		      'CONSTANT-SPACE/BASE
 		      constant-space/base)
-  (package-initialize '(RUNTIME LIST) 'INITIALIZE-PACKAGE! true)
+  (package-initialize '(RUNTIME LIST) 'INITIALIZE-PACKAGE! #t)
   (package-initialize '(RUNTIME RANDOM-NUMBER) 'INITIALIZE-PACKAGE! #t)
   (package-initialize '(RUNTIME GENERIC-PROCEDURE) 'INITIALIZE-TAG-CONSTANTS!
 		      #t)
-  (package-initialize '(RUNTIME POPULATION) 'INITIALIZE-PACKAGE! true)
+  (package-initialize '(RUNTIME POPULATION) 'INITIALIZE-PACKAGE! #t)
   (package-initialize '(RUNTIME RECORD) 'INITIALIZE-RECORD-TYPE-TYPE! #t)
   (package-initialize '(RUNTIME DEFSTRUCT) 'INITIALIZE-STRUCTURE-TYPES! #t)
   (load-files files2)
-  (package-initialize '(RUNTIME 1D-PROPERTY) 'INITIALIZE-PACKAGE! true)
-  (package-initialize '(RUNTIME EVENT-DISTRIBUTOR) 'INITIALIZE-PACKAGE! true)
-  (package-initialize '(RUNTIME GLOBAL-DATABASE) 'INITIALIZE-PACKAGE! true)
-  (package-initialize '(RUNTIME POPULATION) 'INITIALIZE-UNPARSER! true)
-  (package-initialize '(RUNTIME 1D-PROPERTY) 'INITIALIZE-UNPARSER! true)
+  (package-initialize '(RUNTIME 1D-PROPERTY) 'INITIALIZE-PACKAGE! #t)
+  (package-initialize '(RUNTIME EVENT-DISTRIBUTOR) 'INITIALIZE-PACKAGE! #t)
+  (package-initialize '(RUNTIME GLOBAL-DATABASE) 'INITIALIZE-PACKAGE! #t)
+  (package-initialize '(RUNTIME POPULATION) 'INITIALIZE-UNPARSER! #t)
+  (package-initialize '(RUNTIME 1D-PROPERTY) 'INITIALIZE-UNPARSER! #t)
+  (package-initialize '(RUNTIME GC-FINALIZER) 'INITIALIZE-PACKAGE! #t)
 
 ;; Load everything else.
 ;; Note: The following code needs MAP* and MEMBER-PROCEDURE
@@ -398,6 +400,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
    (RUNTIME PRIMITIVE-IO)
    (RUNTIME SAVE/RESTORE)
    (RUNTIME SYSTEM-CLOCK)
+   ((RUNTIME GC-FINALIZER) INITIALIZE-EVENTS! #t)
    ;; Basic data structures
    (RUNTIME NUMBER)
    (RUNTIME CHARACTER)
@@ -512,14 +515,14 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 		      (load/purification-root object)))
 		  fasload-purification-queue)))))))
   (set! (access gc-boot-loading? (->environment '(RUNTIME GARBAGE-COLLECTOR)))
-	false)
+	#f)
   (set! fasload-purification-queue)
   (newline console-output-port)
   (write-string "purifying..." console-output-port)
   ;; First, flush whatever we can.
   (gc-clean)
   ;; Then, really purify the rest.
-  (purify roots true false)
+  (purify roots #t #f)
   (write-string "done" console-output-port))
 
 )
diff --git a/v7/src/runtime/os2graph.scm b/v7/src/runtime/os2graph.scm
index 1447f4851..a4183a988 100644
--- a/v7/src/runtime/os2graph.scm
+++ b/v7/src/runtime/os2graph.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: os2graph.scm,v 1.16 1999/11/08 18:28:28 cph Exp $
+$Id: os2graph.scm,v 1.17 2000/04/10 18:32:36 cph Exp $
 
-Copyright (c) 1995-1999 Massachusetts Institute of Technology
+Copyright (c) 1995-2000 Massachusetts Institute of Technology
 
 This program is free software; you can redistribute it and/or modify
 it under the terms of the GNU General Public License as published by
@@ -89,19 +89,18 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
       (fill-from-byte-vector ,os2-image/fill-from-byte-vector))))
   (set! event-descriptor #f)
   (set! event-previewer-registration #f)
-  (set! window-list (make-protection-list))
-  (set! image-list (make-protection-list))
+  (set! window-finalizer (make-gc-finalizer os2win-close))
+  (set! image-finalizer (make-gc-finalizer destroy-memory-ps))
   (set! user-event-mask user-event-mask:default)
   (set! user-event-queue (make-queue))
   (initialize-color-table)
-  (add-event-receiver! event:before-exit finalize-pm-state!)
-  (add-gc-daemon! close-lost-objects-daemon))
+  (add-event-receiver! event:before-exit finalize-pm-state!))
 
 (define os2-graphics-device-type)
 (define event-descriptor)
 (define event-previewer-registration)
-(define window-list)
-(define image-list)
+(define window-finalizer)
+(define image-finalizer)
 (define user-event-mask)
 (define user-event-queue)
 (define graphics-window-icon)
@@ -114,12 +113,8 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
       (begin
 	(os2win-destroy-pointer graphics-window-icon)
 	(set! graphics-window-icon)
-	(do ((windows (protection-list-elements window-list) (cdr windows)))
-	    ((null? windows))
-	  (close-window (car windows)))
-	(do ((images (protection-list-elements image-list) (cdr images)))
-	    ((null? images))
-	  (destroy-image (car images)))
+	(remove-all-from-gc-finalizer! window-finalizer)
+	(remove-all-from-gc-finalizer! image-finalizer)
 	(deregister-input-thread-event event-previewer-registration)
 	(set! event-previewer-registration #f)
 	(set! user-event-mask user-event-mask:default)
@@ -127,10 +122,6 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 	(os2win-close-event-qid event-descriptor)
 	(set! event-descriptor #f)
 	unspecific)))
-
-(define (close-lost-objects-daemon)
-  (clean-lost-protected-objects window-list os2win-close)
-  (clean-lost-protected-objects image-list destroy-memory-ps))
 
 ;;;; Window Abstraction
 
@@ -159,16 +150,15 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 (define (make-window wid width height)
   (let ((window (%make-window wid width height)))
     (set-window/backing-image! window (create-image width height))
-    (add-to-protection-list! window-list window wid)
+    (add-to-gc-finalizer! window-finalizer window wid)
     window))
 
 (define (close-window window)
   (if (window/wid window)
       (begin
 	(destroy-image (window/backing-image window))
-	(os2win-close (window/wid window))
-	(set-window/wid! window #f)
-	(remove-from-protection-list! window-list window))))
+	(remove-from-gc-finalizer! window-finalizer window)
+	(set-window/wid! window #f))))
 
 (define-integrable (os2-graphics-device/wid device)
   (window/wid (graphics-device/descriptor device)))
@@ -766,7 +756,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
   (without-interrupts
    (lambda ()
      (let ((window
-	    (search-protection-list window-list
+	    (search-gc-finalizer window-finalizer
 	      (let ((wid (event-wid event)))
 		(lambda (window)
 		  (eq? (window/wid window) wid))))))
@@ -922,7 +912,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
   (let ((ps (os2ps-create-memory-ps)))
     (os2ps-set-bitmap ps (os2ps-create-bitmap ps width height))
     (let ((image (make-image ps width height #f)))
-      (add-to-protection-list! image-list image ps)
+      (add-to-gc-finalizer! image-finalizer image ps)
       image)))
 
 (define (os2-image/set-colormap image colormap)
@@ -939,9 +929,8 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 (define (destroy-image image)
   (if (image/ps image)
       (begin
-	(destroy-memory-ps (image/ps image))
-	(set-image/ps! image #f)
-	(remove-from-protection-list! image-list image))))
+	(remove-from-gc-finalizer! image-finalizer image)
+	(set-image/ps! image #f))))
 
 (define (destroy-memory-ps ps)
   (let ((bitmap (os2ps-set-bitmap ps #f)))
diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 6466260f6..bbbd5603d 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.340 2000/04/10 03:34:03 cph Exp $
+$Id: runtime.pkg,v 14.341 2000/04/10 18:32:38 cph Exp $
 
 Copyright (c) 1988-2000 Massachusetts Institute of Technology
 
@@ -917,6 +917,19 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 	  trigger-gc-daemons!)
   (initialization (initialize-package!)))
 
+(define-package (runtime gc-finalizer)
+  (files "gcfinal")
+  (parent ())
+  (export ()
+	  add-to-gc-finalizer!
+	  gc-finalizer-elements
+	  gc-finalizer?
+	  make-gc-finalizer
+	  remove-all-from-gc-finalizer!
+	  remove-from-gc-finalizer!
+	  search-gc-finalizer)
+  (initialization (initialize-package!)))
+
 (define-package (runtime gc-notification)
   (files "gcnote")
   (parent ())
@@ -1783,7 +1796,6 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
   (files "io") 
   (parent ())
   (export ()
-	  add-to-protection-list!
 	  all-open-channels
 	  channel-blocking
 	  channel-blocking?
@@ -1809,7 +1821,6 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 	  channel-write-char-block
 	  channel-write-string-block
 	  channel?
-	  clean-lost-protected-objects
 	  close-all-open-channels
 	  close-all-open-files
 	  directory-channel-close
@@ -1817,15 +1828,12 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 	  directory-channel-read
 	  directory-channel-read-matching
 	  directory-channel?
-	  drop-all-protected-objects
 	  file-open-append-channel
 	  file-open-input-channel
 	  file-open-io-channel
 	  file-open-output-channel
 	  make-pipe
-	  make-protection-list
 	  open-pty-master
-	  protection-list-elements
 	  pty-master-continue
 	  pty-master-hangup
 	  pty-master-interrupt
@@ -1833,8 +1841,6 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 	  pty-master-quit
 	  pty-master-send-signal
 	  pty-master-stop
-	  remove-from-protection-list!
-	  search-protection-list
 	  set-terminal-input-baud-rate!
 	  set-terminal-output-baud-rate!
 	  terminal-cooked-input
diff --git a/v7/src/runtime/x11graph.scm b/v7/src/runtime/x11graph.scm
index 9e5f6783b..adb54d562 100644
--- a/v7/src/runtime/x11graph.scm
+++ b/v7/src/runtime/x11graph.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: x11graph.scm,v 1.49 1999/02/24 21:57:17 cph Exp $
+$Id: x11graph.scm,v 1.50 2000/04/10 18:32:39 cph Exp $
 
-Copyright (c) 1989-1999 Massachusetts Institute of Technology
+Copyright (c) 1989-2000 Massachusetts Institute of Technology
 
 This program is free software; you can redistribute it and/or modify
 it under the terms of the GNU General Public License as published by
@@ -197,9 +197,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 	   (starbase-filename ,x-graphics/starbase-filename)
 	   (visual-info ,x-graphics/visual-info)
 	   (withdraw-window ,x-graphics/withdraw-window))))
-  (set! display-list (make-protection-list))
-  (add-gc-daemon! close-lost-displays-daemon)
-  (add-event-receiver! event:after-restore drop-all-displays)
+  (set! display-finalizer (make-gc-finalizer x-close-display))
   (initialize-image-datatype)
   (initialize-colormap-datatype))
 
@@ -210,7 +208,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 
 ;;;; Open/Close Displays
 
-(define display-list)
+(define display-finalizer)
 
 (define-structure (x-display
 		   (conc-name x-display/)
@@ -220,11 +218,11 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 		      (lambda (display port)
 			(write-char #\space port)
 			(write (x-display/name display) port)))))
-  (name false read-only true)
+  (name #f read-only #t)
   xd
-  (window-list (make-protection-list) read-only true)
+  (window-finalizer (make-gc-finalizer x-close-window) read-only #t)
   (event-queue (make-queue))
-  (properties (make-1d-table) read-only true))
+  (properties (make-1d-table) read-only #t))
 
 (define (x-graphics/open-display name)
   (let ((name
@@ -240,14 +238,14 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 		(error:wrong-type-argument name
 					   "string or #f"
 					   x-graphics/open-display)))))
-    (or (search-protection-list display-list
+    (or (search-gc-finalizer display-finalizer
 	  (lambda (display)
 	    (string=? (x-display/name display) name)))
 	(let ((xd (x-open-display name)))
 	  (if (not xd)
 	      (error "Unable to open display:" name))
 	  (let ((display (make-x-display name xd)))
-	    (add-to-protection-list! display-list display xd)
+	    (add-to-gc-finalizer! display-finalizer display xd)
 	    (make-event-previewer display)
 	    display)))))
 
@@ -256,25 +254,9 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
    (lambda ()
      (if (x-display/xd display)
 	 (begin
-	   (do ((windows
-		 (protection-list-elements (x-display/window-list display))
-		 (cdr windows)))
-	       ((null? windows))
-	     (close-x-window (car windows)))
-	   (x-close-display (x-display/xd display))
-	   (set-x-display/xd! display false)
-	   (remove-from-protection-list! display-list display))))))
-
-(define (close-lost-displays-daemon)
-  (clean-lost-protected-objects display-list x-close-display)
-  (do ((associations (cdr display-list) (cdr associations)))
-      ((null? associations))
-    (clean-lost-protected-objects
-     (x-display/window-list (weak-car (car associations)))
-     x-close-window)))
-
-(define (drop-all-displays)
-  (drop-all-protected-objects display-list))
+	   (remove-all-from-gc-finalizer! (x-display/window-finalizer display))
+	   (remove-from-gc-finalizer! display-finalizer display)
+	   (set-x-display/xd! display #f))))))
 
 (define (make-event-previewer display)
   (let ((registration))
@@ -343,7 +325,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
   (without-interrupts
    (lambda ()
      (let ((window
-	    (search-protection-list (x-display/window-list display)
+	    (search-gc-finalizer (x-display/window-finalizer display)
 	      (let ((xw (vector-ref event 1)))
 		(lambda (window)
 		  (eq? (x-window/xw window) xw))))))
@@ -364,7 +346,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 				    event)))))))))
 
 (define event-handlers
-  (make-vector number-of-event-types false))
+  (make-vector number-of-event-types #f))
 
 (define-integrable (define-event-handler event-type handler)
   (vector-set! event-handlers event-type handler))
@@ -417,14 +399,14 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 
 ;;;; Standard Operations
 
-(define x-graphics:auto-raise? false)
+(define x-graphics:auto-raise? #f)
 
 (define-structure (x-window (conc-name x-window/)
 			    (constructor make-x-window (xw display)))
   xw
-  (display false read-only true)
+  (display #f read-only #t)
   (mapped? 'NEVER)
-  (visibility false)
+  (visibility #f)
   (user-event-mask user-event-mask:default))
 
 (define-integrable (x-graphics-device/xw device)
@@ -450,11 +432,10 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 (define (close-x-window window)
   (if (x-window/xw window)
       (begin
-	(x-close-window (x-window/xw window))
-	(set-x-window/xw! window false)
-	(remove-from-protection-list!
-	 (x-display/window-list (x-window/display window))
-	 window))))
+	(remove-from-gc-finalizer!
+	 (x-display/window-finalizer (x-window/display window))
+	 window)
+	(set-x-window/xw! window #f))))
 
 (define (x-geometry-string x y width height)
   (string-append (if (and width height)
@@ -496,7 +477,8 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 		 (vector #f resource class))))
 	  (x-window-set-event-mask xw event-mask:normal)
 	  (let ((window (make-x-window xw display)))
-	    (add-to-protection-list! (x-display/window-list display) window xw)
+	    (add-to-gc-finalizer! (x-display/window-finalizer display)
+				  window xw)
 	    (if map? (map-window window))
 	    (descriptor->device window)))))))
 
@@ -738,24 +720,24 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 
 (define-structure (x-font-structure (conc-name x-font-structure/)
 				    (type vector))
-  (name false read-only true)
-  (direction false read-only true)
-  (all-chars-exist? false read-only true)
-  (default-char false read-only true)
-  (min-bounds false read-only true)
-  (max-bounds false read-only true)
-  (start-index false read-only true)
-  (character-bounds false read-only true)
-  (max-ascent false read-only true)
-  (max-descent false read-only true))
+  (name #f read-only #t)
+  (direction #f read-only #t)
+  (all-chars-exist? #f read-only #t)
+  (default-char #f read-only #t)
+  (min-bounds #f read-only #t)
+  (max-bounds #f read-only #t)
+  (start-index #f read-only #t)
+  (character-bounds #f read-only #t)
+  (max-ascent #f read-only #t)
+  (max-descent #f read-only #t))
 
 (define-structure (x-character-bounds (conc-name x-character-bounds/)
 				      (type vector))
-  (lbearing false read-only true)
-  (rbearing false read-only true)
-  (width false read-only true)
-  (ascent false read-only true)
-  (descent false read-only true))
+  (lbearing #f read-only #t)
+  (rbearing #f read-only #t)
+  (width #f read-only #t)
+  (ascent #f read-only #t)
+  (descent #f read-only #t))
 
 ;;;; Window Management Operations
 
@@ -810,22 +792,18 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
       (draw     ,x-graphics-image/draw)
       (draw-subimage  ,x-graphics-image/draw-subimage)
       (fill-from-byte-vector  ,x-graphics-image/fill-from-byte-vector))))
-  (set! image-list (make-protection-list))
-  (add-gc-daemon! destroy-lost-images-daemon))
+  (set! image-list (make-gc-finalizer x-destroy-image))
+  unspecific)
 
 (define (create-x-image device width height)
   (let ((window (x-graphics-device/xw device)))
     (let ((descriptor (x-create-image window width height)))
       (let ((image (make-x-image descriptor window width height)))
-	(add-to-protection-list! image-list image descriptor)
+	(add-to-gc-finalizer! image-list image descriptor)
 	image))))
 
-(define (destroy-lost-images-daemon)
-  (clean-lost-protected-objects image-list x-destroy-image))
-
 (define (x-image/destroy image)
-  (x-destroy-image (x-image/descriptor image))
-  (remove-from-protection-list! image-list image))
+  (remove-from-gc-finalizer! image-list image))
 
 (define (x-image/get-pixel image x y)
   (x-get-pixel-from-image (x-image/descriptor image) x y))
@@ -891,12 +869,11 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     (set! x-colormap? (record-predicate rtd))
     (set! %make-colormap (record-constructor rtd))
     (set! colormap/descriptor (record-accessor rtd 'DESCRIPTOR)))
-  (set! colormap-list (make-protection-list))
-  (add-gc-daemon! destroy-lost-colormaps-daemon))
+  (set! colormap-list (make-gc-finalizer x-free-colormap)))
 
 (define (make-colormap descriptor)
   (let ((colormap (%make-colormap descriptor)))
-    (add-to-protection-list! colormap-list colormap descriptor)
+    (add-to-gc-finalizer! colormap-list colormap descriptor)
     colormap))
 
 (define (x-graphics/get-colormap device)
@@ -913,12 +890,8 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 	(x-visual-deallocate visual)
 	(make-colormap descriptor)))))
 
-(define (destroy-lost-colormaps-daemon)
-  (clean-lost-protected-objects colormap-list x-free-colormap))
-
 (define (x-colormap/free colormap)
-  (x-free-colormap (colormap/descriptor colormap))
-  (remove-from-protection-list! colormap-list colormap))
+  (remove-from-gc-finalizer! colormap-list colormap))
 
 (define (x-colormap/allocate-color colormap r g b)
   (x-allocate-color (colormap/descriptor colormap) r g b))
-- 
2.25.1