source: trunk/source/lib/swink.lisp @ 15169

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

Implement remote inspector

File size: 46.2 KB
Line 
1;;;   Copyright (C) 2011 Clozure Associates
2;;;   This file is part of Clozure CL. 
3;;;
4;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
5;;;   License , known as the LLGPL and distributed with Clozure CL as the
6;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
7;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
8;;;   conflict, the preamble takes precedence. 
9;;;
10;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
11;;;
12;;;   The LLGPL is also available online at
13;;;   http://opensource.franz.com/preamble.html
14;;;
15;;;   Implement a protocol (originally based on swank) for communication between
16;;;   a lisp and an external debugger.  This implements the server side, i.e. the lisp
17;;;   being debugged.
18
19(eval-when (eval compile load)
20  (defpackage :swink
21    (:use :cl :ccl)
22    (:export
23     "START-SERVER"
24     "STOP-SERVER"
25
26     ;; Some stuff that's also useful on client side
27     "THREAD"
28     "THREAD-CLASS"
29     "THREAD-CONNECTION"
30     "THREAD-ID"
31     "THREAD-CONTROL-PROCESS"
32     "MAKE-NEW-THREAD"
33
34     "CONNECTION"
35     "FIND-THREAD"
36     "CONNECTION-CONTROL-STREAM"
37     "CONNECTION-CONTROL-PROCESS"
38     "CLOSE-CONNECTION"
39
40     "TAGGED-OBJECT"
41     "TAG-CALLBACK"
42     "INVOKE-CALLBACK"
43     "ABORT-CALLBACK"
44
45     "DESTRUCTURE-CASE"
46
47     "WITH-CONNECTION-LOCK"
48     "WITH-EVENT-HANDLING"
49     "SEND-EVENT"
50     "SEND-EVENT-FOR-VALUE"
51     "SIGNAL-EVENT"
52     "HANDLE-EVENT"
53     "READ-SEXP"
54     )))
55
56(in-package :swink)
57
58(defvar *default-server-port* 4003)
59
60(defvar *dont-close* nil
61  "Keep listening for more connections on the same port after get the first one")
62
63(defvar *external-format* :iso-8859-1)
64
65
66(defvar *swink-lock* (make-lock))
67
68(defmacro with-swink-lock ((&rest lock-options) &body body)
69  `(without-interrupts
70    (with-lock-grabbed (*swink-lock* ,@lock-options)
71      ,@body)))
72
73(defmacro destructure-case (value &rest patterns)
74  "Dispatch VALUE to one of PATTERNS.
75A cross between `case' and `destructuring-bind'.
76The pattern syntax is:
77  ((HEAD . ARGS) . BODY)
78The list of patterns is searched for a HEAD `eq' to the car of
79VALUE. If one is found, the BODY is executed with ARGS bound to the
80corresponding values in the CDR of VALUE."
81  (let ((operator (gensym "op-"))
82        (operands (gensym "rand-"))
83        (tmp (gensym "tmp-"))
84        (case (if (or (eq (caar (last patterns)) t)
85                      (eq (caaar (last patterns)) t)) 'case 'ecase)))
86    `(let* ((,tmp ,value)
87            (,operator (car ,tmp))
88            (,operands (cdr ,tmp)))
89       (,case ,operator
90         ,@(loop for (pattern . body) in patterns collect 
91                 (if (eq pattern t)
92                     `(t ,@body)
93                     (destructuring-bind (op &rest rands) pattern
94                       `(,op (destructuring-bind ,rands ,operands 
95                               ,@body)))))))))
96
97
98(defun string-segment (string start end)
99  (if (and (eql start 0) (eql end (length string)))
100    string
101    (make-array (- end start)
102                :displaced-to string
103                :displaced-index-offset start)))
104
105
106(defun safe-condition-string (condition)
107  (or (ignore-errors (princ-to-string condition))
108      (ignore-errors (prin1-to-string condition))
109      (ignore-errors (format nil "Condition of type ~s"
110                             (type-of condition)))
111      (ignore-errors (and (typep condition 'error)
112                          "<Unprintable error>"))
113      "<Unprintable condition>"))
114
115
116(defun invoke-restart-if-active (restart &rest values)
117  (declare (dynamic-extent values))
118  (handler-case
119      (apply #'invoke-restart restart values)
120    (ccl::inactive-restart () nil)))
121
122(defmethod marshall-argument (conn (process process))
123  (declare (ignore conn))
124  (process-serial-number process))
125
126(defmethod marshall-argument (conn (condition condition))
127  (declare (ignore conn))
128  (safe-condition-string condition))
129
130(defmethod marshall-argument (conn thing)
131  (declare (ignore conn))
132  thing)
133
134(defun marshall-event (conn event)
135  (flet ((marshall (thing)           ;; Only check the top level
136           (marshall-argument conn thing)))
137    (mapcar #'marshall event)))
138
139(defvar *log-events* nil)
140
141(defvar *log-queue*)
142
143(let ((log-lock (make-lock)))
144  (defun log-event (format-string &rest format-args)
145    (when *log-events*
146      (ignore-errors
147        (let* ((string (format nil "[~d] ~?" (process-serial-number *current-process*) format-string format-args)))
148          ;; This kludge is so don't have to disable interrupts while printing.
149          ;; There is a tiny timing screw at end of loop; who cares, it's just for debugging...
150          (if (boundp '*log-queue*) ;; recursive call
151              (without-interrupts 
152                (setq *log-queue* (nconc *log-queue* (list string))))
153              (let ((stream ccl::*stdout*))
154                (with-lock-grabbed (log-lock "Log Output Lock")
155                  (let ((*log-queue* (list string)))
156                    (fresh-line stream)
157                    (loop for string = (without-interrupts (pop *log-queue*)) while string
158                       do (write-string string stream)
159                       do (terpri stream))))
160                (force-output stream))))))))
161
162(defun warn-and-log (format-string &rest format-args)
163  (declare (dynamic-extent format-args))
164  (apply #'log-event format-string format-args)
165  (apply #'warn format-string format-args))
166
167(defclass connection ()
168  ((control-process :initform nil :accessor connection-control-process)
169   (control-stream :initarg :control-stream :reader connection-control-stream)
170   (buffer :initform (make-string 1024) :accessor connection-buffer)
171   (lock :initform (make-lock) :reader connection-lock)
172   (threads :initform nil :accessor %connection-threads)
173   (object-counter :initform most-negative-fixnum :accessor connection-object-counter)
174   (objects :initform nil :accessor connection-objects)))
175
176(defmacro with-connection-lock ((conn &rest lock-args) &body body)
177  `(without-interrupts ;; without callbacks
178    (with-lock-grabbed ((connection-lock ,conn) ,@lock-args)
179      ,@body)))
180
181(defmethod close-connection ((conn connection))
182  (log-event "closing connection ~s" conn)
183  (let ((process (connection-control-process conn)))
184    (when process
185      (process-interrupt process 'invoke-restart-if-active 'close-connection))))
186
187(defun tag-object (conn object)
188  (with-connection-lock (conn)
189    (let* ((id (incf (connection-object-counter conn))))
190      (push (cons id object) (connection-objects conn))
191      id)))
192
193(defun object-tag (conn object)
194  (with-connection-lock (conn)
195    (car (rassoc object (connection-objects conn)))))
196
197(defun tagged-object (conn id &key keep-tagged)
198  (if keep-tagged
199    (cdr (assoc id (connection-objects conn)))
200    (with-connection-lock (conn)
201      (let ((cell (assoc id (connection-objects conn))))
202        (unless cell
203          (warn-and-log "Missing object for remote reference ~s" id))
204        (setf (connection-objects conn) (delq cell (connection-objects conn)))
205        (cdr cell)))))
206
207(defun remove-tag (conn id)
208  (with-connection-lock (conn)
209    (setf (connection-objects conn) (delete id (connection-objects conn) :key #'car))))
210
211(defun tag-callback (conn function)
212  (tag-object conn function))
213
214(defun invoke-callback (conn id &rest values)
215  (declare (dynamic-extent values))
216  (let ((function (tagged-object conn id)))
217    (when function (apply function t values))))
218
219(defun abort-callback (conn id)
220  (let ((function (tagged-object conn id)))
221    (when function
222      (funcall function nil))))
223
224(defun write-packet (conn string)
225  (let ((stream (connection-control-stream conn)))
226     (assert (<= (length string) #xFFFFFF))
227    ;; We could have a separate lock for the stream, but we can't really send back anything until
228    ;; this write is finished, so it doesn't hurt much if random stuff is held up while we do this.
229    (with-connection-lock (conn)
230      (format stream "~6,'0,X" (length string))
231      (write-string string stream))
232    (force-output stream)))
233
234(defvar +swink-io-package+
235  (loop as name = (gensym "SwinkIO/") while (find-package name)
236    finally (let ((package (make-package name :use nil)))
237              (import '(nil t quote) package)
238              (return package))))
239
240(defun format-for-swink (fmt-string fmt-args)
241  (with-standard-io-syntax
242      (let ((*package* +swink-io-package+))
243        (apply #'format nil fmt-string fmt-args))))
244
245(defun write-sexp (conn sexp)
246  (write-packet conn (with-standard-io-syntax
247                         (let ((*package* +swink-io-package+))
248                           (prin1-to-string sexp)))))
249
250(defun send-event (target event &key ignore-errors)
251  (let* ((conn (thread-connection target))
252         (encoded-event (marshall-event conn event)))
253    (log-event "Send-event ~s to ~a" encoded-event (if (eq target conn)
254                                                       "connection"
255                                                       (princ-to-string (thread-id target))))
256    (handler-bind ((stream-error (lambda (c)
257                                   (when (eq (stream-error-stream c) (connection-control-stream conn))
258                                     (unless ignore-errors
259                                       (log-event "send-event error: ~a" c)
260                                       (close-connection conn))
261                                     (return-from send-event)))))
262      (write-sexp conn (cons (thread-id target) encoded-event)))))
263
264(defun send-event-if-open (target event)
265  (send-event target event :ignore-errors t))
266
267#-bootstrapped (fmakunbound 'read-sexp)
268
269;;This assumes only one process reads from the command stream or the read-buffer, so don't need locking.
270(defmethod read-sexp ((conn connection))
271  ;; Returns the sexp or :end-connection event
272  (let* ((stream (connection-control-stream conn))
273         (buffer (connection-buffer conn))
274         (count (stream-read-vector stream buffer 0 6)))
275    (handler-bind ((stream-error (lambda (c)
276                                   ;; This includes parse errors as well as i/o errors
277                                   (when (eql (stream-error-stream c) stream)
278                                     (log-event "read-sexp error: ~a" c)
279                                     ; (setf (connection-io-error conn) t)
280                                     (return-from read-sexp
281                                       `(nil . (:end-connection ,c)))))))
282      (when (< count 6) (ccl::signal-eof-error stream))
283      (setq count (parse-integer buffer :end 6 :radix 16))
284      (when (< (length buffer) count)
285        (setq buffer (setf (connection-buffer conn) (make-string count))))
286      (let ((len (stream-read-vector stream buffer 0 count)))
287        (when (< len count) (ccl::signal-eof-error stream))
288        ;; TODO: verify that there aren't more forms in the string.
289        (with-standard-io-syntax
290            (let ((*package* +swink-io-package+)
291                  (*read-eval* nil))
292              (read-from-string buffer t nil :end count)))))))
293
294(defmethod thread-connection ((conn connection)) conn)
295
296;; Data for processes with swink event handling.
297(defclass thread ()
298  ((connection :initarg :connection :reader thread-connection)
299   (lock :initform (make-lock) :reader thread-lock)
300   (process :initarg :process :accessor thread-process)
301   (event-queue :initform nil :accessor thread-event-queue)))
302
303(defmacro with-thread-lock ((thread &rest lock-args) &rest body)
304  `(without-interrupts
305    (with-lock-grabbed ((thread-lock ,thread) ,@lock-args)
306      ,@body)))
307
308(defmethod thread-id ((thread thread))
309  (thread-id (thread-process thread)))
310
311(defmethod thread-id ((process process))
312  (process-serial-number process))
313
314(defmethod thread-id ((id integer))
315  id)
316
317(defmethod marshall-argument (conn (thread thread))
318  (declare (ignore conn))
319  (thread-id thread))
320
321(defun connection-threads (conn)
322  (with-connection-lock (conn)
323    (copy-list (%connection-threads conn))))
324
325(defun find-thread (conn id &key (key #'thread-id))
326  (with-connection-lock (conn)
327    (find id (%connection-threads conn) :key key)))
328
329(defmethod make-new-thread ((conn connection) &optional (process *current-process*))
330  (with-connection-lock (conn)
331    (assert (not (find-thread conn process :key #'thread-process)))
332    (let ((thread (make-instance (thread-class conn) :connection conn :process process)))
333      (push thread (%connection-threads conn))
334      thread)))
335
336
337(defun queue-event (thread event)
338  (with-thread-lock (thread)
339    (setf (thread-event-queue thread) (nconc (thread-event-queue thread) (list event)))))
340
341(defun dequeue-event (thread)
342  (with-thread-lock (thread) (pop (thread-event-queue thread))))
343
344
345;; Event handling.
346;; Built on conditions rather than semaphores, so events can interrupt a process in i/o wait.
347
348(defvar *signal-events* nil)
349
350(define-condition events-available () ())
351
352(defun enable-event-handling (thread)
353  (setq *signal-events* t)
354  (loop while (thread-event-queue thread)
355        do (let ((*signal-events* nil))
356             (handle-events thread))))
357
358(defmacro with-event-handling ((thread &key restart) &body body)
359  (let ((thread-var (gensym "THREAD")))
360    (if restart
361      `(let ((,thread-var ,thread))
362         (loop
363           (handler-case (return (let ((*signal-events* *signal-events*))
364                                   (enable-event-handling ,thread-var)
365                                   (with-interrupts-enabled
366                                       ,@body)))
367             (events-available () (let ((*signal-events* nil))
368                                   (handle-events ,thread-var))))))
369      `(let ((,thread-var ,thread))
370         (handler-bind ((events-available (lambda (c)
371                                            (declare (ignore c))
372                                            (handle-events ,thread-var))))
373           (let ((*signal-events* *signal-events*))
374             (enable-event-handling ,thread-var)
375             (with-interrupts-enabled
376                 ,@body)))))))
377
378(defun signal-event (thread event)
379  (queue-event thread event)
380  (process-interrupt (or (thread-control-process thread)
381                         (error "Got event ~s for thread ~s with no process" event thread))
382                     (lambda ()
383                       (when *signal-events*
384                         (let ((*signal-events* nil))
385                           (signal 'events-available))))))
386
387
388(defmethod handle-events ((thread thread))
389  (loop as event = (dequeue-event thread) while event
390        do (handle-event thread event)))
391
392
393;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
394;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
395;;
396;;  Server side:
397;;
398;; In any process we can enter a read loop which gets its input from a swink connection
399;; and sends output to the connection.  We can also spawn a process that does nothing else.
400
401(defvar *global-debugger* t
402  "Use remote debugger on errors and user events even in non-repl threads")
403
404(defclass server-ui-object (ccl::ui-object) ())
405
406(defclass server-connection (connection)
407  ((internal-requests :initform nil :accessor connection-internal-requests)))
408
409(defclass server-thread (thread server-ui-object)
410  ((io :initform nil :accessor thread-io)))
411
412(defmethod thread-class ((conn server-connection)) 'server-thread)
413
414(defmethod thread-control-process ((thread server-thread))
415  (thread-process thread))
416
417(defvar *server-connections* '()
418  "List of all active connections, with the most recent at the front.")
419
420(defvar *current-server-thread* nil)
421
422;; TODO: if this process talked to a connection before, we should reuse it
423;;  even if not talking to it now.
424(defun connection-for-process (process)
425  "Return the 'default' connection for implementing a break in a
426non-swink process PROCESS."
427  (let ((data (ccl::process-ui-object process)))
428    (if (typep data 'server-thread)     ;; process is in a swink repl.
429      (thread-connection data)
430      (car *server-connections*))))
431
432(defmethod thread-id ((conn server-connection))
433  (process-serial-number *current-process*))
434
435(defvar *listener-sockets* nil)
436
437(defun start-server (&key (port *default-server-port*)
438                          (dont-close *dont-close*) 
439                          (external-format *external-format*))
440  "Start a SWINK server on PORT.
441  If DONT-CLOSE is true then the listen socket will accept multiple
442  connections, otherwise it will be closed after the first."
443  (let* ((stream-args (and external-format `(:external-format ,external-format)))
444         (socket (make-socket :connect :passive
445                              ;; :local-host "127.0.0.1"
446                              :local-port port
447                              :reuse-address t))
448         (info (cons socket nil))
449         (local-port (local-port socket)))
450    (with-swink-lock ()
451      (setf (getf *listener-sockets* port) info))
452    (setf (cdr info)
453          (process-run-function (format nil "Swink Server ~a" local-port)
454            (lambda ()
455              (setf (cdr info) *current-process*)
456              (flet ((serve ()
457                       (let ((stream nil))
458                         (unwind-protect
459                             (progn
460                               (setq stream (accept-connection socket :wait t :stream-args stream-args))
461                               (spawn-server-connection stream)
462                               (setq stream nil))
463                           (when stream (close stream :abort t))))))
464                (unwind-protect
465                    (cond ((not dont-close) (serve))
466                          (t (loop (ignore-errors (serve)))))
467                  (close socket :abort t)
468                  (with-swink-lock ()
469                    (remf *listener-sockets* info)))))))
470    (log-event "Swink awaiting ~s instructions on port ~s ~s" external-format local-port socket)
471    local-port))
472
473(defun stop-server (port)
474  "Stop server running on PORT."
475  (let* ((info (with-swink-lock () (getf *listener-sockets* port))))
476    (when info
477      (destructuring-bind (socket . process) info
478        (when process
479          (process-kill process))
480        (close socket :abort t) ;; harmless if already closed.
481        (with-swink-lock ()
482          (remf *listener-sockets* info)))
483      t)))
484
485(defun enqueue-internal-request (conn event)
486  (with-connection-lock (conn)
487    (push (cons nil event) (connection-internal-requests conn))))
488
489(defmethod read-sexp ((conn server-connection))
490  (if (and (connection-internal-requests conn)
491           ;; Remote always takes priority
492           (not (stream-listen (connection-control-stream conn))))
493      (with-connection-lock (conn) (pop (connection-internal-requests conn)))
494      (call-next-method)))
495
496(defun server-event-loop (conn)
497  (loop
498    (let ((thread.event (read-sexp conn)))
499      (log-event "received: ~s" thread.event)
500      (destructuring-bind (thread-id . event) thread.event
501        (if thread-id
502          (let ((thread (find-thread conn thread-id)))
503            (when thread
504              (signal-event thread event)))
505          (handle-event conn event))))))
506
507(defun spawn-server-connection (stream)
508  (let ((conn (make-instance 'server-connection :control-stream stream))
509        (startup-signal (make-semaphore)))
510    (setf (connection-control-process conn)
511          (process-run-function (format nil "swink-event-loop@~s" (local-port stream))
512            (lambda ()
513              (unwind-protect
514                   (with-simple-restart (close-connection "Exit server")
515                     (setf (connection-control-process conn) *current-process*)
516                     (handler-bind ((error (lambda (c)
517                                             (log-event "Error: ~a" c)
518                                             (log-event "Backtrace: ~%~a"
519                                                        (ignore-errors
520                                                         (with-output-to-string (s)
521                                                           (print-call-history :detailed-p nil :stream s :print-length 20 :print-level 4))))
522                                             (invoke-restart 'close-connection))))
523                       (when startup-signal (signal-semaphore startup-signal))
524                       (server-event-loop conn)))
525                (control-process-cleanup conn)))))
526    (wait-on-semaphore startup-signal)
527    (with-swink-lock () (push conn *server-connections*))
528    (when *global-debugger*
529      (use-swink-globally t))
530    conn))
531
532;; Note this happens in an unwind-protect, so is without interrupts.  But we've pretty much
533;; returned to top level and hold no locks.
534(defun control-process-cleanup (conn)
535  (with-swink-lock ()
536    (setq *server-connections* (delq conn *server-connections*))
537    (when (null *server-connections*) (use-swink-globally nil)))
538  (flet ((exit-repl ()
539           ;; While exiting, threads may attempt to write to the connection.  That's good, if the
540           ;; connection is still alive and we're attempting an orderly exit.  Don't go into a spiral
541           ;; if the connection is dead.  Once we get any kind of error, just punt.
542           (log-event "Start exit-repl in ~s" (thread-id *current-process*))
543           (handler-case  (invoke-restart-if-active 'exit-repl)
544             (error (c) (log-event "Exit repl error ~a in ~s" c (thread-id *current-process*))))))
545    (loop for thread in  (connection-threads conn)
546       do (process-interrupt (thread-process thread) #'exit-repl)))
547  (let* ((timeout 0.05)
548         (end (+ (get-internal-real-time) (* timeout internal-time-units-per-second))))
549    (process-wait "closing connection"
550      (lambda ()
551        (or (null (%connection-threads conn)) (> (get-internal-real-time) end)))))
552  (when (%connection-threads conn)
553    (warn-and-log "Wasn't able to close these threads: ~s" (connection-threads conn)))
554
555  (close (connection-control-stream conn)))
556
557
558;; This is only called when this lisp receives an interrupt signal.
559(defun select-interactive-process ()
560  (when *global-debugger*
561    (loop for conn in (with-swink-lock () (copy-list *server-connections*))
562      do (loop for thread in (connection-threads conn)
563           when (thread-io thread) ;; still active
564           do (return-from select-interactive-process (thread-process thread))))))
565
566(defun send-event-for-value (target event &key abort-event (semaphore (make-semaphore)))
567  (let* ((returned nil)
568         (return-values nil)
569         (tag nil)
570         (conn (thread-connection target)))
571    (unwind-protect
572        (progn
573          (setq tag (tag-callback conn (lambda (completed? &rest values)
574                                         (setq returned t)
575                                         (when completed?
576                                           ;; Just return 0 values if cancelled.
577                                           (setq return-values values))
578                                         (signal-semaphore semaphore))))
579          ;; In server case, :target is nil,
580          (send-event target `(,@event ,tag))
581          (let ((current-thread (find-thread conn *current-process* :key #'thread-control-process)))
582            (if current-thread ;; if in repl thread, handle thread events while waiting.
583              (with-event-handling (current-thread)
584                (wait-on-semaphore semaphore))
585              (wait-on-semaphore semaphore)))
586          (apply #'values return-values))
587      (when (and tag (not returned))
588        (remove-tag conn tag)
589        (when (and abort-event (not returned))
590          ;; inform the other side that not waiting any more.
591          (send-event-if-open conn `(,@abort-event ,tag)))))))
592
593
594(defmethod get-remote-user-input ((thread server-thread))
595  ;; Usually this is called from a repl evaluation, but the user could have passed the stream to
596  ;; any other process, so we could be running anywhere.  Thread is the thread of the stream.
597  (with-simple-restart (abort-read "Abort reading")
598    (let ((conn (thread-connection thread)))
599      (force-output (thread-io thread))
600      (send-event-for-value conn `(:read-string ,thread) :abort-event `(:abort-read ,thread)))))
601
602
603(defmethod send-remote-user-output ((thread server-thread) string start end)
604  (let ((conn (thread-connection thread)))
605    (send-event conn `(:write-string ,thread ,(string-segment string start end)))))
606
607(defun swink-repl (conn break-level toplevel-loop)
608  (let* ((thread (make-new-thread conn))
609         (in (make-input-stream thread #'get-remote-user-input))
610         (out (make-output-stream thread #'send-remote-user-output))
611         (io (make-two-way-stream in out))
612         (ui-object (ccl::process-ui-object *current-process*)))
613    (assert (null (thread-io thread)))
614    (with-simple-restart (exit-repl "Exit remote read loop")
615      (unwind-protect
616          (let* ((*current-server-thread* thread)
617                 (*standard-input* in)
618                 (*standard-output* out)
619                 (*trace-output* out)
620                 (*debug-io* io)
621                 (*query-io* io)
622                 (*terminal-io* io)
623                 (ccl::*break-level* 0)
624                 (ccl::*read-loop-function* 'swink-read-loop))
625            (setf (ccl::process-ui-object *current-process*) thread)
626            (setf (thread-io thread) io)
627            (ccl:add-auto-flush-stream out)
628            (send-event conn `(:start-repl ,break-level))
629            (funcall toplevel-loop))
630        ;; Do we need this?  We've already exited from the outermost level...
631        (send-event-if-open conn `(:exit-repl))
632        (ccl:remove-auto-flush-stream out)
633        (setf (ccl::process-ui-object *current-process*) ui-object)
634        (setf (thread-io thread) nil)
635        (close in :abort t)
636        (close out :abort t)
637        (with-connection-lock (conn)
638          (setf (%connection-threads conn) (delq thread (%connection-threads conn))))))))
639
640
641(defclass repl-process (process) ())
642
643(defun spawn-repl (conn name)
644  (process-run-function `(:name ,name :class repl-process)
645    (lambda ()
646      (swink-repl conn 0 #'ccl::toplevel-loop))))
647
648;; Invoked for a break in a non-repl process (can only happen if using swink globally).
649(defun swink-debugger-hook (condition hook)
650  (declare (ignore hook))
651  (when (eq ccl::*read-loop-function* 'swink-read-loop)
652    (return-from swink-debugger-hook nil))
653  (let ((conn (connection-for-process *current-process*)))
654    ;; TODO: set up a restart to pick a different connection, if there is more than one.
655    (when conn
656      (swink-repl conn 1 (lambda ()
657                           (ccl::%break-message ccl::*break-loop-type* condition)
658                           ;; Like toplevel-loop but run break-loop to set up error context first
659                           (loop
660                             (catch :toplevel
661                               (ccl::break-loop condition))
662                             (when (eq *current-process* ccl::*initial-process*)
663                               (toplevel))))))))
664
665(defun marshall-debugger-context (context)
666  ;; TODO: neither :GO nor cmd-/ pay attention to the break condition, whereas bt.restarts does...
667  (let* ((continuable (ccl::backtrace-context-continuable-p context))
668         (restarts (ccl::backtrace-context-restarts context))
669         (tcr (ccl::bt.tcr context))
670         ;; Context for printing stack-consed refs
671         #-arm-target                   ;no TSP on ARM
672         (ccl::*aux-tsp-ranges* (ccl::make-tsp-stack-range tcr context))
673         (ccl::*aux-vsp-ranges* (ccl::make-vsp-stack-range tcr context))
674         (ccl::*aux-csp-ranges* (ccl::make-csp-stack-range tcr context))
675         (break-level (ccl::bt.break-level context)))
676    (list :break-level break-level
677          :continuable-p (and continuable t)
678          :restarts (mapcar #'princ-to-string restarts))))
679 
680(defvar *bt-context* nil)
681
682(defun swink-read-loop (&key (break-level 0) &allow-other-keys)
683  (let* ((thread *current-server-thread*)
684         (conn (thread-connection thread))
685         (ccl::*break-level* break-level)
686         (*loading-file-source-file* nil)
687         (ccl::*loading-toplevel-location* nil)
688         (*bt-context* (find break-level ccl::*backtrace-contexts* :key #'ccl::backtrace-context-break-level))
689         *** ** * +++ ++ + /// // / -)
690    (when *bt-context*
691      (send-event conn `(:enter-break ,(marshall-debugger-context *bt-context*))))
692
693    (flet ((repl-until-abort ()
694             (restart-case
695                 (catch :abort
696                   (catch-cancel
697                    ;; everything is done via interrupts ...
698                    (with-event-handling (thread)
699                      (loop (sleep 60)))))
700               (abort ()
701                 :report (lambda (stream)
702                           (if (eq break-level 0)
703                             (format stream "Return to toplevel")
704                             (format stream "Return to break level ~D" break-level)))
705                 nil)
706               (abort-break () (unless (eql break-level 0) (abort))))))
707      (unwind-protect
708          (loop
709            (repl-until-abort)
710            (clear-input)
711            (terpri)
712            (send-event conn `(:read-loop ,break-level)))
713        (send-event-if-open conn `(:debug-return ,break-level))))))
714
715(defmacro with-return-values ((conn remote-tag &body abort-forms) &body body)
716  (let ((ok-var (gensym))
717        (tag-var (gensym))
718        (conn-var (gensym)))
719    `(let ((,ok-var nil) (,conn-var ,conn) (,tag-var ,remote-tag))
720       (send-event ,conn-var `(:return ,,tag-var
721                                       ,@(unwind-protect
722                                             (prog1 (progn ,@body) (setq ,ok-var t))
723                                           (unless ,ok-var
724                                             (send-event-if-open ,conn-var `(:cancel-return ,,tag-var))
725                                             ,@abort-forms)))))))
726
727
728;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
729;;
730;; inspector support.
731
732(defmethod ccl::ui-object-do-operation ((o server-ui-object) (operation (eql :inspect)) &rest args)
733  (let ((conn (connection-for-process *current-process*)))
734    (if conn
735      (apply #'remote-inspect conn args)
736      (call-next-method))))
737
738(defvar $inspector-segment-size 100)
739
740(defstruct (icell (:constructor %make-icell))
741  inspector
742  string
743  count
744  (segments nil) ;; line inspectors, in equal-sized segments.
745  (process *current-process*))
746
747(defmethod marshall-argument ((conn connection) (icell icell))
748  ;; Send the count and string since they need that right away anyhow.
749  (list* (tag-object conn icell) (icell-count icell) (icell-string icell)))
750
751(defun make-icell (inspector)
752  (let* ((count (or (inspector::inspector-line-count inspector)
753                    (inspector::update-line-count inspector)))
754         (seg-size (min count $inspector-segment-size)))
755    (%make-icell :inspector inspector
756                 :count count
757                 :string (inspector::inspector-object-string inspector)
758                 :segments (and (> seg-size 0) ;; pre-reserve the initial segment.
759                                (list (cons 0 seg-size))))))
760
761(defun icell-seg-size (icell)
762  (length (cdar (icell-segments icell))))
763
764(defun iseg-end (seg)
765  (destructuring-bind (start . ln) seg
766    (+ start (if (integerp ln) ln (length ln)))))
767
768(defun compute-lines (icell seg)
769  (let* ((inspector::*inspector-disassembly* t)
770         (inspector (icell-inspector icell))
771         (start-index (car seg))
772         (seg-count (cdr seg)))
773    (unless (integerp seg-count)
774      (warn-and-log "Duplicate request for ~s line ~s" icell seg)
775      (setq seg-count (length seg-count)))
776    (let ((strings (make-array seg-count))
777          (lines (make-array seg-count)))
778      (loop for index from 0 below seg-count
779            do (multiple-value-bind (line-inspector label-string value-string)
780                                    (inspector::inspector-line inspector (+ start-index index))
781                 (setf (aref lines index) line-inspector)
782                 (setf (aref strings index) (cons label-string value-string))))
783      (setf (cdr seg) lines)
784      strings)))
785
786(defmethod remote-inspect ((conn server-connection) thing)
787  (let* ((inspector (let ((inspector::*inspector-disassembly* t))
788                      (inspector::make-inspector thing)))
789         (icell (make-icell inspector)))
790    (send-event conn `(:inspect ,icell))
791    (when (icell-segments icell)
792      (send-inspector-data conn icell))
793    thing))
794
795(defun send-inspector-data (conn icell &optional (seg (car (icell-segments icell))))
796  (let ((strings (compute-lines icell seg)))
797    (send-event conn `(:inspector-data ,(object-tag conn icell) (,(car seg) . ,strings))))
798  ;; arrange to send the rest later
799  (enqueue-internal-request conn `(maybe-send-inspector-data ,icell)))
800
801;; Segment management.
802;; Only the control process messes with icell-segments, so don't need to lock.
803(defun reserve-next-segment (icell)
804  (let* ((segments (icell-segments icell))
805         (count (icell-count icell))
806         (gapptr nil))
807    (loop for last = nil then segs as segs = segments then (cdr segs) while segs
808      when (and last (> (caar last) (iseg-end (car segs)))) do (setq gapptr last))
809    (when gapptr
810      (setq count (caar gapptr) segments (cdr gapptr)))
811    (let* ((start-index (iseg-end (car segments)))
812           (seg-size (min (icell-seg-size icell) (- count start-index)))
813           (new (and (> seg-size 0) (cons start-index seg-size))))
814      ;; gapptr = ((5000 . line) (200 . line) ... (0 . line))
815      (when new
816        (if (null gapptr)
817          (setf (icell-segments icell) (cons new segments))
818          (setf (cdr gapptr) (cons new segments)))
819        new))))
820
821;; Returns NIL if already reserved
822(defun reserve-segment-for-index (icell index)
823  (let* ((seg-size (icell-seg-size icell))
824         (seg-start (- index (mod index seg-size))))
825    (loop for last = nil then segs as segs = (icell-segments icell) then (cdr segs)
826      while (< seg-start (caar segs)) ;; last seg is always 0.
827      finally (return (unless (eql seg-start (caar segs)) ;; already exists.
828                        (let ((this-end (iseg-end (car segs)))
829                              (new (cons seg-start seg-size)))
830                          (assert (>= seg-start this-end))
831                          (if (null last)
832                            (push new (icell-segments icell))
833                            (push new (cdr last)))
834                          new))))))
835
836(defun icell-line-inspector (icell index)
837  (loop for seg in (icell-segments icell)
838    when (and (<= (car seg) index) (< index (iseg-end seg)))
839    return (and (vectorp (cdr seg)) (aref (cdr seg) (- index (car seg))))))
840
841(defun maybe-send-inspector-data (conn icell &optional (seg (car (icell-segments icell))))
842  (when seg
843    (let* ((process (icell-process icell))
844           (thread (ccl::process-ui-object process)))
845      (if (typep thread 'server-thread)
846        ;; Why not just interrupt like any random process?
847        (signal-event thread `(send-inspector-data ,icell ,seg))
848        (process-interrupt process #'send-inspector-data conn icell seg)))))
849
850(defmethod handle-event ((conn server-connection) event)
851  (log-event "handle-event (global): ~s" event)
852  (destructure-case event
853
854    ((:end-connection condition)
855     (declare (ignore condition))
856     (close-connection conn))
857
858    ((:spawn-repl name)
859     (spawn-repl conn name))
860
861    ((:return local-tag &rest values)
862     (apply #'invoke-callback conn local-tag values))
863
864    ((:connection-info remote-tag)
865     (with-return-values (conn remote-tag)
866       (list `(:pid ,(ccl::getpid)
867                    :lisp-implementation-type ,(lisp-implementation-type)
868                    :lisp-implementation-version ,(lisp-implementation-version)
869                    :machine-instance ,(machine-instance)
870                    :machine-type ,(machine-type)
871                    :machine-version ,(machine-version)))))
872
873    ((:describe-more icell-tag index)
874     (let* ((icell (tagged-object conn icell-tag :keep-tagged t))
875            (seg (reserve-segment-for-index icell index)))
876       (when seg
877         (maybe-send-inspector-data conn icell seg))))
878
879    ((:line-inspector icell-tag index return-tag)
880     (let ((new-icell nil))
881       (with-return-values (conn return-tag)
882         (let* ((icell (tagged-object conn icell-tag :keep-tagged t))
883                (line-inspector  (or (icell-line-inspector icell index)
884                                     (error "Requesting undescribed line ~s ~s" icell index))))
885           (setq new-icell (make-icell line-inspector))
886           (list new-icell)))
887       (maybe-send-inspector-data conn new-icell)))
888
889    ((:refresh-inspector icell-tag return-tag)
890     (let ((new-icell nil))
891       (with-return-values (conn return-tag)
892         (let* ((icell (tagged-object conn icell-tag :keep-tagged t))
893                (new-inspector (inspector::refresh-inspector (icell-inspector icell))))
894           (setq new-icell (make-icell new-inspector))
895           (list new-icell)))
896       (maybe-send-inspector-data conn new-icell)))
897
898    ((:inspecting-item icell-tag)
899     (loop with icell = (tagged-object conn icell-tag :keep-tagged t)
900       for thread in (connection-threads conn)
901       when (thread-io thread)
902       do (signal-event thread `(inspecting-item ,icell))))
903
904    ;; Internal event to send data in segments so it's interruptible
905    ((maybe-send-inspector-data icell)
906     (let ((seg (reserve-next-segment icell)))
907       (when seg
908         (maybe-send-inspector-data conn icell seg))))
909
910    #+remote-eval
911    ((:eval form)
912       ;; It's the caller's responsibility to make this quick...  If they want return values
913       ;; or whatever, they can put that in the form.
914       (eval form))))
915 
916
917;; TODO: toplevel-eval checks package change and invokes application-ui-operation, need to send that back.
918
919
920;; Eval all forms in string without printing intermediate results
921(defun read-eval-all-print-last (string package-name)
922  (if package-name
923    (let ((*package* (or (find-package package-name) *package*)))
924      (read-eval-all-print-last string nil))
925    (with-input-from-string (sstream string)
926      (let ((values nil))
927        (loop
928          (let ((form (ccl::read-toplevel-form sstream :eof-value sstream)))
929            (when (eq form sstream)
930              (ccl::toplevel-print values)
931              (force-output)
932              (return))
933            (unless (ccl::check-toplevel-command form)
934              (setq values (ccl::toplevel-eval form nil))
935              (setq /// // // / / values)
936              (unless (eq (car values) (ccl::%unbound-marker))
937                (setq *** ** ** * *  (car values))))))
938        (values)))))
939
940
941(defun read-eval-print-one (conn sstream package)
942  (if package
943    (let ((*package* package))
944      (read-eval-print-one conn sstream nil))
945    (let ((form (ccl::read-toplevel-form sstream :eof-value sstream)))
946      (unless (eq form sstream)
947        (unless (ccl::check-toplevel-command form)
948          (ccl::toplevel-print (ccl::toplevel-eval form nil))))
949      (cond ((listen sstream)
950             (tag-object conn (cons sstream package)))
951            (t
952             (close sstream)
953             nil)))))
954
955
956;; Events from client to specific thread.  This is running at a safe point inside a repl thread.
957(defmethod handle-event ((thread thread) event)
958  (log-event "handle-event (thread ~s): ~s" (process-serial-number *current-process*) event)
959  (let ((conn (thread-connection thread)))
960    (destructure-case event
961     
962      ((:read-eval-all-print-last string package-name remote-tag)
963       (with-return-values (conn remote-tag)
964         (read-eval-all-print-last string package-name)))
965     
966      ((:read-eval-print-one string package-name remote-tag)
967       (let* ((sstream (make-string-input-stream string))
968              (package (and package-name (or (find-package package-name) *package*))))
969         (with-return-values (conn remote-tag (close sstream))
970           (read-eval-print-one conn sstream package))))
971     
972      ((:read-eval-print-next state remote-tag)
973       (destructuring-bind (sstream . package) (tagged-object conn state)
974         (with-return-values (conn remote-tag (close sstream))
975           (read-eval-print-one conn sstream package))))
976
977      ;; Internal events
978      ((send-inspector-data icell seg)
979       (send-inspector-data conn icell seg))
980      ((inspecting-item icell)
981       (inspector::note-inspecting-item (icell-inspector icell)))
982
983      ((:interrupt)
984       (ccl::force-break-in-listener *current-process*))
985
986      ((:invoke-restart restart-name)
987       (invoke-restart restart-name))
988     
989      ((:invoke-restart-in-context index)
990       (invoke-restart-interactively (nth index (ccl::backtrace-context-restarts *bt-context*))))
991
992      ((:toplevel)
993       (toplevel)))))
994
995(let (using-swink-globally select-hook debugger-hook break-hook ui-object)
996  (defun use-swink-globally (yes-or-no)
997    (log-event "use-swink-globally: ~s" yes-or-no)
998    (if yes-or-no
999      (unless using-swink-globally
1000        (setq select-hook *select-interactive-process-hook*)
1001        (setq *select-interactive-process-hook*
1002              (if select-hook
1003                (lambda () (or (select-interactive-process) (funcall select-hook)))
1004                'select-interactive-process))
1005        (setq debugger-hook *debugger-hook*)
1006        (setq *debugger-hook*
1007              (if debugger-hook
1008                (lambda (condition hook)
1009                  (swink-debugger-hook condition hook)
1010                  (funcall debugger-hook condition hook))
1011                'swink-debugger-hook))
1012        (setq break-hook *break-hook*)
1013        (setq *break-hook*
1014              (if break-hook
1015                (lambda (condition hook)
1016                  (swink-debugger-hook condition hook)
1017                  (funcall break-hook condition hook))
1018                'swink-debugger-hook))
1019        ;; This probably should be controlled by something other than use-swink-globally because
1020        ;; might want to use gui inspector even if not using global debugger.
1021        (setq ui-object (ccl::application-ui-object *application*))
1022        (setf (ccl::application-ui-object *application*) (make-instance 'server-ui-object))
1023        (setq using-swink-globally t))
1024      (when using-swink-globally
1025        (setf *select-interactive-process-hook* select-hook
1026              *debugger-hook* debugger-hook
1027              *break-hook* break-hook
1028              (ccl::application-ui-object *application*) ui-object)
1029        (setq using-swink-globally nil)))))
1030
1031
1032;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1033
1034;; Simple buffered stream with a user input/output function.
1035(defclass swink-stream ()
1036  ((thread :initarg :thread :reader stream-thread)
1037   (lock :initform (make-lock))
1038   (buffer :initform "" :initarg :buffer)
1039   (index :initform 0)
1040   (column :initform 0 :reader stream-line-column)
1041   (line-length :initform ccl::*default-right-margin* :accessor stream-line-length)))
1042 
1043(defmethod stream-thread ((stream two-way-stream))
1044  (stream-thread (two-way-stream-input-stream stream)))
1045
1046(defmethod stream-thread ((stream stream))
1047  nil)
1048
1049
1050(defmacro with-swink-stream (slots stream &body body)
1051  `(with-slots (lock ,@slots) ,stream
1052     (with-lock-grabbed (lock)
1053       ,@body)))
1054
1055(defclass swink-output-stream (swink-stream fundamental-character-output-stream)
1056  ((output-fn :initarg :output-fn)
1057   (buffer :initform (make-string 8000) :initarg :buffer)))
1058
1059(defun make-output-stream (thread output-fn)
1060  (make-instance 'swink-output-stream :thread thread :output-fn output-fn))
1061
1062(defun output-stream-output (stream string start end)
1063  (with-slots (output-fn thread) stream
1064    (let ((conn (thread-connection thread)))
1065      (handler-bind ((stream-error (lambda (c)
1066                                     (when (eql (stream-error-stream c)
1067                                                (connection-control-stream conn))
1068                                       (with-slots (ccl::stream) c
1069                                         (setf ccl::stream stream))))))
1070        (funcall output-fn thread string start end)))))
1071
1072
1073(defmethod flush-buffer ((stream swink-output-stream)) ;; called with lock hold
1074  (with-slots (buffer index) stream
1075    (unless (eql index 0)
1076      (output-stream-output stream buffer 0 index)
1077      (setf index 0))))
1078
1079(defmethod stream-write-char ((stream swink-output-stream) char)
1080  (with-swink-stream (buffer index column) stream
1081    (when (eql index (length buffer))
1082      (flush-buffer stream))
1083    (setf (schar buffer index) char)
1084    (incf index)
1085    (if (eql char #\newline)
1086      (setf column 0)
1087      (incf column)))
1088  char)
1089
1090(defmethod stream-write-string ((stream swink-output-stream) string &optional start end)
1091  (with-swink-stream (buffer index column) stream
1092    (let* ((len (length buffer))
1093           (start (or start 0))
1094           (end (ccl::check-sequence-bounds string start end))
1095           (count (- end start))
1096           (free (- len index)))
1097      (when (>= count free)
1098        (flush-buffer stream))
1099      (cond ((< count len)
1100             (replace buffer string :start1 index :start2 start :end2 end)
1101             (incf index count))
1102            (t (output-stream-output stream string start end)))
1103      (let ((last-newline (position #\newline string :from-end t
1104                                    :start start :end end)))
1105        (setf column (if last-newline 
1106                       (- end last-newline 1)
1107                       (+ column count))))))
1108  string)
1109
1110(defmethod stream-force-output ((stream swink-output-stream))
1111  (with-swink-stream () stream
1112    (flush-buffer stream)))
1113
1114(defmethod ccl::stream-finish-output ((stream swink-output-stream))
1115  (stream-force-output stream))
1116
1117(defclass swink-input-stream (swink-stream fundamental-character-input-stream)
1118  ((input-fn :initarg :input-fn)))
1119
1120(defun make-input-stream (thread input-fn)
1121  (make-instance 'swink-input-stream :thread thread :input-fn input-fn))
1122
1123(defun input-stream-input (stream)
1124  (with-slots (input-fn thread) stream
1125    (let ((conn (thread-connection thread)))
1126      (handler-bind ((stream-error (lambda (c)
1127                                     (when (eql (stream-error-stream c)
1128                                                (connection-control-stream conn))
1129                                       (with-slots (ccl::stream) c
1130                                         (setf ccl::stream stream))))))
1131        (funcall input-fn thread)))))
1132
1133(defmethod stream-read-char ((stream swink-input-stream))
1134  (with-swink-stream (buffer index column) stream
1135    (unless (< index (length buffer))
1136      (let ((string (input-stream-input stream)))
1137        (cond ((eql (length string) 0)
1138               (return-from stream-read-char :eof))
1139              (t
1140               (setf buffer string  index 0)))))
1141    (let ((char (aref buffer index)))
1142      (incf index)
1143      (if (eql char #\Newline)
1144        (setf column 0)
1145        (incf column))
1146      char)))
1147
1148(defmethod stream-read-char-no-hang ((stream swink-input-stream))
1149  (with-swink-stream (buffer index column) stream
1150    (when (< index (length buffer))
1151      (let ((char (aref buffer index)))
1152        (incf index)
1153        (if (eql char #\Newline)
1154          (setf column 0)
1155          (incf column))
1156        char))))
1157
1158(defmethod stream-listen ((stream swink-input-stream))
1159  (with-swink-stream (buffer index) stream
1160    (< index (length buffer))))
1161
1162(defmethod stream-unread-char ((stream swink-input-stream) char)
1163  (with-swink-stream (buffer index) stream
1164    (if (eql (length buffer) 0) ;; perhaps did clear-input.
1165      (setf buffer (make-string 1 :initial-element char))
1166      (if (> index 0)
1167        (decf index)
1168        (error "Unread with no preceeding read")))))
1169
1170(defmethod stream-clear-input ((stream swink-input-stream))
1171  (with-swink-stream (buffer index) stream
1172    (setf buffer "" index 0))
1173  nil)
1174
1175
1176
Note: See TracBrowser for help on using the repository browser.