fix global gl lock

collects/racket/draw/gl-context.rkt

@@ -16,21 +16,45 @@
   (and (procedure? v)
        (procedure-arity-includes? v 0)))
 
+(define lock-ch (make-channel))
+(define lock-holder-ch (make-channel))
+(define (lock-manager)
+  (let loop ()
+    (sync (handle-evt
+           lock-ch
+           (lambda (p)
+             (let ([t (car p)]
+                   [ch (cdr p)])
+               (let waiting-loop ()
+                 (sync (handle-evt
+                        (thread-dead-evt t)
+                        (lambda (v) (loop)))
+                       (handle-evt
+                        ch
+                        (lambda (v) (loop)))
+                       (handle-evt
+                        (channel-put-evt lock-holder-ch t)
+                        (lambda (v) (waiting-loop)))))
+               (loop))))
+          (handle-evt
+           (channel-put-evt lock-holder-ch #f)
+           (lambda (v) (loop))))))
+(define manager-t (thread/suspend-to-kill lock-manager))
+
 ;; Implemented by subclasses:
 (defclass gl-context% object%
-  (define lock-thread #f)
-  (define lock (make-semaphore 1))
   
   (define/private (with-gl-lock t)
-    (if (eq? lock-thread (current-thread))
+    (thread-resume manager-t (current-thread))
+    (if (eq? (current-thread) (channel-get lock-holder-ch))
         (t)
-        (call-with-semaphore
-         lock
-         (lambda ()
-           (set! lock-thread (current-thread))
-           (begin0 
-            (t)
-            (set! lock-thread #f))))))
+        (let ([ch (make-channel)])
+          (dynamic-wind
+              (lambda ()
+                (channel-put lock-ch (cons (current-thread) ch)))
+              t
+              (lambda ()
+                (channel-put ch #t))))))
 
   (def/public (call-as-current [procedure-arity-0? t])
     (with-gl-lock