From c1379fc3fefeb7573c82caa6a9baa40f6e486152 Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Fri, 29 Apr 2016 15:36:10 -0700 Subject: [PATCH] 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. --- src/gl/gl-glx.scm | 3 ++ src/gl/gl-glxgears.scm | 107 ++++++++++++++++++++++------------------- src/gl/gl.pkg | 3 +- 3 files changed, 63 insertions(+), 50 deletions(-) diff --git a/src/gl/gl-glx.scm b/src/gl/gl-glx.scm index beab389ad..3353bb187 100644 --- 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 dc1d1cd41..41b00dc75 100644 --- 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 )) + (call-next-method widget) (%trace "fix-widget-new-geometry-callback "widget)) (define-method fix-widget-realize-callback ((widget )) (call-next-method widget) - (%trace "fix-widget-realize-callback "widget) - (set-glxgears-demo-realized?! widget #t) - (wake-animation-thread widget)) + (%trace "fix-widget-realize-callback "widget)) (define-method fix-widget-unrealize-callback ((widget )) (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 c882ebceb..cb363eac4 100644 --- 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 with-glx-widget glx:swap-buffers make-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 -- 2.25.1