From: Chris Hanson Date: Fri, 11 Aug 1989 02:59:31 +0000 (+0000) Subject: Implement `(flush-purification-queue!)', which tries to purify X-Git-Tag: 20090517-FFI~11847 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=fa2cc101730f8d9381b9f2389311e72c664460ae;p=mit-scheme.git 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 d965053b0..ae0d2d25a 100644 --- 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 9e2dd5dc7..306291066 100644 --- 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. |# ;; 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. |# (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 8849c53bc..8dd8d51f6 100644 --- 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 111b33d75..cbd1246df 100644 --- 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 2a1688195..68bde34b4 100644 --- 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 e92a6ee64..3f2f1c2da 100644 --- 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. |# ;; 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. |# (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 a5033755b..c23da2961 100644 --- 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)