From: Matt Birkholz 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))