From: Chris Hanson Date: Tue, 29 Jun 1993 22:58:21 +0000 (+0000) Subject: This runtime system requires microcode version 11.133 or later. X-Git-Tag: 20090517-FFI~8255 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=f70d2ae46b15608e8a1ca83dc75571ba006515c8;p=mit-scheme.git This runtime system requires microcode version 11.133 or later. Implement a new interrupt that is signalled after each GC and which runs at roughly the same priority as character interrupts. All GC daemons, with the exception of the object hash daemon, run in this interrupt handler rather than during the GC proper. This allows GC daemons to allocate storage and prevents GC daemons from running during critical sections. --- diff --git a/v7/src/runtime/boot.scm b/v7/src/runtime/boot.scm index 371fb8393..15fe7c92c 100644 --- a/v7/src/runtime/boot.scm +++ b/v7/src/runtime/boot.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: boot.scm,v 14.5 1992/12/07 19:06:39 cph Exp $ +$Id: boot.scm,v 14.6 1993/06/29 22:58:14 cph Exp $ -Copyright (c) 1988-92 Massachusetts Institute of Technology +Copyright (c) 1988-93 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -67,7 +67,7 @@ MIT in each case. |# (define-integrable interrupt-bit/gc #x0004) (define-integrable interrupt-bit/global-1 #x0008) (define-integrable interrupt-bit/kbd #x0010) -(define-integrable interrupt-bit/global-2 #x0020) +(define-integrable interrupt-bit/after-gc #x0020) (define-integrable interrupt-bit/timer #x0040) (define-integrable interrupt-bit/global-3 #x0080) (define-integrable interrupt-bit/suspend #x0100) @@ -75,6 +75,9 @@ MIT in each case. |# ;; GC & stack overflow only (define-integrable interrupt-mask/gc-ok #x0007) +;; GC, stack overflow, and timer only +(define-integrable interrupt-mask/timer-ok #x0047) + ;; Absolutely everything off (define-integrable interrupt-mask/none #x0000) diff --git a/v7/src/runtime/gc.scm b/v7/src/runtime/gc.scm index e5c10f33b..20b85ffcf 100644 --- a/v7/src/runtime/gc.scm +++ b/v7/src/runtime/gc.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gc.scm,v 14.8 1992/02/07 19:47:24 jinx Exp $ +$Id: gc.scm,v 14.9 1993/06/29 22:58:15 cph Exp $ -Copyright (c) 1988-1992 Massachusetts Institute of Technology +Copyright (c) 1988-93 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -132,8 +132,7 @@ MIT in each case. |# (define (gc-flip-internal safety-margin) (let ((start-value (hook/gc-start))) (let ((space-remaining ((ucode-primitive garbage-collect) safety-margin))) - (gc-abort-test space-remaining) - (hook/gc-finish start-value space-remaining) + (gc-finish start-value space-remaining) space-remaining))) (define (purify-internal item pure-space? safety-margin) @@ -142,8 +141,7 @@ MIT in each case. |# ((ucode-primitive primitive-purify) item pure-space? safety-margin))) - (gc-abort-test (cdr result)) - (hook/gc-finish start-value (cdr result)) + (gc-finish start-value (cdr result)) result))) (define (default/gc-start) @@ -153,12 +151,7 @@ MIT in each case. |# start-value space-remaining false) -(define gc-boot-loading?) - -(define gc-boot-death-message - "\n;; Aborting boot-load: Not enough memory to load -- Use -large option.\n") - -(define (gc-abort-test space-remaining) +(define (gc-finish start-value space-remaining) (if (< space-remaining 4096) (if gc-boot-loading? (let ((console ((ucode-primitive tty-output-channel 0)))) @@ -175,7 +168,14 @@ MIT in each case. |# (cmdl-message/active (lambda (port) port - (with-gc-notification! true gc-clean)))))))) + (with-gc-notification! true 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 diff --git a/v7/src/runtime/gcdemn.scm b/v7/src/runtime/gcdemn.scm index 96271a8e0..d7c8f7c45 100644 --- a/v7/src/runtime/gcdemn.scm +++ b/v7/src/runtime/gcdemn.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: gcdemn.scm,v 14.5 1993/06/25 21:09:08 gjr Exp $ +$Id: gcdemn.scm,v 14.6 1993/06/29 22:58:16 cph Exp $ Copyright (c) 1988-1993 Massachusetts Institute of Technology @@ -38,31 +38,50 @@ MIT in each case. |# (declare (usual-integrations)) (define (initialize-package!) + (set! primitive-gc-daemons (make-queue)) + (set! trigger-primitive-gc-daemons! (make-trigger primitive-gc-daemons)) + (set! add-primitive-gc-daemon! (make-adder primitive-gc-daemons)) (set! gc-daemons (make-queue)) + (set! trigger-gc-daemons! (make-trigger gc-daemons)) + (set! add-gc-daemon! (make-adder gc-daemons)) (set! secondary-gc-daemons (make-queue)) + (set! trigger-secondary-gc-daemons! (make-trigger secondary-gc-daemons)) + (set! add-secondary-gc-daemon! (make-adder secondary-gc-daemons)) (let ((fixed-objects (get-fixed-objects-vector))) - (vector-set! fixed-objects #x0B trigger-gc-daemons) + (vector-set! fixed-objects #x0B trigger-primitive-gc-daemons!) ((ucode-primitive set-fixed-objects-vector!) fixed-objects))) +;;; PRIMITIVE-GC-DAEMONS are executed during the GC. They must not +;;; allocate any storage and they must be prepared to run at times +;;; when many data structures are not consistent. +(define primitive-gc-daemons) +(define trigger-primitive-gc-daemons!) +(define add-primitive-gc-daemon!) + +;;; GC-DAEMONS are executed after each GC from an interrupt handler. +;;; This interrupt handler has lower priority than the GC interrupt, +;;; which guarantees that these daemons will not be run inside of +;;; critical sections. As a result, the daemons may allocate storage +;;; and use most of the runtime facilities. (define gc-daemons) -(define secondary-gc-daemons) - -(define (invoke-thunk thunk) - (thunk)) +(define trigger-gc-daemons!) +(define add-gc-daemon!) -(define (trigger-gc-daemons) - (for-each invoke-thunk - (queue->list/unsafe gc-daemons))) - -(define (trigger-secondary-gc-daemons!) - (for-each invoke-thunk - (queue->list/unsafe secondary-gc-daemons))) +;;; SECONDARY-GC-DAEMONS are executed rarely. Their purpose is to +;;; reclaim storage that is either unlikely to be reclaimed or +;;; expensive to reclaim. +(define secondary-gc-daemons) +(define trigger-secondary-gc-daemons!) +(define add-secondary-gc-daemon!) -(define (add-gc-daemon! daemon) - (enqueue! gc-daemons daemon)) +(define (make-trigger daemons) + (lambda () + (for-each (lambda (thunk) (thunk)) + (queue->list/unsafe daemons)))) -(define (add-secondary-gc-daemon! daemon) - (enqueue! secondary-gc-daemons daemon)) +(define (make-adder daemons) + (lambda (daemon) + (enqueue! daemons daemon))) (define (gc-clean #!optional threshold) (let ((threshold diff --git a/v7/src/runtime/hash.scm b/v7/src/runtime/hash.scm index aa8b5b83f..6fce9e176 100644 --- a/v7/src/runtime/hash.scm +++ b/v7/src/runtime/hash.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/hash.scm,v 14.4 1991/08/18 23:33:20 cph Exp $ +$Id: hash.scm,v 14.5 1993/06/29 22:58:17 cph Exp $ -Copyright (c) 1988-91 Massachusetts Institute of Technology +Copyright (c) 1988-93 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -93,7 +93,7 @@ MIT in each case. |# (set! all-hash-tables (weak-cons 0 '())) (set! default-hash-table (hash-table/make)) (add-event-receiver! event:after-restore (lambda () (gc-flip))) - (add-gc-daemon! rehash-all-gc-daemon)) + (add-primitive-gc-daemon! rehash-all-gc-daemon)) (define-structure (hash-table (conc-name hash-table/) diff --git a/v7/src/runtime/intrpt.scm b/v7/src/runtime/intrpt.scm index 44490ed9c..3692d809d 100644 --- a/v7/src/runtime/intrpt.scm +++ b/v7/src/runtime/intrpt.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: intrpt.scm,v 14.13 1993/04/29 05:24:34 cph Exp $ +$Id: intrpt.scm,v 14.14 1993/06/29 22:58:18 cph Exp $ Copyright (c) 1988-93 Massachusetts Institute of Technology @@ -35,11 +35,14 @@ MIT in each case. |# ;;;; Interrupt System ;;; package: (runtime interrupt-handler) -(declare (usual-integrations)) +(declare (usual-integrations) + (integrate-external "boot")) (define (initialize-package!) (set! index:interrupt-vector (fixed-objects-vector-slot 'SYSTEM-INTERRUPT-VECTOR)) + (set! index:interrupt-mask-vector + (fixed-objects-vector-slot 'INTERRUPT-MASK-VECTOR)) (set! index:termination-vector (fixed-objects-vector-slot 'MICROCODE-TERMINATIONS-PROCEDURES)) (set! hook/clean-input/flush-typeahead false) @@ -69,14 +72,15 @@ MIT in each case. |# (real-timer-clear 0)) (define-integrable stack-overflow-slot 0) -(define-integrable global-gc-slot 1) (define-integrable gc-slot 2) (define-integrable character-slot 4) +(define-integrable after-gc-slot 5) (define-integrable timer-slot 6) (define-integrable suspend-slot 8) (define-integrable illegal-interrupt-slot 9) (define index:interrupt-vector) +(define index:interrupt-mask-vector) (define index:termination-vector) ;;;; Miscellaneous Interrupts @@ -113,6 +117,14 @@ MIT in each case. |# args (abort->nearest "Aborting! Out of memory")) +(define (after-gc-interrupt-handler interrupt-code interrupt-enables) + interrupt-code interrupt-enables + (trigger-gc-daemons!) + ;; By clearing the interrupt after running the daemons we ignore an + ;; GC that occurs while we are running the daemons. This helps + ;; prevent us from getting into a loop just running the daemons. + (clear-interrupts! interrupt-bit/after-gc)) + (define (illegal-interrupt-handler interrupt-code interrupt-enables) (error "Illegal interrupt" interrupt-code interrupt-enables)) @@ -176,50 +188,72 @@ MIT in each case. |# (define (install) (without-interrupts (lambda () - (let ((old-system-interrupt-vector + (let ((system-interrupt-vector (vector-ref (get-fixed-objects-vector) index:interrupt-vector)) + (old-interrupt-mask-vector + (vector-ref (get-fixed-objects-vector) + index:interrupt-mask-vector)) (old-termination-vector (vector-ref (get-fixed-objects-vector) index:termination-vector))) - (let ((previous-gc-interrupt - (vector-ref old-system-interrupt-vector gc-slot)) - (previous-global-gc-interrupt - (vector-ref old-system-interrupt-vector global-gc-slot)) - (previous-stack-interrupt - (vector-ref old-system-interrupt-vector stack-overflow-slot)) - (system-interrupt-vector - (make-vector (vector-length old-system-interrupt-vector) - default-interrupt-handler)) + (let ((interrupt-mask-vector + (let ((length (vector-length system-interrupt-vector))) + (if (and (vector? old-interrupt-mask-vector) + (= (vector-length old-interrupt-mask-vector) length)) + old-interrupt-mask-vector + (let ((masks (make-vector length))) + (do ((i 0 (+ i 1))) + ((= i length)) + (vector-set! masks i (- (expt 2 i) 1))) + masks)))) (termination-vector (let ((length (microcode-termination/code-limit))) (if old-termination-vector (if (> length (vector-length old-termination-vector)) (vector-grow old-termination-vector length) old-termination-vector) - (make-vector length false))))) + (make-vector length #f))))) + + (vector-set! interrupt-mask-vector stack-overflow-slot + interrupt-mask/none) + + (vector-set! interrupt-mask-vector gc-slot + interrupt-mask/none) - (vector-set! system-interrupt-vector gc-slot previous-gc-interrupt) - (vector-set! system-interrupt-vector global-gc-slot - previous-global-gc-interrupt) - (vector-set! system-interrupt-vector stack-overflow-slot - previous-stack-interrupt) - (vector-set! system-interrupt-vector character-slot - external-interrupt-handler) (vector-set! system-interrupt-vector timer-slot timer-interrupt-handler) + (vector-set! interrupt-mask-vector timer-slot + interrupt-mask/gc-ok) + + (vector-set! system-interrupt-vector character-slot + external-interrupt-handler) + (vector-set! interrupt-mask-vector character-slot + interrupt-mask/timer-ok) + + (vector-set! system-interrupt-vector after-gc-slot + after-gc-interrupt-handler) + (vector-set! interrupt-mask-vector after-gc-slot + interrupt-mask/timer-ok) + (vector-set! system-interrupt-vector suspend-slot suspend-interrupt-handler) + (vector-set! interrupt-mask-vector suspend-slot + interrupt-mask/timer-ok) + (vector-set! system-interrupt-vector illegal-interrupt-slot illegal-interrupt-handler) - - ;; install the new vector atomically - (vector-set! (get-fixed-objects-vector) - index:interrupt-vector - system-interrupt-vector) + (vector-set! interrupt-mask-vector illegal-interrupt-slot + interrupt-mask/timer-ok) (vector-set! termination-vector (microcode-termination 'GC-OUT-OF-SPACE) gc-out-of-space-handler) + ;; Install the new tables atomically: + + (vector-set! (get-fixed-objects-vector) + index:interrupt-mask-vector + interrupt-mask-vector) + (vector-set! (get-fixed-objects-vector) index:termination-vector termination-vector) diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index 86df4d09d..80f88cc5f 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.180 1993/06/10 06:07:45 gjr Exp $ +$Id: runtime.pkg,v 14.181 1993/06/29 22:58:20 cph Exp $ Copyright (c) 1988-1993 Massachusetts Institute of Technology @@ -715,6 +715,10 @@ MIT in each case. |# add-secondary-gc-daemon! gc-clean trigger-secondary-gc-daemons!) + (export (runtime hash) + add-primitive-gc-daemon!) + (export (runtime interrupt-handler) + trigger-gc-daemons!) (initialization (initialize-package!))) (define-package (runtime gc-notification) diff --git a/v7/src/runtime/version.scm b/v7/src/runtime/version.scm index cfad85a1f..46bfbc54b 100644 --- a/v7/src/runtime/version.scm +++ b/v7/src/runtime/version.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: version.scm,v 14.162 1993/06/25 21:09:55 gjr Exp $ +$Id: version.scm,v 14.163 1993/06/29 22:58:21 cph Exp $ Copyright (c) 1988-1993 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 162)) + (add-identification! "Runtime" 14 163)) (define microcode-system) diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg index 86df4d09d..80f88cc5f 100644 --- a/v8/src/runtime/runtime.pkg +++ b/v8/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.180 1993/06/10 06:07:45 gjr Exp $ +$Id: runtime.pkg,v 14.181 1993/06/29 22:58:20 cph Exp $ Copyright (c) 1988-1993 Massachusetts Institute of Technology @@ -715,6 +715,10 @@ MIT in each case. |# add-secondary-gc-daemon! gc-clean trigger-secondary-gc-daemons!) + (export (runtime hash) + add-primitive-gc-daemon!) + (export (runtime interrupt-handler) + trigger-gc-daemons!) (initialization (initialize-package!))) (define-package (runtime gc-notification)