[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
bug#31878: Module autoloading is not thread safe
From: |
Ludovic Courtès |
Subject: |
bug#31878: Module autoloading is not thread safe |
Date: |
Mon, 18 Jun 2018 13:11:37 +0200 |
User-agent: |
Gnus/5.13 (Gnus v5.13) Emacs/26.1 (gnu/linux) |
address@hidden (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:
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))))))
@@ -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))))))
+
;;; SRFI-4 in the default environment. FIXME: we should figure out how
How does that look?
Thanks,
Ludo’.