tick actually makes little difference.
queue.scm:73: (without-interrupts (lambda () (queued?/unsafe queue item))))
+ Caller: queued?
queue.scm:76: (without-interrupts (lambda () (enqueue!/unsafe queue object))))
+ Caller: enqueue!
queue.scm:79: (without-interrupts (lambda () (dequeue!/unsafe queue))))
+ Caller: dequeue!
queue.scm:85: (without-interrupts
+ Caller: queue-map!
queue.scm:96: (without-interrupts
+ Caller: queue->list
+
+ Added an optional thread mutex to serialize updates of
+ particular queues, "serial queues". Note that the "safe"
+ queue operations are no longer safe when applied to non-serial
+ queues. This only happens in LIAR, SWAT, Edwin, X11 Graphics
+ and OS2 Graphics -- single-threaded applications. Runtime
+ globals like the event-distributors, gc-daemons and the REPLs
+ are now using serial queues.
+
+ Event-distributors and gc-daemons are used early in the cold
+ load so /unsafe versions (without mutex locking) of the make-
+ and add- procedures were added for use (by poplat.scm and
+ prop1d.scm) before the thread system is initialized. This
+ breaks a circularity where thread system initialization
+ requires population and 1d-table operators which in turn
+ require the thread system.
+
+ Just creating a serial queue is difficult without make-thread-
+ mutex, so this data structure is defined (withOUT define-
+ structure syntax) in a new file, thread-low.scm. The rest of
+ thread.scm must be loaded after record.scm if it is going to
+ use define-structure (or even define-syntax!).
random.scm:56: (let ((mask ((ucode-primitive set-interrupt-enables!) interrupt-mask/gc-ok)))
random.scm:78: ((ucode-primitive set-interrupt-enables!) mask)
(define-structure (event-distributor
(constructor make-event-distributor ())
(conc-name event-distributor/))
- (events (make-queue))
+ (events (make-serial-queue))
(lock false)
(receivers '()))
(declare (usual-integrations))
\f
(define (initialize-package!)
- (set! primitive-gc-daemons (make-queue))
+ (set! primitive-gc-daemons (make-serial-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! add-primitive-gc-daemon!/unsafe
+ (make-adder/unsafe primitive-gc-daemons))
+ (set! gc-daemons (make-serial-queue))
(set! trigger-gc-daemons! (make-trigger gc-daemons))
(set! add-gc-daemon! (make-adder gc-daemons))
- (set! secondary-gc-daemons (make-queue))
+ (set! add-gc-daemon!/unsafe (make-adder/unsafe gc-daemons))
+ (set! secondary-gc-daemons (make-serial-queue))
(set! trigger-secondary-gc-daemons! (make-trigger secondary-gc-daemons))
(set! add-secondary-gc-daemon! (make-adder secondary-gc-daemons))
+ (set! add-secondary-gc-daemon!/unsafe
+ (make-adder/unsafe secondary-gc-daemons))
(let ((fixed-objects ((ucode-primitive get-fixed-objects-vector))))
(vector-set! fixed-objects #x0B trigger-primitive-gc-daemons!)
((ucode-primitive set-fixed-objects-vector!) fixed-objects)))
(define primitive-gc-daemons)
(define %trigger-primitive-gc-daemons!)
(define add-primitive-gc-daemon!)
+(define add-primitive-gc-daemon!/unsafe)
(define (trigger-primitive-gc-daemons!)
(%trigger-primitive-gc-daemons!)
(define gc-daemons)
(define trigger-gc-daemons!)
(define add-gc-daemon!)
+(define add-gc-daemon!/unsafe)
(define (add-gc-daemon!/no-restore daemon)
(add-gc-daemon!
(lambda ()
(define secondary-gc-daemons)
(define trigger-secondary-gc-daemons!)
(define add-secondary-gc-daemon!)
+(define add-secondary-gc-daemon!/unsafe)
(define (make-trigger daemons)
(lambda ()
(lambda (daemon)
(enqueue! daemons daemon)))
+(define (make-adder/unsafe daemons)
+ (lambda (daemon)
+ (enqueue!/unsafe daemons daemon)))
+
(define (gc-clean #!optional threshold)
(let ((threshold
(cond ((default-object? threshold) 100)
("fixart" . (RUNTIME FIXNUM-ARITHMETIC))
("random" . (RUNTIME RANDOM-NUMBER))
("gentag" . (RUNTIME GENERIC-PROCEDURE))
+ ("thread-low" . (RUNTIME THREAD))
("record" . (RUNTIME RECORD))))
(files2
'(("syntax-items" . (RUNTIME SYNTAX ITEMS))
(define (initialize-package!)
(set! population-of-populations (list population-tag (make-thread-mutex)))
- (add-secondary-gc-daemon! clean-all-populations!))
+ (add-secondary-gc-daemon!/unsafe clean-all-populations!))
(define (initialize-unparser!)
(unparser/set-tagged-pair-method! population-tag
\f
(define (initialize-package!)
(set! population-of-1d-tables (make-serial-population/unsafe))
- (add-secondary-gc-daemon! gc-1d-tables!))
+ (add-secondary-gc-daemon!/unsafe gc-1d-tables!))
(define (initialize-unparser!)
(unparser/set-tagged-pair-method! 1d-table-tag
(declare (usual-integrations))
\f
(define-integrable (make-queue)
- (cons '() '()))
+ (cons* #f '() '()))
+
+(define-integrable (make-serial-queue)
+ (cons* (make-thread-mutex) '() '()))
(define-integrable (queue-empty? queue)
- (not (pair? (car queue))))
+ (not (pair? (cadr queue))))
(define-integrable (queued?/unsafe queue item)
- (memq item (car queue)))
+ (memq item (cadr queue)))
(define (enqueue!/unsafe queue object)
(let ((next (cons object '())))
- (if (pair? (cdr queue))
- (set-cdr! (cdr queue) next)
- (set-car! queue next))
- (set-cdr! queue next)
+ (if (pair? (cddr queue))
+ (set-cdr! (cddr queue) next)
+ (set-car! (cdr queue) next))
+ (set-cdr! (cdr queue) next)
unspecific))
(define (dequeue!/unsafe queue)
- (let ((next (car queue)))
+ (let ((next (cadr queue)))
(if (not (pair? next))
(error "Attempt to dequeue from empty queue"))
(if (pair? (cdr next))
- (set-car! queue (cdr next))
+ (set-car! (cdr queue) (cdr next))
(begin
- (set-car! queue '())
- (set-cdr! queue '())))
+ (set-car! (cdr queue) '())
+ (set-cdr! (cdr queue) '())))
(car next)))
(define (queue-map!/unsafe queue procedure)
(loop)))))
(define-integrable (queue->list/unsafe queue)
- (car queue))
+ (cadr queue))
+
+;;; Safe versions of the above operations (when used on a serializing
+;;; queue).
-;;; Safe (interrupt locked) versions of the above operations.
+(define-integrable (with-queue-locked queue thunk)
+ (let ((mutex (car queue)))
+ (if mutex
+ (with-thread-mutex-locked mutex
+ (lambda ()
+ (without-interruption thunk)))
+ (without-interruption thunk))))
(define-integrable (queued? queue item)
- (without-interrupts (lambda () (queued?/unsafe queue item))))
+ (with-queue-locked queue (lambda () (queued?/unsafe queue item))))
(define-integrable (enqueue! queue object)
- (without-interrupts (lambda () (enqueue!/unsafe queue object))))
+ (with-queue-locked queue (lambda () (enqueue!/unsafe queue object))))
(define-integrable (dequeue! queue)
- (without-interrupts (lambda () (dequeue!/unsafe queue))))
+ (with-queue-locked queue (lambda () (dequeue!/unsafe queue))))
(define (queue-map! queue procedure)
(let ((empty (list 'EMPTY)))
(let loop ()
(let ((item
- (without-interrupts
+ (with-queue-locked queue
(lambda ()
(if (queue-empty? queue)
empty
(loop)))))))
(define (queue->list queue)
- (without-interrupts
+ (with-queue-locked queue
(lambda ()
(list-copy (queue->list/unsafe queue)))))
\ No newline at end of file
(condition #f read-only #t)
(reader-history (make-repl-history repl-reader-history-size))
(printer-history (make-repl-history repl-printer-history-size))
- (input-queue (make-queue) read-only #t))
+ (input-queue (make-serial-queue) read-only #t))
(define (repl? object)
(and (cmdl? object)
(parent (runtime))
(export ()
make-queue
+ make-serial-queue
queue-empty?
queued?/unsafe
enqueue!/unsafe
(import (runtime population)
make-serial-population/unsafe
add-to-population!/unsafe)
+ (import (runtime gc-daemons)
+ add-secondary-gc-daemon!/unsafe)
(initialization (initialize-package!)))
(define-package (runtime 2d-property)
(define-package (runtime population)
(files "poplat")
(parent (runtime))
+ (import (runtime gc-daemons)
+ add-secondary-gc-daemon!/unsafe)
(export ()
add-to-population!
empty-population!
(initialization (initialize-package!)))
(define-package (runtime thread)
- (files "thread")
+ (files "thread-low" "thread")
(parent (runtime))
(export ()
assert-thread-mutex-owned
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Massachusetts
+ Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Some thread system structures needed during the early cold load.
+;;; package: (runtime thread)
+
+(declare (usual-integrations))
+
+(define-integrable thread-mutex-tag
+ '|#[(runtime thread)thread-mutex]|)
+
+(define-integrable (thread-mutex? object)
+ (and (vector? object)
+ (fix:= 3 (vector-length object))
+ (eq? (vector-ref object 0) thread-mutex-tag)))
+
+(define-integrable (make-thread-mutex)
+ (vector thread-mutex-tag (make-ring) #f))
+
+(define-integrable (thread-mutex/waiting-threads t) (vector-ref t 1))
+
+(define-integrable (thread-mutex/owner t) (vector-ref t 2))
+(define-integrable (set-thread-mutex/owner! t o) (vector-set! t 2 o))
+\f
+;;;; Circular Rings
+
+#;(define-structure (link (conc-name link/))
+ prev
+ next
+ item)
+
+(define-integrable link-tag
+ '|#[(runtime thread)link]|)
+
+(define-integrable (link? object)
+ (and (vector? object)
+ (fix:= 4 (vector-length object))
+ (eq? (vector-ref object 0) link-tag)))
+
+(define-integrable (make-link prev next item)
+ (vector link-tag prev next item))
+
+(define-integrable (link/prev l) (vector-ref l 1))
+(define-integrable (set-link/prev! l p) (vector-set! l 1 p))
+
+(define-integrable (link/next l) (vector-ref l 2))
+(define-integrable (set-link/next! l n) (vector-set! l 2 n))
+
+(define-integrable (link/item l) (vector-ref l 3))
+(define-integrable (set-link/item! l i) (vector-set! l 3 i))
+
+(define (make-ring)
+ (let ((link (make-link #f #f #f)))
+ (set-link/prev! link link)
+ (set-link/next! link link)
+ link))
+
+(define-integrable (ring/empty? ring)
+ (eq? (link/next ring) ring))
+
+(define (ring/enqueue ring item)
+ (let ((prev (link/prev ring)))
+ (let ((link (make-link prev ring item)))
+ (set-link/next! prev link)
+ (set-link/prev! ring link))))
+
+(define (ring/dequeue ring default)
+ (let ((link (link/next ring)))
+ (if (eq? link ring)
+ default
+ (begin
+ (let ((next (link/next link)))
+ (set-link/next! ring next)
+ (set-link/prev! next ring))
+ (link/item link)))))
+
+(define (ring/discard-all ring)
+ (set-link/prev! ring ring)
+ (set-link/next! ring ring))
+
+(define (ring/remove-item ring item)
+ (let loop ((link (link/next ring)))
+ (if (not (eq? link ring))
+ (if (eq? (link/item link) item)
+ (let ((prev (link/prev link))
+ (next (link/next link)))
+ (set-link/next! prev next)
+ (set-link/prev! next prev))
+ (loop (link/next link))))))
+
+(define (ring/count-max-2 ring)
+ (let ((link (link/next ring)))
+ (cond ((eq? link ring) 0)
+ ((eq? (link/next link) ring) 1)
+ (else 2))))
+
+(define (ring/first-item ring)
+ (link/item (link/next ring)))
+
+(define (ring/set-first-item! ring item)
+ (set-link/item! (link/next ring) item))
\ No newline at end of file
(initialize-error-conditions!)
(reset-threads-high!)
(add-event-receiver! event:after-restore reset-threads!)
- (add-event-receiver! event:before-exit stop-thread-timer))
+ (add-event-receiver! event:before-exit stop-thread-timer)
+ (named-structure/set-tag-description! thread-mutex-tag
+ (make-define-structure-type 'VECTOR
+ "thread-mutex"
+ '#(WAITING-THREADS OWNER)
+ '#(1 2)
+ (vector 2 (lambda () #f))
+ (standard-unparser-method 'THREAD-MUTEX #f)
+ thread-mutex-tag
+ 3))
+ (named-structure/set-tag-description! link-tag
+ (make-define-structure-type 'VECTOR
+ "link"
+ '#(PREV NEXT ITEM)
+ '#(1 2 3)
+ (vector 3 (lambda () #f))
+ (standard-unparser-method 'LINK #f)
+ link-tag
+ 4)))
(define (threads-list)
(with-threads-locked
\f
;;;; Mutexes
-(define-structure (thread-mutex
+;;; A record type cannot be created very early in the cold load, but
+;;; creating thread mutexes early is convenient for users of serial
+;;; populations, queues, etc. The following define-structure is
+;;; hand-expanded as a tagged vector (not record) in thread-low.scm.
+
+#;(define-structure (thread-mutex
(constructor make-thread-mutex ())
(conc-name thread-mutex/))
(waiting-threads (make-ring) read-only #t)
(assert-locked 'remove-thread-mutex!)
(set-thread/mutexes! thread (delq! mutex (thread/mutexes thread))))
\f
-;;;; Circular Rings
-
-(define-structure (link (conc-name link/))
- prev
- next
- item)
-
-(define (make-ring)
- (let ((link (make-link #f #f #f)))
- (set-link/prev! link link)
- (set-link/next! link link)
- link))
-
-(define-integrable (ring/empty? ring)
- (eq? (link/next ring) ring))
-
-(define (ring/enqueue ring item)
- (assert-locked 'ring/enqueue)
- (let ((prev (link/prev ring)))
- (let ((link (make-link prev ring item)))
- (set-link/next! prev link)
- (set-link/prev! ring link))))
-
-(define (ring/dequeue ring default)
- (assert-locked 'ring/dequeue)
- (let ((link (link/next ring)))
- (if (eq? link ring)
- default
- (begin
- (let ((next (link/next link)))
- (set-link/next! ring next)
- (set-link/prev! next ring))
- (link/item link)))))
-
-(define (ring/discard-all ring)
- (assert-locked 'ring/discard-all)
- (set-link/prev! ring ring)
- (set-link/next! ring ring))
-
-(define (ring/remove-item ring item)
- (assert-locked 'ring/remove-item)
- (let loop ((link (link/next ring)))
- (if (not (eq? link ring))
- (if (eq? (link/item link) item)
- (let ((prev (link/prev link))
- (next (link/next link)))
- (set-link/next! prev next)
- (set-link/prev! next prev))
- (loop (link/next link))))))
-
-(define (ring/count-max-2 ring)
- (assert-locked 'ring/count-max-2)
- (let ((link (link/next ring)))
- (cond ((eq? link ring) 0)
- ((eq? (link/next link) ring) 1)
- (else 2))))
-
-(define (ring/first-item ring)
- (assert-locked 'ring/first-item)
- (link/item (link/next ring)))
-
-(define (ring/set-first-item! ring item)
- (assert-locked 'ring/set-first-item!)
- (set-link/item! (link/next ring) item))
-\f
;;;; Error Conditions
(define condition-type:thread-control-error)
projects / mit-scheme.git / commitdiff