Changeset 15065
- Timestamp:
- Nov 10, 2011, 8:53:17 PM (8 years ago)
- Location:
- trunk/source
- Files:
-
- 3 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/source/cocoa-ide/cocoa-listener.lisp
r15020 r15065 106 106 (return (values (call-next-method) nil t))) 107 107 (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))))))))))) 126 127 127 128 (defmethod enqueue-toplevel-form ((stream cocoa-listener-input-stream) string &key package-name pathname offset) … … 445 446 (setq *next-listener-x-pos* nil 446 447 *next-listener-y-pos* nil)) 447 (let* ((p ( shiftf (hemlock-document-process self) nil)))448 (let* ((p (hemlock-document-process self))) 448 449 (when p 450 (setf (hemlock-document-process self) nil) 449 451 (process-kill p))) 450 452 (call-next-method)) -
trunk/source/cocoa-ide/cocoa-remote-lisp.lisp
r15031 r15065 23 23 #+debug ;; For testing, start a ccl running swank, then call this in the ide. 24 24 (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))))) 36 48 37 49 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) 40 53 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)) 47 62 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))) 61 70 (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. 62 73 (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)) 65 78 :class 'remote-cocoa-listener-process 66 79 :initargs `(:remote-thread ,rthread) … … 69 82 (setf (hemlock-document-process doc) *current-process*) 70 83 (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))) 71 108 72 109 (defmethod ccl::output-stream-for-remote-lisp ((app cocoa-application)) -
trunk/source/library/remote-lisp.lisp
r15031 r15065 88 88 (defclass remote-lisp-thread () 89 89 ((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. 91 91 (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))) 94 96 95 97 (defmethod rlisp-host-description ((rthread remote-lisp-thread)) … … 118 120 rthread))))) 119 121 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 120 128 (defmethod rlisp/invoke-restart ((rthread remote-lisp-thread) name &key) 121 129 (rlisp/invoke-restart (rlisp-thread-connection rthread) name :thread rthread)) … … 151 159 (rlisp-host-description conn) 152 160 (rlisp-machine-instance conn)))) 161 153 162 154 163 (defmethod start-rlisp-server ((conn swank-rlisp-connection)) … … 161 170 (handle-swank-event conn (car sexp) (cdr sexp)))))) 162 171 (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))) 164 173 #'swank-event-loop conn))) 165 174 (let ((sem (make-semaphore)) (abort nil)) 166 175 ;; 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. 167 177 (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 180 215 (CL:DEFUN CCL::MAKE-SWANK-REPL-FOR-IDE (NAME) 181 (SWANK::CREATE-REPL ()) 216 (SWANK::CREATE-REPL ()) ;; set up connection.env with redirect threads. 182 217 (CL:LET ((THREAD (SWANK::FIND-REPL-THREAD SWANK::*EMACS-CONNECTION*))) 183 218 (CL:SETF (CCL:PROCESS-NAME THREAD) NAME) 184 219 (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)" 191 221 (lambda (error result) 192 222 (declare (ignore result)) … … 198 228 (signal-semaphore sem))) 199 229 (wait-on-semaphore sem) 230 ;; TODO: should at least kill server process. 200 231 (when abort (return-from start-rlisp-server nil)) 201 232 (rlisp/execute conn "(SWANK:CONNECTION-INFO)" … … 229 260 *standard-input*) 230 261 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 231 315 (defmethod handle-swank-event ((conn swank-rlisp-connection) event args) 232 316 (case event … … 237 321 (destructuring-bind (id message) args 238 322 (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... 241 345 (destructuring-bind (thread-id &rest event-args) args 242 346 (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)))) 248 348 (:new-features 249 349 (destructuring-bind (features) args … … 252 352 (destructuring-bind (name-indent-alist) args 253 353 (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. 254 357 (: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*)))) 257 363 (if (> (length string) 500) 258 364 (process-run-function "Long Remote Output" #'write-string string stream) 259 365 (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)))) 260 370 (:read-string 261 371 (destructuring-bind (thread-id tag) args 262 372 (let ((rthread (rlisp-thread conn thread-id :create nil))) 263 373 (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)) 267 375 ;; not a listener thread. 268 376 ;; TODO: this needs to be wrapped in some error handling. … … 275 383 (t (warn "Received unknown event ~s with args ~s" event args)))) 276 384 385 386 277 387 (define-condition rlisp-read-aborted () 278 388 ((tag :initarg :tag :reader rlisp-read-aborted-tag))) … … 282 392 (when (eql tag (rlisp-read-aborted-tag c)) 283 393 (return-from rlisp-read-string))))) 394 (peek-char t stream) ;; wait for first one, error if none. 284 395 (let ((text (and (peek-char t stream nil) ;; wait for first one, nil means eof 285 396 (read-available-text stream)))) … … 292 403 (destructuring-bind (tag) args 293 404 (rlisp-read-string (rlisp-thread-connection rthread) *standard-input* (rlisp-thread-id rthread) tag))) 294 (:read-aborted 405 (:read-aborted ;; huh? 295 406 (destructuring-bind (tag) args 296 407 (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)) 313 420 (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*))))) 327 435 328 436 … … 332 440 (assert (eq (rlisp-server-process conn) *current-process*)) 333 441 (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))) 336 451 (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)) 338 454 (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))) 341 456 (let ((len (stream-read-vector stream buffer 0 count))) 342 457 (when (< len count) (signal-eof-error stream)) 343 ;; TODO: catch errors here and report them sanely.344 458 ;; 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)))) 350 466 351 467 (defmethod make-rrepl-thread ((conn swank-rlisp-connection) name) … … 409 525 410 526 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 packagethread)527 ;; Continuation will be executed in the current process. 528 (defmethod rlisp/execute ((conn swank-rlisp-connection) form-or-string continuation &key thread) 413 529 (flet ((continuation (result) 414 530 (ecase (car result) … … 416 532 (:abort (apply continuation (or (cadr result) '"NIL") (or (cddr result) '(nil))))))) 417 533 (let* ((sexp `(:emacs-rex ,form-or-string 418 ,package534 nil 419 535 ,(thread-id-for-execute thread) 420 536 ,(and continuation (register-rlisp-callback conn #'continuation))))) … … 423 539 (send-sexp-to-swank conn sexp))))) 424 540 425 426 541 (defmethod rlisp/invoke-restart ((conn swank-rlisp-connection) name &key thread) 427 542 ;; TODO: if had a way to harvest old continuations, could check for error. But since this … … 434 549 (defmethod rlisp/interrupt ((conn swank-rlisp-connection) &key thread) 435 550 (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)))442 551 443 552 (defun read-available-text (stream) … … 447 556 do (vector-push-extend ch buffer) 448 557 finally (return buffer))) 449 558 450 559 ;; Return text for remote evaluation. 451 560 (defmethod toplevel-form-text ((stream input-stream)) … … 470 579 (rlisp-lisp-implementation-version conn) 471 580 (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. 474 603 (defmethod rlisp-read-loop ((rthread remote-lisp-thread) &key break-level) 475 604 (let* ((*break-level* break-level) ;; used by prompt printing 476 605 (*last-break-level* break-level) ;; ditto 477 606 (debug-return nil)) 478 ;; When the user invokes a restart from a list, it will be a remote restart and479 ;; we will pass the request to the remote. However, there are some UI actions that invoke local480 ;; restarts by name, e.g. cmd-/ will invoke 'continue. We need catch those and pass them to481 ;; the remote. The remote will then do whatever the restart does, and will send 'debug-return's482 ;; as needed.483 607 (unwind-protect 484 608 (loop 609 (setf (rlisp-thread-break-level rthread) break-level) 485 610 (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 487 615 ;; about to be sent for evaluation, just in case the continue doesn't end up doing 488 616 ;; anything on the remote end. … … 498 626 (rlisp/invoke-restart rthread 'abort))) 499 627 (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 509 634 (debug-return (target-level) 635 (setq debug-return t) 636 (when (eql target-level break-level) 637 (return-from rlisp-read-loop)) 510 638 (when (> target-level break-level) 511 639 (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)) 513 645 (setq debug-return t) 514 (invoke-restart 'debug-re turntarget-level))))646 (invoke-restart 'debug-restart target-level)))) 515 647 (clear-input) 516 648 (fresh-line)) 517 649 (unless debug-return 518 (warn "Unknown exit from rlisp-read-loop!")))))650 (warn "Unknown exit from rlisp-read-loop!"))))) 519 651 520 652 (defmethod rlisp-read-loop-internal ((rthread remote-lisp-thread)) … … 526 658 (force-output output-stream) 527 659 (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)) 529 666 (if (null text) ;; eof 530 667 (progn … … 550 687 (defmethod remote-listener-eval ((conn swank-rlisp-connection) text 551 688 &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)) 555 695 (rlisp/execute conn 556 696 form 557 697 (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))) 562 704 :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)) 566 707 ;; a list of strings representing each return value 567 708 return-values)) 568 709 569 570 571 572 573 574 575 710 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 576 711 ;; 577 ;; Server-side SWANK support712 ;; Server-side: support for a remote debugger 578 713 ;; 579 714 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 580 715 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. 582 723 583 724 (defun swankvar (name &optional (package :swank)) … … 589 730 (warn "Couldn't find ~a::~a" package name) 590 731 (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)) 591 861 592 862 (defun load-swank (load-path) … … 622 892 (setf (swankvar "*GLOBAL-DEBUGGER*") global-debugger) 623 893 (setf (swankvar "*CONFIGURE-EMACS-INDENTATION*") indentation-updates) 624 (funcall ( find-symbol "CREATE-SERVER" :swank)894 (funcall (swankfun "CREATE-SERVER") 625 895 :style style 626 896 :port port
Note: See TracChangeset
for help on using the changeset viewer.