Index: /trunk/source/cocoa-ide/cocoa-listener.lisp =================================================================== --- /trunk/source/cocoa-ide/cocoa-listener.lisp (revision 15064) +++ /trunk/source/cocoa-ide/cocoa-listener.lisp (revision 15065) @@ -106,22 +106,23 @@ (return (values (call-next-method) nil t))) (wait-on-semaphore queue-semaphore nil "Toplevel Read") - (let ((val (with-lock-grabbed (queue-lock) (pop queue)))) - (cond ((stringp val) - (assert (timed-wait-on-semaphore text-semaphore 0) () "text/queue mismatch!") - (setq cur-string val cur-string-pos 0)) - (t - (destructuring-bind (string package-name pathname offset) val - ;; This env is used both for read and eval. - (let ((env (cons '(*loading-file-source-file* *load-pathname* *load-truename* *loading-toplevel-location* - ccl::*nx-source-note-map*) - (list pathname pathname (and pathname (or (probe-file pathname) pathname)) nil - source-map)))) - (when package-name - (push '*package* (car env)) - (push (ccl::pkg-arg package-name) (cdr env))) - (if source-map - (clrhash source-map) - (setf source-map (make-hash-table :test 'eq :shared nil))) - (setf cur-sstream (make-string-input-stream string) cur-env env cur-offset offset)))))))))) + (without-interrupts + (let ((val (with-lock-grabbed (queue-lock) (pop queue)))) + (cond ((stringp val) + (assert (timed-wait-on-semaphore text-semaphore 0) () "text/queue mismatch!") + (setq cur-string val cur-string-pos 0)) + (val + (destructuring-bind (string package-name pathname offset) val + ;; This env is used both for read and eval. + (let ((env (cons '(*loading-file-source-file* *load-pathname* *load-truename* *loading-toplevel-location* + ccl::*nx-source-note-map*) + (list pathname pathname (and pathname (or (probe-file pathname) pathname)) nil + source-map)))) + (when package-name + (push '*package* (car env)) + (push (ccl::pkg-arg package-name) (cdr env))) + (if source-map + (clrhash source-map) + (setf source-map (make-hash-table :test 'eq :shared nil))) + (setf cur-sstream (make-string-input-stream string) cur-env env cur-offset offset))))))))))) (defmethod enqueue-toplevel-form ((stream cocoa-listener-input-stream) string &key package-name pathname offset) @@ -445,6 +446,7 @@ (setq *next-listener-x-pos* nil *next-listener-y-pos* nil)) - (let* ((p (shiftf (hemlock-document-process self) nil))) + (let* ((p (hemlock-document-process self))) (when p + (setf (hemlock-document-process self) nil) (process-kill p))) (call-next-method)) Index: /trunk/source/cocoa-ide/cocoa-remote-lisp.lisp =================================================================== --- /trunk/source/cocoa-ide/cocoa-remote-lisp.lisp (revision 15064) +++ /trunk/source/cocoa-ide/cocoa-remote-lisp.lisp (revision 15065) @@ -23,44 +23,57 @@ #+debug ;; For testing, start a ccl running swank, then call this in the ide. (defun cl-user::rlisp-test (port &optional host) - (declare (special conn thread)) - (when (boundp 'conn) (close conn)) - (setq conn (ccl::connect-to-swank (or host "localhost") port)) - (setq thread (ccl::make-rrepl-thread conn "IDE Listener")) - (let* ((old ccl::*inhibit-greeting*) - (listener (unwind-protect - (progn - (setq ccl::*inhibit-greeting* t) - (new-listener)) - (setq ccl::*inhibit-greeting* old)))) - (connect-listener-to-remote listener thread))) + (declare (special cl-user::conn)) + (when (boundp 'cl-user::conn) (close cl-user::conn)) + (setq cl-user::conn (ccl::connect-to-swank (or host "localhost") port)) + (ccl::make-rrepl-thread cl-user::conn "IDE Listener")) + +(defclass remote-listener-hemlock-view (hi:hemlock-view) + ((remote-thread :initarg :remote-thread :accessor listener-remote-thread))) + +;; Kludge city +(defun create-remote-listener-view (rthread) + (let* ((listener (new-listener :inhibit-greeting t)) + (doc (hi::buffer-document (hi:hemlock-view-buffer listener))) + (process (or (hemlock-document-process doc) + (error "Not a listener: ~s" listener)))) + (setf (hemlock-document-process doc) nil) ;; so killing the process doesn't close the window + (process-kill process) + (change-class listener 'remote-listener-hemlock-view :remote-thread rthread) + listener)) + +(defmethod activate-rlisp-listener ((view remote-listener-hemlock-view)) + (execute-in-gui + (lambda () + (#/makeKeyAndOrderFront: (#/window (hi::hemlock-view-pane view)) (%null-ptr))))) -(defclass remote-cocoa-listener-process (cocoa-listener-process) - ((remote-thread :initarg :remote-thread :reader process-remote-thread))) +;; TODO: Do something to show that remote is not active +(defmethod deactivate-rlisp-listener ((view remote-listener-hemlock-view)) + nil) -;; in the future, there should be something like a "New Remote Listener" command -;; which should pass relevant info through to new-cocoa-listener-process. -;; But this will do for testing: take an existing normal listener and convert it. -(defmethod connect-listener-to-remote (object rthread) - (let ((view (hemlock-view object))) - (connect-listener-to-remote (or view (require-type object 'hi:hemlock-view)) rthread))) +(defun listener-view-for-remote-thread (rthread &key activate) + (let ((view (first-window-satisfying-predicate (lambda (wptr) + (let ((view (hemlock-view wptr))) + (and (typep view 'remote-listener-hemlock-view) + (eql (listener-remote-thread view) rthread))))))) + (when (and activate view) + (activate-rlisp-listener view)) + view)) -(defmethod connect-listener-to-remote ((view hi:hemlock-view) (rthread ccl::remote-lisp-thread)) - (let* ((doc (hi::buffer-document (hi:hemlock-view-buffer view))) - (process (or (hemlock-document-process doc) - (error "Not a listener: ~s" view))) - (name (process-name process)) - (window (cocoa-listener-process-window process))) - (when (eq process *current-process*) - (error "Cannot connect current listener")) - (setf (hemlock-document-process doc) nil) ;; so killing the process doesn't close the window - (process-kill process) - (let ((pos (search " [Remote " name :from-end t))) - (when pos - (setq name (subseq name 0 pos)))) +(defmethod ccl::create-rlisp-listener ((app cocoa-application) (rthread ccl::remote-lisp-thread)) + (let* ((view (or (listener-view-for-remote-thread rthread :activate t) + (create-remote-listener-view rthread))) + (buffer (hi:hemlock-view-buffer view)) + (doc (hi::buffer-document buffer)) + (name (hi:buffer-name buffer))) + (assert (null (hemlock-document-process doc))) (setf (hemlock-document-process doc) + ;; TODO: hemlock puts the local process number on modeline, which is uninteresting. + ;; TODO: change process name when change buffer name. (new-cocoa-listener-process (format nil "~a [Remote ~a(~a)]" - name (ccl::rlisp-host-description rthread) (ccl::rlisp-thread-id rthread)) - window + name + (ccl::rlisp-host-description rthread) + (ccl::rlisp-thread-id rthread)) + (#/window (hi::hemlock-view-pane view)) :class 'remote-cocoa-listener-process :initargs `(:remote-thread ,rthread) @@ -69,4 +82,28 @@ (setf (hemlock-document-process doc) *current-process*) (ccl::remote-listener-function rthread)))))) + +(defmethod ui-object-do-operation ((ui ns:ns-application) (op (eql :deactivate-rlisp-listener)) rthread) + ;; Do something to show that the listener is not active + (let ((view (listener-view-for-remote-thread rthread))) + (when view + (deactivate-rlisp-listener view)))) + +(defclass remote-cocoa-listener-process (cocoa-listener-process) + ((remote-thread :initarg :remote-thread :reader process-remote-thread))) + +(defmethod process-kill :before ((process remote-cocoa-listener-process)) + (let* ((wptr (cocoa-listener-process-window process)) + (view (hemlock-view wptr))) + (when view + ;; don't close the window just because kill process. + (let ((doc (#/document wptr))) + (when (and doc (not (%null-ptr-p doc))) + (setf (hemlock-document-process doc) nil))) + (deactivate-rlisp-listener view)))) + +;; Cmd-, calls this +(defmethod ccl::force-break-in-listener ((p remote-cocoa-listener-process)) + ;; Cause the other side to enter a breakloop, which it will inform us of when it happens. + (ccl::rlisp/interrupt (process-remote-thread p))) (defmethod ccl::output-stream-for-remote-lisp ((app cocoa-application)) Index: /trunk/source/library/remote-lisp.lisp =================================================================== --- /trunk/source/library/remote-lisp.lisp (revision 15064) +++ /trunk/source/library/remote-lisp.lisp (revision 15065) @@ -88,8 +88,10 @@ (defclass remote-lisp-thread () ((conn :initarg :connection :reader rlisp-thread-connection) - ;; Local process running the local repl + ;; Local process running the local repl: interacting with user, sending to remote for execution. (thread-process :initform nil :accessor rlisp-thread-process) - ;; Remote process doing the evaluation for this process. - (thread-id :initarg :thread-id :reader rlisp-thread-id))) + (break-level :initform nil :accessor rlisp-thread-break-level) + ;; Id of remote process doing the evaluation for the local process. + (thread-id :initarg :thread-id :reader rlisp-thread-id) + (event-queue :initform nil :accessor rlisp-thread-event-queue))) (defmethod rlisp-host-description ((rthread remote-lisp-thread)) @@ -118,4 +120,10 @@ rthread))))) +(defmethod rlisp-thread ((conn remote-lisp-connection) (process process) &key (create nil)) + (with-rlisp-lock (conn) + (or (find process (rlisp-threads conn) :key #'rlisp-thread-process) + (and create + (assert (not create)))))) + (defmethod rlisp/invoke-restart ((rthread remote-lisp-thread) name &key) (rlisp/invoke-restart (rlisp-thread-connection rthread) name :thread rthread)) @@ -151,4 +159,5 @@ (rlisp-host-description conn) (rlisp-machine-instance conn)))) + (defmethod start-rlisp-server ((conn swank-rlisp-connection)) @@ -161,32 +170,53 @@ (handle-swank-event conn (car sexp) (cdr sexp)))))) (setf (rlisp-server-process conn) - (process-run-function (format nil "Swank Client ~a" (remote-port (swank-command-stream conn))) + (process-run-function (format nil "swank-event-loop ~a" (remote-port (swank-command-stream conn))) #'swank-event-loop conn))) (let ((sem (make-semaphore)) (abort nil)) ;; Patch up swank. To be replaced someday by our own set of remote functions... + ;; TODO: advise send-to-emacs to intercept :write-string and add in the thread id. (rlisp/execute conn - "(CL:LET ((CCL:*WARN-IF-REDEFINE* ())) - (CL:DEFUN SWANK::EVAL-REGION (STRING) - (CL:WITH-INPUT-FROM-STRING (STREAM STRING) - (CL:LET (CL:- VALUES) - (CL:LOOP - (CL:LET ((FORM (CL:READ STREAM () STREAM))) - (CL:WHEN (CL:EQ FORM STREAM) - (CL:FINISH-OUTPUT) - (CL:RETURN (CL:VALUES VALUES CL:-))) - (CL:UNLESS (CCL::CHECK-TOPLEVEL-COMMAND FORM) - (CL:SETQ VALUES (CCL::TOPLEVEL-EVAL (CL:SETQ CL:- FORM)))) - (CL:FINISH-OUTPUT)))))) + "(CL:LET ((CCL:*WARN-IF-REDEFINE* ())) + (CL:DEFUN SWANK::SPAWN-REPL-THREAD (CONN NAME) (CCL::RDEBUG-SPAWN-REPL-THREAD CONN NAME)) + (CL:DEFUN SWANK::DEBUG-IN-EMACS (CONN) (CCL::RDEBUG-INVOKE-DEBUGGER CONN)) + (CCL:ADVISE SWANK::DISPATCH-EVENT + (CL:LET* ((EVENT (CL:CAR CCL::ARGLIST)) + (COMMAND (CL:CAR EVENT))) + (CL:IF (CCL:MEMQ COMMAND '(:EMACS-REX :RETURN :EMACS-INTERRUPT + :EMACS-PONG :EMACS-RETURN :EMACS-RETURN-STRING + :EMACS-CHANNEL-SEND :END-OF-STREAM :READER-ERROR)) + (:DO-IT) + (SWANK::ENCODE-MESSAGE EVENT (SWANK::CURRENT-SOCKET-IO)))) + :WHEN :AROUND + :NAME CCL::UNRESTRICTED-OUTGOING-MESSAGES + :DYNAMIC-EXTENT-ARGLIST CL:T) + (CCL:ADVISE SWANK::SEND-TO-EMACS + (CL:LET* ((EVENT (CL:CAR CCL::ARGLIST)) + (COMMAND (CL:CAR EVENT))) + (CL:WHEN (CL:EQ COMMAND :WRITE-STRING) + (CL:SETF (CL:CDDR EVENT) (CL:LIST (SWANK::CURRENT-THREAD-ID))))) + :WHEN :BEFORE + :NAME CCL::SEND-THREAD-WITH-WRITE-STRING) + (CL:DEFUN SWANK::SIMPLE-BREAK () + (CCL::FORCE-BREAK-IN-LISTENER CCL::*CURRENT-PROCESS*)) + (CL:SETF (CCL::APPLICATION-UI-OBJECT CCL::*APPLICATION*) + (CL:MAKE-INSTANCE 'CCL::RDEBUG-UI-OBJECT :CONNECTION SWANK::*EMACS-CONNECTION*)) + + (CL:SETQ CCL::*INVOKE-DEBUGGER-HOOK-ON-INTERRUPT* CL:NIL) ;; let it go thru to break. + + (CL:SETQ CCL:*SELECT-INTERACTIVE-PROCESS-HOOK* 'CCL::RDEBUG-FIND-REPL-THREAD) + + (CL:DEFUN CCL::EXIT-SWANK-LOOP (LEVEL) + (SWANK::SEND-TO-EMACS `(:DEBUG-RETURN + ,(SWANK::CURRENT-THREAD-ID) ,LEVEL ,SWANK::*SLDB-STEPPING-P*)) + (SWANK::WAIT-FOR-EVENT `(:SLDB-RETURN ,(CL:1+ LEVEL)) CL:T) + (CL:WHEN (CL:> LEVEL 1) + (SWANK::SEND-EVENT (SWANK::CURRENT-THREAD) `(:SLDB-RETURN ,LEVEL)))) + (CL:DEFUN CCL::MAKE-SWANK-REPL-FOR-IDE (NAME) - (SWANK::CREATE-REPL ()) + (SWANK::CREATE-REPL ()) ;; set up connection.env with redirect threads. (CL:LET ((THREAD (SWANK::FIND-REPL-THREAD SWANK::*EMACS-CONNECTION*))) (CL:SETF (CCL:PROCESS-NAME THREAD) NAME) (SWANK::THREAD-ID THREAD))) - (CL:DEFUN CCL::LISTENER-EVAL-FOR-IDE (STRING) - (CL:LET ((SWANK::*SEND-REPL-RESULTS-FUNCTION* - #'(CL:LAMBDA (_) (CL:RETURN-FROM CCL::LISTENER-EVAL-FOR-IDE - (CL:MAPCAR #'CL:WRITE-TO-STRING _))))) - (SWANK::REPL-EVAL STRING))) - (CL:SETQ SWANK::*LISTENER-EVAL-FUNCTION* 'CCL::LISTENER-EVAL-FOR-IDE))" + CL:T)" (lambda (error result) (declare (ignore result)) @@ -198,4 +228,5 @@ (signal-semaphore sem))) (wait-on-semaphore sem) + ;; TODO: should at least kill server process. (when abort (return-from start-rlisp-server nil)) (rlisp/execute conn "(SWANK:CONNECTION-INFO)" @@ -229,4 +260,57 @@ *standard-input*) +(defun process-output-stream (process) + (let ((stream (symbol-value-in-process '*standard-output* process))) + (loop + (typecase stream + (synonym-stream + (setq stream (symbol-value-in-process (synonym-stream-symbol stream) process))) + (two-way-stream + (setq stream (two-way-stream-output-stream stream))) + (t (return stream)))))) + +(defvar *signal-swank-events* nil) + +(define-condition swank-events () ()) + +(defmacro with-swank-events ((rthread &key abort) &body body) + (let ((rthread-var (gensym "RTHREAD"))) + (if abort + ;; When body is no re-entrant, abort it before handling the event. + `(let ((,rthread-var ,rthread)) + (loop + (handler-case (return (let ((*signal-swank-events* t)) + (when (rlisp-thread-event-queue ,rthread-var) + (let ((*signal-swank-events* nil)) + (handle-swank-events ,rthread-var))) + ,@body)) + (swank-events () (let ((*signal-swank-events* nil)) + (handle-swank-events rthread)))))) + `(let ((,rthread-var ,rthread)) + (handler-bind ((swank-events (lambda (c) + (declare (ignore c)) + (handle-swank-events ,rthread-var)))) + (let ((*signal-swank-events* t)) + (when (rlisp-thread-event-queue ,rthread-var) + (let ((*signal-swank-events* nil)) + (handle-swank-events ,rthread-var))) + ,@body)))))) + +(defun signal-swank-event (rthread event args) + (with-rlisp-lock ((rlisp-thread-connection rthread)) ;; this is quick, not worth a separate lock + (setf (rlisp-thread-event-queue rthread) + (nconc (rlisp-thread-event-queue rthread) (list `(,event ,@args))))) + (process-interrupt (or (rlisp-thread-process rthread) + (error "Got event ~s ~s for thread ~s with no process" event args rthread)) + (lambda () + (when *signal-swank-events* + (let ((*signal-swank-events* nil)) + (signal 'swank-events)))))) + +(defun handle-swank-events (rthread) + (loop for event = (with-rlisp-lock ((rlisp-thread-connection rthread)) ;; this is quick, not worth a separate lock + (pop (rlisp-thread-event-queue rthread))) + while event do (handle-swank-event rthread (car event) (cdr event)))) + (defmethod handle-swank-event ((conn swank-rlisp-connection) event args) (case event @@ -237,13 +321,29 @@ (destructuring-bind (id message) args (when id (remove-rlisp-object conn id)) - (error "Invalid swank rpc: ~s" message))) - ((:debug :debug-activate :debug-return :debug-condition :read-aborted) + (error "Invalid rpc: ~s" message))) + (:enter-break ;; Starting a new repl (possibly due to an error in a non-repl process) + ;; For now, this is assumed to create the listener before processing another command, so + ;; the remote can send commands to it right away. + ;; If that becomes a problem, can make a protocol so the other side will explicitly wait, + ;; and then we can spawn off a worker thread to do this. + (destructuring-bind (thread-id break-level) args + (let ((rthread (rlisp-thread conn thread-id))) + (enter-rlisp-listener rthread break-level) + ;; TODO: this isn't really right. Need to wait for process context to be set up. Perhaps + ;; make sure thread-process is not set until the process is running in full context. + (process-wait "REPL startup" #'rlisp-thread-process rthread) + ;(signal-swank-event rthread event (cdr args)) + ))) + (:exit-break + (destructuring-bind (thread-id) args + (let ((rthread (rlisp-thread conn thread-id))) + (when (and rthread (rlisp-thread-process rthread)) + (exit-rlisp-listener rthread))))) + ((:read-loop :values :debug-return :debug-condition :read-aborted) + ;; TODO: this needs to make sure the process is in the right dynamic state (with all restarts established etc) + ;; Need our own interrupt queue, with-event-handling macro... (destructuring-bind (thread-id &rest event-args) args (let ((rthread (rlisp-thread conn thread-id))) - (unless (rlisp-thread-process rthread) - (error "Got swank event ~s ~s for thread ~s with no process" event args rthread)) - (process-interrupt (rlisp-thread-process rthread) - #'handle-swank-event - rthread event event-args)))) + (signal-swank-event rthread event event-args)))) (:new-features (destructuring-bind (features) args @@ -252,17 +352,25 @@ (destructuring-bind (name-indent-alist) args (declare (ignore name-indent-alist)))) + ;; TODO: make the i/o streams be thread-specific, so we know which listener to use even if some other + ;; thread is doing the i/o. I.e. this should send a thread id of the owner of the stream, not of the + ;; thread that happens to write it, so it will always be a listener thread. (:write-string - (destructuring-bind (string) args - (let ((stream (output-stream-for-remote-lisp *application*))) + (destructuring-bind (string thread-id) args + (let* ((rthread (rlisp-thread conn thread-id :create nil)) + (stream (if (and rthread (rlisp-thread-process rthread)) + (process-output-stream (rlisp-thread-process rthread)) + (output-stream-for-remote-lisp *application*)))) (if (> (length string) 500) (process-run-function "Long Remote Output" #'write-string string stream) (write-string string stream))))) + (:ping ;; flow control for output + (destructuring-bind (thread-id tag) args + ;; TODO: I guess we're supposed to wait til the previous output is finished or something. + (send-sexp-to-swank conn `(:emacs-pong ,thread-id ,tag)))) (:read-string (destructuring-bind (thread-id tag) args (let ((rthread (rlisp-thread conn thread-id :create nil))) (if (and rthread (rlisp-thread-process rthread)) - (process-interrupt (rlisp-thread-process rthread) - #'handle-swank-event - rthread event `(,tag)) + (signal-swank-event rthread event (cdr args)) ;; not a listener thread. ;; TODO: this needs to be wrapped in some error handling. @@ -275,4 +383,6 @@ (t (warn "Received unknown event ~s with args ~s" event args)))) + + (define-condition rlisp-read-aborted () ((tag :initarg :tag :reader rlisp-read-aborted-tag))) @@ -282,4 +392,5 @@ (when (eql tag (rlisp-read-aborted-tag c)) (return-from rlisp-read-string))))) + (peek-char t stream) ;; wait for first one, error if none. (let ((text (and (peek-char t stream nil) ;; wait for first one, nil means eof (read-available-text stream)))) @@ -292,37 +403,34 @@ (destructuring-bind (tag) args (rlisp-read-string (rlisp-thread-connection rthread) *standard-input* (rlisp-thread-id rthread) tag))) - (:read-aborted + (:read-aborted ;; huh? (destructuring-bind (tag) args (signal 'rlisp-read-aborted :tag tag))) - (:debug ;; SLDB-SETUP - (destructuring-bind (level (condition-text condition-type extras) - ;; list of (restart-name restart-description) - restarts - ;; list of (index frame-description &key restartable) - backtrace - ;; callbacks currently being evaluated in this thread. - ;; Wonder what emacs does with that. - pending-callbacks) args - (declare (ignorable condition-type extras backtrace pending-callbacks)) - (format t "~&Error: ~a" condition-text) - (when *show-restarts-on-break* - (format t "~&Remote restarts:") - (loop for (name description) in restarts - do (format t "~&~a ~a" name description)) - (fresh-line)) + (:read-loop ;; enter (or re-enter after an abort) a break loop. + (destructuring-bind (level) args + (when (eql level *break-level*) ;; restart at same level, aborted current expression. + (invoke-restart 'debug-restart level)) + (unless (eql level (1+ *break-level*)) + (warn ":READ-LOOP level confusion got ~s expected ~s" level (1+ *break-level*))) + ;(format t "~&Error: ~a" condition-text) + ;(when *show-restarts-on-break* + ; (format t "~&Remote restarts:") + ; (loop for (name description) in restarts + ; do (format t "~&~a ~a" name description)) + ; (fresh-line)) (rlisp-read-loop rthread :break-level level))) - (:debug-activate ;; SLDB-ACTIVATE - (destructuring-bind (level flag) args - (declare (ignore flag)) - (unless (eql level *break-level*) - (warn "break level confusion is ~s expected ~s" *break-level* level)))) - (:debug-condition ;; This seems to have something to do with errors in the debugger - (destructuring-bind (message) args - (format t "~&Swank error: ~s" message))) - (:debug-return - (destructuring-bind (level stepping-p) args - (declare (ignore stepping-p)) - (unless (eql level *break-level*) - (invoke-restart 'debug-return level)))))) + (:debug-condition ;; This seems to have something to do with errors in the debugger + (destructuring-bind (message) args + (format t "~&Swank error: ~s" message))) + (:debug-return ;; return from level LEVEL read loop + (destructuring-bind (level stepping-p) args + (declare (ignore stepping-p)) + (invoke-restart 'debug-return level))) + (:values ;; intermediate values when multiple forms in selection. + (destructuring-bind (values) args + (when values + (fresh-line) + (dolist (val values) (write val) (terpri))) + (force-output) + (print-listener-prompt *standard-output*))))) @@ -332,20 +440,28 @@ (assert (eq (rlisp-server-process conn) *current-process*)) (let* ((stream (swank-command-stream conn)) - (buffer (swank-read-buffer conn)) - (count (stream-read-vector stream buffer 0 6))) + (buffer (swank-read-buffer conn))) + (multiple-value-bind (form updated-buffer) (read-remote-event stream buffer) + (unless (eq updated-buffer buffer) + (setf (swank-read-buffer conn) updated-buffer)) + form))) + +(defun read-remote-event (stream &optional buffer) + (let* ((header (or buffer (make-string 6))) + (count (stream-read-vector stream header 0 6))) (when (< count 6) (signal-eof-error stream)) - (setq count (parse-integer buffer :end 6 :radix 16)) + (setq count (parse-integer header :end 6 :radix 16)) + (assert (> count 0)) (when (< (length buffer) count) - (setf (swank-read-buffer conn) - (setq buffer (make-array count :element-type 'character)))) + (setq buffer (make-string count))) (let ((len (stream-read-vector stream buffer 0 count))) (when (< len count) (signal-eof-error stream)) - ;; TODO: catch errors here and report them sanely. ;; TODO: check that there aren't more forms in the string. - (with-standard-io-syntax - (let ((*package* +swank-io-package+) - (*read-eval* nil)) - (read-from-string buffer t nil :end count)))))) - + (values (handler-case + (with-standard-io-syntax + (let ((*package* +swank-io-package+) + (*read-eval* nil)) + (read-from-string buffer t nil :end count))) + (reader-error (c) `(:reader-error ,(copy-seq buffer) ,c))) + buffer)))) (defmethod make-rrepl-thread ((conn swank-rlisp-connection) name) @@ -409,6 +525,6 @@ -;; Continuation is executed in the same process that invoked remote-execute. -(defmethod rlisp/execute ((conn swank-rlisp-connection) form-or-string continuation &key package thread) +;; Continuation will be executed in the current process. +(defmethod rlisp/execute ((conn swank-rlisp-connection) form-or-string continuation &key thread) (flet ((continuation (result) (ecase (car result) @@ -416,5 +532,5 @@ (:abort (apply continuation (or (cadr result) '"NIL") (or (cddr result) '(nil))))))) (let* ((sexp `(:emacs-rex ,form-or-string - ,package + nil ,(thread-id-for-execute thread) ,(and continuation (register-rlisp-callback conn #'continuation))))) @@ -423,5 +539,4 @@ (send-sexp-to-swank conn sexp))))) - (defmethod rlisp/invoke-restart ((conn swank-rlisp-connection) name &key thread) ;; TODO: if had a way to harvest old continuations, could check for error. But since this @@ -434,10 +549,4 @@ (defmethod rlisp/interrupt ((conn swank-rlisp-connection) &key thread) (send-sexp-to-swank conn `(:emacs-interrupt ,(thread-id-for-execute thread)))) - -;;(defmethod rlisp/return-string ((conn swank-rlisp-connection) tag string &key thread) -;; (send-sexp-to-swank conn `(:emacs-return-string ,(thread-id-for-execute thread) ,tag ,string))) - -;;(defmethod swank/remote-return ((conn swank-rlisp-connection) tag value &key thread) -;; (send-sexp-to-swank conn `(:emacs-return ,(thread-id-for-execute thread) ,tag ,value))) (defun read-available-text (stream) @@ -447,5 +556,5 @@ do (vector-push-extend ch buffer) finally (return buffer))) - + ;; Return text for remote evaluation. (defmethod toplevel-form-text ((stream input-stream)) @@ -470,19 +579,38 @@ (rlisp-lisp-implementation-version conn) (rlisp-machine-instance conn)))) - (rlisp-read-loop rthread :break-level 0)) - + (rlisp-read-loop rthread :break-level (rlisp-thread-break-level rthread))) + +;; This can be invoked when the connection dies or break-loop is exited in a non-repl process. +(defmethod exit-rlisp-listener ((rthread remote-lisp-thread)) + (application-ui-operation *application* :deactivate-rlisp-listener rthread) ;; deactivate listener + (let ((process (rlisp-thread-process rthread))) + (setf (rlisp-thread-process rthread) nil) + (process-kill process))) + +(defmethod enter-rlisp-listener ((rthread remote-lisp-thread) break-level) + (when (rlisp-thread-process rthread) + (error "Attempting to re-enter active listener")) + (setf (rlisp-thread-break-level rthread) break-level) + ;; The process creation would be a little different + (create-rlisp-listener *application* rthread)) + +(defmethod create-rlisp-listener ((application application) rthread) + (assert (null (rlisp-thread-process rthread))) + ;; see make-mcl-listener-process + (error "Not implemented yet")) + +;; IDE read-loop with remote evaluation. (defmethod rlisp-read-loop ((rthread remote-lisp-thread) &key break-level) (let* ((*break-level* break-level) ;; used by prompt printing (*last-break-level* break-level) ;; ditto (debug-return nil)) - ;; When the user invokes a restart from a list, it will be a remote restart and - ;; we will pass the request to the remote. However, there are some UI actions that invoke local - ;; restarts by name, e.g. cmd-/ will invoke 'continue. We need catch those and pass them to - ;; the remote. The remote will then do whatever the restart does, and will send 'debug-return's - ;; as needed. (unwind-protect (loop + (setf (rlisp-thread-break-level rthread) break-level) (restart-case - ;; Do continue with a restart bind because don't want to abort whatever form is + ;; There are some UI actions that invoke local restarts by name, e.g. cmd-/ will invoke 'continue. + ;; Catch those and just pass them to the remote. The remote will then do whatever the restart + ;; does, and will send back unwinding directions if appropriate. + ;; Do continue with a restart-bind because don't want to abort whatever form is ;; about to be sent for evaluation, just in case the continue doesn't end up doing ;; anything on the remote end. @@ -498,23 +626,27 @@ (rlisp/invoke-restart rthread 'abort))) (rlisp/toplevel rthread)) - (abort () ;; intercept local attempt to abort - (rlisp/invoke-restart rthread 'abort)) - (abort-break () ;; intercept local attempt to abort-break - (if (eq break-level 0) - (rlisp/invoke-restart rthread 'abort) - (rlisp/invoke-restart rthread 'abort-break))) - (muffle-warning (&optional condition) ;; not likely to be invoked interactively, but... - (assert (null condition)) ;; no way to pass that! - (rlisp/invoke-restart rthread 'muffle-warning)) + ;; These are invoked via invoke-restart-no-return, so must take non-local exit. + (abort () (rlisp/invoke-restart rthread 'abort)) + (abort-break () (if (eql break-level 0) + (rlisp/invoke-restart rthread 'abort) + (rlisp/invoke-restart rthread 'abort-break))) + ;; This is invoked when remote unwinds (debug-return (target-level) + (setq debug-return t) + (when (eql target-level break-level) + (return-from rlisp-read-loop)) (when (> target-level break-level) (error "Missed target level in debug-return - want ~s have ~s" target-level break-level)) - (when (< target-level break-level) + (invoke-restart 'debug-return target-level)) + (debug-restart (target-level) + (unless (eql target-level break-level) + (when (> target-level break-level) + (error "Missed target level in debug-restart - want ~s have ~s" target-level break-level)) (setq debug-return t) - (invoke-restart 'debug-return target-level)))) + (invoke-restart 'debug-restart target-level)))) (clear-input) (fresh-line)) (unless debug-return - (warn "Unknown exit from rlisp-read-loop!"))))) + (warn "Unknown exit from rlisp-read-loop!"))))) (defmethod rlisp-read-loop-internal ((rthread remote-lisp-thread)) @@ -526,5 +658,10 @@ (force-output output-stream) (print-listener-prompt output-stream t) - (multiple-value-bind (text env) (toplevel-form-text input-stream) + + (multiple-value-bind (text env) + ;; Reading is not re-entrant so events during reading need + ;; to abort the read to be handled. + (with-swank-events (rthread :abort t) + (toplevel-form-text input-stream)) (if (null text) ;; eof (progn @@ -550,34 +687,38 @@ (defmethod remote-listener-eval ((conn swank-rlisp-connection) text &key package thread (semaphore (make-semaphore))) - (let* ((form (format nil "(SWANK::LISTENER-EVAL ~s)" text)) - (return-values nil) - (return-error nil)) + (assert thread) + (let* ((form (format nil "(CCL::RDEBUG-LISTENER-EVAL ~s ~s ~s)" + text package + ;; This will send intermediate :values messages + (and *verbose-eval-selection* t))) + (return-values nil)) (rlisp/execute conn form (lambda (error values) - (setq return-error error) - (setq return-values values) - (signal-semaphore semaphore)) - :package package + ;; Error just means evaluation was aborted but we don't yet know why. We will + ;; be told to either restart a readloop or exit it. Stay in semaphore wait + ;; until then. + (unless error + (setq return-values values) + (signal-semaphore semaphore))) :thread thread) - (wait-on-semaphore semaphore) - (when return-error - (error "Remote eval error ~s" return-error)) + (with-swank-events (thread) + (wait-on-semaphore semaphore)) ;; a list of strings representing each return value return-values)) - - - - - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; -;; Server-side SWANK support +;; Server-side: support for a remote debugger ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; (export '(load-swank start-swank-server start-swank-loader stop-swank-loader)) + +;;TODO: This is per application but we may want to allow multiple remote debuggers, and have this track +;; all connections. See also process-ui-object. +(defclass rdebug-ui-object (ui-object) + ((connection :initarg :connection :accessor rdebug-ui-connection))) + +;; Currently built on swank. (defun swankvar (name &optional (package :swank)) @@ -589,4 +730,133 @@ (warn "Couldn't find ~a::~a" package name) (set sym value)))) + +(defun swankfun (name &optional (package :swank)) + (symbol-function (find-symbol name package))) + +#-bootstrapped +(declaim (special *read-loop-function*)) + +(defun rdebug-send (event) + (funcall (swankfun "SEND-TO-EMACS") + (mapcar (lambda (x) (if (processp x) (funcall (swankfun "THREAD-ID") x) x)) event))) + +(defun rdebug-listener-eval (string package-name verbose-eval-selection) + (if package-name + (let ((*package* (or (find-package package-name) *package*))) + (rdebug-listener-eval string nil verbose-eval-selection)) + (with-input-from-string (sstream string) + (let ((values nil)) + (loop + (let ((form (read-toplevel-form sstream :eof-value sstream))) + (when (eq form sstream) + (finish-output) + (return values)) + (when verbose-eval-selection + (rdebug-send `(:values ,*current-process* ,values))) + ;; there is more. + (unless (check-toplevel-command form) + ;; TODO: toplevel-eval checks package change and invokes application-ui-operation, need to send that back. + (setq values (toplevel-eval form nil)) + (setq /// // // / / values) + (unless (eq (car values) (%unbound-marker)) + (setq *** ** ** * * (%car values))) + (setq values (mapcar #'write-to-string values))))))))) + +(defun rdebug-spawn-repl-thread (conn name) + (process-run-function name + (lambda () + (funcall (swankfun "CALL-WITH-CONNECTION") conn + (lambda () + (rdebug-send `(:enter-break ,*current-process* 0)) + (let ((*read-loop-function* 'rdebug-read-loop) + (*debugger-hook* nil) + (*break-hook* nil)) + (unwind-protect + (toplevel-loop) + (rdebug-send `(:exit-break ,*current-process*))))))))) + +;; Debugger invoked in a non-repl process. This is called with all swank stuff already set up. +(defun rdebug-invoke-debugger (condition) + (when (eq *read-loop-function* 'rdebug-read-loop) + (return-from rdebug-invoke-debugger)) + (rdebug-send `(:enter-break ,*current-process* 1)) + (unwind-protect + (let ((*read-loop-function* 'rdebug-read-loop) + (*debugger-hook* nil) + (*break-hook* nil)) + (%break-message *break-loop-type* condition) + ;; Like toplevel-loop but run break-loop to set up error context before going into read-loop + (loop + (catch :toplevel + (break-loop condition)) + (when (eq *current-process* *initial-process*) + (toplevel)))) + (rdebug-send `(:exit-break ,*current-process*)))) + + +;; swank-like read loop except with all the standard ccl restarts and catches. +;; TODO: try to make the standard read-loop customizable enough to do this so don't have to replace it. +(defun rdebug-read-loop (&key (break-level 0) &allow-other-keys) + ;; CCL calls this with :input-stream/:output-stream *debug-io*, but that won't do anything even if those + ;; are set to something non-standard, since swank doesn't hang its protocol on the streams. + (let ((*break-level* break-level) + (*loading-file-source-file* nil) + (*loading-toplevel-location* nil) + *** ** * +++ ++ + /// // / -) + (flet ((repl-until-abort () + (rdebug-send `(:read-loop ,*current-process* ,break-level)) + (restart-case + (catch :abort + (catch-cancel + (loop + (setq *break-level* break-level) + (let ((event (funcall (swankfun "WAIT-FOR-EVENT") + `(or (:emacs-rex . _) + ;; some internal swank kludge... + (:sldb-return ,(1+ break-level)))))) + (when (eql (car event) :sldb-return) + (abort)) + ;; Execute some basic protocol function (not user code). + (apply (swankfun "EVAL-FOR-EMACS") (cdr event)))))) + (abort () + :report (lambda (stream) + (if (eq break-level 0) + (format stream "Return to toplevel") + (format stream "Return to break level ~D" break-level))) + nil) + (abort-break () (unless (eql break-level 0) (abort)))))) + (declare (ftype (function) exit-swank-loop)) + (unwind-protect + (loop + (repl-until-abort) + ;(clear-input) + ;(terpri) + ) + (exit-swank-loop break-level))))) + + (defun safe-condition-string (condition) + (or (ignore-errors (princ-to-string condition)) + (ignore-errors (prin1-to-string condition)) + (ignore-errors (format nil "Condition of type ~s" + (type-of condition))) + (ignore-errors (and (typep condition 'error) + "")) + "")) + +;; Find process to handle interactive abort, i.e. a local ^c. +(defun rdebug-find-repl-thread () + (let ((conn (funcall (swankfun "DEFAULT-CONNECTION")))) + (when conn + ;; TODO: select the frontmost listener (this selects the last created one). + (funcall (swankfun "FIND-REPL-THREAD") conn)))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Standard swank startup +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; (export '(load-swank start-swank-server start-swank-loader stop-swank-loader)) (defun load-swank (load-path) @@ -622,5 +892,5 @@ (setf (swankvar "*GLOBAL-DEBUGGER*") global-debugger) (setf (swankvar "*CONFIGURE-EMACS-INDENTATION*") indentation-updates) - (funcall (find-symbol "CREATE-SERVER" :swank) + (funcall (swankfun "CREATE-SERVER") :style style :port port