From: Matt Birkholz <puck@birchwood-abbey.net>
Date: Thu, 18 Jun 2015 18:22:42 +0000 (-0700)
Subject: Add make-serial-population.
X-Git-Tag: mit-scheme-pucked-9.2.12~376^2~44
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=39cfb8e64cad54f0d2237b170dc584f4d3470aea;p=mit-scheme.git
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 0d06b7e5f..95dda1184 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-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)
(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) '()))
-;;;; 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..223c1e9f4 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-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 c087eb5aa..3f9435b94 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1125,6 +1125,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)
@@ -3175,15 +3178,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)
@@ -5081,6 +5085,9 @@ USA.
without-preemption
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 733367ab9..370b91357 100644
--- a/src/runtime/thread.scm
+++ b/src/runtime/thread.scm
@@ -103,7 +103,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)
@@ -162,7 +162,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))