From: Guillermo J. Rozas Date: Mon, 2 Feb 1987 14:18:35 +0000 (+0000) Subject: New version. Object hashing and file closing use weak pointers so the X-Git-Tag: 20090517-FFI~13734 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=c213086dc131431cd05819f6aa9bc88f958d5aaa;p=mit-scheme.git New version. Object hashing and file closing use weak pointers so the daemons can be written in Scheme and need not look at old space after a GC. --- diff --git a/v7/src/runtime/error.scm b/v7/src/runtime/error.scm index 96887dce8..0b5422e9f 100644 --- a/v7/src/runtime/error.scm +++ b/v7/src/runtime/error.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/error.scm,v 13.41 1987/01/23 00:11:50 jinx Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/error.scm,v 13.42 1987/02/02 14:18:35 jinx Exp $ ;;; ;;; Copyright (c) 1987 Massachusetts Institute of Technology ;;; @@ -416,10 +416,12 @@ using the current read-eval-print environment.")) "Fasload file would not relocate correctly" combination-first-operand) +#| (define-operation-specific-error 'RAN-OUT-OF-HASH-NUMBERS (list (make-primitive-procedure 'OBJECT-HASH)) "Hashed too many objects -- get a wizard" combination-first-operand) +|# ;;; This will trap any external-primitive errors that ;;; aren't caught by special handlers. diff --git a/v7/src/runtime/hash.scm b/v7/src/runtime/hash.scm index 90dfaf6bb..3ba2db05f 100644 --- a/v7/src/runtime/hash.scm +++ b/v7/src/runtime/hash.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/hash.scm,v 13.41 1987/01/23 00:14:04 jinx Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/hash.scm,v 13.42 1987/02/02 14:17:50 jinx Exp $ ;;; ;;; Copyright (c) 1987 Massachusetts Institute of Technology ;;; @@ -37,236 +37,207 @@ ;;; without prior written consent from MIT in each case. ;;; -;;;; Object Hashing +;;;; Object Hashing, populations, and 2D tables -(declare (usual-integrations)) - -((make-primitive-procedure 'INITIALIZE-OBJECT-HASH) 313) -(add-gc-daemon! (make-primitive-procedure 'REHASH-GC-DAEMON)) -(add-event-receiver! event:after-restore gc-flip) +;; The hashing code, and the population code below, depend on weak +;; conses supported by the microcode. In particular, both pieces of +;; code depend on the fact that the car of a weak cons becomes #F if +;; the object is garbage collected. -(define object-hash (make-primitive-procedure 'OBJECT-HASH)) -(define object-unhash (make-primitive-procedure 'OBJECT-UNHASH)) +;; Important: This code must be rewritten for a parallel processor, +;; since two processors may be updating the data structures +;; simultaneously. -(define hash-of-false (object-hash #!FALSE)) -(define hash-of-false-number (primitive-datum hash-of-false)) +(declare (usual-integrations)) + +(add-event-receiver! event:after-restore gc-flip) + +;;;; Object hashing + +;; How this works: + +;; There are two tables, the hash table and the unhash table: + +;; - The hash table associates objects to their hash numbers. The +;; entries are keyed according to the address (datum) of the object, +;; and thus must be recomputed after every relocation (ie. band +;; loading, garbage collection, etc.). + +;; - The unhash table associates the hash numbers with the +;; corresponding objects. It is keyed according to the numbers +;; themselves. + +;; In order to make the hash and unhash tables weakly hold the objects +;; hashed, the following mechanism is used: + +;; The hash table, a vector, has a SNMV header before all the buckets, +;; and therefore the garbage collector will skip it and will not +;; relocate its buckets. It becomes invalid after a garbage +;; collection and the first thing the daemon does is clear it. +;; Each bucket is a normal alist with the objects in the cars, and the +;; numbers in the cdrs, thus assq can be used to find an object in the +;; bucket. + +;; The unhash table, also a vector, holds the objects by means of weak +;; conses. These weak conses are the same as the pairs in the buckets +;; in the hash table, but with their type codes changed. Each of the +;; buckets in the unhash table is headed by an extra pair whose car is +;; usually #T. This pair is used by the splicing code. The daemon +;; treats buckets headed by #F differently from buckets headed by #T. +;; A bucket headed by #T is compressed: Those pairs whose cars have +;; disappeared are spliced out from the bucket. On the other hand, +;; buckets headed by #F are not compressed. The intent is that while +;; object-unhash is traversing a bucket, the bucket is locked so that +;; the daemon will not splice it out behind object-unhash's back. +;; Then object-unhash does not need to be locked against garbage +;; collection. + +(define (hash x) + (if (eq? x #F) + 0 + (object-hash x))) -(define (hash object) - (primitive-datum (object-hash object))) (define (unhash n) - (if (= n hash-of-false-number) - #!FALSE - (or (object-unhash (make-non-pointer-object n)) - (error "Not a valid hash number" 'UNHASH n)))) + (if (zero? n) + #F + (or (object-unhash n) + (error "unhash: Not a valid hash number" n)))) (define (valid-hash-number? n) - (if (eq? n hash-of-false) - #!TRUE + (if (zero? n) + #T (object-unhash n))) - -;;;; Populations -;;; -;;; A population is a collection of objects. This collection -;;; has the property that if one of the objects in the collection -;;; is reclaimed as garbage, then it is no longer an element of -;;; the collection. - -(define make-population) -(define population?) - -(let ((population-tag '(POPULATION))) - -(define population-of-populations - (cons population-tag '())) - -(set! make-population -(named-lambda (make-population) - (let ((population (cons population-tag '()))) - (add-to-population! population-of-populations population) - population))) - -(set! population? -(named-lambda (population? object) - (and (pair? object) - (eq? (car object) population-tag)))) - -(define (gc-population! population) - (set-cdr! population (delete-invalid-hash-numbers! (cdr population)))) - -(define delete-invalid-hash-numbers! - (list-deletor! - (lambda (hash-number) - (not (valid-hash-number? hash-number))))) - -(define (gc-all-populations!) - (gc-population! population-of-populations) - (map-over-population population-of-populations gc-population!)) - -(add-secondary-gc-daemon! gc-all-populations!) -) +(define object-hash) +(define object-unhash) -(define (add-to-population! population object) - (let ((n (object-hash object))) - (if (not (memq n (cdr population))) - (set-cdr! population (cons n (cdr population)))))) +(let ((pair-type (microcode-type 'PAIR)) + (weak-cons-type (microcode-type 'WEAK-CONS)) + (snmv-type (microcode-type 'MANIFEST-SPECIAL-NM-VECTOR)) + (&make-object (make-primitive-procedure '&MAKE-OBJECT))) -(define (remove-from-population! population object) - (set-cdr! population - (delq! (object-hash object) - (cdr population)))) + (declare (compilable-primitive-functions &make-object)) -;;; Population Mappings -;;; These have the effect of doing a GC-POPULATION! every time it is -;;; called, since the cost of doing so is very small. - -(define (map-over-population population procedure) - (let loop ((previous population) - (rest (cdr population))) - (if (null? rest) - '() - (let ((unhash (object-unhash (car rest)))) - (if (or (eq? hash-of-false (car rest)) - unhash) - (cons (procedure unhash) - (loop rest (cdr rest))) - (begin (set-cdr! previous (cdr rest)) - (loop previous (cdr rest)))))))) - -(define (map-over-population! population procedure) - (let loop ((previous population) - (rest (cdr population))) - (if (not (null? rest)) - (let ((unhash (object-unhash (car rest)))) - (if (or (eq? hash-of-false (car rest)) - unhash) - (begin (procedure unhash) - (loop rest (cdr rest))) - (begin (set-cdr! previous (cdr rest)) - (loop previous (cdr rest)))))))) - -(define (for-all-inhabitants? population predicate) - (let loop ((previous population) - (rest (cdr population))) - (or (null? rest) - (let ((unhash (object-unhash (car rest)))) - (if (or (eq? hash-of-false (car rest)) - unhash) - (and (predicate unhash) - (loop rest (cdr rest))) - (begin (set-cdr! previous (cdr rest)) - (loop previous (cdr rest)))))))) - -(define (exists-an-inhabitant? population predicate) - (let loop ((previous population) - (rest (cdr population))) - (and (not (null? rest)) - (let ((unhash (object-unhash (car rest)))) - (if (or (eq? hash-of-false (car rest)) - unhash) - (or (predicate unhash) - (loop rest (cdr rest))) - (begin (set-cdr! previous (cdr rest)) - (loop previous (cdr rest)))))))) - -;;;; Properties - -(define 2D-put!) -(define 2D-get) -(define 2D-remove!) -(define 2D-get-alist-x) -(define 2D-get-alist-y) - -(let ((system-properties '())) - -(set! 2D-put! - (named-lambda (2D-put! x y value) - (let ((x-hash (object-hash x)) - (y-hash (object-hash y))) - (let ((bucket (assq x-hash system-properties))) - (if bucket - (let ((entry (assq y-hash (cdr bucket)))) - (if entry - (set-cdr! entry value) - (set-cdr! bucket - (cons (cons y-hash value) - (cdr bucket))))) - (set! system-properties - (cons (cons x-hash - (cons (cons y-hash value) - '())) - system-properties))))))) - -(set! 2D-get - (named-lambda (2D-get x y) - (let ((bucket (assq (object-hash x) system-properties))) - (and bucket - (let ((entry (assq (object-hash y) (cdr bucket)))) - (and entry - (cdr entry))))))) - -;;; Returns TRUE iff an entry was removed. -;;; Removes the bucket if the entry removed was the only entry. - -(set! 2D-remove! - (named-lambda (2D-remove! x y) - (let ((bucket (assq (object-hash x) system-properties))) - (and bucket - (begin (set-cdr! bucket - (del-assq! (object-hash y) - (cdr bucket))) - (if (null? (cdr bucket)) - (set! system-properties - (del-assq! (object-hash x) - system-properties))) - #!TRUE))))) - -;;; This clever piece of code removes all invalid entries and buckets, -;;; and also removes any buckets which [subsequently] have no entries. - -(define (gc-system-properties!) - (set! system-properties (delete-invalid-hash-numbers! system-properties))) - -(define delete-invalid-hash-numbers! - (list-deletor! - (lambda (bucket) - (or (not (valid-hash-number? (car bucket))) - (begin (set-cdr! bucket (delete-invalid-y! (cdr bucket))) - (null? (cdr bucket))))))) - -(define delete-invalid-y! - (list-deletor! - (lambda (entry) - (not (valid-hash-number? (car entry)))))) - -(add-secondary-gc-daemon! gc-system-properties!) + (define next-hash-number) + (define hash-table-size) + (define unhash-table) + (define hash-table) + + (define (initialize-object-hash! size) + (set! next-hash-number 1) + (set! hash-table-size size) + (set! unhash-table (vector-cons size '())) + (set! hash-table (vector-cons (1+ size) '())) + (vector-set! hash-table 0 (&make-object snmv-type size)) + (let initialize ((n 0)) + (if (= n size) + #T + (begin (vector-set! unhash-table n (cons #T '())) + (initialize (1+ n)))))) + + ;; This is not dangerous because assq is a primitive and does not + ;; cause consing. The rest of the consing (including that by the + ;; interpreter) is a small bounded amount. + + (set! object-hash + (named-lambda (object-hash object) + (with-interrupt-mask INTERRUPT-MASK-NONE + (lambda (ignore) + (let* ((hash-index (1+ (remainder (primitive-datum object) + hash-table-size))) + (bucket (vector-ref hash-table hash-index)) + (association (assq object bucket))) + (if (not (null? association)) + (cdr association) + (let ((pair (cons object next-hash-number)) + (result next-hash-number) + (unhash-bucket + (vector-ref unhash-table + (remainder next-hash-number + hash-table-size)))) + (set! next-hash-number (1+ next-hash-number)) + (vector-set! hash-table hash-index (cons pair bucket)) + (set-cdr! unhash-bucket + (cons (primitive-set-type weak-cons-type + pair) + (cdr unhash-bucket))) + result))))))) + + ;; This is safe because it locks the garbage collector out only for + ;; a little time, enough to tag the bucket being searched, so that + ;; the daemon will not splice that bucket. + + (set! object-unhash + (named-lambda (object-unhash number) + (let ((index (remainder number hash-table-size))) + (with-interrupt-mask INTERRUPT-MASK-NONE + (lambda (ie) + (let ((bucket (vector-ref unhash-table index))) + (set-car! bucket #F) + (let ((result + (with-interrupt-mask INTERRUPT-MASK-GC-OK + (lambda (ignore) + (let loop ((l (cdr bucket))) + (cond ((null? l) #F) + ((= number (system-pair-cdr (car l))) + (system-pair-car (car l))) + (else (loop (cdr l))))))))) + (set-car! bucket #T) + result))))))) -(set! 2D-get-alist-x - (named-lambda (2D-get-alist-x x) - (let ((bucket (assq (object-hash x) system-properties))) - (if bucket - (let loop ((rest (cdr bucket))) - (cond ((null? rest) '()) - ((valid-hash-number? (caar rest)) - (cons (cons (object-unhash (caar rest)) - (cdar rest)) - (loop (cdr rest)))) - (else (loop (cdr rest))))) - '())))) - -(set! 2D-get-alist-y - (named-lambda (2D-get-alist-y y) - (let ((y-hash (object-hash y))) - (let loop ((rest system-properties)) - (cond ((null? rest) '()) - ((valid-hash-number? (caar rest)) - (let ((entry (assq y-hash (cdar rest)))) - (if entry - (cons (cons (object-unhash (caar rest)) - (cdr entry)) - (loop (cdr rest))) - (loop (cdr rest))))) - (else (loop (cdr rest)))))))) - -) +;;;; Rehash daemon + + ;; The following is dangerous because of the (unnecessary) consing + ;; done by the interpreter while it executes the loops. It runs + ;; with interrupts turned off. The (necessary) consing done by + ;; rehash is not dangerous because at least that much storage was + ;; freed by the garbage collector. To understand this, notice that + ;; the hash table has a SNMV header, so the garbage collector does + ;; not trace the hash table buckets, therefore freeing their + ;; storage. The header is SNM rather than NM to make the buckets be + ;; relocated at band load/restore time. + + ;; Until this code is compiled, and therefore safe, it is replaced + ;; by a primitive. See the installation code below. + + #| + + (define (rehash weak-pair) + (let ((index (1+ (remainder + (primitive-datum (system-pair-car weak-pair)) + hash-table-size)))) + (vector-set! hash-table + index + (cons (primitive-set-type pair-type weak-pair) + (vector-ref hash-table index))))) + + (define (cleanup n) + (if (zero? n) + 'DONE + (begin (vector-set! hash-table n '()) + (cleanup (-1+ n))))) + + (define (rehash-gc-daemon) + (cleanup hash-table-size) + (let outer ((n (-1+ hash-table-size))) + (if (negative? n) + #T + (let ((bucket (vector-ref unhash-table n))) + (if (car bucket) + (let inner1 ((l1 bucket) (l2 (cdr bucket))) + (cond ((null? l2) (outer (-1+ n))) + ((eq? (system-pair-car (car l2)) #F) + (set-cdr! l1 (cdr l2)) + (inner1 l1 (cdr l1))) + (else (rehash (car l2)) + (inner1 l2 (cdr l2))))) + (let inner2 ((l (cdr bucket))) + (cond ((null? l) (outer (-1+ n))) + ((eq? (system-pair-car (car l)) #F) + (inner2 (cdr l))) + (else (rehash (car l)) + (inner2 (cdr l)))))))))) + + (add-gc-daemon! rehash-gc-daemon) + |# diff --git a/v7/src/runtime/io.scm b/v7/src/runtime/io.scm index 2e660e492..716ccfdf7 100644 --- a/v7/src/runtime/io.scm +++ b/v7/src/runtime/io.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/io.scm,v 13.41 1987/01/23 00:15:03 jinx Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/io.scm,v 13.42 1987/02/02 14:17:12 jinx Exp $ ;;; ;;; Copyright (c) 1987 Massachusetts Institute of Technology ;;; @@ -39,40 +39,40 @@ ;;;; Input/output utilities -(declare (usual-integrations) - (compilable-primitive-functions &make-object)) +(declare (usual-integrations)) (define close-all-open-files) (define primitive-io - (make-package primitive-io - ((open-files-slot (fixed-objects-vector-slot 'OPEN-FILES)) - (header-size 2) - (counter-slot 0) - (file-vector-slot 1) - (default-size 10) - (buffer-size 10) - (closed-direction 0) + (let ((open-file-list-tag '*ALL-THE-OPEN-FILES*) - (make-physical-channel (make-primitive-procedure 'HUNK3-CONS)) - (channel-number system-hunk3-cxr0) - (channel-name system-hunk3-cxr1) - (channel-direction system-hunk3-cxr2) - (set-channel-direction! system-hunk3-set-cxr2!) - (non-marked-vector-cons - (make-primitive-procedure 'NON-MARKED-VECTOR-CONS)) - (insert-non-marked-vector! - (make-primitive-procedure 'INSERT-NON-MARKED-VECTOR!)) - ) + (weak-cons-type (microcode-type 'WEAK-CONS)) + (make-physical-channel (make-primitive-procedure 'HUNK3-CONS)) + (channel-descriptor system-hunk3-cxr0) + (channel-name system-hunk3-cxr1) + (channel-direction system-hunk3-cxr2) + (set-channel-direction! system-hunk3-set-cxr2!) + + (closed-direction 0)) + + (make-environment + (declare (compilable-primitive-functions (make-physical-channel hunk3-cons) - (channel-number system-hunk3-cxr0) + (channel-descriptor system-hunk3-cxr0) + (set-channel-descriptor! system-hunk3-set-cxr0!) (channel-name system-hunk3-cxr1) (channel-direction system-hunk3-cxr2) - (set-channel-direction! system-hunk3-set-cxr2!) - non-marked-vector-cons - insert-non-marked-vector!)) + (set-channel-direction! system-hunk3-set-cxr2!))) + +(define open-files-list) +(define traversing?) + +(define (initialize) + (set! open-files-list (list open-file-list-tag)) + (set! traversing? #F) + #T) ;;;; Open/Close Files @@ -84,173 +84,105 @@ (define open-channel-wrapper (let ((open-channel (make-primitive-procedure 'FILE-OPEN-CHANNEL))) (named-lambda ((open-channel-wrapper direction) filename) - (let ((open-files-vector - (vector-ref (get-fixed-objects-vector) open-files-slot)) - (file-info - (make-physical-channel (open-channel filename direction) - filename - direction))) - (add-file! file-info - (if (= (vector-ref open-files-vector counter-slot) - (- (vector-length open-files-vector) header-size)) - (grow-files-vector! open-files-vector) - open-files-vector)) - file-info)))) + (without-interrupts + (lambda () + (let ((channel + (make-physical-channel (open-channel filename direction) + filename + direction))) + + (with-interrupt-mask INTERRUPT-MASK-NONE ; Disallow gc + (lambda (ie) + (set-cdr! open-files-list + (cons (system-pair-cons + weak-cons-type + channel + (channel-descriptor channel)) + (cdr open-files-list))))) + channel)))))) (define open-input-channel (open-channel-wrapper #!FALSE)) (define open-output-channel (open-channel-wrapper #!TRUE)) +;; This is locked from interrupts, but GC can occur since the +;; procedure itself hangs on to the channel until the last moment, +;; when it returns the channel's name. The list will not be spliced +;; by the daemon behind its back because of the traversing? flag. + (define close-physical-channel (let ((primitive (make-primitive-procedure 'FILE-CLOSE-CHANNEL))) (named-lambda (close-physical-channel channel) - (if (eq? closed-direction - (set-channel-direction! channel closed-direction)) - #!TRUE ;Already closed! - (begin (primitive channel) - (remove-from-files-vector! channel) - (channel-name channel)))))) - -(define physical-channel-eof? - (let ((primitive (make-primitive-procedure 'FILE-EOF?))) - (named-lambda (physical-channel-eof? channel) - (or (eq? (channel-direction channel) closed-direction) - (primitive (primitive (channel-number channel))))))) - -(set! close-all-open-files -(named-lambda (close-all-open-files) - (without-interrupts - (lambda () - (for-each close-physical-channel (all-open-channels)))))) - -;;; This is a crock -- it will have to be redesigned if we ever have -;;; more than one terminal connected to this system. Right now if one -;;; just opens these channels (using "CONSOLE:" and "KEYBOARD:" on the -;;; 9836), a regular file channel is opened which is both slower and -;;; will not work when restoring the band. - -(define console-output-channel (make-physical-channel 0 "CONSOLE:" #!TRUE)) -(define console-input-channel (make-physical-channel 0 "KEYBOARD:" #!FALSE)) -(define (get-console-output-channel) console-output-channel) -(define (get-console-input-channel) console-input-channel) - -(define (console-channel? channel) - (zero? (channel-number channel))) + (fluid-let ((traversing? #T)) + (without-interrupts + (lambda () + (if (eq? closed-direction + (set-channel-direction! channel closed-direction)) + #!TRUE ;Already closed! + (begin + (primitive (channel-descriptor channel)) + (let loop ((l1 open-files-list) + (l2 (cdr open-files-list))) + (cond ((null? l2) + (set! traversing? #F) + (error "close-physical-channel: lost channel" + channel)) + ((eq? channel (system-pair-car (car l2))) + (set-cdr! l1 (cdr l2)) + (channel-name channel)) + (else (loop l2 (cdr l2))))))))))))) -;;;; Files Vector Operations - -(define (grow-files-vector! old) - (without-interrupts - (lambda () - (let ((new (vector-cons (+ buffer-size (vector-length old)) '())) - (nm (non-marked-vector-cons - (+ buffer-size (- (vector-length old) header-size))))) - (lock-vector! old) - (let ((num (+ header-size (vector-ref old counter-slot)))) - (define (loop current) - (if (= current num) - (begin (clear-vector! new current - (+ buffer-size (vector-length old))) - (vector-set! (get-fixed-objects-vector) open-files-slot - new) - (unlock-vector! old) - (unlock-vector! new)) ;Must be done when installed! - (begin (vector-set! new current (vector-ref old current)) - (loop (1+ current))))) - (vector-set! new counter-slot (vector-ref old counter-slot)) - (insert-non-marked-vector! new file-vector-slot nm) - (lock-vector! new) ;If GC occurs it will be alright - (loop header-size) - new))))) +;;;; Finalization and daemon. -(define (add-file! file open-files) - (without-interrupts - (lambda () - (lock-vector! open-files) - (vector-set! open-files - (+ header-size - (vector-set! open-files - counter-slot - (1+ (vector-ref open-files counter-slot)))) - file) - (unlock-vector! open-files)))) - -(define (remove-from-files-vector! file) - (without-interrupts - (lambda () - (let ((open-files (vector-ref (get-fixed-objects-vector) - open-files-slot))) - (lock-vector! open-files) - (let ((max (+ header-size (vector-ref open-files counter-slot)))) - (define (loop count) - (cond ((= count max) - (unlock-vector! open-files) - (error "Not an i/o channel" 'CLOSE-CHANNEL file)) - ((eq? file (vector-ref open-files count)) - (let inner ((count (1+ count))) - (if (= count max) - (begin - (vector-set! open-files - counter-slot - (-1+ - (vector-ref open-files - counter-slot))) - (vector-set! open-files (-1+ count) '())) - (begin - (vector-set! open-files - (-1+ count) - (vector-ref open-files count)) - (inner (1+ count)))))) - (else (loop (1+ count))))) - (loop header-size) - (unlock-vector! open-files)))))) - -(define (clear-vector! v start end) - (without-interrupts - (lambda () - (subvector-fill! v start end '())))) - -(define (all-open-channels) - (let ((files-vector (vector-ref (get-fixed-objects-vector) open-files-slot))) - (without-interrupts - (lambda () - (lock-vector! files-vector) - (let ((result - (subvector->list files-vector - header-size - (+ header-size - (vector-ref files-vector counter-slot))))) - (unlock-vector! files-vector) - result))))) - -(define ((locker flag) v) - (with-interrupts-reduced INTERRUPT-MASK-NONE - (lambda (old-mask) - (vector-set! v - file-vector-slot - (&make-object flag - (vector-ref v file-vector-slot))) - #!TRUE))) ; Guarantee a good value returned - -(define lock-vector! - (locker (microcode-type 'NULL))) - -(define unlock-vector! - (locker (microcode-type 'MANIFEST-SPECIAL-NM-VECTOR))) - -(define (setup-files-vector) - (let ((base-vector (vector-cons (+ default-size header-size) '()))) - (vector-set! base-vector counter-slot 0) - (insert-non-marked-vector! base-vector file-vector-slot - (non-marked-vector-cons default-size)) -; (lock-vector! base-vector) - (clear-vector! base-vector header-size (+ default-size header-size)) - (vector-set! (get-fixed-objects-vector) open-files-slot base-vector) - (unlock-vector! base-vector))) - -;;; end PRIMITIVE-IO package. -)) - -((access setup-files-vector primitive-io)) -(add-gc-daemon! (make-primitive-procedure 'CLOSE-LOST-OPEN-FILES)) +(set! close-all-open-files + (let ((primitive (make-primitive-procedure 'FILE-CLOSE-CHANNEL))) + (named-lambda (close-all-open-files) + (fluid-let ((traversing? #T)) + (without-interrupts + (lambda () + (let loop ((l (cdr open-files-list))) + (cond ((null? l) #T) + (else + (let ((channel (system-pair-car (car l)))) + (primitive (system-pair-cdr (car l))) + (if (not (eq? channel #F)) + (set-channel-direction! channel + closed-direction)) + (set-cdr! open-files-list (cdr l))) + (loop (cdr open-files-list))))))))))) + +;; This is the daemon which closes files which no one points to. +;; Runs with GC, and lower priority interrupts, disabled. +;; It is unsafe because of the (unnecessary) consing by the +;; interpreter while it executes the loop. + +;; Replaced by a primitive installed below. + +#| + +(define close-lost-open-files-daemon + (let ((primitive (make-primitive-procedure 'FILE-CLOSE-CHANNEL))) + (named-lambda (close-lost-open-files-daemon) + (if (not traversing?) + (let loop ((l1 open-files-list) + (l2 (cdr open-files-list))) + (cond ((null? l2) #T) + ((null? (system-pair-car (car l2))) + (primitive (system-pair-cdr (car l2))) + (set-cdr! l1 (cdr l2)) + (loop l1 (cdr l1))) + (else (loop l2 (cdr l2))))))))) + +|# + +(define close-lost-open-files-daemon + (let ((primitive (make-primitive-procedure 'CLOSE-LOST-OPEN-FILES))) + (named-lambda (close-lost-open-files-daemon) + (if (not traversing?) + (primitive open-files-list))))) + +))) ;; End of PRIMITIVE-IO package. + +((access initialize primitive-io)) +(add-gc-daemon! (access close-lost-open-files-daemon primitive-io)) (add-gc-daemon! (access close-lost-open-files-daemon primitive-io)) \ No newline at end of file