From f729c6441c5a4ef46e2df6fd1bd29fd6f26aaa94 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Fri, 13 Jul 2012 07:45:21 -0600
Subject: [PATCH] racket/draw: fix gl-context<%> locking

The optional arguments for `call-as-current' for `gl-context<%>'
were not implemented, and the locking implementation didn't match
the documentation in other ways.
---
 collects/racket/draw/private/gl-context.rkt | 46 +++++++++++++--------
 collects/tests/gracket/dc.rktl              | 28 +++++++++++++
 2 files changed, 56 insertions(+), 18 deletions(-)

diff --git a/collects/racket/draw/private/gl-context.rkt b/collects/racket/draw/private/gl-context.rkt
index 1c54ee6baa..1e3c504061 100644
--- a/collects/racket/draw/private/gl-context.rkt
+++ b/collects/racket/draw/private/gl-context.rkt
@@ -15,12 +15,13 @@
 (define lock-ch (make-channel))
 (define lock-holder-ch (make-channel))
 (define (lock-manager)
+  (define none '#(#f #f #f))
   (let loop ()
     (sync (handle-evt
            lock-ch
            (lambda (p)
-             (let ([t (car p)]
-                   [ch (cdr p)])
+             (let ([t (vector-ref p 0)]
+                   [ch (vector-ref p 2)])
                (let waiting-loop ()
                  (sync (handle-evt
                         (thread-dead-evt t)
@@ -29,43 +30,52 @@
                         ch
                         (lambda (v) (loop)))
                        (handle-evt
-                        (channel-put-evt lock-holder-ch t)
+                        (channel-put-evt lock-holder-ch p)
                         (lambda (v) (waiting-loop))))))))
           (handle-evt
-           (channel-put-evt lock-holder-ch #f)
+           (channel-put-evt lock-holder-ch none)
            (lambda (v) (loop))))))
 (define manager-t (thread/suspend-to-kill lock-manager))
 
 (define gl-context<%>
   (interface ()
-    [call-as-current (->*m [(-> any)] any)]
+    [call-as-current (->*m [(-> any)] [evt? any/c] any)]
     [ok? (->m boolean?)]
     [swap-buffers (->m any)]))
 
 ;; Implemented by subclasses:
 (define gl-context%
   (class* object% (gl-context<%>)
-    (define/private (with-gl-lock t)
+    (define/private (with-gl-lock t alternate-evt enable-break?)
       (thread-resume manager-t (current-thread))
-      (if (eq? (current-thread) (channel-get lock-holder-ch))
+      (define current (channel-get lock-holder-ch))
+      (if (and (eq? (vector-ref current 0) (current-thread))
+               (eq? (vector-ref current 1) this))
           (t)
-          (let ([ch (make-channel)])
-            (dynamic-wind
-                (lambda ()
-                  (channel-put lock-ch (cons (current-thread) ch)))
-                t
-                (lambda ()
-                  (channel-put ch #t))))))
-
-    (define/public (call-as-current t)
+          ((if enable-break? sync/enable-break sync)
+           (let ([ch (make-channel)])
+             (handle-evt (channel-put-evt lock-ch (vector (current-thread) this ch))
+                         (lambda (val)
+                           (dynamic-wind
+                               void
+                               t
+                               (lambda ()
+                                 (channel-put ch #t))))))
+           alternate-evt)))
+    
+    (define/public (call-as-current t [alternate-evt never-evt] [enable-breaks? #f])
       (with-gl-lock
        (lambda ()
-         (do-call-as-current t))))
+         (do-call-as-current t))
+       alternate-evt
+       enable-breaks?))
 
     (define/public (swap-buffers)
       (with-gl-lock
        (lambda ()
-         (do-swap-buffers))))
+         (do-swap-buffers))
+       never-evt
+       #f))
 
     (define/public (ok?) #t)
 
diff --git a/collects/tests/gracket/dc.rktl b/collects/tests/gracket/dc.rktl
index 52834a1f9f..201f2d6356 100644
--- a/collects/tests/gracket/dc.rktl
+++ b/collects/tests/gracket/dc.rktl
@@ -569,4 +569,32 @@
 
 ;; ----------------------------------------
 
+(let ()
+  (define config (new gl-config%))
+  (define bm1 (make-gl-bitmap 100 100 config))
+  (define bm2 (make-gl-bitmap 100 100 config))
+  (define dc1 (make-object bitmap-dc% bm1))
+  (define dc2 (make-object bitmap-dc% bm2))
+  (define gl1 (send dc1 get-gl-context))
+  (define gl2 (send dc2 get-gl-context))
+  (send gl1 call-as-current
+        (lambda ()
+          (test 5 'alt (send gl2 call-as-current
+                             (lambda () (error "not in this context!"))
+                             (wrap-evt always-evt (lambda (v) 5))))
+          (sync
+           (thread
+            (lambda ()
+              (test 8 'thread/alts
+                    (send gl1 call-as-current
+                          (lambda () (error "not in this thread!"))
+                          (wrap-evt always-evt (lambda (v) 8)))))))
+          (test 8 'reenter (send gl1 call-as-current
+                                 (lambda () 8)))))
+  (with-handlers ([exn? void])
+    (send gl1 call-as-current (lambda () (error "fail"))))
+  (test 12 'post-exn (send gl1 call-as-current (lambda () 12))))
+
+;; ----------------------------------------
+
 (report-errs)