bug#31878: Module autoloading is not thread safe

[ludo@gnu.org (Ludovic Courtès)]

[-- Attachment #1: Type: text/plain, Size: 274 bytes --]

ludo@gnu.org (Ludovic Courtès) skribis:

> I believe this comes from the fact that ‘autoloads-done’ and related
> alists in (ice-9 boot-9) are manipulated in a non-thread-safe fashion.

Here’s a proposed fix for ‘stable-2.2’ as discussed on #guile, Andy:


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: Type: text/x-patch, Size: 5282 bytes --]

diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 4e51e9281..960cb9fa3 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))))))
 
 \f
 
@@ -4061,6 +4067,19 @@ when none is available, reading FILE-NAME with READER."
 ;; Load (ice-9 threads), initializing some internal data structures.
 (resolve-interface '(ice-9 threads))
 
+(set! call-with-module-autoload-lock
+  (let* ((threads (resolve-module '(ice-9 threads)))
+         (mutex   ((module-ref threads 'make-mutex) 'recursive))
+         (lock    (module-ref threads 'lock-mutex))
+         (unlock  (module-ref threads 'unlock-mutex)))
+    (lambda (thunk)
+      (dynamic-wind
+        (lambda ()
+          (lock mutex))
+        thunk
+        (lambda ()
+          (unlock mutex))))))
+
 \f
 
 ;;; SRFI-4 in the default environment.  FIXME: we should figure out how

[-- Attachment #3: Type: text/plain, Size: 44 bytes --]


How does that look?

Thanks,
Ludo’.