1#lang racket/base
2
3(provide (struct-out module-registry)
4         make-module-registry
5         registry-call-with-lock)
6
7(struct module-registry (declarations  ; resolved-module-path -> module
8                         lock-box))    ; reentrant lock to guard registry for use by on-demand visits
9
10(define (make-module-registry)
11  (module-registry (make-hasheq) (box #f)))
12
13(define (registry-call-with-lock r proc)
14  (define lock-box (module-registry-lock-box r))
15  (let loop ()
16    (define v (unbox lock-box))
17    (cond
18     [(or (not v)
19          (sync/timeout 0 (car v) (or (weak-box-value (cdr v)) never-evt)))
20      (define sema (make-semaphore))
21      (define lock (cons (semaphore-peek-evt sema) (make-weak-box (current-thread))))
22      ((dynamic-wind
23        void
24        (lambda ()
25          (cond
26           [(box-cas! lock-box v lock)
27            (call-with-values
28             proc
29             (lambda results
30               (lambda () (apply values results))))]
31           [else
32            ;; CAS failed; take it from the top
33            (lambda () (loop))]))
34        (lambda ()
35          (semaphore-post sema))))]
36     [(eq? (current-thread) (weak-box-value (cdr v)))
37      ;; This thread already holds the lock
38      (proc)]
39     [else
40      ; Wait and try again:
41      (sync (car v) (or (weak-box-value (cdr v)) never-evt))
42      (loop)])))
43