From 5b49c001a700f4f2e171869038643b2280c56c0d Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Mon, 28 Aug 2017 14:07:19 -0700 Subject: [PATCH] gtk (surface-ink-flush): New. Keep a glib-only copy of the surface. The new flush procedure signals the glib thread to update its copy. --- src/gtk/fix-layout.scm | 39 ++++++++++++++++++++++++++++++++++++--- src/gtk/gtk-graphics.scm | 4 +--- src/gtk/gtk.pkg | 3 +++ 3 files changed, 40 insertions(+), 6 deletions(-) diff --git a/src/gtk/fix-layout.scm b/src/gtk/fix-layout.scm index dbb4c730b..4be56302a 100644 --- a/src/gtk/fix-layout.scm +++ b/src/gtk/fix-layout.scm @@ -1723,7 +1723,10 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. () ;; Cairo Image Surface -- a |cairo_surface_t| alien. - (surface define standard initial-value #f)) + (surface define standard) + + ;; For use by the glib thread only. + (exposed define standard initial-value #f)) (define-method initialize-instance ((ink ) width height) (call-next-method ink) @@ -1731,16 +1734,46 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (set-surface-ink-surface! ink (cairo-image-surface-create width height))) (define-method fix-ink-draw-callback ((ink ) widget window cr area) - (declare (ignore window area)) + (declare (ignore area)) (%trace ";drawing "ink" on "widget"\n") (let ((view (fix-layout-view widget)) (extent (fix-ink-extent ink)) - (surface (surface-ink-surface ink))) + (surface (get-exposed ink window))) (let ((x (fix:- (fix-rect-x extent) (fix-rect-x view))) (y (fix:- (fix-rect-y extent) (fix-rect-y view)))) (cairo-set-source-surface cr surface x y) (cairo-paint cr)))) +(define (get-exposed ink window) + (or (surface-ink-exposed ink) + (let ((extent (fix-ink-extent ink)) + (scale (C-call "gdk_window_get_scale_factor" window))) + (let ((width (fix:* scale (fix-rect-width extent))) + (height (fix:* scale (fix-rect-height extent)))) + (let* ((surface (gdk-window-create-similar-surface window + width height)) + (cr (cairo-create surface))) + (cairo-set-source-surface cr (surface-ink-surface ink) 0 0) + (cairo-paint cr) + (cairo-destroy cr) + (set-surface-ink-exposed! ink surface) + surface))))) + +(define (surface-ink-flush ink) + (let ((surface (surface-ink-surface ink)) + (exposed (surface-ink-exposed ink))) + (cairo-surface-flush surface) + (if exposed + (signal-thread-event glib-thread + (lambda () + (%trace2 ";surface-ink-flush copying\n") + (let ((cr (cairo-create exposed))) + (cairo-set-source-surface cr surface 0 0) + (cairo-paint cr) + (cairo-destroy cr)) + (cairo-surface-flush exposed)))) + (drawing-damage ink))) + (define (set-surface-ink-position! ink x y) (set-fix-rect-position! (fix-ink-extent ink) x y)) diff --git a/src/gtk/gtk-graphics.scm b/src/gtk/gtk-graphics.scm index 7444ba2f8..8acc3274e 100644 --- a/src/gtk/gtk-graphics.scm +++ b/src/gtk/gtk-graphics.scm @@ -271,9 +271,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (cairo-fill cr)))) (define (gtk-graphics/flush device) - (let ((graphics (graphics-device/descriptor device))) - (cairo-surface-flush (surface-ink-surface graphics)) - (drawing-damage graphics))) + (surface-ink-flush (graphics-device/descriptor device))) (define (gtk-graphics/set-background-color device name) (let ((graphics (graphics-device/descriptor device))) diff --git a/src/gtk/gtk.pkg b/src/gtk/gtk.pkg index 819348aa8..724d52e2c 100644 --- a/src/gtk/gtk.pkg +++ b/src/gtk/gtk.pkg @@ -180,6 +180,8 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. c-enum-constant-values) (import (pango) make-pango-layout pango-rectangle pangos->pixels pixels->pangos) + (import (glib thread) + glib-thread) (import (gtk gtk-widget) set-gtk-widget-destroy-callback! gtk-widget-destroy-callback @@ -252,6 +254,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. surface-ink? make-surface-ink surface-ink-surface set-surface-ink-position! + surface-ink-flush )) (define-package (gtk keys) -- 2.25.1