Changeset 16524


Ignore:
Timestamp:
Sep 1, 2015, 3:31:53 PM (4 years ago)
Author:
wws
Message:

Radically speed up IDE listener output and make it interruptible.

The IDE listener output is now double-buffered. Printing threads fill
one buffer, and the GUI thread empties the other.

To avoid me having to hurt my brain preventing deadlock, output from
the GUI thread to an IDE listener is dropped on the floor; you'll
never see it. Since it's unusual to output from the GUI thread to an
IDE listener (the default is the AltConsole?, or, if you started CCL
from a command-line shell, that shell), this shouldn't be a practical
problem.

Fixes #1307.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/cocoa-ide/cocoa-listener.lisp

    r16184 r16524  
    185185(defparameter $listener-flush-limit 4095)
    186186
     187(defclass double-output-buffer ()
     188  ((flush-limit :initarg :flush-limit :accessor dob-flush-limit)
     189   (data :initarg :data :accessor dob-data)
     190   (other-data :initform nil :accessor dob-other-data)
     191   (output-data :initarg :output-data :accessor dob-output-data)
     192   (data-lock :initform (make-recursive-lock) :accessor dob-data-lock)
     193   (output-data-lock :initform (make-recursive-lock) :accessor dob-output-data-lock)
     194   (semaphore :initform (make-semaphore) :accessor dob-semaphore)))
     195
     196(defun make-double-output-buffer (&optional (flush-limit $listener-flush-limit))
     197  (check-type flush-limit (integer 0))
     198  (flet ((make-buffer ()
     199           (make-array (1+ flush-limit)
     200                       :adjustable t
     201                       :fill-pointer 0
     202                       :element-type 'character)))
     203    (let* ((data (make-buffer))
     204           (output-data (make-buffer))
     205           (res (make-instance 'double-output-buffer
     206                               :flush-limit flush-limit
     207                               :data data
     208                               :output-data output-data)))
     209      (dob-return-output-data res)
     210      res)))
     211
     212(defmacro with-dob-data ((data dob) &body body)
     213  (let ((thunk (gensym "THUNK")))
     214    `(flet ((,thunk (,data)
     215              ,@body))
     216       (declare (dynamic-extent #',thunk))
     217       (call-with-dob-data #',thunk ,dob))))
     218
     219;; The GUI thread isn't allowed to print on a listener output-stream,
     220;; so ignore all attempts.
     221(defun call-with-dob-data (thunk dob)
     222  (unless (typep *current-process* 'appkit-process)
     223    (with-lock-grabbed ((dob-data-lock dob))
     224      (funcall thunk (dob-data dob)))))
     225
     226(defmacro with-dob-output-data ((data dob) &body body)
     227  (let ((thunk (gensym "THUNK")))
     228    `(flet ((,thunk (,data)
     229              ,@body))
     230       (declare (dynamic-extent #',thunk))
     231       (call-with-dob-output-data #',thunk ,dob))))
     232
     233(defun call-with-dob-output-data (thunk dob)
     234  (with-lock-grabbed ((dob-output-data-lock dob))
     235    (funcall thunk (dob-output-data dob))))
     236
     237;; Should be called only in the GUI thread, except when
     238;; initializing a new double-output-buffer instance (or
     239;; debugging the semaphore wait code).
     240(defun dob-return-output-data (dob)
     241  (with-dob-output-data (output-data dob)
     242    (when output-data
     243      (setf (fill-pointer output-data) 0)
     244      (setf (dob-output-data dob) nil
     245            (dob-other-data dob) output-data)
     246      (signal-semaphore (dob-semaphore dob))
     247      output-data)))
     248
     249;; Must be called inside WITH-DOB-DATA
     250(defun dob-queue-output-data (dob &optional force)
     251  (unless (and (not force) (eql 0 (length (dob-data dob))))
     252    (wait-on-semaphore (dob-semaphore dob))
     253    (when (dob-other-data dob)
     254      (setf (dob-output-data dob) (dob-data dob)
     255            (dob-data dob) (dob-other-data dob)
     256            (dob-other-data dob) nil)
     257      t)))
     258
     259;; True return means we overflowed the current buffer
     260(defun dob-push-char (dob char)
     261  (with-dob-data (data dob)
     262    (when (>= (vector-push-extend char data) (dob-flush-limit dob))
     263      (dob-queue-output-data dob t)
     264      t)))
     265
    187266(defclass cocoa-listener-output-stream (fundamental-character-output-stream)
    188   ((lock :initform (make-lock))
    189    (hemlock-view :initarg :hemlock-view)
    190    (data :initform (make-array (1+ $listener-flush-limit)
    191                                :adjustable t :fill-pointer 0
    192                                :element-type 'character))
    193    (limit :initform $listener-flush-limit)))
     267  ((buffer :initform (make-double-output-buffer $listener-flush-limit))
     268   (hemlock-view :initarg :hemlock-view)))
    194269
    195270(defmethod stream-element-type ((stream cocoa-listener-output-stream))
    196   (with-slots (data) stream
    197     (array-element-type data)))
     271  (with-slots (buffer) stream
     272    (array-element-type (dob-data buffer))))
     273
     274(defun display-cocoa-listener-output-buffer (stream)
     275  (with-slots (hemlock-view buffer) stream
     276    (unwind-protect
     277         (with-dob-output-data (data buffer)
     278           (when (> (fill-pointer data) 0)
     279             (append-output hemlock-view data)
     280             (setf (fill-pointer data) 0)))
     281      (dob-return-output-data buffer))))
    198282
    199283(defmethod ccl:stream-write-char ((stream cocoa-listener-output-stream) char)
    200   (with-slots (data lock limit) stream
    201     (when (with-lock-grabbed (lock)
    202             (>= (vector-push-extend char data) limit))
    203       (stream-force-output stream))))
     284  (with-slots (buffer) stream
     285    (when (dob-push-char buffer char)
     286      (queue-for-gui
     287       (lambda () (display-cocoa-listener-output-buffer stream))))))
    204288
    205289;; This isn't really thread safe, but it's not too bad...  I'll take a chance - trying
     
    212296;; TODO: doesn't do the right thing for embedded tabs (in buffer or data)
    213297(defmethod ccl:stream-line-column ((stream cocoa-listener-output-stream))
    214   (with-slots (hemlock-view data lock) stream
    215     (with-lock-grabbed (lock)
     298  (with-slots (hemlock-view buffer) stream
     299    (with-dob-data (data buffer)
    216300      (let* ((n (length data))
    217301             (pos (position #\Newline data :from-end t)))
    218         (if (null pos)
    219           (+ (hemlock-listener-output-mark-column hemlock-view) n)
    220           (- n pos 1))))))
    221 
    222 (defmethod ccl:stream-fresh-line  ((stream cocoa-listener-output-stream))
    223   (with-slots (hemlock-view data lock limit) stream
    224     (when (with-lock-grabbed (lock)
    225             (let ((n (length data)))
    226               (unless (if (= n 0)
    227                         (= (hemlock-listener-output-mark-column hemlock-view) 0)
    228                         (eq (aref data (1- n)) #\Newline))
    229                 (>= (vector-push-extend #\Newline data) limit))))
    230       (stream-force-output stream))))
     302        (if pos
     303            (- n pos 1)
     304            (with-dob-output-data (output-data buffer)
     305              (let* ((output-n (if output-data (length output-data) 0))
     306                     (output-pos (and (> output-n 0)
     307                                      (position #\Newline output-data :from-end t))))
     308                (if output-pos
     309                    (+ n (- output-n output-pos 1))
     310                    (+ (hemlock-listener-output-mark-column hemlock-view)
     311                       n output-n)))))))))
     312
     313(defmethod ccl:stream-fresh-line ((stream cocoa-listener-output-stream))
     314  (unless (eql 0 (ccl:stream-line-column stream))
     315    (ccl:stream-write-char stream #\Newline)))
    231316
    232317(defmethod ccl::stream-finish-output ((stream cocoa-listener-output-stream))
     
    235320(defmethod ccl:stream-force-output ((stream cocoa-listener-output-stream))
    236321  (if (typep *current-process* 'appkit-process)
    237     (with-slots (hemlock-view data lock) stream
    238       (with-lock-grabbed (lock)
    239         (when (> (fill-pointer data) 0)
    240           (append-output hemlock-view data)
    241           (setf (fill-pointer data) 0))))
    242     (with-slots (data) stream
    243       (when (> (fill-pointer data) 0)
    244         (queue-for-gui #'(lambda () (stream-force-output stream)))))))
     322    (display-cocoa-listener-output-buffer stream)
     323    (with-slots (buffer) stream
     324      (with-dob-data (data buffer)
     325        data
     326        (when (dob-queue-output-data buffer)
     327          (queue-for-gui #'(lambda () (stream-force-output stream))))))))
    245328
    246329(defmethod ccl:stream-clear-output ((stream cocoa-listener-output-stream))
    247   (with-slots (data lock) stream
    248     (with-lock-grabbed (lock)
     330  (with-slots (buffer) stream
     331    (with-dob-data (data buffer)
    249332      (setf (fill-pointer data) 0))))
    250333
Note: See TracChangeset for help on using the changeset viewer.