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