mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 03:30:27 +02:00
Code Activity

Make module autoloading thread-safe.

Browse source 
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).
This commit is contained in:
Ludovic Courtès 2018-06-18 13:42:22 +02:00 • committed by Andy Wingo
parent b79a6e647d
commit 251202fc90
2 changed files with 49 additions and 34 deletions
Download patch file Download diff file Expand all files Collapse all files

72
module/ice-9/boot-9.scm
View file

@ -2936,8 +2936,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 '())
@ -2957,37 +2960,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))))))

11
module/ice-9/threads.scm
View file

@ -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