gl: Use with-glib-lock. Banish without-interrupts.

diff --git a/src/gl/gl-glx.scm b/src/gl/gl-glx.scm
index 480d016f2911215a97471fae7b0b9adc8b79c02b..b2a3dc0d34d31f379a3abf71f5fe92ef2b66aa83 100644 (file)
--- a/src/gl/gl-glx.scm
+++ b/src/gl/gl-glx.scm
@@ -26,6 +26,12 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 
 (C-include "gl")
 
+(define-syntax error-if-null
+  (syntax-rules ()
+    ((_ ALIEN MESSAGE ...)
+     (if (alien-null? ALIEN)
+        (error MESSAGE ...)))))
+
 (define (with-glx-widget widget thunk)
   (let ((xdisplay (glx-widget-xdisplay widget))
        (xwindow (glx-widget-xwindow widget))
@@ -53,6 +59,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 
 (define-method initialize-instance ((widget <glx-widget>) width height)
   (call-next-method widget width height '())
+  (assert-glib-locked '(initialize-instance <glx-widget>))
   (add-glib-cleanup widget (make-glx-widget-cleanup
                            (glx-widget-xdisplay widget)
                            (glx-widget-glxcontext widget)))
@@ -63,19 +70,20 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
     (cleanup-glx-widget xdisplay glxcontext)))
 
 (define (cleanup-glx-widget xdisplay glxcontext)
-  ;;without-interrupts
+  (assert-without-interruption 'cleanup-glx-widget)
   (if (not (alien-null? glxcontext))
       (begin
        (C-call "glXDestroyContext" xdisplay glxcontext)
        (alien-null! glxcontext))))
 
 (define-method gtk-widget-destroy-callback ((widget <glx-widget>))
-  (without-interrupts
+  (without-interruption
    (lambda ()
      (execute-glib-cleanup widget)))
   (call-next-method widget))
 
 (define-method fix-widget-realize-callback ((widget <glx-widget>))
+  (assert-glib-locked '(fix-widget-realize-callback <glx-widget>))
   (let* ((GtkWidget (gobject-alien widget))
         (parent
          (C-call "gtk_widget_get_parent_window" (make-alien '|GdkWindow|)
@@ -162,7 +170,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
     (cleanup-fb-configs alien)))
 
 #;(define (cleanup-fb-configs alien)
-  ;;without-interrupts
+  (assert-without-interrupts 'cleanup-fb-configs)
   (if (not (alien-null? alien))
       (begin
        (C-call "XFree" alien)

diff --git a/src/gl/gl-glxgears.scm b/src/gl/gl-glxgears.scm
index 6e7bd84b297477d490053982657696d9d55bd68e..ba3357030ef6dafce0ecf0d6c692932ccefe1111 100644 (file)
--- a/src/gl/gl-glxgears.scm
+++ b/src/gl/gl-glxgears.scm
@@ -40,15 +40,17 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
   (make-glxgears-demo-device 400 400 "gl-glxgears.scm"))
 
 (define (make-glxgears-demo-device width height title)
-  (let ((window (gtk-window-new 'toplevel)))
-    (gtk-window-set-title window title)
-    (set-gtk-window-delete-event-callback!
-     window (lambda (w) (%trace "closed "w) 0))
-    (gtk-container-set-border-width window 5)
-    (let ((widget (%make-glxgears-demo width height)))
-      (gtk-container-add window widget)
-      (gtk-widget-show-all window)
-      widget)))
+  (with-glib-lock
+   (lambda ()
+     (let ((window (gtk-window-new 'toplevel)))
+       (gtk-window-set-title window title)
+       (set-gtk-window-delete-event-callback!
+       window (lambda (w) (%trace "closed "w) 0))
+       (gtk-container-set-border-width window 5)
+       (let ((widget (%make-glxgears-demo width height)))
+        (gtk-container-add window widget)
+        (gtk-widget-show-all window)
+        widget)))))
 
 (define-class (<glxgears-demo>
               (constructor %make-glxgears-demo () (width height)))
@@ -290,7 +292,7 @@ I - Toggle frame rate reports.")))
   (with-thread-events-blocked
    (lambda ()
      (%trace2 "draw-frame: request draw")
-     (gtk-widget-queue-draw widget)
+     (with-glib-lock (lambda () (gtk-widget-queue-draw widget)))
      (%trace2 "draw-frame: sleep")
      (suspend-current-thread)
      (%trace2 "draw-frame: awake")))

diff --git a/src/gl/gl.pkg b/src/gl/gl.pkg
index 69e785f7a10db527786e9802ceb47b6f3460e520..ce9296f78e43da5ac708162dc9da2cae34047a60 100644 (file)
--- a/src/gl/gl.pkg
+++ b/src/gl/gl.pkg
@@ -82,6 +82,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
   (import (runtime ffi)
          %set-alien/address!)
   (import (glib)
+         assert-glib-locked assert-without-interruption
          add-glib-cleanup execute-glib-cleanup)
   (import (gobject)
          gobject-alien)
@@ -94,7 +95,6 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
          fix-widget-geometry fix-widget-window)
   (import (gtk)
          <fix-widget>
-         error-if-null
          fix-widget-new-geometry-callback
          fix-widget-realize-callback
          gtk-container-add
@@ -131,6 +131,8 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 (define-package (gl glxgears)
   (files "gl-glxgears")
   (parent (gl))
+  (import (glib)
+         with-glib-lock)
   (import (gtk)
          fix-widget-new-geometry-callback
          fix-widget-realize-callback