Changeset 15065


Ignore:
Timestamp:
Nov 10, 2011, 8:53:17 PM (8 years ago)
Author:
gz
Message:

Support for recursive readloops in remote listener. There are stll some problems with prompt printing but the basic mechanisms work

Location:
trunk/source
Files:
3 edited

Legend:

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

    r15020 r15065  
    106106          (return (values (call-next-method) nil t)))
    107107        (wait-on-semaphore queue-semaphore nil "Toplevel Read")
    108         (let ((val (with-lock-grabbed (queue-lock) (pop queue))))
    109           (cond ((stringp val)
    110                  (assert (timed-wait-on-semaphore text-semaphore 0) () "text/queue mismatch!")
    111                  (setq cur-string val cur-string-pos 0))
    112                 (t
    113                  (destructuring-bind (string package-name pathname offset) val
    114                    ;; This env is used both for read and eval.
    115                    (let ((env (cons '(*loading-file-source-file* *load-pathname* *load-truename* *loading-toplevel-location*
    116                                       ccl::*nx-source-note-map*)
    117                                     (list pathname pathname (and pathname (or (probe-file pathname) pathname)) nil
    118                                           source-map))))
    119                      (when package-name
    120                        (push '*package* (car env))
    121                        (push (ccl::pkg-arg package-name) (cdr env)))
    122                      (if source-map
    123                        (clrhash source-map)
    124                        (setf source-map (make-hash-table :test 'eq :shared nil)))
    125                      (setf cur-sstream (make-string-input-stream string) cur-env env cur-offset offset))))))))))
     108        (without-interrupts
     109         (let ((val (with-lock-grabbed (queue-lock) (pop queue))))
     110           (cond ((stringp val)
     111                  (assert (timed-wait-on-semaphore text-semaphore 0) () "text/queue mismatch!")
     112                  (setq cur-string val cur-string-pos 0))
     113                 (val
     114                  (destructuring-bind (string package-name pathname offset) val
     115                    ;; This env is used both for read and eval.
     116                    (let ((env (cons '(*loading-file-source-file* *load-pathname* *load-truename* *loading-toplevel-location*
     117                                                                  ccl::*nx-source-note-map*)
     118                                     (list pathname pathname (and pathname (or (probe-file pathname) pathname)) nil
     119                                           source-map))))
     120                      (when package-name
     121                        (push '*package* (car env))
     122                        (push (ccl::pkg-arg package-name) (cdr env)))
     123                      (if source-map
     124                        (clrhash source-map)
     125                        (setf source-map (make-hash-table :test 'eq :shared nil)))
     126                      (setf cur-sstream (make-string-input-stream string) cur-env env cur-offset offset)))))))))))
    126127
    127128(defmethod enqueue-toplevel-form ((stream cocoa-listener-input-stream) string &key package-name pathname offset)
     
    445446    (setq *next-listener-x-pos* nil
    446447          *next-listener-y-pos* nil))
    447   (let* ((p (shiftf (hemlock-document-process self) nil)))
     448  (let* ((p (hemlock-document-process self)))
    448449    (when p
     450      (setf (hemlock-document-process self) nil)
    449451      (process-kill p)))
    450452  (call-next-method))
  • trunk/source/cocoa-ide/cocoa-remote-lisp.lisp

    r15031 r15065  
    2323#+debug ;; For testing, start a ccl running swank, then call this in the ide.
    2424(defun cl-user::rlisp-test (port &optional host)
    25   (declare (special conn thread))
    26   (when (boundp 'conn) (close conn))
    27   (setq conn (ccl::connect-to-swank (or host "localhost") port))
    28   (setq thread (ccl::make-rrepl-thread conn "IDE Listener"))
    29   (let* ((old ccl::*inhibit-greeting*)
    30          (listener (unwind-protect
    31                        (progn
    32                          (setq ccl::*inhibit-greeting* t)
    33                          (new-listener))
    34                      (setq ccl::*inhibit-greeting* old))))
    35     (connect-listener-to-remote listener thread)))
     25  (declare (special cl-user::conn))
     26  (when (boundp 'cl-user::conn) (close cl-user::conn))
     27  (setq cl-user::conn (ccl::connect-to-swank (or host "localhost") port))
     28  (ccl::make-rrepl-thread cl-user::conn "IDE Listener"))
     29
     30(defclass remote-listener-hemlock-view (hi:hemlock-view)
     31  ((remote-thread :initarg :remote-thread :accessor listener-remote-thread)))
     32
     33;; Kludge city
     34(defun create-remote-listener-view (rthread)
     35  (let* ((listener (new-listener :inhibit-greeting t))
     36         (doc (hi::buffer-document (hi:hemlock-view-buffer listener)))
     37         (process (or (hemlock-document-process doc)
     38                      (error "Not a listener: ~s" listener))))
     39    (setf (hemlock-document-process doc) nil) ;; so killing the process doesn't close the window
     40    (process-kill process)
     41    (change-class listener 'remote-listener-hemlock-view :remote-thread rthread)
     42    listener))
     43
     44(defmethod activate-rlisp-listener ((view remote-listener-hemlock-view))
     45  (execute-in-gui
     46   (lambda ()
     47     (#/makeKeyAndOrderFront: (#/window (hi::hemlock-view-pane view)) (%null-ptr)))))
    3648
    3749
    38 (defclass remote-cocoa-listener-process (cocoa-listener-process)
    39   ((remote-thread :initarg :remote-thread :reader process-remote-thread)))
     50;; TODO: Do something to show that remote is not active
     51(defmethod deactivate-rlisp-listener ((view remote-listener-hemlock-view))
     52  nil)
    4053
    41 ;; in the future, there should be something like a "New Remote Listener" command
    42 ;; which should pass relevant info through to new-cocoa-listener-process.
    43 ;; But this will do for testing: take an existing normal listener and convert it.
    44 (defmethod connect-listener-to-remote (object rthread)
    45   (let ((view (hemlock-view object)))
    46     (connect-listener-to-remote (or view (require-type object 'hi:hemlock-view)) rthread)))
     54(defun listener-view-for-remote-thread (rthread &key activate)
     55  (let ((view (first-window-satisfying-predicate (lambda (wptr)
     56                                                   (let ((view (hemlock-view wptr)))
     57                                                     (and (typep view 'remote-listener-hemlock-view)
     58                                                          (eql (listener-remote-thread view) rthread)))))))
     59    (when (and activate view)
     60      (activate-rlisp-listener view))
     61    view))
    4762
    48 (defmethod connect-listener-to-remote ((view hi:hemlock-view) (rthread ccl::remote-lisp-thread))
    49   (let* ((doc (hi::buffer-document (hi:hemlock-view-buffer view)))
    50          (process (or (hemlock-document-process doc)
    51                       (error "Not a listener: ~s" view)))
    52          (name (process-name process))
    53          (window (cocoa-listener-process-window process)))
    54     (when (eq process *current-process*)
    55       (error "Cannot connect current listener"))
    56     (setf (hemlock-document-process doc) nil) ;; so killing the process doesn't close the window
    57     (process-kill process)
    58     (let ((pos (search " [Remote " name :from-end t)))
    59       (when pos
    60         (setq name (subseq name 0 pos))))
     63(defmethod ccl::create-rlisp-listener ((app cocoa-application) (rthread ccl::remote-lisp-thread))
     64  (let* ((view (or (listener-view-for-remote-thread rthread :activate t)
     65                   (create-remote-listener-view rthread)))
     66         (buffer (hi:hemlock-view-buffer view))
     67         (doc (hi::buffer-document buffer))
     68         (name (hi:buffer-name buffer)))
     69    (assert (null (hemlock-document-process doc)))
    6170    (setf (hemlock-document-process doc)
     71          ;; TODO: hemlock puts the local process number on modeline, which is uninteresting.
     72          ;; TODO: change process name when change buffer name.
    6273          (new-cocoa-listener-process (format nil "~a [Remote ~a(~a)]"
    63                                               name (ccl::rlisp-host-description rthread) (ccl::rlisp-thread-id rthread))
    64                                       window
     74                                              name
     75                                              (ccl::rlisp-host-description rthread)
     76                                              (ccl::rlisp-thread-id rthread))
     77                                      (#/window (hi::hemlock-view-pane view))
    6578                                      :class 'remote-cocoa-listener-process
    6679                                      :initargs  `(:remote-thread ,rthread)
     
    6982                                        (setf (hemlock-document-process doc) *current-process*)
    7083                                        (ccl::remote-listener-function rthread))))))
     84
     85(defmethod ui-object-do-operation ((ui ns:ns-application) (op (eql :deactivate-rlisp-listener)) rthread)
     86  ;; Do something to show that the listener is not active
     87  (let ((view (listener-view-for-remote-thread rthread)))
     88    (when view
     89      (deactivate-rlisp-listener view))))
     90
     91(defclass remote-cocoa-listener-process (cocoa-listener-process)
     92  ((remote-thread :initarg :remote-thread :reader process-remote-thread)))
     93
     94(defmethod process-kill :before ((process remote-cocoa-listener-process))
     95  (let* ((wptr (cocoa-listener-process-window process))
     96         (view (hemlock-view wptr)))
     97    (when view
     98      ;; don't close the window just because kill process.
     99      (let ((doc (#/document wptr)))
     100        (when (and doc (not (%null-ptr-p doc)))
     101          (setf (hemlock-document-process doc) nil)))
     102      (deactivate-rlisp-listener view))))
     103
     104;; Cmd-, calls this
     105(defmethod ccl::force-break-in-listener ((p remote-cocoa-listener-process))
     106  ;; Cause the other side to enter a breakloop, which it will inform us of when it happens.
     107  (ccl::rlisp/interrupt (process-remote-thread p)))
    71108
    72109(defmethod ccl::output-stream-for-remote-lisp ((app cocoa-application))
  • trunk/source/library/remote-lisp.lisp

    r15031 r15065  
    8888(defclass remote-lisp-thread ()
    8989  ((conn :initarg :connection :reader rlisp-thread-connection)
    90    ;; Local process running the local repl
     90   ;; Local process running the local repl: interacting with user, sending to remote for execution.
    9191   (thread-process :initform nil :accessor rlisp-thread-process)
    92    ;; Remote process doing the evaluation for this process.
    93    (thread-id :initarg :thread-id :reader rlisp-thread-id)))
     92   (break-level :initform nil :accessor rlisp-thread-break-level)
     93   ;; Id of remote process doing the evaluation for the local process.
     94   (thread-id :initarg :thread-id :reader rlisp-thread-id)
     95   (event-queue :initform nil :accessor rlisp-thread-event-queue)))
    9496
    9597(defmethod rlisp-host-description ((rthread remote-lisp-thread))
     
    118120               rthread)))))
    119121
     122(defmethod rlisp-thread ((conn remote-lisp-connection) (process process) &key (create nil))
     123  (with-rlisp-lock (conn)
     124    (or (find process (rlisp-threads conn) :key #'rlisp-thread-process)
     125        (and create
     126             (assert (not create))))))
     127
    120128(defmethod rlisp/invoke-restart ((rthread remote-lisp-thread) name &key)
    121129  (rlisp/invoke-restart (rlisp-thread-connection rthread) name :thread rthread))
     
    151159            (rlisp-host-description conn)
    152160            (rlisp-machine-instance conn))))
     161
    153162
    154163(defmethod start-rlisp-server ((conn swank-rlisp-connection))
     
    161170               (handle-swank-event conn (car sexp) (cdr sexp))))))
    162171    (setf (rlisp-server-process conn)
    163           (process-run-function (format nil "Swank Client ~a" (remote-port (swank-command-stream conn)))
     172          (process-run-function (format nil "swank-event-loop ~a" (remote-port (swank-command-stream conn)))
    164173                                #'swank-event-loop conn)))
    165174  (let ((sem (make-semaphore)) (abort nil))
    166175    ;; Patch up swank.  To be replaced someday by our own set of remote functions...
     176    ;; TODO: advise send-to-emacs to intercept :write-string  and add in the thread id.
    167177    (rlisp/execute conn
    168                   "(CL:LET ((CCL:*WARN-IF-REDEFINE* ()))
    169                      (CL:DEFUN SWANK::EVAL-REGION (STRING)
    170                        (CL:WITH-INPUT-FROM-STRING (STREAM STRING)
    171                          (CL:LET (CL:- VALUES)
    172                            (CL:LOOP
    173                              (CL:LET ((FORM (CL:READ STREAM () STREAM)))
    174                                (CL:WHEN (CL:EQ FORM STREAM)
    175                                  (CL:FINISH-OUTPUT)
    176                                  (CL:RETURN (CL:VALUES VALUES CL:-)))
    177                                (CL:UNLESS (CCL::CHECK-TOPLEVEL-COMMAND FORM)
    178                                  (CL:SETQ VALUES (CCL::TOPLEVEL-EVAL (CL:SETQ CL:- FORM))))
    179                                (CL:FINISH-OUTPUT))))))
     178                   "(CL:LET ((CCL:*WARN-IF-REDEFINE* ()))
     179                     (CL:DEFUN SWANK::SPAWN-REPL-THREAD (CONN NAME) (CCL::RDEBUG-SPAWN-REPL-THREAD CONN NAME))
     180                     (CL:DEFUN SWANK::DEBUG-IN-EMACS (CONN) (CCL::RDEBUG-INVOKE-DEBUGGER CONN))
     181                     (CCL:ADVISE SWANK::DISPATCH-EVENT
     182                                 (CL:LET* ((EVENT (CL:CAR CCL::ARGLIST))
     183                                           (COMMAND (CL:CAR EVENT)))
     184                                   (CL:IF (CCL:MEMQ COMMAND '(:EMACS-REX :RETURN :EMACS-INTERRUPT
     185                                                                         :EMACS-PONG :EMACS-RETURN :EMACS-RETURN-STRING
     186                                                                         :EMACS-CHANNEL-SEND :END-OF-STREAM :READER-ERROR))
     187                                     (:DO-IT)
     188                                     (SWANK::ENCODE-MESSAGE EVENT (SWANK::CURRENT-SOCKET-IO))))
     189                                 :WHEN :AROUND
     190                                 :NAME CCL::UNRESTRICTED-OUTGOING-MESSAGES
     191                                 :DYNAMIC-EXTENT-ARGLIST CL:T)
     192                     (CCL:ADVISE SWANK::SEND-TO-EMACS
     193                                 (CL:LET* ((EVENT (CL:CAR CCL::ARGLIST))
     194                                           (COMMAND (CL:CAR EVENT)))
     195                                   (CL:WHEN (CL:EQ COMMAND :WRITE-STRING)
     196                                      (CL:SETF (CL:CDDR EVENT) (CL:LIST (SWANK::CURRENT-THREAD-ID)))))
     197                                 :WHEN :BEFORE
     198                                 :NAME CCL::SEND-THREAD-WITH-WRITE-STRING)
     199                     (CL:DEFUN SWANK::SIMPLE-BREAK ()
     200                       (CCL::FORCE-BREAK-IN-LISTENER CCL::*CURRENT-PROCESS*))
     201                     (CL:SETF (CCL::APPLICATION-UI-OBJECT CCL::*APPLICATION*)
     202                               (CL:MAKE-INSTANCE 'CCL::RDEBUG-UI-OBJECT :CONNECTION SWANK::*EMACS-CONNECTION*))
     203
     204                     (CL:SETQ CCL::*INVOKE-DEBUGGER-HOOK-ON-INTERRUPT* CL:NIL) ;; let it go thru to break.
     205
     206                     (CL:SETQ CCL:*SELECT-INTERACTIVE-PROCESS-HOOK* 'CCL::RDEBUG-FIND-REPL-THREAD)
     207
     208                     (CL:DEFUN CCL::EXIT-SWANK-LOOP (LEVEL)
     209                       (SWANK::SEND-TO-EMACS `(:DEBUG-RETURN
     210                                               ,(SWANK::CURRENT-THREAD-ID) ,LEVEL ,SWANK::*SLDB-STEPPING-P*))
     211                       (SWANK::WAIT-FOR-EVENT `(:SLDB-RETURN ,(CL:1+ LEVEL)) CL:T)
     212                       (CL:WHEN (CL:> LEVEL 1)
     213                         (SWANK::SEND-EVENT (SWANK::CURRENT-THREAD) `(:SLDB-RETURN ,LEVEL))))
     214
    180215                     (CL:DEFUN CCL::MAKE-SWANK-REPL-FOR-IDE (NAME)
    181                        (SWANK::CREATE-REPL ())
     216                       (SWANK::CREATE-REPL ()) ;; set up connection.env with redirect threads.
    182217                       (CL:LET ((THREAD (SWANK::FIND-REPL-THREAD SWANK::*EMACS-CONNECTION*)))
    183218                         (CL:SETF (CCL:PROCESS-NAME THREAD) NAME)
    184219                         (SWANK::THREAD-ID THREAD)))
    185                      (CL:DEFUN CCL::LISTENER-EVAL-FOR-IDE (STRING)
    186                        (CL:LET ((SWANK::*SEND-REPL-RESULTS-FUNCTION*
    187                                  #'(CL:LAMBDA (_) (CL:RETURN-FROM CCL::LISTENER-EVAL-FOR-IDE
    188                                                     (CL:MAPCAR #'CL:WRITE-TO-STRING _)))))
    189                          (SWANK::REPL-EVAL STRING)))
    190                      (CL:SETQ SWANK::*LISTENER-EVAL-FUNCTION* 'CCL::LISTENER-EVAL-FOR-IDE))"
     220                     CL:T)"
    191221                   (lambda (error result)
    192222                     (declare (ignore result))
     
    198228                     (signal-semaphore sem)))
    199229    (wait-on-semaphore sem)
     230    ;; TODO: should at least kill server process.
    200231    (when abort (return-from start-rlisp-server nil))
    201232    (rlisp/execute conn "(SWANK:CONNECTION-INFO)"
     
    229260  *standard-input*)
    230261
     262(defun process-output-stream (process)
     263  (let ((stream (symbol-value-in-process '*standard-output* process)))
     264    (loop
     265      (typecase stream
     266        (synonym-stream
     267         (setq stream (symbol-value-in-process (synonym-stream-symbol stream) process)))
     268        (two-way-stream
     269         (setq stream (two-way-stream-output-stream stream)))
     270        (t (return stream))))))
     271
     272(defvar *signal-swank-events* nil)
     273
     274(define-condition swank-events () ())
     275
     276(defmacro with-swank-events ((rthread &key abort) &body body)
     277  (let ((rthread-var (gensym "RTHREAD")))
     278    (if abort
     279      ;; When body is no re-entrant, abort it before handling the event.
     280      `(let ((,rthread-var ,rthread))
     281         (loop
     282           (handler-case (return (let ((*signal-swank-events* t))
     283                                   (when (rlisp-thread-event-queue ,rthread-var)
     284                                     (let ((*signal-swank-events* nil))
     285                                       (handle-swank-events ,rthread-var)))
     286                                   ,@body))
     287             (swank-events () (let ((*signal-swank-events* nil))
     288                                (handle-swank-events rthread))))))
     289      `(let ((,rthread-var ,rthread))
     290         (handler-bind ((swank-events (lambda (c)
     291                                        (declare (ignore c))
     292                                        (handle-swank-events ,rthread-var))))
     293           (let ((*signal-swank-events* t))
     294             (when (rlisp-thread-event-queue ,rthread-var)
     295               (let ((*signal-swank-events* nil))
     296                 (handle-swank-events ,rthread-var)))
     297             ,@body))))))
     298
     299(defun signal-swank-event (rthread event args)
     300  (with-rlisp-lock ((rlisp-thread-connection rthread)) ;; this is quick, not worth a separate lock
     301    (setf (rlisp-thread-event-queue rthread)
     302          (nconc (rlisp-thread-event-queue rthread) (list `(,event ,@args)))))
     303  (process-interrupt (or (rlisp-thread-process rthread)
     304                         (error "Got event ~s ~s for thread ~s with no process" event args rthread))
     305                     (lambda ()
     306                       (when *signal-swank-events*
     307                         (let ((*signal-swank-events* nil))
     308                           (signal 'swank-events))))))
     309
     310(defun handle-swank-events (rthread)
     311  (loop for event = (with-rlisp-lock ((rlisp-thread-connection rthread)) ;; this is quick, not worth a separate lock
     312                      (pop (rlisp-thread-event-queue rthread)))
     313    while event do (handle-swank-event rthread (car event) (cdr event))))
     314
    231315(defmethod handle-swank-event ((conn swank-rlisp-connection) event args)
    232316  (case event
     
    237321     (destructuring-bind (id message) args
    238322       (when id (remove-rlisp-object conn id))
    239        (error "Invalid swank rpc: ~s" message)))
    240     ((:debug :debug-activate :debug-return :debug-condition :read-aborted)
     323       (error "Invalid rpc: ~s" message)))
     324    (:enter-break ;; Starting a new repl (possibly due to an error in a non-repl process)
     325     ;; For now, this is assumed to create the listener before processing another command, so
     326     ;; the remote can send commands to it right away.
     327     ;; If that becomes a problem, can make a protocol so the other side will explicitly wait,
     328     ;; and then we can spawn off a worker thread to do this.
     329     (destructuring-bind (thread-id break-level) args
     330       (let ((rthread (rlisp-thread conn thread-id)))
     331         (enter-rlisp-listener rthread break-level)
     332         ;; TODO: this isn't really right.  Need to wait for process context to be set up.  Perhaps
     333         ;; make sure thread-process is not set until the process is running in full context.
     334         (process-wait "REPL startup" #'rlisp-thread-process rthread)
     335         ;(signal-swank-event rthread event (cdr args))
     336         )))
     337    (:exit-break
     338     (destructuring-bind (thread-id) args
     339       (let ((rthread (rlisp-thread conn thread-id)))
     340         (when (and rthread (rlisp-thread-process rthread))
     341           (exit-rlisp-listener rthread)))))
     342    ((:read-loop :values :debug-return :debug-condition :read-aborted)
     343     ;; TODO: this needs to make sure the process is in the right dynamic state (with all restarts established etc)
     344     ;;  Need our own interrupt queue, with-event-handling macro...
    241345     (destructuring-bind (thread-id &rest event-args) args
    242346       (let ((rthread (rlisp-thread conn thread-id)))
    243          (unless (rlisp-thread-process rthread)
    244            (error "Got swank event ~s ~s for thread ~s with no process" event args rthread))
    245          (process-interrupt (rlisp-thread-process rthread)
    246                             #'handle-swank-event
    247                             rthread event event-args))))
     347         (signal-swank-event rthread event event-args))))
    248348    (:new-features
    249349     (destructuring-bind (features) args
     
    252352     (destructuring-bind (name-indent-alist) args
    253353       (declare (ignore name-indent-alist))))
     354    ;; TODO: make the i/o streams be thread-specific, so we know which listener to use even if some other
     355    ;; thread is doing the i/o.  I.e. this should send a thread id of the owner of the stream, not of the
     356    ;; thread that happens to write it, so it will always be a listener thread.
    254357    (:write-string
    255      (destructuring-bind (string) args
    256        (let ((stream (output-stream-for-remote-lisp *application*)))
     358     (destructuring-bind (string thread-id) args
     359       (let* ((rthread (rlisp-thread conn thread-id :create nil))
     360              (stream (if (and rthread (rlisp-thread-process rthread))
     361                        (process-output-stream (rlisp-thread-process rthread))
     362                        (output-stream-for-remote-lisp *application*))))
    257363         (if (> (length string) 500)
    258364           (process-run-function "Long Remote Output" #'write-string string stream)
    259365           (write-string string stream)))))
     366    (:ping ;; flow control for output
     367     (destructuring-bind (thread-id tag) args
     368       ;; TODO: I guess we're supposed to wait til the previous output is finished or something.
     369       (send-sexp-to-swank conn `(:emacs-pong ,thread-id ,tag))))
    260370    (:read-string
    261371     (destructuring-bind (thread-id tag) args
    262372       (let ((rthread (rlisp-thread conn thread-id :create nil)))
    263373         (if (and rthread (rlisp-thread-process rthread))
    264            (process-interrupt (rlisp-thread-process rthread)
    265                               #'handle-swank-event
    266                               rthread event `(,tag))
     374           (signal-swank-event rthread event (cdr args))
    267375           ;; not a listener thread.
    268376           ;; TODO: this needs to be wrapped in some error handling.
     
    275383    (t (warn "Received unknown event ~s with args ~s" event args))))
    276384
     385
     386
    277387(define-condition rlisp-read-aborted ()
    278388  ((tag :initarg :tag :reader rlisp-read-aborted-tag)))
     
    282392                                       (when (eql tag (rlisp-read-aborted-tag c))
    283393                                         (return-from rlisp-read-string)))))
     394    (peek-char t stream) ;; wait for first one, error if none.
    284395    (let ((text (and (peek-char t stream nil) ;; wait for first one, nil means eof
    285396                     (read-available-text stream))))
     
    292403     (destructuring-bind (tag) args
    293404       (rlisp-read-string (rlisp-thread-connection rthread) *standard-input* (rlisp-thread-id rthread) tag)))
    294     (:read-aborted
     405    (:read-aborted  ;; huh?
    295406     (destructuring-bind (tag) args
    296407       (signal 'rlisp-read-aborted :tag tag)))
    297     (:debug     ;; SLDB-SETUP
    298      (destructuring-bind (level (condition-text condition-type extras)
    299                                 ;; list of (restart-name restart-description)
    300                                 restarts
    301                                 ;; list of (index frame-description &key restartable)
    302                                 backtrace
    303                                 ;; callbacks currently being evaluated in this thread.
    304                                 ;; Wonder what emacs does with that.
    305                                 pending-callbacks) args
    306        (declare (ignorable condition-type extras backtrace pending-callbacks))
    307        (format t "~&Error: ~a" condition-text)
    308        (when *show-restarts-on-break*
    309          (format t "~&Remote restarts:")
    310          (loop for (name description) in restarts
    311            do (format t "~&~a ~a" name description))
    312          (fresh-line))
     408    (:read-loop ;; enter (or re-enter after an abort) a break loop.
     409     (destructuring-bind (level) args
     410       (when (eql level *break-level*) ;; restart at same level, aborted current expression.
     411         (invoke-restart 'debug-restart level))
     412       (unless (eql level (1+ *break-level*))
     413         (warn ":READ-LOOP level confusion got ~s expected ~s" level (1+ *break-level*)))
     414       ;(format t "~&Error: ~a" condition-text)
     415       ;(when *show-restarts-on-break*
     416       ;  (format t "~&Remote restarts:")
     417       ;  (loop for (name description) in restarts
     418       ;    do (format t "~&~a ~a" name description))
     419       ;  (fresh-line))
    313420       (rlisp-read-loop rthread :break-level level)))
    314     (:debug-activate ;; SLDB-ACTIVATE
    315      (destructuring-bind (level flag) args
    316        (declare (ignore flag))
    317        (unless (eql level *break-level*)
    318          (warn "break level confusion is ~s expected ~s" *break-level* level))))
    319     (:debug-condition ;; This seems to have something to do with errors in the debugger
    320      (destructuring-bind (message) args
    321        (format t "~&Swank error: ~s" message)))
    322     (:debug-return
    323      (destructuring-bind (level stepping-p) args
    324        (declare (ignore stepping-p))
    325        (unless (eql level *break-level*)
    326          (invoke-restart 'debug-return level))))))
     421     (:debug-condition ;; This seems to have something to do with errors in the debugger
     422         (destructuring-bind (message) args
     423           (format t "~&Swank error: ~s" message)))
     424     (:debug-return ;; return from level LEVEL read loop
     425      (destructuring-bind (level stepping-p) args
     426        (declare (ignore stepping-p))
     427        (invoke-restart 'debug-return level)))
     428     (:values ;; intermediate values when multiple forms in selection.
     429      (destructuring-bind (values) args
     430        (when values
     431          (fresh-line)
     432          (dolist (val values) (write val) (terpri)))
     433        (force-output)
     434        (print-listener-prompt *standard-output*)))))
    327435
    328436
     
    332440  (assert (eq (rlisp-server-process conn) *current-process*))
    333441  (let* ((stream (swank-command-stream conn))
    334          (buffer (swank-read-buffer conn))
    335          (count (stream-read-vector stream buffer 0 6)))
     442         (buffer (swank-read-buffer conn)))
     443    (multiple-value-bind (form updated-buffer) (read-remote-event stream buffer)
     444      (unless (eq updated-buffer buffer)
     445        (setf (swank-read-buffer conn) updated-buffer))
     446      form)))
     447
     448(defun read-remote-event (stream &optional buffer)
     449  (let* ((header (or buffer (make-string 6)))
     450         (count (stream-read-vector stream header 0 6)))
    336451    (when (< count 6) (signal-eof-error stream))
    337     (setq count (parse-integer buffer :end 6 :radix 16))
     452    (setq count (parse-integer header :end 6 :radix 16))
     453    (assert (> count 0))
    338454    (when (< (length buffer) count)
    339       (setf (swank-read-buffer conn)
    340             (setq buffer (make-array count :element-type 'character))))
     455      (setq buffer (make-string count)))
    341456    (let ((len (stream-read-vector stream buffer 0 count)))
    342457      (when (< len count) (signal-eof-error stream))
    343       ;; TODO: catch errors here and report them sanely.
    344458      ;; TODO: check that there aren't more forms in the string.
    345       (with-standard-io-syntax
    346           (let ((*package* +swank-io-package+)
    347                 (*read-eval* nil))
    348             (read-from-string buffer t nil :end count))))))
    349 
     459      (values (handler-case
     460                  (with-standard-io-syntax
     461                      (let ((*package* +swank-io-package+)
     462                            (*read-eval* nil))
     463                        (read-from-string buffer t nil :end count)))
     464                (reader-error (c) `(:reader-error ,(copy-seq buffer) ,c)))
     465              buffer))))
    350466
    351467(defmethod make-rrepl-thread ((conn swank-rlisp-connection) name)
     
    409525
    410526
    411 ;; Continuation is executed in the same process that invoked remote-execute.
    412 (defmethod rlisp/execute ((conn swank-rlisp-connection) form-or-string continuation &key package thread)
     527;; Continuation will be executed in the current process.
     528(defmethod rlisp/execute ((conn swank-rlisp-connection) form-or-string continuation &key thread)
    413529  (flet ((continuation (result)
    414530           (ecase (car result)
     
    416532             (:abort (apply continuation (or (cadr result) '"NIL") (or (cddr result) '(nil)))))))
    417533    (let* ((sexp `(:emacs-rex ,form-or-string
    418                               ,package
     534                              nil
    419535                              ,(thread-id-for-execute thread)
    420536                              ,(and continuation (register-rlisp-callback conn #'continuation)))))
     
    423539        (send-sexp-to-swank conn sexp)))))
    424540
    425 
    426541(defmethod rlisp/invoke-restart ((conn swank-rlisp-connection) name &key thread)
    427542  ;; TODO: if had a way to harvest old continuations, could check for error.  But since this
     
    434549(defmethod rlisp/interrupt ((conn swank-rlisp-connection) &key thread)
    435550  (send-sexp-to-swank conn `(:emacs-interrupt ,(thread-id-for-execute thread))))
    436  
    437 ;;(defmethod rlisp/return-string ((conn swank-rlisp-connection) tag string &key thread)
    438 ;;  (send-sexp-to-swank conn `(:emacs-return-string ,(thread-id-for-execute thread) ,tag ,string)))
    439 
    440 ;;(defmethod swank/remote-return ((conn swank-rlisp-connection) tag value &key thread)
    441 ;;  (send-sexp-to-swank conn `(:emacs-return ,(thread-id-for-execute thread) ,tag ,value)))
    442551
    443552(defun read-available-text (stream)
     
    447556    do (vector-push-extend ch buffer)
    448557    finally (return buffer)))
    449  
     558
    450559;; Return text for remote evaluation.
    451560(defmethod toplevel-form-text ((stream input-stream))
     
    470579              (rlisp-lisp-implementation-version conn)
    471580              (rlisp-machine-instance conn))))
    472   (rlisp-read-loop rthread :break-level 0))
    473  
     581  (rlisp-read-loop rthread :break-level (rlisp-thread-break-level rthread)))
     582
     583;; This can be invoked when the connection dies or break-loop is exited in a non-repl process.
     584(defmethod exit-rlisp-listener ((rthread remote-lisp-thread))
     585  (application-ui-operation *application* :deactivate-rlisp-listener rthread) ;; deactivate listener
     586  (let ((process (rlisp-thread-process rthread)))
     587    (setf (rlisp-thread-process rthread) nil)
     588    (process-kill process)))
     589
     590(defmethod enter-rlisp-listener ((rthread remote-lisp-thread) break-level)
     591  (when (rlisp-thread-process rthread)
     592    (error "Attempting to re-enter active listener"))
     593  (setf (rlisp-thread-break-level rthread) break-level)
     594  ;; The process creation would be a little different
     595  (create-rlisp-listener *application* rthread))
     596
     597(defmethod create-rlisp-listener ((application application) rthread)
     598  (assert (null (rlisp-thread-process rthread)))
     599  ;; see make-mcl-listener-process
     600  (error "Not implemented yet"))
     601
     602;; IDE read-loop with remote evaluation.
    474603(defmethod rlisp-read-loop ((rthread remote-lisp-thread) &key break-level)
    475604  (let* ((*break-level* break-level)  ;; used by prompt printing
    476605         (*last-break-level* break-level)  ;; ditto
    477606         (debug-return nil))
    478     ;; When the user invokes a restart from a list, it will be a remote restart and
    479     ;; we will pass the request to the remote.  However, there are some UI actions that invoke local
    480     ;; restarts by name, e.g. cmd-/ will invoke 'continue.  We need catch those and pass them to
    481     ;; the remote.  The remote will then do whatever the restart does, and will send 'debug-return's
    482     ;; as needed.
    483607    (unwind-protect
    484608        (loop
     609          (setf (rlisp-thread-break-level rthread) break-level)
    485610          (restart-case
    486               ;; Do continue with a restart bind because don't want to abort whatever form is
     611              ;; There are some UI actions that invoke local restarts by name, e.g. cmd-/ will invoke 'continue.
     612              ;; Catch those and just pass them to the remote.  The remote will then do whatever the restart
     613              ;; does, and will send back unwinding directions if appropriate.
     614              ;; Do continue with a restart-bind because don't want to abort whatever form is
    487615              ;; about to be sent for evaluation, just in case the continue doesn't end up doing
    488616              ;; anything on the remote end.
     
    498626                    (rlisp/invoke-restart rthread 'abort)))
    499627                (rlisp/toplevel rthread))
    500             (abort () ;; intercept local attempt to abort
    501               (rlisp/invoke-restart rthread 'abort))
    502             (abort-break () ;; intercept local attempt to abort-break
    503               (if (eq break-level 0)
    504                 (rlisp/invoke-restart rthread 'abort)
    505                 (rlisp/invoke-restart rthread 'abort-break)))
    506             (muffle-warning (&optional condition) ;; not likely to be invoked interactively, but...
    507               (assert (null condition)) ;; no way to pass that!
    508               (rlisp/invoke-restart rthread 'muffle-warning))
     628            ;; These are invoked via invoke-restart-no-return, so must take non-local exit.
     629            (abort () (rlisp/invoke-restart rthread 'abort))
     630            (abort-break () (if (eql break-level 0)
     631                              (rlisp/invoke-restart rthread 'abort)
     632                              (rlisp/invoke-restart rthread 'abort-break)))
     633            ;; This is invoked when remote unwinds
    509634            (debug-return (target-level)
     635               (setq debug-return t)
     636               (when (eql target-level break-level)
     637                 (return-from rlisp-read-loop))
    510638               (when (> target-level break-level)
    511639                 (error "Missed target level in debug-return - want ~s have ~s" target-level break-level))
    512                (when (< target-level break-level)
     640               (invoke-restart 'debug-return target-level))
     641            (debug-restart (target-level)
     642               (unless (eql target-level break-level)
     643                 (when (> target-level break-level)
     644                   (error "Missed target level in debug-restart - want ~s have ~s" target-level break-level))
    513645                 (setq debug-return t)
    514                  (invoke-restart 'debug-return target-level))))
     646                 (invoke-restart 'debug-restart target-level))))
    515647          (clear-input)
    516648          (fresh-line))
    517649      (unless debug-return
    518         (warn "Unknown exit from rlisp-read-loop!")))))
     650        (warn "Unknown exit from rlisp-read-loop!")))))
    519651
    520652(defmethod rlisp-read-loop-internal ((rthread remote-lisp-thread))
     
    526658      (force-output output-stream)
    527659      (print-listener-prompt output-stream t)
    528       (multiple-value-bind (text env) (toplevel-form-text input-stream)
     660
     661      (multiple-value-bind (text env)
     662                           ;; Reading is not re-entrant so events during reading need
     663                           ;; to abort the read to be handled.
     664                           (with-swank-events (rthread  :abort t)
     665                             (toplevel-form-text input-stream))
    529666        (if (null text) ;; eof
    530667          (progn
     
    550687(defmethod remote-listener-eval ((conn swank-rlisp-connection) text
    551688                                 &key package thread (semaphore (make-semaphore)))
    552   (let* ((form (format nil "(SWANK::LISTENER-EVAL ~s)" text))
    553          (return-values nil)
    554          (return-error nil))
     689  (assert thread)
     690  (let* ((form (format nil "(CCL::RDEBUG-LISTENER-EVAL ~s ~s ~s)"
     691                       text package
     692                       ;; This will send intermediate :values messages
     693                       (and *verbose-eval-selection* t)))
     694         (return-values nil))
    555695    (rlisp/execute conn
    556696                   form
    557697                   (lambda (error values)
    558                      (setq return-error error)
    559                      (setq return-values values)
    560                      (signal-semaphore semaphore))
    561                    :package package
     698                     ;; Error just means evaluation was aborted but we don't yet know why.  We will
     699                     ;; be told to either restart a readloop or exit it.  Stay in semaphore wait
     700                     ;; until then.
     701                     (unless error
     702                       (setq return-values values)
     703                       (signal-semaphore semaphore)))
    562704                   :thread thread)
    563     (wait-on-semaphore semaphore)
    564     (when return-error
    565       (error "Remote eval error ~s" return-error))
     705    (with-swank-events (thread)
     706      (wait-on-semaphore semaphore))
    566707    ;; a list of strings representing each return value
    567708    return-values))
    568709
    569 
    570 
    571 
    572 
    573 
    574 
    575710;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    576711;;
    577 ;; Server-side SWANK support
     712;; Server-side: support for a remote debugger
    578713;;
    579714;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    580715
    581 ;; (export '(load-swank start-swank-server start-swank-loader stop-swank-loader))
     716
     717;;TODO: This is per application but we may want to allow multiple remote debuggers, and have this track
     718;; all connections.   See also process-ui-object.
     719(defclass rdebug-ui-object (ui-object)
     720  ((connection :initarg :connection :accessor rdebug-ui-connection)))
     721
     722;; Currently built on swank.
    582723
    583724(defun swankvar (name &optional (package :swank))
     
    589730      (warn "Couldn't find ~a::~a" package name)
    590731      (set sym value))))
     732
     733(defun swankfun (name &optional (package :swank))
     734  (symbol-function (find-symbol name package)))
     735
     736#-bootstrapped
     737(declaim (special *read-loop-function*))
     738
     739(defun rdebug-send (event)
     740  (funcall (swankfun "SEND-TO-EMACS")
     741           (mapcar (lambda (x) (if (processp x) (funcall (swankfun "THREAD-ID") x) x)) event)))
     742
     743(defun rdebug-listener-eval (string package-name verbose-eval-selection)
     744  (if package-name
     745    (let ((*package* (or (find-package package-name) *package*)))
     746      (rdebug-listener-eval string nil verbose-eval-selection))
     747    (with-input-from-string (sstream string)
     748      (let ((values nil))
     749        (loop
     750          (let ((form (read-toplevel-form sstream :eof-value sstream)))
     751            (when (eq form sstream)
     752              (finish-output)
     753              (return values))
     754            (when verbose-eval-selection
     755              (rdebug-send `(:values ,*current-process* ,values)))
     756            ;; there is more.
     757            (unless (check-toplevel-command form)
     758              ;; TODO: toplevel-eval checks package change and invokes application-ui-operation, need to send that back.
     759              (setq values (toplevel-eval form nil))
     760              (setq /// // // / / values)
     761              (unless (eq (car values) (%unbound-marker))
     762                (setq *** ** ** * *  (%car values)))
     763              (setq values (mapcar #'write-to-string values)))))))))
     764
     765(defun rdebug-spawn-repl-thread (conn name)
     766  (process-run-function name
     767                        (lambda ()
     768                          (funcall (swankfun "CALL-WITH-CONNECTION") conn
     769                                   (lambda ()
     770                                     (rdebug-send `(:enter-break ,*current-process* 0))
     771                                     (let ((*read-loop-function* 'rdebug-read-loop)
     772                                           (*debugger-hook* nil)
     773                                           (*break-hook* nil))
     774                                       (unwind-protect
     775                                           (toplevel-loop)
     776                                         (rdebug-send `(:exit-break ,*current-process*)))))))))
     777
     778;; Debugger invoked in a non-repl process.  This is called with all swank stuff already set up.
     779(defun rdebug-invoke-debugger (condition)
     780   (when (eq *read-loop-function* 'rdebug-read-loop)
     781      (return-from rdebug-invoke-debugger))
     782    (rdebug-send `(:enter-break ,*current-process* 1))
     783    (unwind-protect
     784        (let ((*read-loop-function* 'rdebug-read-loop)
     785              (*debugger-hook* nil)
     786              (*break-hook* nil))
     787          (%break-message *break-loop-type* condition)
     788          ;; Like toplevel-loop but run break-loop to set up error context before going into read-loop
     789          (loop
     790            (catch :toplevel
     791              (break-loop condition))
     792            (when (eq *current-process* *initial-process*)
     793              (toplevel))))
     794      (rdebug-send `(:exit-break ,*current-process*))))
     795
     796
     797;; swank-like read loop except with all the standard ccl restarts and catches.
     798;; TODO: try to make the standard read-loop customizable enough to do this so don't have to replace it.
     799(defun rdebug-read-loop (&key (break-level 0) &allow-other-keys)
     800  ;; CCL calls this with :input-stream/:output-stream *debug-io*, but that won't do anything even if those
     801  ;; are set to something non-standard, since swank doesn't hang its protocol on the streams.
     802  (let ((*break-level* break-level)
     803        (*loading-file-source-file* nil)
     804        (*loading-toplevel-location* nil)
     805        *** ** * +++ ++ + /// // / -)
     806    (flet ((repl-until-abort ()
     807             (rdebug-send `(:read-loop ,*current-process* ,break-level))
     808             (restart-case
     809                 (catch :abort
     810                   (catch-cancel
     811                    (loop
     812                      (setq *break-level* break-level)
     813                      (let ((event (funcall (swankfun "WAIT-FOR-EVENT")
     814                                            `(or (:emacs-rex . _)
     815                                                 ;; some internal swank kludge...
     816                                                 (:sldb-return ,(1+ break-level))))))
     817                        (when (eql (car event) :sldb-return)
     818                          (abort))
     819                        ;; Execute some basic protocol function (not user code).
     820                        (apply (swankfun "EVAL-FOR-EMACS") (cdr event))))))
     821               (abort ()
     822                 :report (lambda (stream)
     823                           (if (eq break-level 0)
     824                             (format stream "Return to toplevel")
     825                             (format stream "Return to break level ~D" break-level)))
     826                 nil)
     827               (abort-break () (unless (eql break-level 0) (abort))))))
     828      (declare (ftype (function) exit-swank-loop))
     829      (unwind-protect
     830          (loop
     831            (repl-until-abort)
     832            ;(clear-input)
     833            ;(terpri)
     834            )
     835        (exit-swank-loop break-level)))))
     836
     837 (defun safe-condition-string (condition)
     838   (or (ignore-errors (princ-to-string condition))
     839       (ignore-errors (prin1-to-string condition))
     840       (ignore-errors (format nil "Condition of type ~s"
     841                              (type-of condition)))
     842       (ignore-errors (and (typep condition 'error)
     843                           "<Unprintable error>"))
     844       "<Unprintable condition>"))
     845
     846;; Find process to handle interactive abort, i.e. a local ^c.
     847(defun rdebug-find-repl-thread ()
     848  (let ((conn (funcall (swankfun "DEFAULT-CONNECTION"))))
     849    (when conn
     850      ;; TODO: select the frontmost listener (this selects the last created one).
     851      (funcall (swankfun "FIND-REPL-THREAD") conn))))
     852
     853
     854;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     855;;
     856;; Standard swank startup
     857;;
     858;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     859
     860;; (export '(load-swank start-swank-server start-swank-loader stop-swank-loader))
    591861
    592862(defun load-swank (load-path)
     
    622892  (setf (swankvar "*GLOBAL-DEBUGGER*") global-debugger)
    623893  (setf (swankvar "*CONFIGURE-EMACS-INDENTATION*") indentation-updates)
    624   (funcall (find-symbol "CREATE-SERVER" :swank)
     894  (funcall (swankfun "CREATE-SERVER")
    625895           :style style
    626896           :port port
Note: See TracChangeset for help on using the changeset viewer.