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 371fb83937985cf617c7672a61ab1dd763d3be3c..15fe7c92c561ce5d4bff55b5dc3e9bdbf7f7d8d0 100644 (file)
--- 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 e5c10f33b26896638525a8a942e3efe83af72d57..20b85ffcf098a7855144750e55ed60ca2b46ef75 100644 (file)
--- 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")
 \f
 ;;;; User Primitives
 

diff --git a/v7/src/runtime/gcdemn.scm b/v7/src/runtime/gcdemn.scm
index 96271a8e0c49abeddc255880662fcbd868218bfa..d7c8f7c459efdc90ccb3c592a5e8c33c4527e8c7 100644 (file)
--- 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))
 \f
 (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 aa8b5b83ffe25873ac6704fb128941744a34ddc7..6fce9e17641e278d8b6d50f811a05a02e8d0ad0f 100644 (file)
--- 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 44490ed9ca7d60eb151cc46f72978effa5d06e24..3692d809d6a91e521b2dbdb027e8aadf7710337c 100644 (file)
--- 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"))
 \f
 (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)
 \f
 ;;;; 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 86df4d09dada05badda8ed65e2546fadffee81fd..80f88cc5f3c22991f285838acc4db94306eb173e 100644 (file)
--- 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 cfad85a1fcf750364baddc2fa1c381e01c4a263c..46bfbc54baa61a2c209dacc09897f0cb4cbc6ea9 100644 (file)
--- 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 86df4d09dada05badda8ed65e2546fadffee81fd..80f88cc5f3c22991f285838acc4db94306eb173e 100644 (file)
--- 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)