add namespace-call-with-registry-lock

Lazy require benefits from using a lock on a namespace registry for
much the same reason as on-demand instantiation of ready modules. Make
lazy require use the lock that's alerady in place for on-demand
instantiation, and expose `namespace-call-with-registry-lock` for
other potential uses.

Thanks to @m4burns for tracking down the problem and its solution.

Related to #3805

pkgs/base/info.rkt

@@ -14,7 +14,7 @@
 
 ;; In the Racket source repo, this version should change only when
 ;; "racket_version.h" changes:
-(define version "8.1.0.4")
+(define version "8.1.0.5")
 
 (define deps `("racket-lib"
                ["racket" #:version ,version]))

pkgs/racket-doc/scribblings/reference/module-reflect.scrbl

@@ -532,7 +532,9 @@ phase}, if it is not yet @tech{instantiate}d. The current @tech{module
 name resolver} may load a module declaration to resolve @racket[mod]
 (see @racket[current-module-name-resolver]); the path is resolved
 relative to @racket[current-load-relative-directory] and/or
-@racket[current-directory].
+@racket[current-directory]. Beware that concurrent @racket[dynamic-require]s
+in namespaces that share a @tech{module registry} can create race
+conditions; see also @racket[namespace-call-with-registry-lock].
 
 If @racket[provided] is @racket[#f], then the result is @|void-const|,
 and the module is not @tech{visit}ed (see @secref["mod-parse"]) or

pkgs/racket-doc/scribblings/reference/namespaces.scrbl

@@ -366,6 +366,21 @@ Returns the @tech{module registry} of the given namespace. This value
 is useful only for identification via @racket[eq?].}
 
 
+@defproc[(namespace-call-with-registry-lock [namespace namespace?]
+                                            [thunk (-> any)])
+         any]{
+
+Calls @racket[thunk] while holding a reentrant lock for the namespace's
+@tech{module registry}.
+
+Namespace functions do not automatically use the registry lock, but it
+can be used via @racket[namespace-call-with-registry-lock] among
+threads that load and instantiate modules to avoid internal race
+conditions. On-demand @tech{instantiation} of @tech{available} modules
+also takes the lock; see @secref["mod-parse"].
+
+@history[#:added "8.1.0.5"]}
+
 @defproc[(module->namespace [mod (or/c module-path? 
                                        resolved-module-path? 
                                        module-path-index?)]

pkgs/racket-doc/scribblings/reference/syntax-model.scrbl

@@ -919,7 +919,9 @@ are visited. More generally, initiating expansion at @tech{phase}
 @tech{visits} and @tech{instantiations} apply to @tech{available}
 modules in the enclosing @tech{namespace}'s @tech{module registry};
 a per-registry lock prevents multiple threads from concurrently
-instantiating and visiting available modules.
+instantiating and visiting available modules. On-demand instantiation
+of available modules uses the same reentrant lock as
+@racket[namespace-call-with-registry-lock].
 
 When the expander encounters @racket[require] and @racket[(require
 (for-syntax ....))] within a @tech{module context}, the resulting

pkgs/racket-test-core/tests/racket/namespac.rktl

@@ -208,6 +208,26 @@
 
 ;; ----------------------------------------
 
+(test 'ok namespace-call-with-registry-lock (current-namespace) (lambda () 'ok))
+(test-values '(1 2 3) (lambda () (namespace-call-with-registry-lock (current-namespace)
+                                                                    (lambda () (values 1 2 3)))))
+
+(test 'rentrant namespace-call-with-registry-lock (current-namespace)
+      (lambda ()
+        (namespace-call-with-registry-lock (current-namespace)
+                                           (lambda () 'rentrant))))
+
+(test 'fine namespace-call-with-registry-lock (current-namespace)
+      (lambda ()
+        (let ([result 'fine])
+          (thread (lambda ()
+                    (namespace-call-with-registry-lock (current-namespace)
+                                                       (lambda () (set! result 'lock-oops)))))
+          (sync (system-idle-evt))
+          result)))
+
+;; ----------------------------------------
+
 (parameterize ([current-namespace (make-base-namespace)])
   (eval '(define-namespace-anchor anchor))
   (test 1 eval '(eval 1 (namespace-anchor->namespace anchor))))

racket/collects/racket/lazy-require.rkt

@@ -89,7 +89,10 @@
              (define (get-sym sym)
                (parameterize ((current-namespace (variable-reference->namespace (#%variable-reference))))
                  (begin0
-                     (dynamic-require mpi-var sym)
+                   (namespace-call-with-registry-lock
+                    (current-namespace)
+                    (lambda ()
+                      (dynamic-require mpi-var sym)))
                    (do-registration (#%variable-reference) (quote modpath)))))
              (define aux-name (make-lazy-function 'exp-name 'bind-name get-sym)) ...
              (define-syntax bind-name

racket/src/bc/src/startup.inc

@@ -12930,7 +12930,10 @@ static const char *startup_source =
 " void"
 "(lambda()"
 "(if(box-cas! lock-box_0 v_0 lock_0)"
-"(let-values()(begin(proc_0) void))"
+"(let-values()"
+"(call-with-values"
+" proc_0"
+"(lambda results_0(lambda()(apply values results_0)))))"
 "(let-values()(lambda()(loop_0)))))"
 "(lambda()(semaphore-post sema_0)))))))"
 "(if(eq?(current-thread)(weak-box-value(cdr v_0)))"
@@ -50766,6 +50769,22 @@ static const char *startup_source =
 "(()(begin 'namespace-base-phase(namespace-base-phase_0 unsafe-undefined)))"
 "((ns38_0)(namespace-base-phase_0 ns38_0)))))"
 "(define-values"
+"(1/namespace-call-with-registry-lock)"
+"(lambda(ns_0 thunk_0)"
+"(begin"
+" 'namespace-call-with-registry-lock"
+"(let-values()"
+"(let-values()"
+"(begin"
+"(if(1/namespace? ns_0)"
+"(void)"
+"              (let-values () (raise-argument-error 'namespace-call-with-registry-lock \"namespace?\" ns_0)))"
+"(if((lambda(p_0)(if(procedure? p_0)(procedure-arity-includes? p_0 0) #f)) thunk_0)"
+"(void)"
+"(let-values()"
+"                (raise-argument-error 'namespace-call-with-registry-lock \"(procedure-arity-includes/c 0)\" thunk_0)))"
+"(registry-call-with-lock(namespace-module-registry$1 ns_0) thunk_0)))))))"
+"(define-values"
 "(1/eval)"
 "(let-values(((eval_0)"
 "(lambda(s3_0 ns1_0 compile2_0)"
@@ -66784,6 +66803,8 @@ static const char *startup_source =
 " 1/namespace-mapped-symbols"
 " 'namespace-base-phase"
 " 1/namespace-base-phase"
+" 'namespace-call-with-registry-lock"
+" 1/namespace-call-with-registry-lock"
 " 'module-declared?"
 " 1/module-declared?"
 " 'module-predefined?"

racket/src/cs/schemified/expander.scm

@@ -15494,7 +15494,10 @@
                         void
                         (lambda ()
                           (if (unsafe-box*-cas! lock-box_0 v_0 lock_0)
-                            (begin (|#%app| proc_0) void)
+                            (|#%call-with-values|
+                             proc_0
+                             (lambda results_0
+                               (lambda () (apply values results_0))))
                             (lambda () (loop_0))))
                         (lambda () (semaphore-post sema_0))))))
                   (if (let ((app_0 (current-thread)))
@@ -57141,6 +57144,22 @@
      (case-lambda
       (() (begin (namespace-base-phase_0 unsafe-undefined)))
       ((ns38_0) (namespace-base-phase_0 ns38_0))))))
+(define namespace-call-with-registry-lock
+  (lambda (ns_0 thunk_0)
+    (begin
+      (if (1/namespace? ns_0)
+        (void)
+        (raise-argument-error
+         'namespace-call-with-registry-lock
+         "namespace?"
+         ns_0))
+      (if (if (procedure? thunk_0) (procedure-arity-includes? thunk_0 0) #f)
+        (void)
+        (raise-argument-error
+         'namespace-call-with-registry-lock
+         "(procedure-arity-includes/c 0)"
+         thunk_0))
+      (registry-call-with-lock (namespace-module-registry$1 ns_0) thunk_0))))
 (define 1/eval
   (let ((eval_0
          (|#%name|
@@ -74412,6 +74431,8 @@
    1/namespace-mapped-symbols
    'namespace-base-phase
    1/namespace-base-phase
+   'namespace-call-with-registry-lock
+   namespace-call-with-registry-lock
    'module-declared?
    1/module-declared?
    'module-predefined?

racket/src/expander/boot/main-primitive.rkt

@@ -77,7 +77,8 @@
           'namespace-set-variable-value! namespace-set-variable-value!
           'namespace-undefine-variable!	namespace-undefine-variable!
           'namespace-mapped-symbols namespace-mapped-symbols 
-          'namespace-base-phase namespace-base-phase          
+          'namespace-base-phase namespace-base-phase
+          'namespace-call-with-registry-lock namespace-call-with-registry-lock
           
           'module-declared? module-declared?
           'module-predefined? module-predefined?

racket/src/expander/namespace/api.rkt

@@ -9,6 +9,7 @@
          "../syntax/mapped-name.rkt"
          "namespace.rkt"
          "module.rkt"
+         "registry.rkt"
          "attach.rkt"
          "core.rkt"
          "../common/set.rkt"
@@ -41,7 +42,9 @@
          
          namespace-mapped-symbols
 
-         namespace-base-phase)
+         namespace-base-phase
+
+         namespace-call-with-registry-lock)
 
 (define (make-empty-namespace)
   (define current-ns (current-namespace))
@@ -258,3 +261,10 @@
 (define/who (namespace-base-phase [ns (current-namespace)])
   (check who namespace? ns)
   (namespace-phase ns))
+
+(define/who (namespace-call-with-registry-lock ns thunk)
+  (check who namespace? ns)
+  (check who (procedure-arity-includes/c 0) thunk)
+  (registry-call-with-lock
+   (namespace-module-registry ns)
+   thunk))

racket/src/expander/namespace/registry.rkt

@@ -24,8 +24,10 @@
         (lambda ()
           (cond
            [(box-cas! lock-box v lock)
-            (proc)
-            void]
+            (call-with-values
+             proc
+             (lambda results
+               (lambda () (apply values results))))]
            [else
             ;; CAS failed; take it from the top
             (lambda () (loop))]))

racket/src/version/racket_version.h

@@ -16,7 +16,7 @@
 #define MZSCHEME_VERSION_X 8
 #define MZSCHEME_VERSION_Y 1
 #define MZSCHEME_VERSION_Z 0
-#define MZSCHEME_VERSION_W 4
+#define MZSCHEME_VERSION_W 5
 
 /* A level of indirection makes `#` work as needed: */
 #define AS_a_STR_HELPER(x) #x