Changeset 15201


Ignore:
Timestamp:
Feb 8, 2012, 10:45:33 PM (8 years ago)
Author:
rme
Message:

Implement execute-for-gui in a slightly different way.

Instead of performSelectorOnMainThread:withObject:waitUntilDone:,
we always enqueue a user-defined event which tells the event
loop to call a designated lisp function. We do the process
synchronization in lisp rather than relying on whatever Cocoa
uses internally.

File:
1 edited

Legend:

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

    r15109 r15201  
    212212           ,@body)))))
    213213
    214 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    215 ;;
    216 ;; utilities for executing in the cocoa event thread
    217 
    218 (defstatic *cocoa-thread-arg-id-map* (make-id-map))
    219 
    220 ;; This is for debugging, it's preserved across queue-for-gui and bound
    221 ;; so it can be seen in backtraces.
    222 (defvar *invoking-event-context* "unknown")
    223 (defvar *invoking-event-process* nil)
    224 
    225 (defun register-cocoa-thread-function (thunk result-handler context)
    226   (assign-id-map-id *cocoa-thread-arg-id-map* (list* thunk
    227                                                      result-handler
    228                                                      (or context *invoking-event-context*)
    229                                                      *current-process*)))
    230 
    231 (objc:defmethod (#/invokeLispFunction: :void) ((self ns:ns-application) id)
    232   (invoke-lisp-function self id))
    233 
    234 (defmethod invoke-lisp-function ((self ns:ns-application) id)
    235   (destructuring-bind (thunk result-handler context . invoking-process)
    236                       (id-map-free-object *cocoa-thread-arg-id-map* (if (numberp id) id (#/longValue id)))
    237     (handle-invoking-lisp-function thunk result-handler context invoking-process)))
    238 
    239 (defun execute-in-gui (thunk &key context)
    240   "Execute thunk in the main cocoa thread, return whatever values it returns"
    241   (if (typep *current-process* 'appkit-process)
    242     (handle-invoking-lisp-function thunk nil context)
    243     (if (or (not *nsapp*) (not (#/isRunning *nsapp*)))
    244       (error "cocoa thread not available")
    245       (with-autorelease-pool
    246           (let* ((return-values nil)
    247                  (result-handler #'(lambda (&rest values) (setq return-values values)))
    248                  (arg (make-instance 'ns:ns-number
    249                                      :with-long (register-cocoa-thread-function thunk result-handler context))))
    250             (#/performSelectorOnMainThread:withObject:waitUntilDone:
    251              *nsapp*
    252              (@selector #/invokeLispFunction:)
    253              arg
    254              t)
    255             (#/release arg)
    256             (apply #'values return-values))))))
    257 
    258 
    259 (defconstant $lisp-function-event-subtype 17)
     214
     215;;; Usually, one does not sublass NSApplication.  We do it mainly
     216;;; because we use a user-defined event to signal the event loop to
     217;;; invoke a lisp function, and the only way I know of to respond to a
     218;;; user-defined event is to override -[NSApplication sendEvent:].
    260219
    261220(defclass lisp-application (ns:ns-application)
     
    263222     (console :foreign-type :id :accessor console))
    264223  (:metaclass ns:+ns-object))
     224
     225(defconstant $lisp-function-event-subtype 17)
     226
     227(objc:defmethod (#/sendEvent: :void) ((self lisp-application) e)
     228  (declare (dynamic-extent self e))
     229  (if (and (eql (#/type e) #$NSApplicationDefined)
     230           (eql (#/subtype e) $lisp-function-event-subtype))
     231    (deregister-and-invoke-epf-id (#/data1 e))
     232    (call-next-method e)))
     233
     234;;; Large parts of Cocoa are not thread safe.  Many calls must be made
     235;;; only on the "main" (i.e., the initial) thread.  As mentioned
     236;;; above, we use a user-defined event to provide a way for this to
     237;;; happen.
     238;;;
     239;;; For historical reasons, CCL calls threads "processes".  So,
     240;;; instead of speaking of the "main thread" or "event thread", we
     241;;; will use the term "event process".  Note that in the following
     242;;; functions, "epf" means "event process function".
     243
     244(defstatic *epf-id-map* (make-id-map))
     245
     246(defun register-epf (f)
     247  (assign-id-map-id *epf-id-map* f))
     248
     249(defun deregister-and-invoke-epf-id (id)
     250  (let ((f (id-map-free-object *epf-id-map* id)))
     251    (funcall f)))
     252
     253(defun queue-for-event-process (f &key at-start)
     254  "Place a special event on the event process's event queue that will
     255cause the zero-argument function F to be invoked when the event is
     256processed.  Any return values from F are ignored.  If AT-START is
     257true, the event will be placed at the front of the event queue."
     258  (if (and *nsapp* (#/isRunning *nsapp*))
     259    ;; It's possible that the event loop will go away after we check,
     260    ;; but in that case the application is probably in the process of
     261    ;; exiting.
     262    (let ((id (register-epf f)))
     263      (rletz ((pt #>NSPoint))
     264        (objc:with-autorelease-pool
     265          (with-macptrs ((e (#/otherEventWithType:location:modifierFlags:timestamp:windowNumber:context:subtype:data1:data2:
     266                             ns:ns-event
     267                             #$NSApplicationDefined ;type
     268                             pt                     ;location
     269                             0                      ;modifierFlags
     270                             0d0                    ;timestamp
     271                             0                      ;windowNumber
     272                             +null-ptr+             ;context
     273                             $lisp-function-event-subtype ;subtype
     274                             id                     ;data1
     275                             0)))                   ;data2
     276              ;; It's explicitly OK to do this from any thread.
     277              (#/postEvent:atStart: *nsapp* e (if at-start #$YES #$NO))))))
     278    (error "The event process does not seem to be running an event loop")))
     279
     280(defun epf-semaphore ()
     281  (or (getf (process-plist *current-process*) :epf-semaphore)
     282      (setf (getf (process-plist *current-process*) :epf-semaphore)
     283            (make-semaphore))))
     284
     285(defun call-in-event-process (f)
     286  "Arrange to invoke the zero-argument function F in the event
     287process, and return whatever values F returns.  If called from the
     288event process, invoke F immediately.  Otherwise, place a special event
     289at the front of the event process's queue, and block until the event
     290process has processed that event and invoked F."
     291  (if (eq *current-process* ccl::*initial-process*)
     292    (funcall f)
     293    (let ((return-values nil)
     294          (done (epf-semaphore)))
     295      (flet ((epf-wrapper ()
     296               (unwind-protect
     297                    (setq return-values (multiple-value-list (funcall f)))
     298                 (signal-semaphore done))))
     299        (declare (dynamic-extent #'epf-wrapper)) ;careful with this
     300        (queue-for-event-process #'epf-wrapper :at-start t)
     301        (wait-on-semaphore done nil "epf semaphore wait")
     302        (apply #'values return-values)))))
     303
     304;;; previously used names
     305(defun execute-in-gui (thunk &key context)
     306  (declare (ignore context))
     307  (call-in-event-process thunk))
     308
     309(defun queue-for-gui (thunk &key result-handler context at-start)
     310  (declare (ignore result-handler context))
     311  (queue-for-event-process thunk :at-start at-start))
     312
    265313
    266314(defmethod current-event-modifier-p (modifier-mask)
     
    271319(defun current-event-command-key-p ()
    272320  (current-event-modifier-p #$NSCommandKeyMask))
    273 
    274 ;;; I'm not sure if there's another way to recognize events whose
    275 ;;; type is #$NSApplicationDefined.
    276 (objc:defmethod (#/sendEvent: :void) ((self lisp-application) e)
    277   (declare (dynamic-extent self e))
    278   (if (and (eql (#/type e) #$NSApplicationDefined)
    279            (eql (#/subtype e) $lisp-function-event-subtype))
    280     (invoke-lisp-function self (#/data1 e))
    281     (call-next-method e)))
    282 
    283 ;; This queues an event rather than just doing performSelectorOnMainThread, so that the
    284 ;; action is deferred until the event thread is idle.
    285 (defun queue-for-gui (thunk &key result-handler context at-start)
    286   "Queue thunk for execution in main cocoa thread and return immediately."
    287   (execute-in-gui
    288    #'(lambda ()
    289        (let* ((e (#/otherEventWithType:location:modifierFlags:timestamp:windowNumber:context:subtype:data1:data2:
    290                   ns:ns-event
    291                   #$NSApplicationDefined
    292                   (ns:make-ns-point 0 0)
    293                   0
    294                   0.0d0
    295                   0
    296                   +null-ptr+
    297                   $lisp-function-event-subtype
    298                   (register-cocoa-thread-function thunk result-handler context)
    299                   0)))
    300          ;(#/retain e)
    301          (#/postEvent:atStart: *nsapp* e (not (null at-start)))))))
    302 
    303 (defun handle-invoking-lisp-function (thunk result-handler context &optional (invoking-process *current-process*))
    304   ;; TODO: the point is to execute result-handler in the original process, but this will do for now.
    305   (let* ((*invoking-event-process* invoking-process)
    306          (*invoking-event-context* context))
    307     (if result-handler
    308       (multiple-value-call result-handler (funcall thunk))
    309       (funcall thunk))))
    310321
    311322(defun choose-directory-dialog ()
Note: See TracChangeset for help on using the changeset viewer.