From 70ebb22b9f2914c636032ada450a2a0861b9f88c Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Sat, 25 Oct 2014 16:24:46 -0700 Subject: [PATCH] gl-glxgears: Fix missing MAP event bug. The MAP event was sometimes arriving before its handler was assigned, leaving the animation thread to wait forever for the widget to be mapped. Fix this by moving the handler assignments to the initialize-instance method. The more common way to initialize a widget is in its fix-widget- realize-callback. Rename the "mapped?" slot "realized?". Add an unrealize-callback method to clear the "realized?" slot, just for completeness. Use (fresh-line) and "; glxgears: " consistently before the asynchronous, running notes. Also add some missing `free's to the primitive version: glxgears.scm. --- src/gl/gl-glxgears.scm | 81 ++++++++++++++++++++---------------------- src/gl/gl.pkg | 15 +++----- src/gl/glxgears.scm | 2 ++ 3 files changed, 46 insertions(+), 52 deletions(-) diff --git a/src/gl/gl-glxgears.scm b/src/gl/gl-glxgears.scm index 4dad46c1b..4855a9122 100644 --- a/src/gl/gl-glxgears.scm +++ b/src/gl/gl-glxgears.scm @@ -37,22 +37,7 @@ USA. (/ flo:/ (null-value 1. single) (group left)))) (define (make-glxgears-demo) - (let ((dev (make-glxgears-demo-device 400 400 "glxgears.scm"))) - (set-gtk-widget-unrealize-callback! dev unrealize-callback) - (set-gtk-widget-draw-callback! dev draw-callback) - (set-fix-widget-map-handler! dev map-handler) - (set-fix-widget-unmap-handler! dev unmap-handler) - (set-fix-widget-enter-notify-handler! dev enter-notify-handler) - (set-fix-widget-leave-notify-handler! dev leave-notify-handler) - (set-fix-widget-focus-change-handler! dev focus-change-handler) - (set-fix-widget-visibility-notify-handler! dev visibility-notify-handler) - (set-fix-widget-key-press-handler! dev key-press-handler) - (set-fix-widget-motion-handler! dev motion-handler) - (set-fix-widget-button-handler! dev 'press button-handler) - (set-fix-widget-button-handler! dev 'release button-handler) - (set-fix-widget-button-handler! dev 'double-press button-handler) - (set-fix-widget-button-handler! dev 'triple-press button-handler) - dev)) + (make-glxgears-demo-device 400 400 "gl-glxgears.scm")) (define (make-glxgears-demo-device width height title) (let ((window (gtk-window-new 'toplevel))) @@ -75,7 +60,7 @@ USA. (gears define standard initial-value #f) (shape define standard initial-value '(0 . 0)) - (mapped? define standard initial-value #f) + (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,14 +79,34 @@ USA. (define-method initialize-instance ((widget ) width height) (call-next-method widget width height) + (set-gtk-widget-draw-callback! widget draw-callback) + (set-fix-widget-visibility-notify-handler! widget visibility-notify-handler) + (set-fix-widget-key-press-handler! widget key-press-handler) + (set-fix-widget-motion-handler! widget motion-handler) + (set-fix-widget-button-handler! widget 'press button-handler) + (set-fix-widget-button-handler! widget 'release button-handler) + (set-fix-widget-button-handler! widget 'double-press button-handler) + (set-fix-widget-button-handler! widget 'triple-press button-handler) + + (set-fix-widget-enter-notify-handler! widget enter-notify-handler) + (set-fix-widget-leave-notify-handler! widget leave-notify-handler) + (set-fix-widget-focus-change-handler! widget focus-change-handler) + (make-animation-thread widget)) (define-method fix-widget-new-geometry-callback ((widget )) - (%trace "fix-widget-new-geometry-callback ") + (%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)) -(define (unrealize-callback widget) - (%trace "unrealize-callback "widget" "(gtk-widget-destroyed? widget)) +(define-method fix-widget-unrealize-callback ((widget )) + (call-next-method widget) + (%trace "fix-widget-unrealize-callback "widget + " "(gtk-widget-destroyed? widget)) ;; Is this necessary when the context is about to be (already?) destroyed? #;(let ((gears (glxgears-demo-gears widget))) (with-glx-widget widget @@ -109,21 +114,12 @@ 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)) - -(define (map-handler widget) - (%trace "map-handler "widget) - (set-glxgears-demo-mapped?! widget #t) - (wake-animation-thread widget) - #f) - -(define (unmap-handler widget) - (%trace "unmap-handler "widget) - (set-glxgears-demo-mapped?! widget #f) - #f) + (%trace "draw-callback "widget" "area) + (wake-animation-thread widget)) (define (enter-notify-handler widget) (%trace "enter-notify-handler "widget) @@ -153,20 +149,20 @@ USA. ((#\a #\A) (if (glxgears-demo-animate? widget) (begin - (display "; glxgears: animation OFF\n") + (fresh-line) (display "; glxgears: animation OFF\n") (set-glxgears-demo-animate?! widget #f)) (begin - (display "; glxgears: animation ON\n") + (fresh-line) (display "; glxgears: animation ON\n") (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 - (display "; glxgears: fps reporting OFF\n") + (fresh-line) (display "; glxgears: fps reporting OFF\n") (set-glxgears-demo-report-fps?! widget #f)) (begin - (display "; glxgears: fps reporting ON\n") + (fresh-line) (display "; glxgears: fps reporting ON\n") (set-glxgears-demo-frame-count-start! widget #f) (set-glxgears-demo-report-fps?! widget #t)))) ((|Up|) (rotx! widget 5.) (wake-animation-thread widget)) @@ -202,11 +198,11 @@ USA. (%trace "animation thread started") (let loop () - ;; Sleep when not mapped?, not animate?, or obscured. + ;; Sleep when not realized?, not animate?, or obscured. (without-interrupts (lambda () (let ((visibility (glxgears-demo-visibility widget))) - (if (or (not (glxgears-demo-mapped? widget)) + (if (or (not (glxgears-demo-realized? widget)) (not (glxgears-demo-animate? widget)) (eq? 'OBSCURED visibility)) (begin @@ -216,8 +212,8 @@ USA. (suspend-current-thread) (%trace "...awake!")))))) - (if (not (glxgears-demo-mapped? widget)) - (%trace "not mapped!") + (if (not (glxgears-demo-realized? widget)) + (%trace "not realized!") (begin ;; Init, if necessary. (if (not (glxgears-demo-gears widget)) @@ -226,7 +222,7 @@ USA. ;; Draw. (draw-frame widget))) (loop)))) - (display "; glxgears: done\n"))))) + (fresh-line) (display "; glxgears: done\n"))))) (set-glxgears-demo-animation-thread! widget thread) thread)) @@ -278,6 +274,7 @@ USA. (number->string (/ (round (* 10. n)) 10.))) (define-integrable (%.3f n) (number->string (/ (round (* 1000. n)) 1000.))) + (fresh-line) (for-each display (list "; glxgears: "count" frames" " in "(%.1f seconds)" seconds" " = "(%.3f fps)" FPS\n")) @@ -533,7 +530,7 @@ USA. (define-integrable color flo:4d) -(define %trace? #t) +(define %trace? #f) (define-syntax %trace (syntax-rules () diff --git a/src/gl/gl.pkg b/src/gl/gl.pkg index 1e793719f..5d502622f 100644 --- a/src/gl/gl.pkg +++ b/src/gl/gl.pkg @@ -91,8 +91,7 @@ USA. gtk-widget-destroy-callback) (import (gtk fix-layout) fix-rect-x fix-rect-y fix-rect-width fix-rect-height - fix-widget-geometry fix-widget-window - set-fix-widget-map-handler! set-fix-widget-unmap-handler!) + fix-widget-geometry fix-widget-window) (import (gtk) error-if-null gtk-window-new @@ -130,24 +129,20 @@ USA. (import (gtk) gtk-widget-destroyed? gtk-widget-destroy gtk-widget-parent gtk-widget-show-all + set-gtk-widget-draw-callback! gtk-container-add gtk-container-set-border-width gtk-window-new gtk-window-set-opacity gtk-window-set-title set-gtk-window-delete-event-callback! + fix-widget-new-geometry-callback + fix-widget-realize-callback + fix-widget-unrealize-callback set-fix-widget-key-press-handler! - fix-widget-new-geometry-callback) - - (import (gtk) - set-gtk-widget-draw-callback! - set-gtk-widget-unrealize-callback! set-fix-widget-button-handler! set-fix-widget-enter-notify-handler! set-fix-widget-focus-change-handler! set-fix-widget-leave-notify-handler! - set-fix-widget-map-handler! set-fix-widget-motion-handler! - set-fix-widget-unmap-handler! set-fix-widget-visibility-notify-handler!) - (import (gtk fix-layout) fix-rect-width fix-rect-height fix-widget-geometry) diff --git a/src/gl/glxgears.scm b/src/gl/glxgears.scm index dac8a825c..b63344109 100644 --- a/src/gl/glxgears.scm +++ b/src/gl/glxgears.scm @@ -445,6 +445,7 @@ USA. mask ;valuemask attr))) (%trace ";XCreateWindow => "win"\n") + (free attr) (if fullscreen (no-border dpy win)) @@ -586,6 +587,7 @@ USA. (let ((buffer (malloc 10 'char))) (C-call "XLookupString" event buffer 10 0 0) (let ((buffer0 (C-> buffer "char"))) + (free buffer) (cond ((= buffer0 27) ;; escape 'EXIT) -- 2.25.1