[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
bug#31878: Module autoloading is not thread safe
|
From: |
Mark H Weaver |
|
Subject: |
bug#31878: Module autoloading is not thread safe |
|
Date: |
Sun, 21 Oct 2018 14:16:49 -0400 |
|
User-agent: |
Gnus/5.13 (Gnus v5.13) Emacs/26.1 (gnu/linux) |
I've written a preliminary patch to implement the improved thread-safe
module autoloading that I outlined in earlier messages in this bug
report.
Comments, suggestions, and testing welcome.
Mark
>From 897a6f76280612e83f48d63430bf962520c0e7b3 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <address@hidden>
Date: Sun, 21 Oct 2018 09:56:16 -0400
Subject: [PATCH] DRAFT: Fix thread-safe module loading.
* module/ice-9/boot-9.scm (%modules-being-loaded)
(%local-modules-being-loaded, %modules-waiting-for): New variables.
(%force-lazy-module-cell!, %module-waiting-for?)
(%module-waiting-for!): New procedures.
(resolve-module): If the requested module is not in the regular global
module table, look in '%local-modules-being-loaded' and
'%modules-being-loaded', and handle these cases appropriately. Support
looping without recursively locking the autoload lock. When
autoloading, unlock the mutex before calling 'try-load-module'.
(try-module-autoload): Add entries to '%modules-being-loaded' and
'%local-modules-being-loaded' before loading the module. Also, load the
module with the autoload mutex unlocked. When the load attempt
finishes (or fails), add the module to the regular global module table
if it was ever created, signal the threads waiting for this module, and
remove it from the '*-begin-loaded' and '%modules-waiting-for' tables.
(call-with-module-autoload-lock): Accept a unary procedure instead of a
thunk.
(module-name): Adapt to the new 'call-with-module-autoload-lock'.
(nested-define-module!): If we're asked to define a submodule of a
module that's currently being loaded, install the parent module being
loaded into the global module table.
* module/ice-9/threads.scm (call-with-module-autoload-lock):
Pass the mutex as an argument to the procedure.
* test-suite/tests/threads.test: Add tests.
* test-suite/tests/delayed-test.scm,
test-suite/tests/mutual-delayed-a.scm,
test-suite/tests/mutual-delayed-b.scm,
test-suite/tests/mutual-delayed-c.scm: New files.
* test-suite/Makefile.am (EXTRA_DIST): Add them.
---
module/ice-9/boot-9.scm | 292 ++++++++++++++++++++++----
module/ice-9/threads.scm | 4 +-
test-suite/Makefile.am | 7 +-
test-suite/tests/delayed-test.scm | 28 +++
test-suite/tests/mutual-delayed-a.scm | 29 +++
test-suite/tests/mutual-delayed-b.scm | 29 +++
test-suite/tests/mutual-delayed-c.scm | 29 +++
test-suite/tests/threads.test | 66 +++++-
8 files changed, 435 insertions(+), 49 deletions(-)
create mode 100644 test-suite/tests/delayed-test.scm
create mode 100644 test-suite/tests/mutual-delayed-a.scm
create mode 100644 test-suite/tests/mutual-delayed-b.scm
create mode 100644 test-suite/tests/mutual-delayed-c.scm
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index d8801dada..404a19d49 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -2502,13 +2502,32 @@ interfaces are added to the inports list."
(tail (cdr names)))
(if (null? tail)
(module-define-submodule! cur head module)
- (let ((cur (or (module-ref-submodule cur head)
- (let ((m (make-module 31)))
- (set-module-kind! m 'directory)
- (set-module-name! m (append (module-name cur)
- (list head)))
- (module-define-submodule! cur head m)
- m))))
+ (let ((cur
+ (or (module-ref-submodule cur head)
+ (let ((dir-name (append (module-name cur)
+ (list head))))
+ (cond ((assoc dir-name %modules-being-loaded)
+ => (lambda (entry)
+ ;; The module we're being asked to define
+ ;; is a submodule of a module that's
+ ;; currently being loaded. In this case,
+ ;; we must install the parent module
+ ;; being loaded into the global module
+ ;; table. This is unfortunate, but it's
+ ;; not clear how to avoid this without
+ ;; changing the structure of the global
+ ;; module table.
+ (let ((m (%force-lazy-module-cell!
+ (cddr entry)
+ dir-name)))
+ (module-define-submodule! cur head m)
+ m)))
+ (else
+ (let ((m (make-module 31)))
+ (set-module-kind! m 'directory)
+ (set-module-name! m dir-name)
+ (module-define-submodule! cur head m)
+ m)))))))
(loop cur (car tail) (cdr tail)))))))
@@ -2607,13 +2626,13 @@ interfaces are added to the inports list."
-(define (call-with-module-autoload-lock thunk)
- ;; This binding is overridden when (ice-9 threads) is available to
- ;; implement a critical section around the call to THUNK. It must be
- ;; used anytime 'autoloads-done' and related variables are accessed
- ;; and whenever submodules are accessed (via the 'nested-'
- ;; procedures.)
- (thunk))
+(define (call-with-module-autoload-lock proc)
+ ;; Apply PROC to the autoload lock or #f, while holding the lock.
+ ;; This must be used anytime 'autoloads-done' and related variables
+ ;; are accessed and whenever submodules are accessed (e.g. via the
+ ;; 'nested-' procedures.) This is initially a stub, but it will be
+ ;; overwritten when (ice-9 threads) is loaded.
+ (proc #f))
;; Now that modules are booted, give module-name its final definition.
;;
@@ -2627,7 +2646,7 @@ interfaces are added to the inports list."
;; names and relies on being able to `resolve-module' them.
(set-module-name! mod name)
(call-with-module-autoload-lock
- (lambda ()
+ (lambda (mutex)
(nested-define-module! (resolve-module '() #f) name mod)))
(accessor mod))))))
@@ -2701,36 +2720,175 @@ deterministic."
(beautify-user-module! m)
m))
+;; '%modules-being-loaded' is a global table of modules currently
+;; being loaded. Its entries are of the form:
+;;
+;; (NAME COND-VAR . LAZY-MODULE-CELL)
+;;
+;; where COND-VAR is a condition variable that will signaled when the
+;; current module load attempt succeeds (or fails), and LAZY-MODULE-CELL
+;; is a singleton list whose element is either a module or #f. It
+;; should only be accessed from within 'call-with-module-autoload-lock'.
+;;
+;; The modules in '%modules-being-loaded' are normally not added to the
+;; regular global module table until they have finished loading. The
+;; idea is that other threads should not be able to see the partially
+;; loaded module. If another thread tries to load the partially loaded
+;; module, it will normally wait on COND-VAR until the module has
+;; finished loading (or the load attempt fails). However, there are two
+;; cases when a thread is given access to a partially loaded module: (1)
+;; when the partially loaded module is in its
+;; '%local-modules-being-loaded' list, and (2) when a non-trivial cycle
+;; would be introduced in the reflexive and transitive closure of the
+;; global %modules-waiting-for relation.
+(define %modules-being-loaded
+ '())
+
+;; The entries in (fluid-ref %local-modules-being-loaded) are of
+;; the form:
+;;
+;; (NAME . LAZY-MODULE-CELL)
+;;
+;; where LAZY-MODULE-CELL is a singleton list whose element is
+;; either a module or #f. It should only be accessed from within
+;; 'call-with-module-autoload-lock'.
+;;
+;; Modules listed in (fluid-ref %local-modules-being-loaded) are visible
+;; to the local thread, even if they are not present in the regular
+;; global module table.
+(define %local-modules-being-loaded
+ (make-fluid '()))
+
+(define (%force-lazy-module-cell! cell name)
+ (or (car cell) ; the module already exists; return it
+ ;; otherwise, create a fresh new module, store it in the
+ ;; lazy-module-cell, and return it.
+ (let ((m (make-module 31)))
+ (set-module-name! m name)
+ (set-car! cell m)
+ m)))
+
+;; The '%modules-waiting-for' relation is a partial order on
+;; the modules present in the '%modules-being-loaded' table.
+;; Its entries are of the form:
+;;
+;; (NAME-1 . NAME-2)
+;;
+;; '%modules-waiting-for' is used to prevent deadlocks that would
+;; otherwise occur when mutually dependent modules are loaded
+;; concurrently. It should only be accessed from within
+;; 'call-with-module-autoload-lock'.
+(define %modules-waiting-for
+ '())
+
+;; Return #t if (NAME-1 NAME-2) is in the reflexive and transitive
+;; closure of '%modules-waiting-for'. This procedure should only be
+;; called from within 'call-with-module-autoload-lock'.
+(define (%module-waiting-for? name-1 name-2)
+ (or (equal? name-1 name-2)
+ (cond ((assoc name-1 %modules-waiting-for)
+ => (lambda (entry)
+ (%module-waiting-for? (cdr entry) name-2)))
+ (else #f))))
+
+;; Add (NAME-1 NAME-2) to the '%modules-waiting-for' relation if it's
+;; not already in the reflexive and transitive closure. Raise an error
+;; if adding it would introduce a cycle. This procedure should only be
+;; called from within 'call-with-module-autoload-lock'.
+(define (%module-waiting-for! name-1 name-2)
+ (unless (%module-waiting-for? name-1 name-2)
+ (when (%module-waiting-for? name-2 name-1)
+ (error "%module-waiting-for!: would introduce a cycle"
+ (list name-1 name-2 %modules-waiting-for)))
+ (set! %modules-waiting-for
+ (cons (cons name-1 name-2)
+ %modules-waiting-for))))
+
;; NOTE: This binding is used in libguile/modules.c.
;;
(define resolve-module
- (let ((root (make-module)))
+ (let ((root (make-module))
+ (ice-9-threads
+ (lambda (sym)
+ (module-ref (resolve-module '(ice-9 threads)) sym))))
+
(set-module-name! root '())
;; Define the-root-module as '(guile).
(module-define-submodule! root 'guile the-root-module)
(lambda* (name #:optional (autoload #t) (version #f) #:key (ensure #t))
(call-with-module-autoload-lock
- (lambda ()
- (let ((already (nested-ref-module root name)))
- (cond
- ((and already
- (or (not autoload) (module-public-interface already)))
- ;; A hit, a palpable hit.
- (if (and version
- (not (version-matches? version (module-version
already))))
+ (lambda (mutex)
+ (let loop ((autoload autoload))
+ ;; First check the global module table.
+ (let ((already (nested-ref-module root name)))
+ (cond
+ ((and already
+ (or (not autoload) (module-public-interface already)))
+ ;; A hit, a palpable hit.
+ (when (and version
+ (not (version-matches? version (module-version
already))))
(error "incompatible module version already loaded" name))
- already)
- (autoload
- ;; Try to autoload the module, and recurse.
- (try-load-module name version)
- (resolve-module name #f #:ensure ensure))
- (else
- ;; No module found (or if one was, it had no public interface),
and
- ;; we're not autoloading. Make an empty module if #:ensure is
true.
- (or already
- (and ensure
- (make-modules-in root name)))))))))))
+ already)
+
+ ;; The module is not in the global module table.
+ ;; Check %local-modules-being-loaded. If there's a
+ ;; matching entry, return the associated module,
+ ;; forcing the lazy module cell if needed.
+ ((assoc name (fluid-ref %local-modules-being-loaded))
+ => (lambda (entry)
+ (%force-lazy-module-cell! (cdr entry) name)))
+
+ ;; Check the global '%modules-being-loaded' table. If
+ ;; there's a matching entry, add an entry to the
+ ;; '%modules-waiting-for' relation (checking to
+ ;; make sure we don't introduce a cycle), wait on the
+ ;; associated condition variable for the module to be
+ ;; loaded, and try again.
+ ((assoc name %modules-being-loaded)
+ => (lambda (entry)
+ (let ((cond-var (cadr entry))
+ (lazy-module-cell (cddr entry))
+ (local-modules (fluid-ref
%local-modules-being-loaded)))
+ (if (or (not mutex)
+ (and (pair? local-modules)
+ ;; check for circular dependency below
+ (%module-waiting-for? name (caar
local-modules))))
+ ;; If (ice-9 threads) is not yet loaded, or
+ ;; if adding the new entry to
+ ;; '%module-waiting-for' would add a
+ ;; circular dependency, then punt and
+ ;; immediately return the partially-loaded
+ ;; module.
+ (%force-lazy-module-cell! lazy-module-cell name)
+ ;; Otherwise, add an entry to the
+ ;; '%modules-waiting-for' relation, wait on
+ ;; the associated condition variable for the
+ ;; module to be loaded, and try again.
+ (begin
+ (when (pair? local-modules)
+ (%module-waiting-for! (caar local-modules) name))
+ ;; wait for the pending module load to finish.
+ ((ice-9-threads 'wait-condition-variable) cond-var
mutex)
+ (loop #f)))))) ; and try again
+
+ (autoload
+ ;; Here we try to autoload the module. Unlock the mutex
+ ;; while we call 'try-load-module'.
+ (dynamic-wind
+ (lambda () (when mutex
+ ((ice-9-threads 'unlock-mutex) mutex)))
+ (lambda () (try-load-module name version))
+ (lambda () (when mutex
+ ((ice-9-threads 'lock-mutex) mutex))))
+ ;; Now try again with autoload set to #f.
+ (loop #f))
+ (else
+ ;; No module found (or if one was, it had no public interface),
and
+ ;; we're not autoloading. Make an empty module if #:ensure is
true.
+ (or already
+ (and ensure
+ (make-modules-in root name))))))))))))
(define (try-load-module name version)
@@ -2973,6 +3131,8 @@ module '(ice-9 q) '(make-q q-length))}."
"Try to load a module of the given name. If it is not found, return
#f. Otherwise return #t. May raise an exception if a file is found,
but it fails to load."
+ (define (ice-9-threads sym)
+ (module-ref (resolve-module '(ice-9 threads)) sym))
(let* ((reverse-name (reverse module-name))
(name (symbol->string (car reverse-name)))
(dir-hint-module-name (reverse (cdr reverse-name)))
@@ -2980,17 +3140,34 @@ but it fails to load."
(map (lambda (elt)
(string-append (symbol->string elt)
file-name-separator-string))
- dir-hint-module-name))))
- (resolve-module dir-hint-module-name #f)
+ dir-hint-module-name)))
+ (parent-module (resolve-module dir-hint-module-name #f)))
(call-with-module-autoload-lock
- (lambda ()
+ (lambda (mutex)
(and (not (autoload-done-or-in-progress? dir-hint name))
- (let ((didit #f))
+ (let ((lazy-module-cell (list #f))
+ (cond-var (and mutex
+ ((ice-9-threads 'make-condition-variable))))
+ (didit #f))
+
+ ;; Add an entry to the '%modules-being-loaded' table,
+ ;; with an associated condition variable to be signaled
+ ;; when the module is finished loading.
+ (set! %modules-being-loaded
+ (cons (cons* module-name cond-var lazy-module-cell)
+ %modules-being-loaded))
+
(dynamic-wind
- (lambda () (autoload-in-progress! dir-hint name))
(lambda ()
- (with-fluids ((current-reader #f))
+ (autoload-in-progress! dir-hint name)
+ (when mutex
+ ((ice-9-threads 'unlock-mutex) mutex)))
+ (lambda ()
+ (with-fluids ((%local-modules-being-loaded
+ (cons (cons module-name lazy-module-cell)
+ (fluid-ref
%local-modules-being-loaded)))
+ (current-reader #f))
(save-module-excursion
(lambda ()
(define (call/ec proc)
@@ -3014,7 +3191,38 @@ but it fails to load."
(primitive-load-path (in-vicinity dir-hint name)
abort)
(set! didit #t)))))))
- (lambda () (set-autoloaded! dir-hint name didit)))
+ (lambda ()
+ (when mutex
+ ((ice-9-threads 'lock-mutex) mutex))
+ (set-autoloaded! dir-hint name didit)))
+
+ ;; If the local module was actually created, then we
+ ;; now add it to the global module table.
+ (let ((module (car lazy-module-cell)))
+ (when module
+ (module-define-submodule! parent-module
+ (car reverse-name)
+ module)))
+
+ ;; Signal all threads waiting on the condition variable
+ ;; for this module to be loaded.
+ (when cond-var
+ ((ice-9-threads 'broadcast-condition-variable) cond-var))
+
+ ;; Remove the module from '%modules-being-loaded'.
+ (set! %modules-being-loaded
+ (assoc-remove! %modules-being-loaded
+ module-name))
+
+ ;; Remove all '%modules-waiting-for' entries that are
+ ;; directly related to the module that we just loaded
+ ;; (or attempted to load).
+ (set! %modules-waiting-for
+ (filter! (lambda (entry)
+ (not (or (equal? module-name (car entry))
+ (equal? module-name (cdr entry)))))
+ %modules-waiting-for))
+
didit))))))
diff --git a/module/ice-9/threads.scm b/module/ice-9/threads.scm
index c42bd266f..81fa22063 100644
--- a/module/ice-9/threads.scm
+++ b/module/ice-9/threads.scm
@@ -385,8 +385,8 @@ of applying P-PROC on ARGLISTS."
;; thread-safe.
(set! (@ (guile) call-with-module-autoload-lock)
(let ((mutex (make-mutex 'recursive)))
- (lambda (thunk)
+ (lambda (proc)
(with-mutex mutex
- (thunk)))))
+ (proc mutex)))))
;;; threads.scm ends here
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 0934dbb34..354c33152 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -1,7 +1,6 @@
## Process this file with automake to produce Makefile.in.
##
-## Copyright 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
-## 2010, 2011, 2012, 2013, 2014 Software Foundation, Inc.
+## Copyright 2001-2018 Software Foundation, Inc.
##
## This file is part of GUILE.
##
@@ -204,6 +203,10 @@ EXTRA_DIST = \
$(SCM_TESTS) \
tests/rnrs-test-a.scm \
tests/srfi-64-test.scm \
+ tests/mutual-delayed-a.scm \
+ tests/mutual-delayed-b.scm \
+ tests/mutual-delayed-c.scm \
+ tests/delayed-test.scm \
ChangeLog-2008
diff --git a/test-suite/tests/delayed-test.scm
b/test-suite/tests/delayed-test.scm
new file mode 100644
index 000000000..cc584d61d
--- /dev/null
+++ b/test-suite/tests/delayed-test.scm
@@ -0,0 +1,28 @@
+;;;; delayed-test.scm --- A test helper. -*- scheme -*-
+;;;;
+;;;; Copyright 2018 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+
+(define-module (tests delayed-test)
+ #:use-module (tests threads)
+ #:export (delayed-proc))
+
+(increment-delayed-test-count!)
+(define delayed-proc #f)
+(thread-safe-format "delayed-test: starting sleep\n")
+(sleep 2)
+(define (delayed-proc) 'done)
+(thread-safe-format "delayed-test: done\n")
diff --git a/test-suite/tests/mutual-delayed-a.scm
b/test-suite/tests/mutual-delayed-a.scm
new file mode 100644
index 000000000..6a8c4f116
--- /dev/null
+++ b/test-suite/tests/mutual-delayed-a.scm
@@ -0,0 +1,29 @@
+;;;; mutual-delayed-a.scm --- A test helper. -*- scheme -*-
+;;;;
+;;;; Copyright 2018 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+
+(define-module (tests mutual-delayed-a)
+ #:use-module (tests threads)
+ #:export (delayed-a))
+
+(define delayed-a #f)
+(thread-safe-format "mutual-delayed-a: starting sleep\n")
+(sleep 2)
+(thread-safe-format "mutual-delayed-a: loading mutual-delayed-b\n")
+(resolve-module '(tests mutual-delayed-b))
+(define (delayed-a) 'a)
+(thread-safe-format "mutual-delayed-a: done\n")
diff --git a/test-suite/tests/mutual-delayed-b.scm
b/test-suite/tests/mutual-delayed-b.scm
new file mode 100644
index 000000000..81aad5b52
--- /dev/null
+++ b/test-suite/tests/mutual-delayed-b.scm
@@ -0,0 +1,29 @@
+;;;; mutual-delayed-b.scm --- A test helper. -*- scheme -*-
+;;;;
+;;;; Copyright 2018 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+
+(define-module (tests mutual-delayed-b)
+ #:use-module (tests threads)
+ #:export (delayed-b))
+
+(define delayed-b #f)
+(thread-safe-format "mutual-delayed-b: starting sleep\n")
+(sleep 2)
+(thread-safe-format "mutual-delayed-b: loading mutual-delayed-c\n")
+(resolve-module '(tests mutual-delayed-c))
+(define (delayed-b) 'b)
+(thread-safe-format "mutual-delayed-b: done\n")
diff --git a/test-suite/tests/mutual-delayed-c.scm
b/test-suite/tests/mutual-delayed-c.scm
new file mode 100644
index 000000000..90e84a52f
--- /dev/null
+++ b/test-suite/tests/mutual-delayed-c.scm
@@ -0,0 +1,29 @@
+;;;; mutual-delayed-c.scm --- A test helper. -*- scheme -*-
+;;;;
+;;;; Copyright 2018 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+
+(define-module (tests mutual-delayed-c)
+ #:use-module (tests threads)
+ #:export (delayed-c))
+
+(define delayed-c #f)
+(thread-safe-format "mutual-delayed-c: starting sleep\n")
+(sleep 2)
+(thread-safe-format "mutual-delayed-c: loading mutual-delayed-a\n")
+(resolve-module '(tests mutual-delayed-a))
+(define (delayed-c) 'c)
+(thread-safe-format "mutual-delayed-c: done\n")
diff --git a/test-suite/tests/threads.test b/test-suite/tests/threads.test
index efdf36db2..434a1f4e8 100644
--- a/test-suite/tests/threads.test
+++ b/test-suite/tests/threads.test
@@ -1,7 +1,7 @@
;;;; threads.test --- Tests for Guile threading. -*- scheme -*-
;;;;
;;;; Copyright 2003, 2006, 2007, 2009, 2010, 2011, 2012, 2013,
-;;;; 2014 Free Software Foundation, Inc.
+;;;; 2014, 2018 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -17,10 +17,12 @@
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-(define-module (test-threads)
+(define-module (tests threads)
#:use-module (ice-9 threads)
#:use-module (system base compile)
- #:use-module (test-suite lib))
+ #:use-module (test-suite lib)
+ #:export (increment-delayed-test-count!
+ thread-safe-format))
(define (asyncs-still-working?)
(let ((a #f))
@@ -448,3 +450,61 @@
(pass-if "current-processor-count"
(and (>= (current-processor-count) 1)
(>= (total-processor-count) (current-processor-count)))))
+
+;;
+;; thread safe module loading
+;;
+
+(define thread-safe-format
+ (let ((mutex (make-mutex)))
+ (lambda args
+ (with-mutex mutex
+ (apply format (current-error-port) args)))))
+(define delayed-test-count-mutex (make-mutex))
+(define delayed-test-count 0)
+(define (increment-delayed-test-count!)
+ (with-mutex delayed-test-count-mutex
+ (set! delayed-test-count
+ (+ delayed-test-count 1))))
+
+(with-test-prefix "thread safe module loading"
+ ;; We deliberately avoid using 'par-map' below, because the
+ ;; effectiveness of these tests depend on them running roughly in
+ ;; parallel. When 'par-map' is used on a machine with only 1 or 2
+ ;; cores, the tests below are unable to reliably detect the problems
+ ;; that exist before guile-2.2.5.
+ (define (spawn-test-thread module-name sym)
+ (call-with-new-thread
+ (lambda ()
+ (cond ((module-variable (resolve-module module-name) sym)
+ => (lambda (v)
+ (and (variable? v)
+ (procedure? (variable-ref v))
+ ((variable-ref v)))))
+ (else
+ #f)))))
+ (define (join-thread-with-timeout deadline)
+ (lambda (thread)
+ (join-thread thread deadline 'timeout)))
+ (pass-if-equal "concurrent loading of the same module by multiple threads"
+ '(1 done done done done done done)
+ (let ((results
+ (map (join-thread-with-timeout (+ (current-time) 20))
+ (map (lambda (i)
+ (spawn-test-thread '(tests delayed-test)
+ 'delayed-proc))
+ (iota 6)))))
+ (cons delayed-test-count results)))
+ (pass-if-equal "mutually dependent modules loaded concurrently"
+ '(a b c a b c a b c)
+ (map (join-thread-with-timeout (+ (current-time) 20))
+ (map (lambda (i)
+ (case (modulo i 3)
+ ((0) (spawn-test-thread '(tests mutual-delayed-a)
+ 'delayed-a))
+ ((1) (spawn-test-thread '(tests mutual-delayed-b)
+ 'delayed-b))
+ ((2) (spawn-test-thread '(tests mutual-delayed-c)
+ 'delayed-c))
+ (else #f)))
+ (iota 9)))))
--
2.19.1
- bug#31878: Module autoloading is not thread safe,
Mark H Weaver <=