From: Matt Birkholz Date: Tue, 10 Mar 2015 21:11:39 +0000 (-0700) Subject: smp: without-interrupts: queue.scm X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=9acd4dc1bde9d6993dedbebbd4d381936046de98;p=mit-scheme.git smp: without-interrupts: queue.scm --- diff --git a/README.txt b/README.txt index 6e68e604f..5b3d80f3a 100644 --- a/README.txt +++ b/README.txt @@ -1456,10 +1456,37 @@ The hits with accompanying analysis: 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) diff --git a/src/runtime/events.scm b/src/runtime/events.scm index 6be93e1fd..691842c95 100644 --- a/src/runtime/events.scm +++ b/src/runtime/events.scm @@ -37,7 +37,7 @@ USA. (define-structure (event-distributor (constructor make-event-distributor ()) (conc-name event-distributor/)) - (events (make-queue)) + (events (make-serial-queue)) (lock false) (receivers '())) diff --git a/src/runtime/gcdemn.scm b/src/runtime/gcdemn.scm index bb70cfa0c..b6f809c1e 100644 --- a/src/runtime/gcdemn.scm +++ b/src/runtime/gcdemn.scm @@ -30,15 +30,20 @@ USA. (declare (usual-integrations)) (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))) @@ -49,6 +54,7 @@ USA. (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!) @@ -63,6 +69,7 @@ USA. (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 () @@ -75,6 +82,7 @@ USA. (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 () @@ -85,6 +93,10 @@ USA. (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) diff --git a/src/runtime/make.scm b/src/runtime/make.scm index 748fce548..3dd81a625 100644 --- a/src/runtime/make.scm +++ b/src/runtime/make.scm @@ -366,6 +366,7 @@ USA. ("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)) diff --git a/src/runtime/poplat.scm b/src/runtime/poplat.scm index 0e2bf17d7..70a034e11 100644 --- a/src/runtime/poplat.scm +++ b/src/runtime/poplat.scm @@ -34,7 +34,7 @@ USA. (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 diff --git a/src/runtime/prop1d.scm b/src/runtime/prop1d.scm index 46990b655..c58e59977 100644 --- a/src/runtime/prop1d.scm +++ b/src/runtime/prop1d.scm @@ -31,7 +31,7 @@ USA. (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 diff --git a/src/runtime/queue.scm b/src/runtime/queue.scm index bf9d0527a..c5fe1bd7c 100644 --- a/src/runtime/queue.scm +++ b/src/runtime/queue.scm @@ -30,31 +30,34 @@ USA. (declare (usual-integrations)) (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) @@ -65,24 +68,33 @@ USA. (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 @@ -93,6 +105,6 @@ USA. (loop))))))) (define (queue->list queue) - (without-interrupts + (with-queue-locked queue (lambda () (list-copy (queue->list/unsafe queue))))) \ No newline at end of file diff --git a/src/runtime/rep.scm b/src/runtime/rep.scm index 9ea3cf0ed..65c86f072 100644 --- a/src/runtime/rep.scm +++ b/src/runtime/rep.scm @@ -677,7 +677,7 @@ USA. (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) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 9fb00e887..b752be9ae 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -564,6 +564,7 @@ USA. (parent (runtime)) (export () make-queue + make-serial-queue queue-empty? queued?/unsafe enqueue!/unsafe @@ -1114,6 +1115,8 @@ USA. (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) @@ -3158,6 +3161,8 @@ USA. (define-package (runtime population) (files "poplat") (parent (runtime)) + (import (runtime gc-daemons) + add-secondary-gc-daemon!/unsafe) (export () add-to-population! empty-population! @@ -5021,7 +5026,7 @@ USA. (initialization (initialize-package!))) (define-package (runtime thread) - (files "thread") + (files "thread-low" "thread") (parent (runtime)) (export () assert-thread-mutex-owned diff --git a/src/runtime/thread-low.scm b/src/runtime/thread-low.scm new file mode 100644 index 000000000..e46662baf --- /dev/null +++ b/src/runtime/thread-low.scm @@ -0,0 +1,124 @@ +#| -*-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)) + +;;;; 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 diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm index 70ad67128..ddf49817e 100644 --- a/src/runtime/thread.scm +++ b/src/runtime/thread.scm @@ -186,7 +186,25 @@ USA. (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 @@ -1324,7 +1342,12 @@ USA. ;;;; 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) @@ -1438,71 +1461,6 @@ USA. (assert-locked 'remove-thread-mutex!) (set-thread/mutexes! thread (delq! mutex (thread/mutexes thread)))) -;;;; 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)) - ;;;; Error Conditions (define condition-type:thread-control-error)