smp: Add make-serial-population.

diff --git a/src/runtime/make.scm b/src/runtime/make.scm
index 13fa51d469b9ee8dc7b81811bc4036e3c220fb2c..748fce54857b992266e78a02214c27a4da4f2a0c 100644 (file)
--- 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 0d06b7e5f0b7628c91151353ba9a47143c027149..0e2bf17d78a193588c2924c2d25d09737582f492 100644 (file)
--- a/src/runtime/poplat.scm
+++ b/src/runtime/poplat.scm
@@ -29,13 +29,12 @@ USA.
 
 (declare (usual-integrations))
 \f
-;;; 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)
 \f
 (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) '()))
 \f
-;;;; 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 84d9270b66374c884ceaf18ae316c7cd3a2b4eae..46990b65585f26c11f4057cf526b70d1cfa57a50 100644 (file)
--- a/src/runtime/prop1d.scm
+++ b/src/runtime/prop1d.scm
@@ -30,7 +30,7 @@ USA.
 (declare (usual-integrations))
 \f
 (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 c8a8d086d1b8794a5f5c9353332e15c199ac8cad..b042811e1ad7921c5a37634902c93c59636dc3fb 100644 (file)
--- 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 219fe067cb38f4eac18ff735e883e71fd7f1340b..c987ee09bdd563ed2b6436b08dd90180911ea96e 100644 (file)
--- a/src/runtime/thread.scm
+++ b/src/runtime/thread.scm
@@ -90,7 +90,7 @@ USA.
       value)))
 \f
 (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