From 4f2ba269ccf8a451a05d8fb21b32721fd1e7243c Mon Sep 17 00:00:00 2001
From: Matt Birkholz <matt@birchwood-abbey.net>
Date: Thu, 22 Mar 2018 11:34:43 -0700
Subject: [PATCH] gl: Use with-glib-lock.  Banish without-interrupts.

---
 src/gl/gl-glx.scm      | 14 +++++++++++---
 src/gl/gl-glxgears.scm | 22 ++++++++++++----------
 src/gl/gl.pkg          |  4 +++-
 3 files changed, 26 insertions(+), 14 deletions(-)

diff --git a/src/gl/gl-glx.scm b/src/gl/gl-glx.scm
index 480d016f2..b2a3dc0d3 100644
--- 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 6e7bd84b2..ba3357030 100644
--- 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 69e785f7a..ce9296f78 100644
--- 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
-- 
2.25.1