Implement `(flush-purification-queue!)', which tries to purify

anything that is in the purification queue.  When this procedure
returns, the queue should be empty.  Call this procedure after the
cold load, and after the "system-loader", to guarantee that the items
loaded are purified before being used.

diff --git a/v7/src/runtime/gc.scm b/v7/src/runtime/gc.scm
index d965053b0ad18b363ca3dab8dcfcba22e4ee72a3..ae0d2d25a90e6a7b203db96c94cd30631ecbbb52 100644 (file)
--- a/v7/src/runtime/gc.scm
+++ b/v7/src/runtime/gc.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gc.scm,v 14.2 1989/03/29 02:45:39 jinx Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gc.scm,v 14.3 1989/08/11 02:59:14 cph Exp $
 
 Copyright (c) 1988, 1989 Massachusetts Institute of Technology
 
@@ -108,12 +108,13 @@ MIT in each case. |#
            (pure-space?
             (with-absolutely-no-interrupts
              (lambda ()
-               (set! pure-space-queue (cons item pure-space-queue)))))
+               (set! pure-space-queue (cons item pure-space-queue))
+               unspecific)))
            (else
             (with-absolutely-no-interrupts
              (lambda ()
-               (set! constant-space-queue
-                     (cons item constant-space-queue))))))))
+               (set! constant-space-queue (cons item constant-space-queue))
+               unspecific))))))
 
 (define (default/stack-overflow)
   (abort "maximum recursion depth exceeded"))
@@ -172,6 +173,14 @@ MIT in each case. |#
      (hook/gc-flip (if (default-object? safety-margin)
                       default-safety-margin
                       safety-margin)))))
+
+(define (flush-purification-queue!)
+  (if (or (not (null? pure-space-queue))
+         (not (null? 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.

diff --git a/v7/src/runtime/make.scm b/v7/src/runtime/make.scm
index 9e2dd5dc7efc40734dd38d987ebf1892a110a404..30629106607457bb75b286e55998470d2e080b74 100644 (file)
--- a/v7/src/runtime/make.scm
+++ b/v7/src/runtime/make.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/make.scm,v 14.15 1989/08/07 07:36:42 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/make.scm,v 14.16 1989/08/11 02:59:18 cph Exp $
 
 Copyright (c) 1988, 1989 Massachusetts Institute of Technology
 
@@ -170,7 +170,7 @@ MIT in each case. |#
 
 (define (implemented-primitive-procedure? primitive)
   (get-primitive-address (intern (get-primitive-name (object-datum primitive)))
-                        false))
+                        #f))
 
 (define map-filename
   (if (implemented-primitive-procedure? file-exists?)
@@ -210,7 +210,7 @@ MIT in each case. |#
 \f
 ;; Construct the package structure.
 ;; Lotta hair here to load the package code before its package is built.
-(eval (cold-load/purify (fasload (map-filename "packag") true))
+(eval (cold-load/purify (fasload (map-filename "packag") #t))
       environment-for-package)
 ((access initialize-package! environment-for-package))
 (let loop ((names
@@ -233,8 +233,8 @@ MIT in each case. |#
                                    (car names))
             (loop (cdr names)))))
 (package/add-child! system-global-package 'PACKAGE environment-for-package)
-(eval (fasload "runtim.bcon" false)
-      ;; (cold-load/purify (fasload "runtim.bcon" false))
+(eval (fasload "runtim.bcon" #f)
+      ;; (cold-load/purify (fasload "runtim.bcon" #f))
       system-global-environment)
 
 ;; Global databases.  Load, then initialize.
@@ -251,7 +251,7 @@ MIT in each case. |#
   (if (not (null? files))
       (begin
        (eval (cold-load/purify
-              (fasload (map-filename (car (car files))) true))
+              (fasload (map-filename (car (car files))) #t))
              (package-reference (cdr (car files))))
        (loop (cdr files)))))
 (package-initialize '(RUNTIME GC-DAEMONS) 'INITIALIZE-PACKAGE!)
@@ -269,7 +269,7 @@ MIT in each case. |#
                    constant-space/base)
 
 ;; Load everything else.
-((eval (fasload "runtim.bldr" false) system-global-environment)
+((eval (fasload "runtim.bldr" #f) system-global-environment)
  (lambda (filename environment)
    (if (not (or (string=? filename "packag")
                (string=? filename "gcdemn")
@@ -280,7 +280,7 @@ MIT in each case. |#
                (string=? filename "boot")
                (string=? filename "queue")
                (string=? filename "gc")))
-       (eval (purify (fasload (map-filename filename) true)) environment)))
+       (eval (purify (fasload (map-filename filename) #t)) environment)))
  `((SORT-TYPE . MERGE-SORT)
    (OS-TYPE . ,(intern os-name-string))
    (OPTIONS . NO-LOAD)))
@@ -364,7 +364,7 @@ MIT in each case. |#
 \f
 (let ((filename (map-filename "site")))
   (if (file-exists? filename)
-      (eval (purify (fasload filename true)) system-global-environment)))
+      (eval (purify (fasload filename #t)) system-global-environment)))
 
 (let ((fasload/update-debugging-info!
        (access fasload/update-debugging-info!
@@ -377,4 +377,4 @@ MIT in each case. |#
 
 )
 
-(package/add-child! system-global-package 'USER user-initial-environment)(initial-top-level-repl)
\ No newline at end of file
+(package/add-child! system-global-package 'USER user-initial-environment)(flush-purification-queue!)(initial-top-level-repl)
\ No newline at end of file

diff --git a/v7/src/runtime/packag.scm b/v7/src/runtime/packag.scm
index 8849c53bc4c997a9eb635cef4766139b315e2348..8dd8d51f610dfe60954b41d7ca70b23e1f565753 100644 (file)
--- a/v7/src/runtime/packag.scm
+++ b/v7/src/runtime/packag.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/packag.scm,v 14.8 1989/08/07 07:36:45 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/packag.scm,v 14.9 1989/08/11 02:59:22 cph Rel $
 
 Copyright (c) 1988, 1989 Massachusetts Institute of Technology
 
@@ -131,7 +131,11 @@ MIT in each case. |#
             (lambda (filename environment)
               (load filename environment syntax-table true))
             options))))))
-  unspecific)
+  ;; Make sure that everything we just loaded is purified.  If the
+  ;; program runs before it gets purified, some of its run-time state
+  ;; can end up being purified also.
+  (flush-purification-queue!))
+
 (define-integrable (package/reference package name)
   (lexical-reference (package/environment package) name))
 

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 111b33d7505e77cb44732537056b3e8488ae5c49..cbd1246df4f8fb74a138e2111ef30329020e02ac 100644 (file)
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.46 1989/08/10 08:18:17 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.47 1989/08/11 02:59:26 cph Exp $
 
 Copyright (c) 1988, 1989 Massachusetts Institute of Technology
 
@@ -550,7 +550,9 @@ MIT in each case. |#
   (files "gc")
   (parent ())
   (export ()
-         constant-space/in-use   gc-flip
+         constant-space/in-use
+         flush-purification-queue!
+         gc-flip
          purify
          set-gc-safety-margin!)
   (export (runtime gc-statistics)

diff --git a/v7/src/runtime/version.scm b/v7/src/runtime/version.scm
index 2a16881951f18dedd2da9e324c056271dec998be..68bde34b4e38a956523cce92ad2a61880cd375a0 100644 (file)
--- a/v7/src/runtime/version.scm
+++ b/v7/src/runtime/version.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.51 1989/08/10 08:18:40 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.52 1989/08/11 02:59:31 cph Exp $
 
 Copyright (c) 1988, 1989 Massachusetts Institute of Technology
 
@@ -45,7 +45,7 @@ MIT in each case. |#
                     '()))
   (add-system! microcode-system)
   (add-event-receiver! event:after-restore snarf-microcode-version!)
-  (add-identification! "Runtime" 14 51))
+  (add-identification! "Runtime" 14 52))
 (define microcode-system)
 
 (define (snarf-microcode-version!)

diff --git a/v8/src/runtime/make.scm b/v8/src/runtime/make.scm
index e92a6ee64a4f45b9b19e4baa2b5689ea03558124..3f2f1c2da279aa75e594995f02d95f9248ad52cc 100644 (file)
--- a/v8/src/runtime/make.scm
+++ b/v8/src/runtime/make.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/make.scm,v 14.15 1989/08/07 07:36:42 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/make.scm,v 14.16 1989/08/11 02:59:18 cph Exp $
 
 Copyright (c) 1988, 1989 Massachusetts Institute of Technology
 
@@ -170,7 +170,7 @@ MIT in each case. |#
 
 (define (implemented-primitive-procedure? primitive)
   (get-primitive-address (intern (get-primitive-name (object-datum primitive)))
-                        false))
+                        #f))
 
 (define map-filename
   (if (implemented-primitive-procedure? file-exists?)
@@ -210,7 +210,7 @@ MIT in each case. |#
 \f
 ;; Construct the package structure.
 ;; Lotta hair here to load the package code before its package is built.
-(eval (cold-load/purify (fasload (map-filename "packag") true))
+(eval (cold-load/purify (fasload (map-filename "packag") #t))
       environment-for-package)
 ((access initialize-package! environment-for-package))
 (let loop ((names
@@ -233,8 +233,8 @@ MIT in each case. |#
                                    (car names))
             (loop (cdr names)))))
 (package/add-child! system-global-package 'PACKAGE environment-for-package)
-(eval (fasload "runtim.bcon" false)
-      ;; (cold-load/purify (fasload "runtim.bcon" false))
+(eval (fasload "runtim.bcon" #f)
+      ;; (cold-load/purify (fasload "runtim.bcon" #f))
       system-global-environment)
 
 ;; Global databases.  Load, then initialize.
@@ -251,7 +251,7 @@ MIT in each case. |#
   (if (not (null? files))
       (begin
        (eval (cold-load/purify
-              (fasload (map-filename (car (car files))) true))
+              (fasload (map-filename (car (car files))) #t))
              (package-reference (cdr (car files))))
        (loop (cdr files)))))
 (package-initialize '(RUNTIME GC-DAEMONS) 'INITIALIZE-PACKAGE!)
@@ -269,7 +269,7 @@ MIT in each case. |#
                    constant-space/base)
 
 ;; Load everything else.
-((eval (fasload "runtim.bldr" false) system-global-environment)
+((eval (fasload "runtim.bldr" #f) system-global-environment)
  (lambda (filename environment)
    (if (not (or (string=? filename "packag")
                (string=? filename "gcdemn")
@@ -280,7 +280,7 @@ MIT in each case. |#
                (string=? filename "boot")
                (string=? filename "queue")
                (string=? filename "gc")))
-       (eval (purify (fasload (map-filename filename) true)) environment)))
+       (eval (purify (fasload (map-filename filename) #t)) environment)))
  `((SORT-TYPE . MERGE-SORT)
    (OS-TYPE . ,(intern os-name-string))
    (OPTIONS . NO-LOAD)))
@@ -364,7 +364,7 @@ MIT in each case. |#
 \f
 (let ((filename (map-filename "site")))
   (if (file-exists? filename)
-      (eval (purify (fasload filename true)) system-global-environment)))
+      (eval (purify (fasload filename #t)) system-global-environment)))
 
 (let ((fasload/update-debugging-info!
        (access fasload/update-debugging-info!
@@ -377,4 +377,4 @@ MIT in each case. |#
 
 )
 
-(package/add-child! system-global-package 'USER user-initial-environment)(initial-top-level-repl)
\ No newline at end of file
+(package/add-child! system-global-package 'USER user-initial-environment)(flush-purification-queue!)(initial-top-level-repl)
\ No newline at end of file

diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg
index a5033755bbaee4c4975890891ca211d0bd380cea..c23da296106839f7b3aa33f9e1cadc6f352076a1 100644 (file)
--- a/v8/src/runtime/runtime.pkg
+++ b/v8/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.46 1989/08/10 08:18:17 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.47 1989/08/11 02:59:26 cph Exp $
 
 Copyright (c) 1988, 1989 Massachusetts Institute of Technology
 
@@ -550,7 +550,9 @@ MIT in each case. |#
   (files "gc")
   (parent ())
   (export ()
-         constant-space/in-use   gc-flip
+         constant-space/in-use
+         flush-purification-queue!
+         gc-flip
          purify
          set-gc-safety-margin!)
   (export (runtime gc-statistics)