gl/gl-glxgears.scm: Do all GL callouts in a Gtk callback.

Otherwise this demo will not operate alongside a layout demo or a
glx-viewport.  While it holds the GL libray mutex, it causes them
to suspend-current-thread in their draw callback.

diff --git a/src/gl/gl-glx.scm b/src/gl/gl-glx.scm
index beab389adf23544ae35e36977f645de7c099e9b6..3353bb18741608eb10b8a7a7d09c84da67147d3d 100644 (file)
--- a/src/gl/gl-glx.scm
+++ b/src/gl/gl-glx.scm
@@ -136,6 +136,9 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 
     (C-call "gtk_widget_set_can_focus" GtkWidget 1)))
 
+(define (glx-widget-realized? widget)
+  (not (alien-null? (glx-widget-glxcontext widget))))
+
 (declare (integrate-operator bit-ior))
 (define (bit-ior . ints)
   (reduce bitwise-ior 0 ints))

diff --git a/src/gl/gl-glxgears.scm b/src/gl/gl-glxgears.scm
index dc1d1cd418d1efad1f3e2a9f6153f5b82c76dcd2..41b00dc75b4a42ef4067ef9e4ee69374077fd60d 100644 (file)
--- a/src/gl/gl-glxgears.scm
+++ b/src/gl/gl-glxgears.scm
@@ -59,7 +59,6 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
   (gears define standard initial-value #f)
 
   (shape define standard initial-value '(0 . 0))
-  (realized? define standard initial-value #f)
   ;; This "visibility" slot was intended to reflect when my screen is
   ;; blanked, because the animation loop spins up to more than 300fps.
   ;; (Please help stop the spinning!)  Why so few visibility-notify
@@ -94,13 +93,12 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
   (make-animation-thread widget))
 
 (define-method fix-widget-new-geometry-callback ((widget <glxgears-demo>))
+  (call-next-method widget)
   (%trace "fix-widget-new-geometry-callback <glxgears-demo> "widget))
 
 (define-method fix-widget-realize-callback ((widget <glxgears-demo>))
   (call-next-method widget)
-  (%trace "fix-widget-realize-callback <glxgears-demo> "widget)
-  (set-glxgears-demo-realized?! widget #t)
-  (wake-animation-thread widget))
+  (%trace "fix-widget-realize-callback <glxgears-demo> "widget))
 
 (define-method fix-widget-unrealize-callback ((widget <glxgears-demo>))
   (call-next-method widget)
@@ -113,12 +111,20 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
        (gl:delete-lists (car gears) 1)
        (gl:delete-lists (cadr gears) 1)
        (gl:delete-lists (caddr gears) 1))))
-  (set-glxgears-demo-realized?! widget #f)
   (halt-animation-thread widget))
 
-(define (draw-callback widget area)
-  (%trace "draw-callback "widget" "area)
-  (wake-animation-thread widget))
+(define (draw-callback widget cr)
+  (declare (ignore cr))
+  (%trace2 "draw-callback "widget)
+  (with-glx-widget widget
+    (lambda ()
+      (if (not (glxgears-demo-gears widget))
+         (init widget))
+      (draw widget)
+      (%trace2 "  swap-buffers")
+      (glx:swap-buffers widget)))
+  (wake-animation-thread widget)
+  (%trace2 "draw-callback "widget" done"))
 
 (define (enter-notify-handler widget)
   (%trace "enter-notify-handler "widget)
@@ -137,7 +143,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
   (let ((old (glxgears-demo-visibility widget)))
     (set-glxgears-demo-visibility! widget how)
     (if (and (eq? old 'OBSCURED) (not (eq? how 'OBSCURED)))
-       (wake-animation-thread)))
+       (wake-animation-thread widget)))
   #t)
 
 (define (key-press-handler widget key bits)
@@ -148,26 +154,26 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
     ((#\a #\A)
      (if (glxgears-demo-animate? widget)
         (begin
-          (fresh-line) (display "; glxgears: animation OFF\n")
+          (%trace "toggle animation off")
           (set-glxgears-demo-animate?! widget #f))
         (begin
-          (fresh-line) (display "; glxgears: animation ON\n")
+          (%trace "toggle animation on")
           (set-glxgears-demo-frame-count-start! widget #f)
           (set-glxgears-demo-animate?! widget #t)
           (wake-animation-thread widget))))
     ((#\i #\I)
      (if (glxgears-demo-report-fps? widget)
         (begin
-          (fresh-line) (display "; glxgears: fps reporting OFF\n")
+          (%trace "fps reporting off")
           (set-glxgears-demo-report-fps?! widget #f))
         (begin
-          (fresh-line) (display "; glxgears: fps reporting ON\n")
+          (%trace "fps reporting on")
           (set-glxgears-demo-frame-count-start! widget #f)
           (set-glxgears-demo-report-fps?! widget #t))))           
-    ((|Up|) (rotx! widget 5.) (wake-animation-thread widget))
-    ((|Down|) (rotx! widget -5.) (wake-animation-thread widget))
-    ((|Left|) (roty! widget 5.) (wake-animation-thread widget))
-    ((|Right|) (roty! widget -5.) (wake-animation-thread widget)))
+    ((|Up|) (rotx! widget 5.) (gtk-widget-queue-draw widget))
+    ((|Down|) (rotx! widget -5.) (gtk-widget-queue-draw widget))
+    ((|Left|) (roty! widget 5.) (gtk-widget-queue-draw widget))
+    ((|Right|) (roty! widget -5.) (gtk-widget-queue-draw widget)))
   #t)
 
 (define-integrable (rotx! widget incr)
@@ -194,41 +200,43 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
             (call-with-current-continuation
              (lambda (halt)
                (set-glxgears-demo-animation-halt! widget halt)
-               (%trace "animation thread started")
+               (%trace "animation started")
                (let loop ()
 
                  ;; Sleep when not realized?, not animate?, or obscured.
                  (with-thread-events-blocked
                   (lambda ()
                     (let ((visibility (glxgears-demo-visibility widget)))
-                      (if (or (not (glxgears-demo-realized? widget))
+                      (if (or (not (glx-widget-realized? widget))
                               (not (glxgears-demo-animate? widget))
                               (eq? 'OBSCURED visibility))
                           (begin
                             (if (and %trace? (eq? 'OBSCURED visibility))
-                                (%trace "sleeping while obscured...")
-                                (%trace "sleeping..."))
+                                (%trace2
+                                 "animation sleeping while obscured...")
+                                (%trace2 "animation sleeping..."))
                             (suspend-current-thread)
-                            (%trace "...awake!"))))))
-
-                 (if (not (glxgears-demo-realized? widget))
-                     (%trace "not realized!")
-                     (begin
-                       ;; Init, if necessary.
-                       (if (not (glxgears-demo-gears widget))
-                           (init widget))
-
-                       ;; Draw.
-                       (draw-frame widget)))
+                            (%trace2 "animation awake"))
+                          (%trace2 "animation rolling")))))
+
+                 (if (and (glx-widget-realized? widget)
+                          (glxgears-demo-animate? widget)
+                          (not (eq? 'OBSCURED
+                                    (glxgears-demo-visibility widget))))
+                     (draw-frame widget)
+                     (%trace2 "animation skip!"))
+                 (%trace2 "animation loop")
                  (loop))))
-            (fresh-line) (display "; glxgears: done\n")))))
+            (%trace "animation done")))))
     (set-glxgears-demo-animation-thread! widget thread)
     thread))
 
 (define (wake-animation-thread widget)
   (signal-thread-event
    (glxgears-demo-animation-thread widget)
-   (lambda () unspecific)))
+   (lambda ()
+     (%trace2 "wake animation")
+     unspecific)))
 
 (define (halt-animation-thread widget)
   (signal-thread-event
@@ -252,11 +260,15 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
                                                 (int:- now start)))))
                                    (+ angle (* 70. dt))))
        (set-glxgears-demo-frame-count! widget (int:1+ count))))
-  (with-glx-widget widget
-    (lambda ()
-      (draw widget)
-      (%trace2 "swap-buffers")
-      (glx:swap-buffers widget)))
+
+  (with-thread-events-blocked
+   (lambda ()
+     (%trace2 "draw-frame: request draw")
+     (gtk-widget-queue-draw widget)
+     (%trace2 "draw-frame: sleep")
+     (suspend-current-thread)
+     (%trace2 "draw-frame: awake")))
+
   (if (and (glxgears-demo-animate? widget)
           (glxgears-demo-report-fps? widget))
       (let ((now (glxgears-demo-frame-start widget))
@@ -329,9 +341,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
       (if (not (and (fix:= (car w.h) width)
                    (fix:= (cdr w.h) height)))
          (begin
-           (%trace "reshape "width" "height" "widget)
-           (with-glx-widget widget
-             (lambda ()
+           (%trace "  reshape "width" "height" "widget)
                (gl:viewport 0 0 width height)
                (let ((h (/ (->flonum height) (->flonum width))))
                  (gl:matrix-mode 'PROJECTION)
@@ -340,16 +350,15 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 
                (gl:matrix-mode 'MODELVIEW)
                (gl:load-identity)
-               (gl:translate 0. 0. -40.)))
+               (gl:translate 0. 0. -40.)
            (set-glxgears-demo-frame-start! widget #f)
            (set-glxgears-demo-frame-count! widget 0)
-           (set-glxgears-demo-shape! widget (cons width height)))))))
+           (set-glxgears-demo-shape! widget (cons width height)))
+         (%trace "  reshape "width" "height" "widget" no change")))))
 
 (define (init widget)
   (%trace "init "widget)
   (reshape widget)
-  (with-glx-widget widget
-    (lambda ()
       (let ((pos (flo:4d 5.0 5.0 10.0 0.0))
            (red (color 0.8 0.1 0.0 1.0))
            (green (color 0.0 0.8 0.2 1.0))
@@ -384,7 +393,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
              (gl:end-list)
 
              (gl:enable 'NORMALIZE)
-             (set-glxgears-demo-gears! widget (list gear1 gear2 gear3)))))))))
+             (set-glxgears-demo-gears! widget (list gear1 gear2 gear3)))))))
 
 (define (draw-gear inner-radius                ; radius of hole at center
                   outer-radius         ; radius at center of teeth
@@ -532,11 +541,11 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 (define-syntax %trace
   (syntax-rules ()
     ((_ ARGS ...)
-     (if %trace? (outf-error "; " ARGS ... "\n")))))
+     (if %trace? (outf-error "; glxgears: " ARGS ... "\n")))))
 
 (define %trace2? #f)
 
 (define-syntax %trace2
   (syntax-rules ()
     ((_ ARGS ...)
-     (if %trace2? (outf-error ";   " ARGS ... "\n")))))
\ No newline at end of file
+     (if %trace2? (outf-error "; glxgears: " ARGS ... "\n")))))
\ No newline at end of file

diff --git a/src/gl/gl.pkg b/src/gl/gl.pkg
index c882ebceb9a2cd89bdc04a514884905d5a6bc654..cb363eac48359e7896e75062860c3c7eec525eb5 100644 (file)
--- a/src/gl/gl.pkg
+++ b/src/gl/gl.pkg
@@ -112,6 +112,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
          make-glx-widget <glx-widget>
          with-glx-widget glx:swap-buffers
          make-glx-viewport <glx-viewport>
+         glx-widget-realized?
          glx-viewport-draw
          glx-viewport-key-press-handler
          glx-viewport-position
@@ -127,7 +128,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
   (parent (gl))
   (import (gtk)
          gtk-widget-destroyed? gtk-widget-destroy
-         gtk-widget-parent gtk-widget-show-all
+         gtk-widget-parent gtk-widget-show-all gtk-widget-queue-draw
          set-gtk-widget-draw-callback!
          gtk-container-add gtk-container-set-border-width
          gtk-window-new gtk-window-set-title