Changeset 15109


Ignore:
Timestamp:
Dec 5, 2011, 12:35:28 AM (8 years ago)
Author:
gz
Message:

Make cmd-. cmd-, and cmd-/ work in remote listeners.

Add some local error handling in swink so a broken connection doesn't lead to a death spiral.

Location:
trunk/source
Files:
7 edited

Legend:

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

    r14654 r15109  
    388388  (#/autorelease self))
    389389
     390
     391(defmethod backtrace-context-backtrace-window ((context vector))
     392  (ccl::bt.dialog context))
     393(defmethod (setf backtrace-context-backtrace-window) (obj (context vector))
     394  (setf (ccl::bt.dialog context) obj))
     395
     396(defmethod backtrace-context-restarts-window ((context vector))
     397  (car (ccl::bt.restarts context)))
     398(defmethod (setf backtrace-context-restarts-window) (obj (context vector))
     399  (setf (car (ccl::bt.restarts context)) obj))
     400
    390401;; Called when current process is about to enter a breakloop
    391 (defmethod ui-object-enter-backtrace-context ((app ns:ns-application)
    392                                               context)
    393   (let* ((proc *current-process*))
    394     (when (typep proc 'cocoa-listener-process)
    395       (push context (cocoa-listener-process-backtrace-contexts proc)))))
    396 
    397 (defmethod ui-object-exit-backtrace-context ((app ns:ns-application)
    398                                               context)
    399   (let* ((proc *current-process*))
    400     (when (typep proc 'cocoa-listener-process)
    401       (when (eq context (car (cocoa-listener-process-backtrace-contexts proc)))
    402         (setf (cocoa-listener-process-backtrace-contexts proc)
    403               (cdr (cocoa-listener-process-backtrace-contexts proc)))
    404         (let* ((btwindow (prog1 (ccl::bt.dialog context)
    405                            (setf (ccl::bt.dialog context) nil)))
    406                (restartswindow
    407                 (prog1 (car (ccl::bt.restarts context))
    408                            (setf (ccl::bt.restarts context) nil))))
    409           (when btwindow
    410             (#/performSelectorOnMainThread:withObject:waitUntilDone: btwindow (@selector #/close)  +null-ptr+ t))
    411           (when restartswindow
    412             (#/performSelectorOnMainThread:withObject:waitUntilDone: restartswindow (@selector #/close)  +null-ptr+ t)))))))
    413 
    414  
     402(defmethod ui-object-enter-backtrace-context ((app ns:ns-application) context)
     403  (enter-backtrace-context *current-process* context))
     404
     405(defmethod ui-object-exit-backtrace-context ((app ns:ns-application) context)
     406  (exit-backtrace-context *current-process* context))
     407
     408(defmethod enter-backtrace-context ((process process) context)
     409  (declare (ignore context)))
     410
     411(defmethod exit-backtrace-context ((process process) context)
     412  (declare (ignore context)))
     413
     414(defmethod enter-backtrace-context ((process cocoa-listener-process) context)
     415  (push context (cocoa-listener-process-backtrace-contexts process)))
     416
     417(defmethod exit-backtrace-context ((process cocoa-listener-process) context)
     418  (when (eq context (car (cocoa-listener-process-backtrace-contexts process)))
     419    (pop (cocoa-listener-process-backtrace-contexts process))
     420    (let ((w (backtrace-context-backtrace-window context)))
     421      (when w
     422        (setf (backtrace-context-backtrace-window context) nil)
     423        (cocoa-close w t)))
     424    (let ((w (backtrace-context-restarts-window context)))
     425      (when w
     426        (setf (backtrace-context-restarts-window context) nil)
     427        (cocoa-close w t)))))
     428
     429
    415430(objc:defmethod (#/validateToolbarItem: #>BOOL) ((self backtrace-window-controller)
    416431                                                 toolbar-item)
  • trunk/source/cocoa-ide/cocoa-listener.lisp

    r15100 r15109  
    282282                         (when doc
    283283                           (setf (hemlock-document-process doc) nil) ;; so #/close doesn't kill it.
    284                            (#/performSelectorOnMainThread:withObject:waitUntilDone:
    285                             doc
    286                             (@selector #/close)
    287                             +null-ptr+
    288                             nil)))))
     284                           (cocoa-close doc nil)))))
    289285                 hi:*buffer-list*))
    290286     :initial-function
     
    622618          (process-interrupt process #'invoke-restart-interactively 'continue))))))
    623619
    624 
    625 
    626 
    627 
    628 
    629620;;; Menu item action validation.  It'd be nice if we could distribute this a
    630621;;; bit better, so that this method didn't have to change whenever a new
     
    649640              t
    650641              (and context
    651                    (find 'continue (cdr (ccl::bt.restarts context))
    652                          :key #'restart-name)))))
     642                   (ccl::backtrace-context-continuable-p context)))))
    653643          ((or (eql action (@selector #/backtrace:))
    654644               (eql action (@selector #/exitBreak:))
     
    955945                                       (format output-stream "~%~%{process ~s exiting}~%" *current-process*))
    956946                                      (t
    957                                        (#/performSelectorOnMainThread:withObject:waitUntilDone:
    958                                         w
    959                                         (@selector #/close)
    960                                         +null-ptr+
    961                                         t)))
     947                                       (cocoa-close w t)))
    962948                                (close input-stream)
    963949                                (close output-stream)))))))
  • trunk/source/cocoa-ide/cocoa-remote-lisp.lisp

    r15105 r15109  
    147147                       (push package-name (cdr env)))
    148148                     (return (values string env)))))))))))
     149
     150(defclass cocoa-remote-backtrace-context (ccl::remote-backtrace-context)
     151  ((backtrace-window :initform nil :accessor backtrace-context-backtrace-window)
     152   (restarts-window :initform nil :accessor backtrace-context-restarts-window)))
     153
     154(defmethod ccl::remote-context-class ((application cocoa-application)) 'cocoa-remote-backtrace-context)
  • trunk/source/cocoa-ide/cocoa-utils.lisp

    r15064 r15109  
    174174    (when wptr (hemlock-view wptr))))
    175175
     176(defun cocoa-close (object &optional wait-p)
     177  (if (eq *current-process* ccl::*initial-process*)
     178    (#/close object)
     179    (#/performSelectorOnMainThread:withObject:waitUntilDone:
     180     object
     181     (@selector #/close)
     182     +null-ptr+
     183     wait-p)))
     184
    176185;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    177186;;
  • trunk/source/level-1/l1-readloop-lds.lisp

    r15062 r15109  
    633633    ))
    634634
    635 (declaim (notinline select-backtrace))
    636 
    637635(defmacro new-backtrace-info (dialog youngest oldest tcr condition current fake db-link level)
    638636  (let* ((cond (gensym)))
    639637  `(let* ((,cond ,condition))
    640638    (vector ,dialog ,youngest ,oldest ,tcr (cons nil (compute-restarts ,cond)) (%catch-top ,tcr) ,cond ,current ,fake ,db-link ,level))))
     639
     640(defmethod backtrace-context-continuable-p ((context vector))
     641  (not (null (find 'continue (cdr (bt.restarts context)) :key #'restart-name))))
     642
     643(declaim (notinline select-backtrace))
    641644
    642645(defun select-backtrace ()
     
    678681         (*read-suppress* nil)
    679682         (*print-readably* nil)
    680          (*default-integer-command* `(:c 0 ,(1- (length (compute-restarts condition)))))
    681          (context (new-backtrace-info nil
     683         (context (new-backtrace-info nil
    682684                                      frame-pointer
    683685                                      (if *backtrace-contexts*
     
    695697                                      (db-link)
    696698                                      (1+ *break-level*)))
     699         (*default-integer-command* `(:c 0 ,(1- (length (cdr (bt.restarts context))))))
    697700         (*backtrace-contexts* (cons context *backtrace-contexts*)))
    698701    (with-terminal-input
  • trunk/source/lib/swink.lisp

    r15105 r15109  
    233233                           (prin1-to-string sexp)))))
    234234
    235 (defun send-event (target event)
    236   (let ((conn (etypecase target
    237                 (connection target)
    238                 (thread (thread-connection target)))))
    239     (log-event "Send-event ~s to ~s" event target)
    240     (write-sexp conn (cons (thread-id target) (marshall-event conn event)))))
     235(defun send-event (target event &key ignore-errors)
     236  (let* ((conn (etypecase target
     237                 (connection target)
     238                 (thread (thread-connection target))))
     239         (encoded-event (marshall-event conn event)))
     240    (log-event "Send-event ~s to ~a" encoded-event (if (eq target conn)
     241                                                       "connection"
     242                                                       (princ-to-string (thread-id target))))
     243    (handler-bind ((stream-error (lambda (c)
     244                                   (when (eq (stream-error-stream c) (connection-control-stream conn))
     245                                     (unless ignore-errors
     246                                       (log-event "send-event error: ~a" c)
     247                                       (close-connection conn))
     248                                     (return-from send-event)))))
     249      (write-sexp conn (cons (thread-id target) encoded-event)))))
     250
     251(defun send-event-if-open (target event)
     252  (send-event target event :ignore-errors t))
    241253
    242254;;This assumes only one process reads from the command stream or the read-buffer, so don't need locking.
    243255(defun read-sexp (conn)
    244   ;; Returns the sexp or (:end-connection)
     256  ;; Returns the sexp or :end-connection event
    245257  (let* ((stream (connection-control-stream conn))
    246258         (buffer (connection-buffer conn))
     
    249261                                   ;; This includes parse errors as well as i/o errors
    250262                                   (when (eql (stream-error-stream c) stream)
    251                                      (log-event "Error: ~a" c)
     263                                     (log-event "read-sexp error: ~a" c)
     264                                     ; (setf (connection-io-error conn) t)
    252265                                     (return-from read-sexp
    253266                                       `(nil . (:end-connection ,c)))))))
     
    456469          (process-run-function (format nil "swink-event-loop@~s" (local-port stream))
    457470            (lambda ()
    458               (with-simple-restart (close-connection "Exit server")
    459                 (setf (connection-control-process conn) *current-process*)
    460                 (unwind-protect
    461                     (handler-bind ((error (lambda (c)
    462                                             (log-event "Error: ~a" c)
    463                                             (invoke-restart 'close-connection))))
    464                       (when startup-signal (signal-semaphore startup-signal))
    465                       (server-event-loop conn))
    466                   (control-process-cleanup conn))))))
     471              (unwind-protect
     472                   (with-simple-restart (close-connection "Exit server")
     473                     (setf (connection-control-process conn) *current-process*)
     474                     (handler-bind ((error (lambda (c)
     475                                             (log-event "Error: ~a" c)
     476                                             (invoke-restart 'close-connection))))
     477                       (when startup-signal (signal-semaphore startup-signal))
     478                       (server-event-loop conn)))
     479                (control-process-cleanup conn)))))
    467480    (wait-on-semaphore startup-signal)
    468481    (with-swink-lock () (push conn *server-connections*))
     
    477490    (setq *server-connections* (delq conn *server-connections*))
    478491    (when (null *server-connections*) (use-swink-globally nil)))
    479 
    480   (loop for thread in (with-connection-lock (conn)
    481                         (copy-list (connection-threads conn)))
    482         do (process-interrupt (thread-process thread) 'invoke-restart-if-active 'exit-repl))
    483 
     492  (flet ((exit-repl ()
     493           ;; While exiting, threads may attempt to write to the connection.  That's good, if the
     494           ;; connection is still alive and we're attempting an orderly exit.  Don't go into a spiral
     495           ;; if the connection is dead.  Once we get any kind of error, just punt.
     496           (log-event "Start exit-repl in ~s" (thread-id *current-process*))
     497           (handler-case  (invoke-restart-if-active 'exit-repl)
     498             (error (c) (log-event "Exit repl error ~a in ~s" c (thread-id *current-process*))))))
     499    (loop for thread in (with-connection-lock (conn)
     500                          (copy-list (connection-threads conn)))
     501       do (process-interrupt (thread-process thread) #'exit-repl)))
    484502  (let* ((timeout 0.05)
    485503         (end (+ (get-internal-real-time) (* timeout internal-time-units-per-second))))
     
    507525  (with-simple-restart (abort-read "Abort reading")
    508526    (let* ((conn (thread-connection thread))
     527           (returned nil)
    509528           (returned-string nil)
    510529           (return-signal (make-semaphore))
     
    512531      (force-output (thread-io thread))
    513532      (unwind-protect
    514           (progn
    515             (setq tag (tag-callback conn (lambda (string)
    516                                            (setq returned-string string)
    517                                            (signal-semaphore return-signal))))
    518             (send-event conn `(:read-string ,thread ,tag))
    519 
    520             (let ((current-thread (find-thread conn *current-process* :key #'thread-process)))
    521               (with-interrupts-enabled
    522                   (if current-thread ;; we're running in a repl, process events while waiting.
    523                     (with-event-handling (current-thread)
    524                       (wait-on-semaphore return-signal))
    525                     (wait-on-semaphore return-signal))))
    526             returned-string)
    527         (unless returned-string
    528           ;; Something interrupted us and aborted, tell client to stop reading as well.
    529           (send-event conn `(:abort-read ,thread ,tag))
    530           ;; ignore response if sent anyway.
    531           (when tag
    532             (remove-tag conn tag)))))))
     533           (progn
     534             (setq tag (tag-callback conn (lambda (string)
     535                                            (setq returned t)
     536                                            (setq returned-string string)
     537                                            (signal-semaphore return-signal))))
     538             (send-event conn `(:read-string ,thread ,tag))
     539             (let ((current-thread (find-thread conn *current-process* :key #'thread-process)))
     540               (with-interrupts-enabled
     541                (if current-thread ;; we're running in a repl, process events while waiting.
     542                     (with-event-handling (current-thread)
     543                       (wait-on-semaphore return-signal))
     544                     (wait-on-semaphore return-signal))))
     545             returned-string)
     546        (unless returned
     547          ;; Something interrupted us and aborted
     548          ;; ignore response if sent
     549          (when tag (remove-tag conn tag))
     550          ;; tell client to stop reading as well.
     551          (send-event-if-open conn `(:abort-read ,thread ,tag)))))))
    533552
    534553
    535554(defmethod send-remote-user-output ((thread server-thread) string start end)
    536   (send-event (thread-connection thread) `(:write-string ,thread ,(string-segment string start end))))
     555  (let ((conn (thread-connection thread)))
     556    (send-event conn `(:write-string ,thread ,(string-segment string start end)))))
    537557
    538558(defun swink-repl (conn break-level toplevel-loop)
     
    560580            (funcall toplevel-loop))
    561581        ;; Do we need this?  We've already exited from the outermost level...
    562         (send-event conn `(:exit-repl))
     582        (send-event-if-open conn `(:exit-repl))
    563583        (ccl:remove-auto-flush-stream out)
    564584        (setf (ccl::process-ui-object *current-process*) ui-object)
     
    600620         (*loading-file-source-file* nil)
    601621         (ccl::*loading-toplevel-location* nil)
     622         (context (find break-level ccl::*backtrace-contexts* :key (lambda (bt) (ccl::bt.break-level bt))))
    602623         *** ** * +++ ++ + /// // / -)
     624    (when context
     625      ;; TODO: neither :GO nor cmd-/ pay attention to the break condition, whereas bt.restarts does...
     626      (let ((continuable (ccl::backtrace-context-continuable-p context)))
     627        (send-event conn `(:enter-break ,break-level ,(and continuable t)))))
     628
    603629    (flet ((repl-until-abort ()
    604              (send-event conn `(:read-loop ,break-level))
    605630             (restart-case
    606631                 (catch :abort
     
    620645            (repl-until-abort)
    621646            (clear-input)
    622             (terpri))
    623         (send-event conn `(:debug-return ,break-level))))))
     647            (terpri)
     648            (send-event conn `(:read-loop ,break-level)))
     649        (send-event-if-open conn `(:debug-return ,break-level))))))
    624650
    625651(defmacro with-return-values ((conn remote-tag &body abort-forms) &body body)
     
    632658                                             (prog1 (progn ,@body) (setq ,ok-var t))
    633659                                           (unless ,ok-var
    634                                              (send-event ,conn-var `(:cancel-return ,,tag-var))
     660                                             (send-event-if-open ,conn-var `(:cancel-return ,,tag-var))
    635661                                             ,@abort-forms)))))))
    636662
     
    736762(let (using-swink-globally select-hook debugger-hook break-hook ui-object)
    737763  (defun use-swink-globally (yes-or-no)
     764    (log-event "use-swink-globally: ~s" yes-or-no)
    738765    (if yes-or-no
    739766      (unless using-swink-globally
     
    798825  (make-instance 'swink-output-stream :thread thread :output-fn output-fn))
    799826
     827(defun output-stream-output (stream string start end)
     828  (with-slots (output-fn thread) stream
     829    (let ((conn (thread-connection thread)))
     830      (handler-bind ((stream-error (lambda (c)
     831                                     (when (eql (stream-error-stream c)
     832                                                (connection-control-stream conn))
     833                                       (with-slots (ccl::stream) c
     834                                         (setf ccl::stream stream))))))
     835        (funcall output-fn thread string start end)))))
     836
     837
    800838(defmethod flush-buffer ((stream swink-output-stream)) ;; called with lock hold
    801   (with-slots (output-fn buffer index) stream
     839  (with-slots (buffer index) stream
    802840    (unless (eql index 0)
    803       (funcall output-fn (stream-thread stream) buffer 0 index)
     841      (output-stream-output stream buffer 0 index)
    804842      (setf index 0))))
    805843
     
    827865             (replace buffer string :start1 index :start2 start :end2 end)
    828866             (incf index count))
    829             (t (with-slots (output-fn) stream
    830                  (funcall output-fn (stream-thread stream) string start end))))
     867            (t (output-stream-output stream string start end)))
    831868      (let ((last-newline (position #\newline string :from-end t
    832869                                    :start start :end end)))
     
    849886  (make-instance 'swink-input-stream :thread thread :input-fn input-fn))
    850887
     888(defun input-stream-input (stream)
     889  (with-slots (input-fn thread) stream
     890    (let ((conn (thread-connection thread)))
     891      (handler-bind ((stream-error (lambda (c)
     892                                     (when (eql (stream-error-stream c)
     893                                                (connection-control-stream conn))
     894                                       (with-slots (ccl::stream) c
     895                                         (setf ccl::stream stream))))))
     896        (funcall input-fn thread)))))
     897
    851898(defmethod stream-read-char ((stream swink-input-stream))
    852   (with-swink-stream (input-fn buffer index column) stream
     899  (with-swink-stream (buffer index column) stream
    853900    (unless (< index (length buffer))
    854       (let ((string (funcall input-fn (stream-thread stream))))
     901      (let ((string (input-stream-input stream)))
    855902        (cond ((eql (length string) 0)
    856903               (return-from stream-read-char :eof))
  • trunk/source/library/remote-lisp.lisp

    r15105 r15109  
    175175      (apply #'values return-values))))
    176176
     177(defclass remote-backtrace-context ()
     178  ((process :initform *current-process* :reader backtrace-context-process)
     179   (break-level :initarg :break-level :reader backtrace-context-break-level)
     180   (continuable-p :initarg :continuable-p :reader backtrace-context-continuable-p)))
     181
     182(defmethod remote-context-class ((application application)) 'remote-backtrace-context)
     183
    177184(defmethod swink:handle-event ((rthread remote-lisp-thread) event)
    178185  (assert (eq (swink:thread-control-process rthread) *current-process*))
     
    185192    ((:write-string string)
    186193     (write-string string))
    187     ((:read-loop level) ;; enter (or re-enter after an abort) a break loop.
    188      (when (eql level *break-level*) ;; restart at same level, aborted current expression.
    189        (invoke-restart 'debug-restart level))
    190      (unless (eql level (1+ *break-level*))
     194    ((:read-loop level)
     195     (unless (eql level *break-level*)
    191196       (warn ":READ-LOOP level confusion got ~s expected ~s" level (1+ *break-level*)))
     197     (invoke-restart 'debug-restart level)) ;; restart at same level, aborted current expression.
     198    ((:enter-break level continuablep)
     199     (unless (or (eql level 0) (eql level (1+ *break-level*)))
     200       (warn ":ENTER-BREAK level confusion got ~s expected ~s" level (1+ *break-level*)))
    192201     ;(format t "~&Error: ~a" condition-text)
    193202     ;(when *show-restarts-on-break*
     
    196205     ;    do (format t "~&~a ~a" name description))
    197206     ;  (fresh-line))
    198      (rlisp-read-loop rthread :break-level level))
     207     (let ((rcontext (make-instance (remote-context-class *application*)
     208                       :break-level level
     209                       :continuable-p continuablep)))
     210       (unwind-protect
     211           (progn
     212             (application-ui-operation *application* :enter-backtrace-context rcontext)
     213             (rlisp-read-loop rthread :break-level level))
     214         (application-ui-operation *application* :exit-backtrace-context rcontext))))
    199215    ((:debug-return level) ;; return from level LEVEL read loop
    200216     (invoke-restart 'debug-return level))))
Note: See TracChangeset for help on using the changeset viewer.