[mcclim-cvs] CVS mcclim/Drei
thenriksen
thenriksen at common-lisp.net
Fri Feb 15 13:16:17 UTC 2008
Update of /project/mcclim/cvsroot/mcclim/Drei
In directory clnet:/tmp/cvs-serv6104/Drei
Modified Files:
drei-redisplay.lisp lisp-syntax.lisp packages.lisp syntax.lisp
views.lisp
Log Message:
Improved Drei redisplay performance by 66% in most cases.
The main difference is that syntaxes are now supposed to report which
parts of the display may need to be updated, previously their view of
the display was computed for every redisplay iteration, and any
changes drawn.
Of course, no syntaxes do that yet, so if you use Lisp block-comments
or string-quoting, you will see "delayed" redrawing of some parts of
the display. Just like Emacs!
Currently, a heuristic is used that invalidates parts of the display
corresponding to buffer regions that have actually been changed, so it
does work fine for the common cases.
--- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/02/13 21:58:50 1.64
+++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/02/15 13:16:17 1.65
@@ -427,24 +427,21 @@
some point)."
(aref (line-strokes line) (1- (line-stroke-count line))))
-(defun put-stroke (view line pump-state line-change)
+(defun put-stroke (view line pump-state line-change offset)
"Use `stroke-pump' with `pump-state' to get a new stroke for
`view', and add it to the sequence of displayed strokes in
`line'. `Line-change' should be a relative offset specifying how
much the start-offset of `line' has changed since the last time
it was redisplayed. `Offset' is the offset at which the next
stroke will start."
- (let* ((stroke (line-stroke-information line (line-stroke-count line)))
- (old-start-offset (stroke-start-offset stroke))
- (old-end-offset (stroke-end-offset stroke))
- (old-drawing-options (stroke-drawing-options stroke)))
+ (let ((stroke (line-stroke-information line (line-stroke-count line))))
+ (unless (stroke-modified stroke)
+ (incf (stroke-start-offset stroke) line-change)
+ (incf (stroke-end-offset stroke) line-change)
+ (when (or (null (stroke-start-offset stroke))
+ (/= (stroke-start-offset stroke) offset))
+ (invalidate-stroke stroke :modified t)))
(prog1 (stroke-pump view stroke pump-state)
- (unless (and old-start-offset
- (= (+ old-start-offset line-change) (stroke-start-offset stroke))
- (= (+ old-end-offset line-change) (stroke-end-offset stroke))
- (drawing-options-equal old-drawing-options
- (stroke-drawing-options stroke)))
- (invalidate-stroke stroke :modified t))
(incf (line-stroke-count line))
(setf (line-end-offset line) (stroke-end-offset stroke)))))
@@ -685,8 +682,8 @@
for index from 0
for stroke = (line-stroke-information line index)
for stroke-dimensions = (stroke-dimensions stroke)
- for pump-state = (put-stroke view line initial-pump-state offset-change)
- then (put-stroke view line pump-state offset-change)
+ for pump-state = (put-stroke view line initial-pump-state offset-change offset)
+ then (put-stroke view line pump-state offset-change offset)
do (update-stroke-dimensions pane view stroke cursor-x cursor-y)
(setf cursor-x (x2 stroke-dimensions))
(setf offset (stroke-end-offset stroke))
@@ -795,7 +792,8 @@
(pane-height (bounding-rectangle-height (or (pane-viewport pane) pane))))
;; For invalidation of the parts of the display that have
;; changed.
- (synchronize-view view :begin (offset (top view)) :end (offset (bot view)))
+ (synchronize-view view :begin (offset (top view)) :end (max (offset (bot view))
+ (offset (top view))))
(setf (displayed-lines-count view) 0
(max-line-width view) 0)
(multiple-value-bind (cursor-x cursor-y) (stream-cursor-position pane)
@@ -890,6 +888,35 @@
(defmethod stroke-pump ((view drei-buffer-view) stroke pump-state)
(buffer-view-stroke-pump view stroke pump-state))
+;;; The following is the equivalent of a turbocharger for the
+;;; redisplay engine.
+(defstruct (skipalong-pump-state
+ (:constructor make-skipalong-pump-state (offset)))
+ "A pump state for fast skipalong that doesn't involve
+the (potentially expensive) actual stroke pump. It transparently
+turns into a real pump state when it happens across invalid
+strokes. `Offset' is the offset of the next stroke to be pumped."
+ offset)
+
+(defmethod stroke-pump :around ((view drei-buffer-view) (stroke displayed-stroke)
+ (pump-state skipalong-pump-state))
+ (with-accessors ((state-offset skipalong-pump-state-offset)) pump-state
+ (if (or (stroke-modified stroke)
+ (/= (stroke-start-offset stroke) state-offset))
+ (stroke-pump view stroke (pump-state-for-offset view state-offset))
+ (progn (setf state-offset
+ (+ (stroke-end-offset stroke)
+ (if (offset-end-of-line-p
+ (buffer view) (stroke-end-offset stroke))
+ 1 0)))
+ pump-state))))
+
+(defmethod stroke-pump :around ((view drei-buffer-view) (stroke displayed-stroke)
+ pump-state)
+ (if (stroke-modified stroke)
+ (call-next-method)
+ (stroke-pump view stroke (make-skipalong-pump-state (stroke-start-offset stroke)))))
+
;;; Cursor handling.
(defun offset-in-stroke-position (stream view stroke offset)
@@ -1170,7 +1197,7 @@
(setf (offset top) (offset bot))
(beginning-of-line top)
(setf (offset (point view)) (offset top))
- (invalidate-all-strokes view))))
+ (invalidate-all-strokes view :modified t))))
(defmethod page-up (pane (view drei-buffer-view))
(with-accessors ((top top) (bot bot)) view
--- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/02/10 00:42:03 1.74
+++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/02/15 13:16:17 1.75
@@ -1921,6 +1921,24 @@
(defmethod syntax-highlighting-rules ((syntax lisp-syntax))
*syntax-highlighting-rules*)
+(defmethod invalidate-strokes ((view textual-drei-syntax-view) (syntax lisp-syntax))
+ ;; Invalidate the area touched by parenthesis highlighting, if
+ ;; applicable. Cheap test to do coarse elimination...
+ (when (or (and (not (end-of-buffer-p (point view)))
+ (equal (object-after (point view)) #\())
+ (and (not (beginning-of-buffer-p (point view)))
+ (equal (object-before (point view)) #\))))
+ ;; Might still be a fake match, so do the semiexpensive proper test.
+ (let ((form (form-around syntax (offset (point view)))))
+ (when form
+ (let ((start-offset (start-offset form))
+ (end-offset (end-offset form)))
+ (when (or (mark= start-offset (point view))
+ (mark= end-offset (point view)))
+ ;; We actually have parenthesis highlighting.
+ (list (cons start-offset (1+ start-offset))
+ (cons (1- end-offset) end-offset))))))))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; exploit the parse
--- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/02/11 23:05:22 1.52
+++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/02/15 13:16:17 1.53
@@ -220,7 +220,7 @@
#:drei-buffer-view #:buffer #:top #:bot #:buffer-view-p
#:lines
- #:buffer-line #:start-mark #:line-length #:chunks #:end-offset
+ #:buffer-line #:start-mark #:end-mark #:line-length #:chunks
#:line-containing-offset #:offset-in-line-p
#:buffer-view-pump-state-for-offset
#:buffer-view-stroke-pump
@@ -243,6 +243,8 @@
#:overwrite-mode
#:goal-column
+ #:invalidate-strokes
+
#:view-command-tables
#:use-editor-commands-p
#:synchronize-view
@@ -538,6 +540,8 @@
#:action #:new-state #:done
#:reduce-fixed-number #:reduce-until-type #:reduce-all
#:error-state #:error-reduce-state
+ #:do-parse-symbols-forward
+ #:parser-symbol-containing-offset
#:define-syntax-highlighting-rules
#:syntax-highlighting-rules)
(:documentation "Underlying LR parsing functionality."))
--- /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2008/02/08 18:37:32 1.18
+++ /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2008/02/15 13:16:17 1.19
@@ -22,7 +22,7 @@
(in-package :drei-syntax)
-(defclass syntax (name-mixin)
+(defclass syntax (name-mixin observable-mixin)
((%buffer :initarg :buffer :reader buffer)
(%command-table :initarg :command-table
:initform (error "A command table has not been provided for this syntax")
--- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/02/14 08:15:01 1.38
+++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/02/15 13:16:17 1.39
@@ -605,7 +605,10 @@
(%lines-suffix :accessor lines-suffix-size
:documentation "The number of unchanged objects
at the end of the buffer since since the list of lines was last
-updated."))
+updated.")
+ (%last-seen-buffer-size :accessor last-seen-buffer-size
+ :documentation "The buffer size the
+last time a change to the buffer was registered."))
(:metaclass modual-class)
(:documentation "A view that contains a `drei-buffer'
object. The buffer is displayed on a simple line-by-line basis,
@@ -618,7 +621,8 @@
(declare (ignore initargs))
(with-accessors ((top top) (bot bot)
(lines-prefix lines-prefix-size)
- (lines-suffix lines-suffix-size)) view
+ (lines-suffix lines-suffix-size)
+ (buffer-size last-seen-buffer-size)) view
(unless buffer
;; So many fun things are defined on (setf buffer) that we use
;; slot-value here. This is just a glorified initform anyway.
@@ -629,7 +633,8 @@
(setf top (make-buffer-mark (buffer view) 0 :left)
bot (clone-mark top :right)
lines-prefix 0
- lines-suffix 0)))
+ lines-suffix 0
+ buffer-size (size (buffer view)))))
(defmethod (setf top) :after (new-value (view drei-buffer-view))
(invalidate-all-strokes view))
@@ -641,11 +646,13 @@
(invalidate-all-strokes view)
(with-accessors ((top top) (bot bot)
(lines-prefix lines-prefix-size)
- (lines-suffix lines-suffix-size)) view
+ (lines-suffix lines-suffix-size)
+ (buffer-size last-seen-buffer-size)) view
(setf top (make-buffer-mark buffer 0 :left)
bot (clone-mark top :right)
lines-prefix 0
- lines-suffix 0)))
+ lines-suffix 0
+ buffer-size 0)))
(defmethod cache-string :around ((view drei-buffer-view))
(let ((string (call-next-method)))
@@ -670,9 +677,9 @@
((%start-mark :reader start-mark
:initarg :start-mark
:documentation "The mark at which this line starts.")
- (%line-length :reader line-length
- :initarg :line-length
- :documentation "The length of the line described by this object.")
+ (%end-mark :reader end-mark
+ :initarg :end-mark
+ :documentation "The mark at which this line ends.")
(%chunks :accessor chunks
:initform (make-array 5
:adjustable t
@@ -700,9 +707,15 @@
when (= chunk-start-offset line-end-offset)
do (loop-finish)))
+(defmethod start-offset ((line buffer-line))
+ (offset (start-mark line)))
+
(defmethod end-offset ((line buffer-line))
- "Return the end buffer offset of `line'."
- (+ (offset (start-mark line)) (line-length line)))
+ (offset (end-mark line)))
+
+(defun line-length (line)
+ "Return the length of the `buffer-line' object `line'."
+ (- (end-offset line) (start-offset line)))
(defun get-chunk (buffer line-start-offset chunk-start-offset line-end-offset)
"Return a chunk in the form of a cons cell. The chunk will
@@ -755,12 +768,11 @@
;; Analyze new lines.
(loop while (mark<= low-mark high-mark)
for i from low-index
- do (progn (let ((line-start-mark (clone-mark low-mark)))
- (insert* lines i (make-instance
- 'buffer-line
+ do (progn (let ((line-start-mark (clone-mark low-mark :left))
+ (line-end-mark (clone-mark (end-of-line low-mark) :right)))
+ (insert* lines i (make-instance 'buffer-line
:start-mark line-start-mark
- :line-length (- (offset (end-of-line low-mark))
- (offset line-start-mark))))
+ :end-mark line-end-mark))
(if (end-of-buffer-p low-mark)
(loop-finish)
;; skip newline
@@ -770,12 +782,40 @@
(defmethod observer-notified ((view drei-buffer-view) (buffer drei-buffer)
changed-region)
+ (declare (optimize (debug 3)))
(destructuring-bind (start-offset . end-offset) changed-region
- (invalidate-strokes-in-region view start-offset end-offset :modified t)
(with-accessors ((prefix-size lines-prefix-size)
- (suffix-size lines-suffix-size)) view
- (setf prefix-size (min start-offset prefix-size)
- suffix-size (min (- (size buffer) end-offset) suffix-size)))))
+ (suffix-size lines-suffix-size)
+ (buffer-size last-seen-buffer-size)) view
+ ;; Figure out whether the change involved insertion or deletion of
+ ;; a newline.
+ (let* ((line-index (index-of-line-containing-offset view start-offset))
+ (line (element* (lines view) line-index))
+ (newline-change
+ (or (loop for index from start-offset below end-offset
+ when (equal (buffer-object (buffer view) index) #\Newline)
+ return t)
+ ;; If the line is joined with the one before or
+ ;; after it, a newline object has been removed.
+ (or (when (/= line-index (nb-elements (lines view)))
+ (= (start-offset (element* (lines view) (1+ line-index)))
+ (end-offset line)))
+ (when (plusp line-index)
+ (= (end-offset (element* (lines view) (1- line-index)))
+ (start-offset line)))))))
+ ;; If the line structure changed, everything after the newline is suspect.
+ (invalidate-strokes-in-region view start-offset
+ (if newline-change
+ (max start-offset (offset (bot view)))
+ end-offset)
+ :modified t)
+ (setf prefix-size (min start-offset prefix-size)
+ suffix-size (min (- (size buffer) end-offset) suffix-size)
+ buffer-size (size buffer))
+ ;; If the line structure changed, we need to update the line
+ ;; data, or we can't pick up future changes correctly.
+ (when newline-change
+ (update-line-data view))))))
(defmethod synchronize-view ((view drei-buffer-view) &key)
(update-line-data view))
@@ -844,13 +884,14 @@
&key (syntax *default-syntax*))
(declare (ignore args))
(check-type syntax (or symbol syntax))
- (with-accessors ((view-syntax syntax)
- (buffer buffer)
+ (with-accessors ((buffer buffer)
(suffix-size suffix-size)
(prefix-size prefix-size)) view
- (setf view-syntax (if (symbolp syntax)
- (make-syntax-for-view view syntax)
- syntax))
+ (setf (slot-value view '%syntax)
+ (if (symbolp syntax)
+ (make-syntax-for-view view syntax)
+ syntax))
+ (add-observer (syntax view) view)
(add-observer buffer view)))
(defmethod (setf buffer) :before ((buffer drei-buffer) (view drei-syntax-view))
@@ -866,7 +907,11 @@
(with-accessors ((view-syntax syntax)) view
(setf view-syntax (make-syntax-for-view view (class-of view-syntax)))))
+(defmethod (setf syntax) :before (syntax (view drei-syntax-view))
+ (remove-observer (syntax view) view))
+
(defmethod (setf syntax) :after (syntax (view drei-syntax-view))
+ (add-observer syntax view)
(setf (prefix-size view) 0
(suffix-size view) 0
(buffer-size view) -1))
@@ -899,6 +944,11 @@
modified-p t)))
(call-next-method))
+(defmethod observer-notified ((view drei-syntax-view) (syntax syntax)
+ changed-region)
+ (destructuring-bind (start-offset . end-offset) changed-region
+ (invalidate-strokes-in-region view start-offset end-offset :modified t)))
+
(defun needs-resynchronization (view)
"Return true if the the view of the buffer of `view' is
potentially out of date. Return false otherwise."
@@ -1018,6 +1068,37 @@
highlighting, and maintains point and mark marks into the buffer,
in order to permit useful editing commands."))
+(defgeneric invalidate-strokes (view syntax)
+ (:documentation "Called just before redisplay of the
+`textual-drei-syntax-view' `view' in order to give `syntax',
+which is the syntax of `view', a chance to mark part of the
+display as invalid due to do something not caused by buffer
+modification (for example, parenthesis matching). This function
+should return a list of pairs of buffer offsets, each pair
+delimiting a buffer region that should be redrawn.")
+ (:method ((view textual-drei-syntax-view view) (syntax syntax))
+ nil))
+
+(defun invalidate-as-appropriate (view invalid-regions)
+ "Invalidate strokes of `view' overlapping regions in
+`invalid-regions'. `Invalid-regions' is a list of conses of
+buffer offsets delimiting regions."
+ (loop with top-offset = (offset (top view))
+ with bot-offset = (offset (bot view))
+ for (start . end) in invalid-regions
+ do (as-region (start end)
+ (when (overlaps start end top-offset bot-offset)
+ (invalidate-strokes-in-region view start end :modified t)))))
+
+(defmethod display-drei-view-contents :around (stream (view textual-drei-syntax-view))
+ (let ((invalid-regions (invalidate-strokes view (syntax view))))
+ (invalidate-as-appropriate view invalid-regions)
+ (call-next-method)
+ ;; We do not expect whatever ephemeral state that caused
+ ;; invalidation to stick around until the next redisplay, so
+ ;; whatever it imposed on us, mark as dirty immediately.
+ (invalidate-as-appropriate view invalid-regions)))
+
(defmethod create-view-cursors nconc ((output-stream extended-output-stream)
(view textual-drei-syntax-view))
(unless (no-cursors view)
More information about the Mcclim-cvs
mailing list