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