From: Matt Birkholz Date: Wed, 25 Feb 2015 15:12:38 +0000 (-0700) Subject: smp: Add make-serial-population. X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=4824062c5a35bcf36480531ba27d776e56edfb32;p=mit-scheme.git smp: Add make-serial-population. --- diff --git a/src/runtime/make.scm b/src/runtime/make.scm index 13fa51d46..748fce548 100644 --- a/src/runtime/make.scm +++ b/src/runtime/make.scm @@ -366,16 +366,16 @@ USA. ("fixart" . (RUNTIME FIXNUM-ARITHMETIC)) ("random" . (RUNTIME RANDOM-NUMBER)) ("gentag" . (RUNTIME GENERIC-PROCEDURE)) - ("poplat" . (RUNTIME POPULATION)) ("record" . (RUNTIME RECORD)))) (files2 '(("syntax-items" . (RUNTIME SYNTAX ITEMS)) ("syntax-transforms" . (RUNTIME SYNTAX TRANSFORMS)) + ("poplat" . (RUNTIME POPULATION)) + ("thread" . (RUNTIME THREAD)) ("prop1d" . (RUNTIME 1D-PROPERTY)) ("events" . (RUNTIME EVENT-DISTRIBUTOR)) ("gdatab" . (RUNTIME GLOBAL-DATABASE)) ("vector" . (RUNTIME VECTOR)) - ("thread" . (RUNTIME THREAD)) ("wind" . (RUNTIME WIND)) ("gcfinal" . (RUNTIME GC-FINALIZER)) ("string" . (RUNTIME STRING)) ; First GC-finalizer. @@ -392,15 +392,15 @@ USA. (package-initialize '(RUNTIME RANDOM-NUMBER) #f #t) (package-initialize '(RUNTIME GENERIC-PROCEDURE) 'INITIALIZE-TAG-CONSTANTS! #t) - (package-initialize '(RUNTIME POPULATION) #f #t) (package-initialize '(RUNTIME RECORD) 'INITIALIZE-RECORD-TYPE-TYPE! #t) (load-files files2) - (package-initialize '(RUNTIME 1D-PROPERTY) #f #t) + (package-initialize '(RUNTIME POPULATION) #f #t) + (package-initialize '(RUNTIME 1D-PROPERTY) #f #t) ;First population. + (package-initialize '(RUNTIME THREAD) 'INITIALIZE-LOW! #t) ;First 1d-table. (package-initialize '(RUNTIME EVENT-DISTRIBUTOR) #f #t) (package-initialize '(RUNTIME GLOBAL-DATABASE) #f #t) (package-initialize '(RUNTIME POPULATION) 'INITIALIZE-UNPARSER! #t) (package-initialize '(RUNTIME 1D-PROPERTY) 'INITIALIZE-UNPARSER! #t) - (package-initialize '(RUNTIME THREAD) 'INITIALIZE-LOW! #t) (package-initialize '(RUNTIME GC-FINALIZER) #f #t) (package-initialize '(RUNTIME STRING) #f #t) diff --git a/src/runtime/poplat.scm b/src/runtime/poplat.scm index 0d06b7e5f..0e2bf17d7 100644 --- a/src/runtime/poplat.scm +++ b/src/runtime/poplat.scm @@ -29,13 +29,12 @@ USA. (declare (usual-integrations)) -;;; 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. +;;; A population is a weak collection of objects. A serial +;;; population is a population with a mutex to serialize its operations. (define (initialize-package!) - (set! population-of-populations (cons population-tag '())) - (add-secondary-gc-daemon! gc-all-populations!)) + (set! population-of-populations (list population-tag (make-thread-mutex))) + (add-secondary-gc-daemon! clean-all-populations!)) (define (initialize-unparser!) (unparser/set-tagged-pair-method! population-tag @@ -43,7 +42,6 @@ USA. (define bogus-false '(BOGUS-FALSE)) (define population-tag '(POPULATION)) -(define-integrable weak-cons-type (ucode-type weak-cons)) (define-integrable (canonicalize object) (if (eq? object false) bogus-false object)) @@ -51,43 +49,67 @@ USA. (define-integrable (uncanonicalize object) (if (eq? object bogus-false) false object)) -(define (gc-population! population) - (let loop ((l1 population) (l2 (cdr population))) +(define (clean-population! population) + (if (cadr population) + (with-thread-mutex-locked (cadr population) + (lambda () + (%clean-population! population))) + (%clean-population! population))) + +(define (%clean-population! population) + (let loop ((l1 (cdr population)) (l2 (cddr population))) (cond ((null? l2) true) ((eq? (system-pair-car l2) false) (system-pair-set-cdr! l1 (system-pair-cdr l2)) - (loop l1 (system-pair-cdr l1))) + (loop l1 (system-pair-cdr l2))) (else (loop l2 (system-pair-cdr l2)))))) -(define (gc-all-populations!) - (gc-population! population-of-populations) - (map-over-population! population-of-populations gc-population!)) +(define (clean-all-populations!) + (clean-population! population-of-populations) + (map-over-population! population-of-populations clean-population!)) (define population-of-populations) (define (make-population) - (let ((population (cons population-tag '()))) + (let ((population (list population-tag #f))) + (add-to-population! population-of-populations population) + population)) + +(define (make-population/unsafe) + (let ((population (list population-tag #f))) + (add-to-population!/unsafe population-of-populations population) + population)) + +(define (make-serial-population) + (let ((population (list population-tag (make-thread-mutex)))) (add-to-population! population-of-populations population) population)) +(define (make-serial-population/unsafe) + (let ((population (list population-tag (make-thread-mutex)))) + (add-to-population!/unsafe population-of-populations population) + population)) + (define (population? object) (and (pair? object) (eq? (car object) population-tag))) -(define (add-to-population!/unsafe population object) - (set-cdr! population - (system-pair-cons weak-cons-type - (canonicalize object) - (cdr population)))) +(define-guarantee population "population") (define (add-to-population! population object) + (guarantee-population population 'add-to-population!) + (if (cadr population) + (with-thread-mutex-locked (cadr population) + (lambda () + (%add-to-population! population object))) + (%add-to-population! population object))) + +(define (%add-to-population! population object) (let ((object (canonicalize object))) - (let loop ((previous population) (this (cdr population))) + (let loop ((previous (cdr population)) (this (cddr population))) (if (null? this) - (set-cdr! population - (system-pair-cons weak-cons-type - object - (cdr population))) + (set-cdr! (cdr population) + (weak-cons object (cddr population))) (let ((entry (system-pair-car this)) (next (system-pair-cdr this))) (cond ((not entry) @@ -96,9 +118,21 @@ USA. ((not (eq? object entry)) (loop this next)))))))) +(define (add-to-population!/unsafe population object) + ;; No canonicalization, no uniquification, no locking. + (set-cdr! (cdr population) (weak-cons object (cddr population)))) + (define (remove-from-population! population object) + (guarantee-population population 'remove-from-population!) + (if (cadr population) + (with-thread-mutex-locked (cadr population) + (lambda () + (%remove-from-population! population object))) + (%remove-from-population! population object))) + +(define (%remove-from-population! population object) (let ((object (canonicalize object))) - (let loop ((previous population) (this (cdr population))) + (let loop ((previous (cdr population)) (this (cddr population))) (if (not (null? this)) (let ((entry (system-pair-car this)) (next (system-pair-cdr this))) @@ -106,43 +140,52 @@ USA. (begin (system-pair-set-cdr! previous next) (loop previous next)) (loop this next))))))) + +(define (empty-population! population) + (guarantee-population population 'empty-population!) + (if (cadr population) + (with-thread-mutex-locked (cadr population) + (lambda () + (%empty-population! population))) + (%empty-population! population))) + +(define (%empty-population! population) + (set-cdr! (cdr population) '())) -;;;; Higher level operations +;;;; Read-only operations + +;;; These are safe without serialization. (define (map-over-population population procedure) - (let loop ((l1 population) (l2 (cdr population))) + (let loop ((l2 (cddr population))) (cond ((null? l2) '()) ((eq? (system-pair-car l2) false) - (system-pair-set-cdr! l1 (system-pair-cdr l2)) - (loop l1 (system-pair-cdr l1))) + (loop (system-pair-cdr l2))) (else (cons (procedure (uncanonicalize (system-pair-car l2))) - (loop l2 (system-pair-cdr l2))))))) + (loop (system-pair-cdr l2))))))) (define (map-over-population! population procedure) - (let loop ((l1 population) (l2 (cdr population))) + (let loop ((l2 (cddr population))) (cond ((null? l2) true) ((eq? (system-pair-car l2) false) - (system-pair-set-cdr! l1 (system-pair-cdr l2)) - (loop l1 (system-pair-cdr l1))) + (loop (system-pair-cdr l2))) (else (procedure (uncanonicalize (system-pair-car l2))) - (loop l2 (system-pair-cdr l2)))))) + (loop (system-pair-cdr l2)))))) (define (for-all-inhabitants? population predicate) - (let loop ((l1 population) (l2 (cdr population))) + (let loop ((l2 (cddr population))) (or (null? l2) (if (eq? (system-pair-car l2) false) - (begin (system-pair-set-cdr! l1 (system-pair-cdr l2)) - (loop l1 (system-pair-cdr l1))) + (loop (system-pair-cdr l2)) (and (predicate (uncanonicalize (system-pair-car l2))) - (loop l2 (system-pair-cdr l2))))))) + (loop (system-pair-cdr l2))))))) (define (exists-an-inhabitant? population predicate) - (let loop ((l1 population) (l2 (cdr population))) + (let loop ((l2 (cddr population))) (and (not (null? l2)) (if (eq? (system-pair-car l2) false) - (begin (system-pair-set-cdr! l1 (system-pair-cdr l2)) - (loop l1 (system-pair-cdr l1))) + (loop (system-pair-cdr l2)) (or (predicate (uncanonicalize (system-pair-car l2))) - (loop l2 (system-pair-cdr l2))))))) \ No newline at end of file + (loop (system-pair-cdr l2))))))) \ No newline at end of file diff --git a/src/runtime/prop1d.scm b/src/runtime/prop1d.scm index 84d9270b6..46990b655 100644 --- a/src/runtime/prop1d.scm +++ b/src/runtime/prop1d.scm @@ -30,7 +30,7 @@ USA. (declare (usual-integrations)) (define (initialize-package!) - (set! population-of-1d-tables (make-population)) + (set! population-of-1d-tables (make-serial-population/unsafe)) (add-secondary-gc-daemon! gc-1d-tables!)) (define (initialize-unparser!) @@ -43,6 +43,11 @@ USA. (map-over-population! population-of-1d-tables 1d-table/clean!)) (define (make-1d-table) + (let ((table (list 1d-table-tag))) + (add-to-population! population-of-1d-tables table) + table)) + +(define (make-1d-table/unsafe) (let ((table (list 1d-table-tag))) (add-to-population!/unsafe population-of-1d-tables table) table)) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index c8a8d086d..b042811e1 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -1108,6 +1108,9 @@ USA. 1d-table/remove! 1d-table? make-1d-table) + (import (runtime population) + make-serial-population/unsafe + add-to-population!/unsafe) (initialization (initialize-package!))) (define-package (runtime 2d-property) @@ -3153,15 +3156,16 @@ USA. (parent (runtime)) (export () add-to-population! + empty-population! exists-an-inhabitant? for-all-inhabitants? + (for-each-inhabitant map-over-population!) make-population + make-serial-population map-over-population map-over-population! population? remove-from-population!) - (export (runtime) - add-to-population!/unsafe) (initialization (initialize-package!))) (define-package (runtime pretty-printer) @@ -5065,6 +5069,10 @@ USA. with-thread-mutex-unlocked with-thread-timer-stopped yield-current-thread) + (import (runtime population) + make-population/unsafe) + (import (runtime 1d-property) + make-1d-table/unsafe) (export (runtime interrupt-handler) thread-timer-interrupt-handler) (export (runtime primitive-io) diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm index 219fe067c..c987ee09b 100644 --- a/src/runtime/thread.scm +++ b/src/runtime/thread.scm @@ -90,7 +90,7 @@ USA. value))) (define-structure (thread - (constructor %make-thread ()) + (constructor %make-thread (properties)) (conc-name thread/)) (execution-state 'RUNNING) ;; One of: @@ -141,7 +141,7 @@ USA. ;; List of mutexes that this thread owns or is waiting to own. Used ;; to disassociate the thread from those mutexes when it is exited. - (properties (make-1d-table) read-only #t)) + (properties #f read-only #t)) (define-integrable (guarantee-thread thread procedure) (if (not (thread? thread)) @@ -164,16 +164,16 @@ USA. (define (initialize-low!) ;; Called early in the cold load to create the first thread. - (set! thread-population (make-population)) + (set! thread-population (make-population/unsafe)) (set! first-runnable-thread #f) (set! last-runnable-thread #f) (set! next-scheduled-timeout #f) (set! timer-records #f) (set! timer-interval 100) (reset-threads-low!) - (let ((first (%make-thread))) + (let ((first (%make-thread (make-1d-table/unsafe)))) (set-thread/exit-value! first detached-thread-marker) - (add-to-population!/unsafe thread-population first) + (add-to-population! thread-population first) (vector-set! current-threads (if enable-smp? ((ucode-primitive smp-id 0)) @@ -210,11 +210,11 @@ USA. (lambda () (call-with-current-continuation (lambda (continuation) - (let ((thread (%make-thread))) + (let ((thread (%make-thread (make-1d-table)))) (set-thread/continuation! thread continuation) (with-threads-locked (lambda () - (add-to-population!/unsafe thread-population thread) + (add-to-population! thread-population thread) (thread-running (%id) thread))) (%within-continuation (let ((k return)) (set! return #f) k) #t