source: release/1.9/source/library/remote-lisp.lisp @ 15706

Last change on this file since 15706 was 15169, checked in by gz, 7 years ago

Implement remote inspector

File size: 23.4 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2011 Clozure Associates
4;;;   This file is part of Clozure CL. 
5;;;
6;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with Clozure CL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16;;;
17
18(in-package :ccl)
19
20;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
21;;
22;; swink client -- use this ccl to debug a remote ccl.
23;;
24;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
25
26(defclass remote-lisp-connection (swink:connection)
27  ((features :initform nil :accessor rlisp-features)
28   (lisp-implementation-type :initform "???" :accessor rlisp-lisp-implementation-type)
29   (lisp-implementation-version :initform "???" :accessor rlisp-lisp-implementation-version)
30   (machine-instance :initform "???" :accessor rlisp-machine-instance)
31   (proxies :initform (make-hash-table :test 'eql :weak :value) :reader connection-proxies)))
32
33(defmethod swink:thread-id ((conn remote-lisp-connection)) nil)
34
35(defmethod update-rlisp-connection-info ((conn remote-lisp-connection)
36                                         &key lisp-implementation-type
37                                              lisp-implementation-version
38                                              machine-instance
39                                              (features nil featuresp)
40                                         &allow-other-keys)
41  (swink:with-connection-lock (conn)
42    (when featuresp
43      (setf (rlisp-features conn) features))
44    (when machine-instance
45      (setf (rlisp-machine-instance conn) machine-instance))
46    (when lisp-implementation-type
47      (setf (rlisp-lisp-implementation-type conn) lisp-implementation-type))
48    (when lisp-implementation-version
49      (setf (rlisp-lisp-implementation-version conn) lisp-implementation-version))))
50
51;; Proxy for a thread on the remote server.
52(defclass remote-lisp-thread (swink:thread)
53  (;; Local process running the local repl: interacting with user, sending to remote for execution.
54   ;;    (the swink:thread-process slot has thread-id of the remote process)
55   (control-process :initform nil :accessor swink:thread-control-process)
56   (break-level :initform nil :accessor rthread-break-level)))
57
58(defmethod swink:thread-class ((conn remote-lisp-connection)) 'remote-lisp-thread)
59
60(defmethod rlisp-host-description ((rthread remote-lisp-thread))
61  (rlisp-host-description (swink:thread-connection rthread)))
62
63(defmethod rlisp-thread-description ((rthread remote-lisp-thread))
64  (format nil "~a thread ~a" (rlisp-host-description rthread) (swink:thread-id rthread)))
65
66(defmethod print-object ((rthread remote-lisp-thread) stream)
67  (print-unreadable-object (rthread stream :type t :identity t)
68    (princ (rlisp-thread-description rthread) stream)))
69
70(defmethod rlisp/invoke-restart ((rthread remote-lisp-thread) name)
71  (swink:send-event rthread `(:invoke-restart ,name)))
72
73(defmethod rlisp/invoke-restart-in-context ((rthread remote-lisp-thread) index)
74  (swink:send-event rthread `(:invoke-restart-in-context ,index)))
75
76(defmethod rlisp/toplevel ((rthread remote-lisp-thread))
77  (swink:send-event rthread `(:toplevel)))
78
79(defmethod rlisp/interrupt ((rthread remote-lisp-thread))
80  (swink:send-event rthread `(:interrupt)))
81
82(defmethod rlisp-host-description ((conn remote-lisp-connection))
83  (let ((socket (swink:connection-control-stream conn)))
84    (if (open-stream-p socket)
85      (format nil "~a:~a" (ipaddr-to-dotted (remote-host socket)) (remote-port socket))
86      ":CLOSED")))
87
88(defmethod print-object ((conn remote-lisp-connection) stream)
89  (print-unreadable-object (conn stream :type t :identity t)
90    (format stream "~a @~a"
91            (rlisp-host-description conn)
92            (rlisp-machine-instance conn))))
93
94
95(defmethod start-rlisp-process ((conn remote-lisp-connection))
96  (assert (null (swink:connection-control-process conn)))
97  (setf (swink:connection-control-process conn)
98        (process-run-function (format nil "swank-event-loop ~a" (remote-port (swink:connection-control-stream conn)))
99          (lambda ()
100            (setf (swink:connection-control-process conn) *current-process*)
101            (with-simple-restart (swink:close-connection "Close connection")
102              (loop (dispatch-event conn (swink:read-sexp conn)))))))
103  (let ((info (swink:send-event-for-value conn `(:connection-info))))
104    (when info
105      (apply #'update-rlisp-connection-info conn info)))
106  conn)
107
108
109(defmethod dispatch-event ((conn remote-lisp-connection) thread.event)
110  (swink::log-event "Dispatch-event ~s" thread.event)
111  (destructuring-bind (sender-id . event) thread.event
112    (swink:destructure-case event
113      ((:end-connection condition)
114       (declare (ignore condition))
115       (swink:close-connection conn))
116      ((:start-repl break-level)
117       ;; Starting a new repl (possibly due to an error in a non-repl process)
118       (let ((rthread (swink:make-new-thread conn sender-id)))
119         (start-remote-listener rthread break-level)))
120      ((:exit-repl)
121       (let ((rthread (swink:find-thread conn sender-id)))
122         (when (and rthread (swink:thread-control-process rthread))
123           (exit-remote-listener rthread))))
124      ((:return local-tag &rest values)
125       ;; Note this interrupts the process rather than going through the event mechanism,
126       ;; the caller has to set up the callback environment before sending the request.
127       (when local-tag
128         (apply #'swink:invoke-callback conn local-tag values)))
129      ((:cancel-return local-tag)
130       (when local-tag
131         (swink:abort-callback conn local-tag)))
132      (((:read-string :abort-read :write-string) stream-thread-id &rest args)
133       ;; Do I/O stuff in the stream listener process, not the caller's listener
134       ;; process (which might not even exist)
135       (let ((stream-listener (swink:find-thread conn stream-thread-id)))
136         (if stream-listener
137           (swink:signal-event stream-listener (cons (car event) args))
138           (warn "Missing listener for ~s" event))))
139      ((:inspect remote-inspector)
140       (let ((proxy (new-inspector-proxy conn remote-inspector)))
141         (spawn-inspector *application* proxy)))
142      ((:inspector-data tag segment)
143       (let ((proxy (inspector-proxy-for-tag conn tag)))
144         (register-inspector-proxy-segment proxy segment)))
145      (t (let ((thread (swink:find-thread conn sender-id)))
146           (when thread
147             (swink:signal-event thread event))))))
148  (swink::log-event "Dispatch-event done"))
149
150(define-condition rlisp-read-aborted ()
151  ((tag :initarg :tag :reader rlisp-read-aborted-tag)))
152
153(defun rlisp-read-string (rthread tag)
154  (handler-bind ((rlisp-read-aborted (lambda (c)
155                                       (when (eql tag (rlisp-read-aborted-tag c))
156                                         (return-from rlisp-read-string)))))
157    (let ((text (and (swink:with-event-handling (rthread :restart t)
158                       (peek-char nil *standard-input* nil)) ;; wait for first one, nil means eof
159                     (read-available-text *standard-input*))))
160      (swink:send-event (swink:thread-connection rthread) `(:return ,tag ,text)))))
161
162
163(defclass remote-backtrace-context ()
164  ((thread :initarg :thread :reader backtrace-context-thread)
165   (break-level :initarg :break-level :reader backtrace-context-break-level)
166   (continuable-p :initarg :continuable-p :reader backtrace-context-continuable-p)
167   (restarts :initarg :restarts :reader backtrace-context-restarts)))
168
169(defmethod remote-context-class ((application application)) 'remote-backtrace-context)
170
171(defmethod swink:handle-event ((rthread remote-lisp-thread) event)
172  (assert (eq (swink:thread-control-process rthread) *current-process*))
173  (swink::log-event "Handle-event in thread ~s: ~s" (swink:thread-id rthread) event)
174  (swink:destructure-case event
175    ((:read-string remote-tag)
176     (rlisp-read-string rthread remote-tag))
177    ((:abort-read remote-tag)
178     (signal 'rlisp-read-aborted :tag remote-tag))
179    ((:write-string string)
180     (write-string string))
181    ((:read-loop level)
182     (unless (eql level *break-level*)
183       (warn ":READ-LOOP level confusion got ~s expected ~s" level (1+ *break-level*)))
184     (invoke-restart 'debug-restart level)) ;; restart at same level, aborted current expression.
185    ((:enter-break context-plist)
186     (let* ((rcontext (apply #'make-instance (remote-context-class *application*)
187                             :thread rthread
188                             context-plist))
189            (level (backtrace-context-break-level rcontext)))
190       (unless (or (eql level 0) (eql level (1+ *break-level*)))
191         (warn ":ENTER-BREAK level confusion got ~s expected ~s" level (1+ *break-level*)))
192       ;(format t "~&Error: ~a" condition-text)
193       ;(when *show-restarts-on-break*
194       ;  (format t "~&Remote restarts:")
195       ;  (loop for (name description) in restarts
196       ;    do (format t "~&~a ~a" name description))
197       ;  (fresh-line))
198       (unwind-protect
199           (progn
200             (application-ui-operation *application* :enter-backtrace-context rcontext)
201             (rlisp-read-loop rthread :break-level level))
202         (application-ui-operation *application* :exit-backtrace-context rcontext))))
203    ((:debug-return level) ;; return from level LEVEL read loop
204     (invoke-restart 'debug-return level))))
205
206(defmethod make-rrepl-thread ((conn remote-lisp-connection) name)
207  (swink:send-event conn `(:spawn-repl ,name)))
208
209(defun connect-to-swink (host port)
210  (let* ((socket (make-socket :remote-host host :remote-port port :nodelay t))
211         (conn (make-instance 'remote-lisp-connection :control-stream socket)))
212    (start-rlisp-process conn)))
213
214(defmethod close ((conn remote-lisp-connection) &key abort)
215  ;; TODO: kill process.
216  (close (swink:connection-control-stream conn) :abort abort))
217
218(defun read-available-text (stream)
219  (loop with buffer = (make-array 100 :element-type 'character :adjustable t :fill-pointer 0)
220    for ch = (stream-read-char-no-hang stream)
221    until (or (eq ch :eof) (null ch))
222    do (vector-push-extend ch buffer)
223    finally (return buffer)))
224
225;; Return text for remote evaluation.
226(defmethod wait-for-toplevel-form ((stream input-stream)) (peek-char t stream nil))
227(defmethod toplevel-form-text ((stream input-stream)) (read-available-text stream))
228
229(defmethod wait-for-toplevel-form ((stream synonym-stream))
230  (wait-for-toplevel-form (symbol-value (synonym-stream-symbol stream))))
231(defmethod toplevel-form-text ((stream synonym-stream))
232  (toplevel-form-text (symbol-value (synonym-stream-symbol stream))))
233
234(defmethod wait-for-toplevel-form ((stream two-way-stream))
235  (if (typep stream 'echo-stream)
236    (call-next-method)
237    (wait-for-toplevel-form (two-way-stream-input-stream stream))))
238(defmethod toplevel-form-text ((stream two-way-stream))
239  (if (typep stream 'echo-stream)
240    (call-next-method)
241    (toplevel-form-text (two-way-stream-input-stream stream))))
242
243
244(defmethod start-remote-listener ((rthread remote-lisp-thread) break-level)
245  (when (swink:thread-control-process rthread) (error "Attempting to re-enter active listener"))
246  (setf (rthread-break-level rthread) break-level)
247  (create-rlisp-listener *application* rthread)
248  ;; This is running in the server control process.  Don't process any other events until
249  ;; the thread actually starts up.
250  (process-wait "REPL startup" #'swink:thread-control-process rthread))
251
252;; This can be invoked when the connection dies or break-loop is exited in a non-repl process.
253(defmethod exit-remote-listener ((rthread remote-lisp-thread))
254  (application-ui-operation *application* :deactivate-rlisp-listener rthread) ;; deactivate listener window
255  (let ((process (swink:thread-control-process rthread)))
256    (setf (swink:thread-control-process rthread) nil)
257    (when process
258      ;; This runs unwind-protects, which should clean up any streams
259      (process-kill process))))
260
261;; pass this as the initial-function in make-mcl-listener-process
262(defmethod remote-listener-function ((rthread remote-lisp-thread))
263  (setf (swink:thread-control-process rthread) *current-process*)
264  (unless (or *inhibit-greeting* *quiet-flag*)
265    (let ((conn (swink:thread-connection rthread)))
266      (format t "~&Welcome to ~A ~A on ~A!"
267              (rlisp-lisp-implementation-type conn)
268              (rlisp-lisp-implementation-version conn)
269              (rlisp-machine-instance conn))))
270  (rlisp-read-loop rthread :break-level (rthread-break-level rthread)))
271
272(defmethod create-rlisp-listener ((application application) rthread)
273  (assert (null (swink:thread-control-process rthread)))
274  ;; see make-mcl-listener-process
275  (error "Not implemented yet"))
276
277;; IDE read-loop with remote evaluation.
278(defmethod rlisp-read-loop ((rthread remote-lisp-thread) &key break-level)
279  (let* ((*break-level* break-level)  ;; used by prompt printing
280         (*last-break-level* break-level)  ;; ditto
281         (debug-return nil))
282    (unwind-protect
283        (loop
284          (setf (rthread-break-level rthread) break-level)
285          (restart-case
286              ;; There are some UI actions that invoke local restarts by name, e.g. cmd-/ will invoke 'continue.
287              ;; Catch those and just pass them to the remote.  The remote will then do whatever the restart
288              ;; does, and will send back unwinding directions if appropriate.
289              ;; Do continue with a restart-bind because don't want to abort whatever form is
290              ;; about to be sent for evaluation, just in case the continue doesn't end up doing
291              ;; anything on the remote end.
292              (restart-bind ((continue (lambda () (rlisp/invoke-restart rthread 'continue))))
293                (catch :toplevel
294                  (loop
295                    (catch :abort
296                      (loop
297                        (catch-cancel ;; exactly like :abort except prints Cancelled.
298                         (rlisp-read-loop-internal rthread))
299                        (rlisp/invoke-restart rthread 'abort)
300                        (format *terminal-io* "~&Cancelled")))
301                    (rlisp/invoke-restart rthread 'abort)))
302                (rlisp/toplevel rthread))
303            ;; These are invoked via invoke-restart-no-return, so must take non-local exit.
304            (abort () (rlisp/invoke-restart rthread 'abort))
305            (abort-break () (if (eql break-level 0)
306                              (rlisp/invoke-restart rthread 'abort)
307                              (rlisp/invoke-restart rthread 'abort-break)))
308            ;; This is invoked when remote unwinds
309            (debug-return (target-level)
310               (setq debug-return t)
311               (when (eql target-level break-level)
312                 (return-from rlisp-read-loop))
313               (when (> target-level break-level)
314                 (error "Missed target level in debug-return - want ~s have ~s" target-level break-level))
315               (invoke-restart 'debug-return target-level))
316            (debug-restart (target-level)
317               (unless (eql target-level break-level)
318                 (when (> target-level break-level)
319                   (error "Missed target level in debug-restart - want ~s have ~s" target-level break-level))
320                 (setq debug-return t)
321                 (invoke-restart 'debug-restart target-level))))
322          (clear-input)
323          (fresh-line))
324      (unless debug-return
325        (warn "Unknown exit from rlisp-read-loop!")))))
326
327(defmethod rlisp-read-loop-internal ((rthread remote-lisp-thread))
328  (let* ((input-stream *standard-input*)
329         (sem (make-semaphore))
330         (eof-count 0))
331    (loop
332      (force-output)
333      (print-listener-prompt *standard-output* t)
334     
335      (swink:with-event-handling (rthread :restart t)
336        (wait-for-toplevel-form input-stream))
337      (multiple-value-bind (text env) (toplevel-form-text input-stream)
338        (if (null text) ;; eof
339          (progn
340            (when (> (incf eof-count) *consecutive-eof-limit*)
341              (#_ _exit 0))
342            (unless (and (not *batch-flag*)
343                         (not *quit-on-eof*)
344                         (stream-eof-transient-p input-stream))
345              (exit-interactive-process *current-process*))
346            (stream-clear-input input-stream)
347            (rlisp/invoke-restart rthread 'abort-break))
348          (progn
349            (setq eof-count 0)
350            ;;(let* ((values (toplevel-eval form env)))
351            ;;      (if print-result (toplevel-print values)))
352            (let* ((package-name (loop for sym in (car env) for val in (cdr env)
353                                   when (eq sym '*package*) do (return val))))
354              (if *verbose-eval-selection*
355                (let ((state (swink:send-event-for-value rthread
356                                                         `(:read-eval-print-one ,text ,package-name)
357                                                         :semaphore sem)))
358                  (loop while state
359                    do (force-output)
360                    do (print-listener-prompt *standard-output* t)
361                    do (swink:send-event-for-value rthread
362                                                   `(:read-eval-print-next ,state)
363                                                   :semaphore sem)))
364                (swink:send-event-for-value rthread
365                                            `(:read-eval-all-print-last ,text ,package-name)
366                                            :semaphore sem)))))))))
367
368;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
369;; inspector support
370
371;; TODO: tell server no longer need tag when the proxy gets gc'd.
372(defclass remote-inspector-proxy (inspector::inspector)
373  ((connection :initarg :connection :reader remote-inspector-proxy-connection)
374   (tag :initarg :tag :reader remote-inspector-proxy-tag)
375   (string :initarg :string :reader inspector::inspector-object-string)
376   (count :initarg :count :reader inspector::inspector-line-count)
377   ;; This is accumulating strings info from remote.
378   (segments :initform nil)))
379
380(defmethod initialize-instance :after ((proxy remote-inspector-proxy) &rest args)
381  (declare (ignore args))
382  (let ((conn (remote-inspector-proxy-connection proxy))
383        (tag (remote-inspector-proxy-tag proxy)))
384    (swink:with-connection-lock (conn)
385      (assert (null (gethash tag (connection-proxies conn))))
386      (setf (gethash tag (connection-proxies conn)) proxy))))
387
388(defmethod spawn-inspector ((application application) (proxy remote-inspector-proxy))
389  ;; Artist conception... we don't really support non-GUI client side, but it would
390  ;; go something like this.
391  (let* ((conn (remote-inspector-proxy-connection proxy))
392         (thread (swink:find-thread conn t :key #'true))) ;; any thread.
393    (when thread
394      (process-interrupt (swink:thread-control-process thread) 'inspect proxy))))
395
396(defmethod inspector::note-inspecting-item ((proxy remote-inspector-proxy))
397  (let ((conn (remote-inspector-proxy-connection proxy))
398        (tag (remote-inspector-proxy-tag proxy)))
399    (swink:send-event conn `(:inspecting-item ,tag))))
400
401(defmethod inspector::refresh-inspector ((proxy remote-inspector-proxy))
402  (let ((conn (remote-inspector-proxy-connection proxy))
403        (tag (remote-inspector-proxy-tag proxy)))
404    (let ((remote-inspector (swink:send-event-for-value conn `(:refresh-inspector ,tag))))
405      (new-inspector-proxy conn remote-inspector))))
406
407(defmethod new-inspector-proxy ((conn remote-lisp-connection) remote-inspector)
408  (destructuring-bind (remote-tag new-count . new-string) remote-inspector
409    (let ((i (inspector-proxy-for-tag conn remote-tag)))
410      (with-slots (string count) i
411        ;; The proxy might have already existed, if received some segments for it before we got
412        ;; here, but it better be uninitialized.
413        (when count (error "Duplicate proxy for ~s" remote-tag))
414        (setf string new-string count new-count))
415      i)))
416
417(defmethod inspector-proxy-for-tag ((conn remote-lisp-connection) remote-tag)
418  (or (gethash remote-tag (connection-proxies conn))
419      ;; Make a blank proxy to catch any segments that come in while we're initializing.
420      (setf (gethash remote-tag (connection-proxies conn))
421            (make-instance 'remote-inspector-proxy
422              :connection conn
423              :tag remote-tag
424              :count nil))))
425
426(defmethod register-inspector-proxy-segment ((proxy remote-inspector-proxy) segment)
427  (with-slots (connection segments) proxy
428    (swink:with-connection-lock (connection)
429      (push segment segments))))
430
431;; Get the strings for given line, pinging server if we don't already have it.
432(defmethod remote-inspector-proxy-strings ((proxy remote-inspector-proxy) index)
433  (with-slots (connection tag segments) proxy
434    ;; No need to lock because we only ever push onto segments.
435    (let ((last-segments nil)
436          (result nil))
437      (flet ((lookup (index segs)
438               (loop for tail on segs until (eq tail last-segments)
439                 as (start-index . strings) = (car tail) as pos = (- index start-index)
440                 when (and (<= 0 pos) (< pos (length strings)))
441                 do (progn
442                      (setq result (aref strings pos))
443                      (return t))
444                 finally (setq last-segments segs))))
445        (unless (lookup index segments)
446          (swink:send-event connection `(:describe-more ,tag ,index))
447          (process-wait "Remote Describe" (lambda ()
448                                            (and (neq segments last-segments)
449                                                 ;; something new has arrived
450                                                 (lookup index segments)))))
451        result))))
452
453
454(defclass remote-inspector-line (inspector::inspector)
455  ((parent :initarg :parent :reader remote-inspector-line-parent)
456   (index :initarg :index :reader remote-inspector-line-index)
457   ;; Lazily computed remote inspector proxy
458   (proxy :initform nil)))
459
460(defmethod inspector::inspector-line ((proxy remote-inspector-proxy) index)
461  (destructuring-bind (label-string . value-string)
462                      (remote-inspector-proxy-strings proxy index)
463    (values (make-instance 'remote-inspector-line :parent proxy :index index)
464            label-string
465            value-string)))
466
467(defmethod remote-inspector-line-proxy ((line remote-inspector-line))
468  (with-slots (parent index proxy) line
469    (or proxy
470        (setf proxy
471              (with-slots (connection tag) parent
472                (let ((remote-inspector
473                       (swink:send-event-for-value connection
474                                                   `(:line-inspector ,tag ,index))))
475                  (new-inspector-proxy connection remote-inspector)))))))
476
477(defmethod inspector::inspector-line-count ((line remote-inspector-line))
478  (inspector::inspector-line-count (remote-inspector-line-proxy line)))
479
480(defmethod inspector::inspector-object-string ((line remote-inspector-line))
481  (inspector::inspector-object-string (remote-inspector-line-proxy line)))
482
483(defmethod inspector::inspector-line ((line remote-inspector-line) index)
484  (inspector::inspector-line (remote-inspector-line-proxy line) index))
485
486(defmethod inspector::note-inspecting-item ((line remote-inspector-line))
487  (inspector::note-inspecting-item (remote-inspector-line-proxy line)))
Note: See TracBrowser for help on using the repository browser.