summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2016-10-23 11:56:13 +0200
committerAndy Wingo <wingo@pobox.com>2016-10-23 12:17:19 +0200
commit56b490a4dd9b8d775d476154c0d4b96483b49436 (patch)
tree8130c458df4e6bedf22e952ee988c2269f85a9ac
parent206dced87f425af7eed628530313067a45bee2c2 (diff)
downloadguile-56b490a4dd9b8d775d476154c0d4b96483b49436.tar.gz
Deferred module observers via a parameter
* module/ice-9/boot-9.scm (module-defer-observers): Instead of being a global flag, change to be a parameter. (module-defer-observers-mutex, module-defer-observers-table): Remove. (module-modified): Adapt. (call-with-deferred-observers): Adapt. Allow nested called.
-rw-r--r--module/ice-9/boot-9.scm38
1 files changed, 20 insertions, 18 deletions
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 99543e7a5..48ea61d77 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -2029,31 +2029,33 @@ written into the port is returned."
(set-module-observers! module (delq1! id (module-observers module)))))
*unspecified*)
-(define module-defer-observers #f)
-(define module-defer-observers-mutex (make-mutex 'recursive))
-(define module-defer-observers-table (make-hash-table))
+;; Hash table of module -> #t indicating modules that changed while
+;; observers were deferred, or #f if observers are not being deferred.
+(define module-defer-observers (make-parameter #f))
(define (module-modified m)
- (if module-defer-observers
- (hash-set! module-defer-observers-table m #t)
- (module-call-observers m)))
+ (cond
+ ((module-defer-observers) => (lambda (tab) (hashq-set! tab m #t)))
+ (else (module-call-observers m))))
;;; This function can be used to delay calls to observers so that they
;;; can be called once only in the face of massive updating of modules.
;;;
(define (call-with-deferred-observers thunk)
- (dynamic-wind
- (lambda ()
- (lock-mutex module-defer-observers-mutex)
- (set! module-defer-observers #t))
- thunk
- (lambda ()
- (set! module-defer-observers #f)
- (hash-for-each (lambda (m dummy)
- (module-call-observers m))
- module-defer-observers-table)
- (hash-clear! module-defer-observers-table)
- (unlock-mutex module-defer-observers-mutex))))
+ (cond
+ ((module-defer-observers) (thunk))
+ (else
+ (let ((modules (make-hash-table)))
+ (dynamic-wind (lambda () #t)
+ (lambda ()
+ (parameterize ((module-defer-observers modules))
+ (thunk)))
+ (lambda ()
+ (let ((changed (hash-map->list cons modules)))
+ (hash-clear! modules)
+ (for-each (lambda (pair)
+ (module-call-observers (car pair)))
+ changed))))))))
(define (module-call-observers m)
(for-each (lambda (proc) (proc m)) (module-observers m))