;;; -*-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
;;;
;;; without prior written consent from MIT in each case.
;;;
-;;;; Object Hashing
+;;;; Object Hashing, populations, and 2D tables
-(declare (usual-integrations))
-\f
-((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)
+\f
+;;;; 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)))
-\f
-;;;; 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))
\f
-;;; 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))))))))
-\f
-;;;; 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)))))))
\f
-(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)
+ |#
;;; -*-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
;;;
;;;; Input/output utilities
-(declare (usual-integrations)
- (compilable-primitive-functions &make-object))
+(declare (usual-integrations))
\f
(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)
\f
;;;; Open/Close Files
(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)))))))))))))
\f
-;;;; 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))))))
-\f
-(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
projects / mit-scheme.git / commitdiff