[Guile-commits] 03/07: Make module autoloading thread-safe.

[Ludovic Courtès]

civodul pushed a commit to branch stable-2.2
in repository guile.

commit 761cf0fb8c364e885e4c6fced34563f8157c3b84
Author: Ludovic Courtès <address@hidden>
Date:   Mon Jun 18 13:42:22 2018 +0200

    Make module autoloading thread-safe.
    
    Fixes <https://bugs.gnu.org/31878>.
    
    * module/ice-9/boot-9.scm (call-with-module-autoload-lock): New procedure.
    (try-module-autoload): Wrap body in 'call-with-module-autoload-lock'.
    * module/ice-9/threads.scm: Set (@ (guile) call-with-module-autoload-lock).
---
 module/ice-9/boot-9.scm  | 74 ++++++++++++++++++++++++++----------------------
 module/ice-9/threads.scm | 11 ++++++-
 2 files changed, 50 insertions(+), 35 deletions(-)

diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 4e51e92..6cd9b47 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -1,6 +1,6 @@
 ;;; -*- mode: scheme; coding: utf-8; -*-
 
-;;;; Copyright (C) 1995-2014, 2016-2017  Free Software Foundation, Inc.
+;;;; Copyright (C) 1995-2014, 2016-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
@@ -2952,8 +2952,11 @@ module '(ice-9 q) '(make-q q-length))}."
 ;;; {Autoloading modules}
 ;;;
 
-;;; XXX FIXME autoloads-in-progress and autoloads-done
-;;;           are not handled in a thread-safe way.
+(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 the autoload variables below are used.
+  (thunk))
 
 (define autoloads-in-progress '())
 
@@ -2973,37 +2976,40 @@ but it fails to load."
                                                 file-name-separator-string))
                                dir-hint-module-name))))
     (resolve-module dir-hint-module-name #f)
-    (and (not (autoload-done-or-in-progress? dir-hint name))
-         (let ((didit #f))
-           (dynamic-wind
-            (lambda () (autoload-in-progress! dir-hint name))
-            (lambda ()
-              (with-fluids ((current-reader #f))
-                (save-module-excursion
-                 (lambda () 
-                   (define (call/ec proc)
-                     (let ((tag (make-prompt-tag)))
-                       (call-with-prompt
-                        tag
-                        (lambda ()
-                          (proc (lambda () (abort-to-prompt tag))))
-                        (lambda (k) (values)))))
-                   ;; The initial environment when loading a module is a fresh
-                   ;; user module.
-                   (set-current-module (make-fresh-user-module))
-                   ;; Here we could allow some other search strategy (other 
than
-                   ;; primitive-load-path), for example using versions encoded
-                   ;; into the file system -- but then we would have to figure
-                   ;; out how to locate the compiled file, do auto-compilation,
-                   ;; etc. Punt for now, and don't use versions when locating
-                   ;; the file.
-                   (call/ec
-                    (lambda (abort)
-                      (primitive-load-path (in-vicinity dir-hint name)
-                                           abort)
-                      (set! didit #t)))))))
-            (lambda () (set-autoloaded! dir-hint name didit)))
-           didit))))
+
+    (call-with-module-autoload-lock
+     (lambda ()
+       (and (not (autoload-done-or-in-progress? dir-hint name))
+            (let ((didit #f))
+              (dynamic-wind
+                (lambda () (autoload-in-progress! dir-hint name))
+                (lambda ()
+                  (with-fluids ((current-reader #f))
+                    (save-module-excursion
+                     (lambda ()
+                       (define (call/ec proc)
+                         (let ((tag (make-prompt-tag)))
+                           (call-with-prompt
+                               tag
+                             (lambda ()
+                               (proc (lambda () (abort-to-prompt tag))))
+                             (lambda (k) (values)))))
+                       ;; The initial environment when loading a module is a 
fresh
+                       ;; user module.
+                       (set-current-module (make-fresh-user-module))
+                       ;; Here we could allow some other search strategy 
(other than
+                       ;; primitive-load-path), for example using versions 
encoded
+                       ;; into the file system -- but then we would have to 
figure
+                       ;; out how to locate the compiled file, do 
auto-compilation,
+                       ;; etc. Punt for now, and don't use versions when 
locating
+                       ;; the file.
+                       (call/ec
+                        (lambda (abort)
+                          (primitive-load-path (in-vicinity dir-hint name)
+                                               abort)
+                          (set! didit #t)))))))
+                (lambda () (set-autoloaded! dir-hint name didit)))
+              didit))))))
 
 
 
diff --git a/module/ice-9/threads.scm b/module/ice-9/threads.scm
index 65108d9..c42bd26 100644
--- a/module/ice-9/threads.scm
+++ b/module/ice-9/threads.scm
@@ -1,5 +1,5 @@
 ;;;;   Copyright (C) 1996, 1998, 2001, 2002, 2003, 2006, 2010, 2011,
-;;;;      2012 Free Software Foundation, Inc.
+;;;;      2012, 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
@@ -380,4 +380,13 @@ of applying P-PROC on ARGLISTS."
                              (loop))))))
                  threads)))))
 
+
+;; Now that thread support is loaded, make module autoloading
+;; thread-safe.
+(set! (@ (guile) call-with-module-autoload-lock)
+  (let ((mutex (make-mutex 'recursive)))
+    (lambda (thunk)
+      (with-mutex mutex
+        (thunk)))))
+
 ;;; threads.scm ends here