From f0bca06747e529a43b692d9a3faf986264feec84 Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Thu, 15 Mar 2018 20:00:30 -0700 Subject: [PATCH] gtk-screen: Serialize callouts to glib. Banish without-interrupts. --- src/gtk-screen/gtk-screen.pkg | 2 + src/gtk-screen/gtk-screen.scm | 343 ++++++++++++++++------------------ 2 files changed, 165 insertions(+), 180 deletions(-) diff --git a/src/gtk-screen/gtk-screen.pkg b/src/gtk-screen/gtk-screen.pkg index 70b194217..ba394efd6 100644 --- a/src/gtk-screen/gtk-screen.pkg +++ b/src/gtk-screen/gtk-screen.pkg @@ -105,6 +105,8 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. set-fix-rect-size! set-fix-rect-position! fix-rect-intersect? fix-rect-union!) (import (glib) + assert-glib-locked + with-glib-lock without-glib-lock gobject-alien gobject-unref!) (import (gtk) gtk-css-provider-load-from-data diff --git a/src/gtk-screen/gtk-screen.scm b/src/gtk-screen/gtk-screen.scm index 1c9337a96..c4a1cc32b 100644 --- a/src/gtk-screen/gtk-screen.scm +++ b/src/gtk-screen/gtk-screen.scm @@ -63,28 +63,30 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. ;; Whether a cursor should be blinking. (in-focus? define standard initial-value #f)) -(define screen-list) +(define screen-list) ;serialize with glib lock (define (make-gtk-screen #!optional geometry) (%trace "; make-gtk-screen "geometry"\n") - (let* ((toplevel (gtk-window-new 'toplevel)) - (screen (%make-gtk-screen toplevel (current-thread) (make-queue))) - (geometry* (if (default-object? geometry) - "80x24" - (begin - (guarantee-string geometry 'make-gtk-screen) - geometry)))) - (gtk-widget-set-opacity toplevel 0.95) - (init-font-dimensions! screen "Monospace 11") - (init-size! screen geometry*) - (let ((thread (create-blinker-thread screen))) - (%trace "; blinker thread: "thread"\n") - (set-gtk-screen-blinker! screen thread) - (detach-thread thread) - (%trace "; editor thread: "(current-thread)"\n")) - (set! screen-list (cons screen screen-list)) - (%trace "; screen: "screen"\n") - screen)) + (with-glib-lock + (lambda () + (let* ((toplevel (gtk-window-new 'toplevel)) + (screen (%make-gtk-screen toplevel (current-thread) (make-queue))) + (geometry* (if (default-object? geometry) + "80x24" + (begin + (guarantee-string geometry 'make-gtk-screen) + geometry)))) + (gtk-widget-set-opacity toplevel 0.95) + (init-font-dimensions! screen "Monospace 11") + (init-size! screen geometry*) + (let ((thread (create-blinker-thread screen))) + (%trace "; blinker thread: "thread"\n") + (set-gtk-screen-blinker! screen thread) + (detach-thread thread) + (%trace "; editor thread: "(current-thread)"\n")) + (set! screen-list (cons screen screen-list)) + (%trace "; screen: "screen"\n") + screen)))) (define (init-font-dimensions! screen spec) (%trace "; init-font-dimensions! "screen" "spec"\n") @@ -195,7 +197,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define-method set-screen-size! ((screen ) x-size y-size) (%trace "; (set-screen-size! ) "screen" "x-size"x"y-size"\n") - (without-interrupts + (%without-interruption (lambda () (set-screen-x-size! screen x-size) (set-screen-y-size! screen y-size) @@ -214,7 +216,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (lambda () (%trace2 ";blinking started on "screen"\n") (let loop () - (without-interrupts + (%without-interruption (lambda () (let ((cursor (gtk-screen-blinking screen))) (cond ((not cursor) @@ -227,13 +229,16 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (%trace2 ";blinker: awake after invisible "cursor"\n")) (else (%trace3 ";blinker: off "cursor"\n") - (set-fix-ink-widgets! cursor '()) + (with-glib-lock + (lambda () (set-fix-ink-widgets! cursor '()))) (sleep-current-thread 500) (if (cursor-ink-visible? cursor) (begin (%trace3 ";blinker: on "cursor"\n") - (set-fix-ink-widgets! cursor - (cursor-ink-widget-list cursor)) + (with-glib-lock + (lambda () + (set-fix-ink-widgets! + cursor (cursor-ink-widget-list cursor)))) (sleep-current-thread 500)) (begin (%trace ";blinker: on: invisible "cursor"\n") @@ -241,26 +246,38 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (loop))))) (define-method screen-beep ((screen )) + (assert-glib-locked '(screen-beep )) (gtk-widget-error-bell (gtk-screen-toplevel screen))) (define-method screen-enter! ((screen )) (%trace "; screen-enter! "screen"\n") + (assert-glib-locked '(screen-enter! )) (update-widgets screen) (gtk-window-present (gtk-screen-toplevel screen)) (%trace "; screen-enter!: done\n")) (define-method screen-exit! ((screen )) (%trace "; screen-exit! "screen"\n") + (assert-glib-locked '(screen-exit! )) (set-gtk-screen-in-focus?! screen #f) (update-blinking screen)) (define-method screen-discard! ((screen )) + (%trace "; screen-discard! "screen"\n") + (assert-glib-locked '(screen-discard! )) (set! screen-list (delq! screen screen-list)) (gtk-widget-destroy (gtk-screen-toplevel screen)) (pango-font-description-free (gtk-screen-font screen))) +(define %glib-mutex (access glib-mutex (->environment '(glib)))) (define-method screen-modeline-event! ((screen ) window type) - (%trace "; screen-modeline-event! "screen" "window" "type"\n")) + (%trace "; screen-modeline-event! "screen" "window" "type"\n") + ;;(assert-glib-locked '(screen-modeline-event! )) + (if (not (eq? (current-thread) (thread-mutex-owner %glib-mutex))) + (begin + (outf-error "Yo!\n") + (error "yo:" screen window type))) + unspecific) ;;; These scrolling procedures are for editor commands (not ;;; scrollbars). They force a buffer-drawing layout update @@ -270,6 +287,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define-method screen/window-scroll-y-absolute! ((screen ) frame y-point) (%trace "; screen/window-scroll-y-absolute! "screen" "frame" "y-point"\n") + (assert-glib-locked '(screen/window-scroll-y-absolute! )) (with-updated-window screen frame 'SCROLL-Y-ABSOLUTE! (lambda (widget) @@ -314,6 +332,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define-method screen/window-scroll-y-relative! ((screen ) frame delta) (%trace "; screen/window-scroll-y-relative! "screen" "frame" "delta"\n") + (assert-glib-locked '(screen/window-scroll-y-relative! )) (with-updated-window screen frame 'SCROLL-Y-RELATIVE! (lambda (widget) @@ -327,6 +346,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define-method screen/set-window-start-mark! ((screen ) frame mark force?) (%trace "; screen/set-window-start-mark! "screen" "frame" "mark" "force?"\n") + (assert-glib-locked '(screen/set-window-start-mark! )) (with-updated-window screen frame 'SET-START-MARK! (lambda (widget) @@ -351,6 +371,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define-method screen/window-mark-visible? ((screen ) frame mark) (%trace "; screen/window-mark-visible? "screen" "frame" "mark"\n") + (assert-glib-locked '(screen/window-mark-visible? )) (with-updated-window screen frame 'MARK-VISIBLE? (lambda (widget) @@ -372,6 +393,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define-method screen/window-mark->x ((screen ) frame mark) (%trace "; screen/window-mark->x "screen" "frame" "mark"\n") + (assert-glib-locked '(screen/window-mark->x )) (with-updated-window screen frame 'MARK->X (lambda (widget) @@ -388,6 +410,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define-method screen/window-mark->y ((screen ) frame mark) (%trace "; screen/window-mark->y "screen" "frame" "mark"\n") + (assert-glib-locked '(screen/window-mark->y )) (with-updated-window screen frame 'MARK->Y (lambda (widget) @@ -408,6 +431,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define-method screen/window-mark->coordinates ((screen ) frame mark) (%trace "; screen/window-mark->coordinates "screen" "frame" "mark"\n") + (assert-glib-locked '(screen/window-mark->coordinates )) (with-updated-window screen frame 'MARK->COORDINATES (lambda (widget) @@ -418,18 +442,22 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (line->row line widget screen))))))) (define-method screen/window-point-x ((screen ) frame) + (assert-glib-locked '(screen/window-point-x )) (screen/window-mark->x screen frame (window-point frame))) (define-method screen/window-point-y ((screen ) frame) + (assert-glib-locked '(screen/window-point-y )) (screen/window-mark->y screen frame (window-point frame))) (define-method screen/window-point-coordinates ((screen ) frame) + (assert-glib-locked '(screen/window-point-coordinates )) (screen/window-mark->coordinates screen frame (window-point frame))) (define-method screen/window-coordinates->mark ((screen ) frame x y) (%trace "; screen/window-coordinates->mark "screen" "frame" "x" "y"\n") (%trace-buttons "coordinates->mark "screen" "frame" "x" "y) + (assert-glib-locked '(screen/window-coordinates->mark! )) (with-updated-window screen frame 'COORDINATES->MARK (lambda (widget) @@ -655,16 +683,22 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. ((INPUT-EVENT) #t) ((PROCESS-STATUS) - (if (handle-process-status-changes) - (update-screens! #f)) + (with-glib-lock + (lambda () + (if (handle-process-status-changes) + (update-screens! #f)))) (loop)) ((PROCESS-OUTPUT) - (if (accept-process-output) - (update-screens! #f)) + (with-glib-lock + (lambda () + (if (accept-process-output) + (update-screens! #f)))) (loop)) ((INFERIOR-THREAD-OUTPUT) - (if (accept-thread-output) - (update-screens! #f)) + (with-glib-lock + (lambda () + (if (accept-thread-output) + (update-screens! #f)))) (loop)) ((TIMEOUT) #f) @@ -693,27 +727,34 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. halt?)) (named-lambda (gtk-screen-peek-no-hang msec) (%trace2 ";peek-no-hang "msec"\n") - (let ((event (and (block-for-input-event event-queue msec) - (queue/peek event-queue)))) - (%trace2 ";peek-no-hang "msec" => "event"\n") - event)) + (without-glib-lock + (lambda () + (let ((event (and (block-for-input-event event-queue msec) + (queue/peek event-queue)))) + (%trace2 ";peek-no-hang "msec" => "event"\n") + event)))) (named-lambda (gtk-screen-peek) (%trace2 ";peek\n") - (let ((event (and (block-for-input-event event-queue #f) - (queue/peek event-queue)))) - (%trace2 ";peek => "event"\n") - event)) + (without-glib-lock + (lambda () + (let ((event (and (block-for-input-event event-queue #f) + (queue/peek event-queue)))) + (%trace2 ";peek => "event"\n") + event)))) (named-lambda (gtk-screen-read) (%trace2 ";read\n") - (let ((event (and (block-for-input-event event-queue #f) - (dequeue!/unsafe event-queue)))) - (%trace2 ";read => "event"\n") - event))))) + (without-glib-lock + (lambda () + (let ((event (and (block-for-input-event event-queue #f) + (dequeue!/unsafe event-queue)))) + (%trace2 ";read => "event"\n") + event))))))) (set! os/interprogram-cut (named-lambda (os/interprogram-cut string point) (declare (ignore point)) + (assert-glib-locked 'os/interprogram-cut) (gtk-window-set-clipboard-text (gtk-screen-toplevel (selected-screen)) string))) @@ -721,38 +762,16 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. os/interprogram-paste (named-lambda (os/interprogram-paste point) (declare (ignore point)) + (assert-glib-locked 'os/interprogram-paste) (gtk-window-get-clipboard-text (gtk-screen-toplevel (selected-screen))))) -(define interrupts?) +(define (with-gtk-grabbed receiver) + (%trace "; with-gtk-grabbed "(current-thread)"\n") + (with-glib-lock (lambda () (receiver with-gtk-ungrabbed '())))) -(define (interrupt!) - (%trace ";interrupt!...") - (if interrupts? - (begin - (%trace " signaling.\n") - (editor-beep) - (temporary-message "Quit") - (^G-signal)) - (%trace " masked!\n"))) - -(define (with-editor-interrupts-from-gtk receiver) - (fluid-let ((interrupts? #t)) - (%trace ";with-editor-interrupts-from-gtk "(current-thread)"\n") - (receiver (lambda (thunk) (thunk)) '()))) - -(define (with-gtk-interrupts-enabled thunk) - (fluid-let ((interrupts? #t)) - (%trace ";with-gtk-interrupts-enabled\n") - (let ((v (thunk))) - (%trace ";with-gtk-interrupts-enabled => "v"\n") - v))) - -(define (with-gtk-interrupts-disabled thunk) - (fluid-let ((interrupts? #f)) - (%trace ";with-gtk-interrupts-disabled\n") - (let ((v (thunk))) - (%trace ";with-gtk-interrupts-disabled => "v"\n") - v))) +(define (with-gtk-ungrabbed thunk) + (%trace "; with-gtk-ungrabbbed "(current-thread)"\n") + (without-glib-lock thunk)) (define (focus-change-handler widget in?) (%trace "; Focus-"(if in? "in" "out")": "widget"\n") @@ -803,7 +822,9 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. thread (lambda () (%trace ";interrupt! in editor "(current-thread)"\n") - (interrupt!))) + (editor-beep) + (temporary-message "Quit") + (^G-signal))) (%trace "; pushed ^G in "(current-thread)".\n") #t) (queue! (merge-bucky-bits k char-bits))) @@ -874,9 +895,9 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. gtk-initialized? make-gtk-screen get-gtk-input-operations - with-editor-interrupts-from-gtk - with-gtk-interrupts-enabled - with-gtk-interrupts-disabled)) + with-gtk-grabbed + %with-interruption + %without-interruption)) unspecific) (define (spawn-edit . args) @@ -1256,7 +1277,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. unspecific) (define-method fix-widget-realize-callback ((widget )) - (%trace ";(fix-widget-realize-callback ) "widget"\n") + (%trace "; (fix-widget-realize-callback ) "widget"\n") (let ((geometry (fix-widget-geometry widget))) (if (or (not (fix-rect-width geometry)) (not (fix-rect-height geometry))) @@ -1446,7 +1467,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. widget) (define-method fix-widget-realize-callback ((widget )) - (%trace ";(fix-widget-realize-callback ) "widget"\n") + (%trace "; (fix-widget-realize-callback ) "widget"\n") (let ((screen (edwin-widget-screen widget)) (geometry (fix-widget-geometry widget))) (if (or (not (fix-rect-width geometry)) @@ -1517,7 +1538,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. ;; remembers the start and end indices of a line in a buffer and the ;; bounding box of the laid-up line/paragraph, and not much else. ;; -;; The INCREMENTAL version of this process UPDATES an existing column +;; The incremental version of this process updates an existing column ;; of s after the buffer has changed. It skips ;; unchanged lines at the top, and re-lays out lines in the change ;; region. Depending on the newlines in the region, it may re-use @@ -1530,8 +1551,8 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. ;; keep a PangoLayout around to service expose events. A drawing of a ;; large buffer, with thousands of lines, if drawn with ;; simple-text-inks, would allocate thousands of PangoLayouts, each -;; with an image of a line (the images alone consuming more bytes than -;; in the original buffer content). +;; with an image of a line. The images alone would occupy more bytes +;; than the buffer text. ;; ;; To lighten the footprint of a large buffer drawing, line-inks do ;; not hold a PangoLayout, but create one on demand using the buffer @@ -1540,30 +1561,13 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. ;; allows most expose events to find exposed line-inks ready with a ;; PangoLayout to paint. As lines scroll into view, new PangoLayouts ;; are allocated (or stolen), and the buffer text is re-imaged, -;; styled, and re-layed-out just as when originally drawn. Sometimes, -;; however, the original buffer text is NOT available. -;; -;; Expose events arrive ASYNCHRONOUSLY, and may find that a line's -;; text has changed. The line may extend into (or just touch!) a -;; buffer's change region. The original buffer text is no longer -;; available, so the original PangoLayout cannot be re-constructed. -;; The event handler must PUNT, and leave the line blank. (It will -;; have been cleared to the background color.) -;; -;; To ensure that lines can be exposed as soon as they are re-drawn, -;; each buffer drawing keeps an "update region" that it narrows as it -;; redraws. The expose handlers refer to THIS change region, when -;; available (during Redisplay), rather than the buffer's change -;; region. Narrowing a buffer-drawing's update region BEFORE -;; redrawing lines ensures that the resulting expose events will not -;; be punted. +;; styled, and re-layed-out just as when originally drawn. ;; -;; Punted exposures should be infrequent, resulting from external -;; events (e.g. an obscuring window was closed) exposing lines that -;; have just recently changed in the buffer, during the tiny Eval and -;; Redisplay parts of Edwin's main loop. These occasional misses -;; should be hardly noticeable. The blank line should be quickly -;; redrawn by the end of Redisplay. +;; Edwin now runs with the glib lock, giving it up only to read input. +;; Thus the expose event handler should not run until the end of +;; redisplay when all drawings are up-to-date and there are no buffer +;; changed regions, allowing an exposed line ink to re-construct its +;; PangoLayout from unchanged buffer text. (define-method update-screen! ((screen ) display-style) (%trace "; (update-screen! ) "screen" "display-style"\n") @@ -1607,16 +1611,12 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (declare (integrate-operator with-screen-in-update)) (define (with-screen-in-update screen thunk) + (assert-glib-locked 'with-screen-in-update) (if (screen-in-update? screen) (error "Recursive update:" screen)) (set-screen-in-update?! screen #t) (let ((v (thunk))) (set-screen-in-update?! screen #f) - ;; It would be better if this happened AFTER buffer change - ;; regions were cleared. Or use gdk-window-process-updates here? - (for-each (lambda (buffer.drawing) - (set-buffer-drawing-update-region! (cdr buffer.drawing) #f)) - (gtk-screen-drawings screen)) v)) (define (update-blinking screen) @@ -1908,8 +1908,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (mark-index display-start))) (change-end-index (if (buffer-drawing-valid? drawing) (group-end-changes-index group) - (mark-index display-end))) - (update-region #f)) + (mark-index display-end)))) (define-syntax %trace3 (syntax-rules () @@ -1929,8 +1928,6 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (%trace ";\tno changes\n") #t) (else - (set! update-region (cons change-start-index change-end-index)) - (set-buffer-drawing-update-region! drawing update-region) (let ((finished? (redraw-start @@ -1951,7 +1948,6 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. redraw-end))))))))) - (set-buffer-drawing-update-region! drawing finished?) (if finished? (begin (set-size) @@ -2184,15 +2180,6 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (set! drawing-extent (copy-fix-rect extent)) (fix-rect-union! drawing-extent extent))) - ;; If the update region is narrowed to exclude each line before it - ;; is re-drawn, then the resulting exposes will not be punted by - ;; the line-ink expose handler (which is otherwise shuns change - ;; regions). The expose event could arrive instantly (thread - ;; timer interrupts permitting), so this must be done before - ;; (re)drawing the line-ink. - (define (update-region! start) - (set-car! update-region (mark-index start))) - ;; Keeps the next line to redraw on the front, skipping inks like ;; cursors, selection boxes, embedded images/widgets/whatnot. (define (next-lines inks) @@ -2245,7 +2232,6 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (%trace3 "; add-line "start" "num" "y" "old"\n") (let ((new (make-line-ink))) (set-line-ink-start! new (mark-permanent-copy start)) - (update-region! start) (set-line-ink-end! new (mark-permanent-copy start)) (set-line-ink-number! new num) (fix-drawing-add-ink! drawing new (and (pair? old) (car old))) @@ -2256,7 +2242,6 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define (steal-line! line start num y) (%trace3 "; steal-line! "line" "start" "num" "y"\n") (move-mark-to! (line-ink-start line) start) - (update-region! start) (set-line-ink-number! line num) (redraw-line! line 0 y (layout)) (union-ink! line)) @@ -2265,7 +2250,6 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (let* ((extent (fix-ink-extent line)) (old-num (line-ink-number line)) (old-y (fix-rect-y extent))) - (update-region! start) (if (not (fix:= old-y y)) (set-text-ink-position! line 0 y)) (if (not (fix:= old-num num)) @@ -2278,7 +2262,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define (remove-line line) (mark-temporary! (line-ink-start line)) (mark-temporary! (line-ink-end line)) - (without-interrupts + (%without-interruption (lambda () (clear-cached-pango-layout line) (fix-ink-remove! line)))) @@ -2327,13 +2311,13 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (%trace3 ";\t redraw-line! "line" from "(line-ink-start line) " ("x","y") with "pango-layout"\n") - (without-interrupts + (%without-interruption (lambda () (%layout-line! line pango-layout))) (pango-layout-get-pixel-extents pango-layout (lambda (width height) - (without-interrupts + (%without-interruption (lambda () (clear-cached-pango-layout line) (%trace3 ";\t erasing "(fix-ink-extent line)"\n") @@ -2348,8 +2332,6 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define image-buffer (string-allocate image-buffer-size)) (define (%layout-line! line pango-layout) - ;; This must run without-interrupts because it uses image-buffer. - ;; An async expose event might otherwise fubar it. (let* ((drawing (fix-ink-drawing line)) (buffer (buffer-drawing-buffer drawing)) (group (buffer-group buffer)) @@ -2382,23 +2364,12 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (declare (integrate-operator unchanged?)) (define (unchanged? line) (let* ((drawing (fix-ink-drawing line)) - (update-region (buffer-drawing-update-region drawing))) - (cond ((eq? update-region #t) #t) - ((pair? update-region) - (or - (let ((change-start (car update-region)) - (line-end (line-ink-end-index line))) - (fix:<= line-end change-start)) - (let ((change-end (cdr update-region)) - (line-start (line-ink-start-index line))) - (fix:< change-end line-start)))) - (else - (let ((buffer (buffer-drawing-buffer drawing))) - (and buffer - (let ((group (buffer-group buffer))) - (%unchanged? line - (group-start-changes-index group) - (group-end-changes-index group))))))))) + (buffer (buffer-drawing-buffer drawing))) + (and buffer + (let ((group (buffer-group buffer))) + (%unchanged? line + (group-start-changes-index group) + (group-end-changes-index group)))))) (declare (integrate-operator %unchanged?)) (define (%unchanged? line change-start change-end) @@ -2537,10 +2508,6 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (display-start define standard initial-value #f) (display-end define standard initial-value #f) - ;; During redisplay this is the portion of the buffer's change - ;; region that has yet to be re-drawn. - (update-region define standard initial-value #f) - ;; These are the particulars of the set of PangoLayouts in use. ;; Each element is a "cache" containing: (|#f ;; . ). Thus each layout is either idle, or in use -- @@ -2591,9 +2558,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define-method text-ink-pango-layout ((ink )) ;; A cached pango layout is presumed to be all laid out. A cache - ;; miss means a PangoLayout must be re-laid-up from the buffer text, - ;; if the text has not changed. If the change region intersects, - ;; punt! + ;; miss means a PangoLayout must be re-laid-up from the buffer text. (define (salvage-pango-layout line) ;; Look for a cached PangoLayout to re-use. Returns abandoned @@ -2634,31 +2599,13 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. layout)) ;; Do not (call-next-method ink). There is no method. - (cond ((fix:zero? (fix-rect-height (fix-ink-extent ink))) - ;; An expose event can arrive between adding a new line to - ;; the drawing and laying it out (see add-line in - ;; update-drawing). If the dimensions (any) are zero, punt. - #f) - ((unchanged? ink) - (or (line-ink-cached-pango-layout ink) - ;; When executed by the expose handler, this already runs - ;; without-interrupts. However there are other places - ;; (e.g. redraw-cursor) where this could be called. Ensure - ;; that the async. expose handlers do not start frobbing the - ;; pango-layout cache until we are done here. - (without-interrupts - (lambda () - (let ((layout (or (salvage-pango-layout ink) - (cache-pango-layout ink)))) - (%layout-line! ink layout) - layout))))) - (else - (outf-error ";text-ink-pango-layout: punted "ink"\n") - #f))) + (or (line-ink-cached-pango-layout ink) + (let ((layout (or (salvage-pango-layout ink) + (cache-pango-layout ink)))) + (%layout-line! ink layout) + layout))) (define (clear-cached-pango-layout line) - ;; This probably aught to be done without-interrupts, since it - ;; frobs a cache used (filled!) by the async expose handler. (let ((layout (line-ink-cached-pango-layout line))) (if layout (let* ((drawing (fix-ink-drawing line)) @@ -2692,7 +2639,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define (visible! cursor visible?) ;; Atomically sets cursor-ink-visible? and fix-ink-widgets. - (without-interrupts + (%without-interruption (lambda () (if visible? (if (not (cursor-ink-visible? cursor)) @@ -2707,7 +2654,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define (blink! screen cursor) ;; Atomically sets CURSOR up to blink. CURSOR may be #f, in which ;; case blinking will pause. - (without-interrupts + (%without-interruption (lambda () (let ((old (gtk-screen-blinking screen))) (if cursor @@ -2745,6 +2692,42 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. () (text-ink define standard)) +(define-integrable %without-interruption without-interruption) +#;(define (%without-interruption thunk) + (%trace "; %without-interruption "thunk"\n") + (%assert-with-interruption '%without-interruption) + (let ((v (without-interruption thunk))) + (%trace "; %without-interruption "thunk" => "v"\n") + v)) + +(define (%with-interruption thunk) + (%trace "; %with-interruption "thunk"\n") + (%assert-without-interruption '%with-interruption) + (unblock-thread-events) + (let ((v (thunk))) + (%trace "; %with-interruption "thunk" => "v"\n") + (block-thread-events) + v)) + +#;(begin + (define-integrable (%assert-without-interruption operator) + (declare (ignore operator)) + #f) + (define-integrable (%assert-with-interruption operator) + (declare (ignore operator)) + #f)) + +(begin + (define %get-thread-event-block + (access get-thread-event-block (->environment '(runtime thread)))) + + (define-integrable (%assert-without-interruption operator) + (if (not (%get-thread-event-block)) + (outf-error ";not without interruption: "operator"\n"))) + (define-integrable (%assert-with-interruption operator) + (if (%get-thread-event-block) + (outf-error ";not with interruption: "operator"\n")))) + (define %trace? #f) (define-syntax %trace -- 2.25.1