Add make-serial-population.

Also add empty-population! and for-each-inhabitant.

Do not export the /unsafe procedures even to (runtime); require that
they be explicitly imported (specifically exported?).  Use the /unsafe
procedures in (runtime 1d-property) and (runtime thread) package
initializations to avoid trying to lock the population-of-populations
too early in the cold load.

diff --git a/src/runtime/poplat.scm b/src/runtime/poplat.scm
index 0d06b7e5f0b7628c91151353ba9a47143c027149..95dda1184ef469068a5026622ae0d032b75bb5a5 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-lock (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-lock (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-lock (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-lock (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..223c1e9f4bea7d60d84b2a9aed844b91ca30a6be 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-population/unsafe))
   (add-secondary-gc-daemon! gc-1d-tables!))
 
 (define (initialize-unparser!)

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index e3f0cf6d9128bd2eaff4d0927789cbae63f4ed3e..aa48c9e9b80407127d400c343741662832707290 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1105,6 +1105,9 @@ USA.
          1d-table/remove!
          1d-table?
          make-1d-table)
+  (import (runtime population)
+         make-population/unsafe
+         add-to-population!/unsafe)
   (initialization (initialize-package!)))
 
 (define-package (runtime 2d-property)
@@ -3154,15 +3157,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)
@@ -5055,6 +5059,9 @@ USA.
          (without-interruption with-thread-events-blocked)
          without-thread-mutex-lock
          yield-current-thread)
+  (import (runtime population)
+         add-to-population!/unsafe
+         make-population/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 5e7a0b151bd8c3da9cd019d546fa420e60b5c5e7..d39b2b582f6712968216fcc0f13083ce05be35ba 100644 (file)
--- a/src/runtime/thread.scm
+++ b/src/runtime/thread.scm
@@ -102,7 +102,7 @@ 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-running-thread #f)
   (set! last-running-thread #f)
   (set! next-scheduled-timeout #f)
@@ -161,7 +161,7 @@ USA.
     (set-thread/continuation! thread continuation)
     (set-thread/root-state-point! thread
                                  (current-state-point state-space:local))
-    (add-to-population!/unsafe thread-population thread)
+    (add-to-population! thread-population thread)
     (thread-running thread)
     thread))