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

Last change on this file since 16377 was 16377, checked in by svspire, 5 years ago

Fixed bug in #'stop-server; added #'stop-all-servers.

File size: 46.3 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     "STOP-ALL-SERVERS"
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* port)))
483      t)))
484
485(defun stop-all-servers ()
486  "Stop all swink servers"
487  (loop for info on *listener-sockets* by #'cddr do
488    (stop-server (car info))))
489
490(defun enqueue-internal-request (conn event)
491  (with-connection-lock (conn)
492    (push (cons nil event) (connection-internal-requests conn))))
493
494(defmethod read-sexp ((conn server-connection))
495  (if (and (connection-internal-requests conn)
496           ;; Remote always takes priority
497           (not (stream-listen (connection-control-stream conn))))
498      (with-connection-lock (conn) (pop (connection-internal-requests conn)))
499      (call-next-method)))
500
501(defun server-event-loop (conn)
502  (loop
503    (let ((thread.event (read-sexp conn)))
504      (log-event "received: ~s" thread.event)
505      (destructuring-bind (thread-id . event) thread.event
506        (if thread-id
507          (let ((thread (find-thread conn thread-id)))
508            (when thread
509              (signal-event thread event)))
510          (handle-event conn event))))))
511
512(defun spawn-server-connection (stream)
513  (let ((conn (make-instance 'server-connection :control-stream stream))
514        (startup-signal (make-semaphore)))
515    (setf (connection-control-process conn)
516          (process-run-function (format nil "swink-event-loop@~s" (local-port stream))
517            (lambda ()
518              (unwind-protect
519                   (with-simple-restart (close-connection "Exit server")
520                     (setf (connection-control-process conn) *current-process*)
521                     (handler-bind ((error (lambda (c)
522                                             (log-event "Error: ~a" c)
523                                             (log-event "Backtrace: ~%~a"
524                                                        (ignore-errors
525                                                         (with-output-to-string (s)
526                                                           (print-call-history :detailed-p nil :stream s :print-length 20 :print-level 4))))
527                                             (invoke-restart 'close-connection))))
528                       (when startup-signal (signal-semaphore startup-signal))
529                       (server-event-loop conn)))
530                (control-process-cleanup conn)))))
531    (wait-on-semaphore startup-signal)
532    (with-swink-lock () (push conn *server-connections*))
533    (when *global-debugger*
534      (use-swink-globally t))
535    conn))
536
537;; Note this happens in an unwind-protect, so is without interrupts.  But we've pretty much
538;; returned to top level and hold no locks.
539(defun control-process-cleanup (conn)
540  (with-swink-lock ()
541    (setq *server-connections* (delq conn *server-connections*))
542    (when (null *server-connections*) (use-swink-globally nil)))
543  (flet ((exit-repl ()
544           ;; While exiting, threads may attempt to write to the connection.  That's good, if the
545           ;; connection is still alive and we're attempting an orderly exit.  Don't go into a spiral
546           ;; if the connection is dead.  Once we get any kind of error, just punt.
547           (log-event "Start exit-repl in ~s" (thread-id *current-process*))
548           (handler-case  (invoke-restart-if-active 'exit-repl)
549             (error (c) (log-event "Exit repl error ~a in ~s" c (thread-id *current-process*))))))
550    (loop for thread in  (connection-threads conn)
551       do (process-interrupt (thread-process thread) #'exit-repl)))
552  (let* ((timeout 0.05)
553         (end (+ (get-internal-real-time) (* timeout internal-time-units-per-second))))
554    (process-wait "closing connection"
555      (lambda ()
556        (or (null (%connection-threads conn)) (> (get-internal-real-time) end)))))
557  (when (%connection-threads conn)
558    (warn-and-log "Wasn't able to close these threads: ~s" (connection-threads conn)))
559
560  (close (connection-control-stream conn)))
561
562
563;; This is only called when this lisp receives an interrupt signal.
564(defun select-interactive-process ()
565  (when *global-debugger*
566    (loop for conn in (with-swink-lock () (copy-list *server-connections*))
567      do (loop for thread in (connection-threads conn)
568           when (thread-io thread) ;; still active
569           do (return-from select-interactive-process (thread-process thread))))))
570
571(defun send-event-for-value (target event &key abort-event (semaphore (make-semaphore)))
572  (let* ((returned nil)
573         (return-values nil)
574         (tag nil)
575         (conn (thread-connection target)))
576    (unwind-protect
577        (progn
578          (setq tag (tag-callback conn (lambda (completed? &rest values)
579                                         (setq returned t)
580                                         (when completed?
581                                           ;; Just return 0 values if cancelled.
582                                           (setq return-values values))
583                                         (signal-semaphore semaphore))))
584          ;; In server case, :target is nil,
585          (send-event target `(,@event ,tag))
586          (let ((current-thread (find-thread conn *current-process* :key #'thread-control-process)))
587            (if current-thread ;; if in repl thread, handle thread events while waiting.
588              (with-event-handling (current-thread)
589                (wait-on-semaphore semaphore))
590              (wait-on-semaphore semaphore)))
591          (apply #'values return-values))
592      (when (and tag (not returned))
593        (remove-tag conn tag)
594        (when (and abort-event (not returned))
595          ;; inform the other side that not waiting any more.
596          (send-event-if-open conn `(,@abort-event ,tag)))))))
597
598
599(defmethod get-remote-user-input ((thread server-thread))
600  ;; Usually this is called from a repl evaluation, but the user could have passed the stream to
601  ;; any other process, so we could be running anywhere.  Thread is the thread of the stream.
602  (with-simple-restart (abort-read "Abort reading")
603    (let ((conn (thread-connection thread)))
604      (force-output (thread-io thread))
605      (send-event-for-value conn `(:read-string ,thread) :abort-event `(:abort-read ,thread)))))
606
607
608(defmethod send-remote-user-output ((thread server-thread) string start end)
609  (let ((conn (thread-connection thread)))
610    (send-event conn `(:write-string ,thread ,(string-segment string start end)))))
611
612(defun swink-repl (conn break-level toplevel-loop)
613  (let* ((thread (make-new-thread conn))
614         (in (make-input-stream thread #'get-remote-user-input))
615         (out (make-output-stream thread #'send-remote-user-output))
616         (io (make-two-way-stream in out))
617         (ui-object (ccl::process-ui-object *current-process*)))
618    (assert (null (thread-io thread)))
619    (with-simple-restart (exit-repl "Exit remote read loop")
620      (unwind-protect
621          (let* ((*current-server-thread* thread)
622                 (*standard-input* in)
623                 (*standard-output* out)
624                 (*trace-output* out)
625                 (*debug-io* io)
626                 (*query-io* io)
627                 (*terminal-io* io)
628                 (ccl::*break-level* 0)
629                 (ccl::*read-loop-function* 'swink-read-loop))
630            (setf (ccl::process-ui-object *current-process*) thread)
631            (setf (thread-io thread) io)
632            (ccl:add-auto-flush-stream out)
633            (send-event conn `(:start-repl ,break-level))
634            (funcall toplevel-loop))
635        ;; Do we need this?  We've already exited from the outermost level...
636        (send-event-if-open conn `(:exit-repl))
637        (ccl:remove-auto-flush-stream out)
638        (setf (ccl::process-ui-object *current-process*) ui-object)
639        (setf (thread-io thread) nil)
640        (close in :abort t)
641        (close out :abort t)
642        (with-connection-lock (conn)
643          (setf (%connection-threads conn) (delq thread (%connection-threads conn))))))))
644
645
646(defclass repl-process (process) ())
647
648(defun spawn-repl (conn name)
649  (process-run-function `(:name ,name :class repl-process)
650    (lambda ()
651      (swink-repl conn 0 #'ccl::toplevel-loop))))
652
653;; Invoked for a break in a non-repl process (can only happen if using swink globally).
654(defun swink-debugger-hook (condition hook)
655  (declare (ignore hook))
656  (when (eq ccl::*read-loop-function* 'swink-read-loop)
657    (return-from swink-debugger-hook nil))
658  (let ((conn (connection-for-process *current-process*)))
659    ;; TODO: set up a restart to pick a different connection, if there is more than one.
660    (when conn
661      (swink-repl conn 1 (lambda ()
662                           (ccl::%break-message ccl::*break-loop-type* condition)
663                           ;; Like toplevel-loop but run break-loop to set up error context first
664                           (loop
665                             (catch :toplevel
666                               (ccl::break-loop condition))
667                             (when (eq *current-process* ccl::*initial-process*)
668                               (toplevel))))))))
669
670(defun marshall-debugger-context (context)
671  ;; TODO: neither :GO nor cmd-/ pay attention to the break condition, whereas bt.restarts does...
672  (let* ((continuable (ccl::backtrace-context-continuable-p context))
673         (restarts (ccl::backtrace-context-restarts context))
674         (tcr (ccl::bt.tcr context))
675         ;; Context for printing stack-consed refs
676         #-arm-target                   ;no TSP on ARM
677         (ccl::*aux-tsp-ranges* (ccl::make-tsp-stack-range tcr context))
678         (ccl::*aux-vsp-ranges* (ccl::make-vsp-stack-range tcr context))
679         (ccl::*aux-csp-ranges* (ccl::make-csp-stack-range tcr context))
680         (break-level (ccl::bt.break-level context)))
681    (list :break-level break-level
682          :continuable-p (and continuable t)
683          :restarts (mapcar #'princ-to-string restarts))))
684 
685(defvar *bt-context* nil)
686
687(defun swink-read-loop (&key (break-level 0) &allow-other-keys)
688  (let* ((thread *current-server-thread*)
689         (conn (thread-connection thread))
690         (ccl::*break-level* break-level)
691         (*loading-file-source-file* nil)
692         (ccl::*loading-toplevel-location* nil)
693         (*bt-context* (find break-level ccl::*backtrace-contexts* :key #'ccl::backtrace-context-break-level))
694         *** ** * +++ ++ + /// // / -)
695    (when *bt-context*
696      (send-event conn `(:enter-break ,(marshall-debugger-context *bt-context*))))
697
698    (flet ((repl-until-abort ()
699             (restart-case
700                 (catch :abort
701                   (catch-cancel
702                    ;; everything is done via interrupts ...
703                    (with-event-handling (thread)
704                      (loop (sleep 60)))))
705               (abort ()
706                 :report (lambda (stream)
707                           (if (eq break-level 0)
708                             (format stream "Return to toplevel")
709                             (format stream "Return to break level ~D" break-level)))
710                 nil)
711               (abort-break () (unless (eql break-level 0) (abort))))))
712      (unwind-protect
713          (loop
714            (repl-until-abort)
715            (clear-input)
716            (terpri)
717            (send-event conn `(:read-loop ,break-level)))
718        (send-event-if-open conn `(:debug-return ,break-level))))))
719
720(defmacro with-return-values ((conn remote-tag &body abort-forms) &body body)
721  (let ((ok-var (gensym))
722        (tag-var (gensym))
723        (conn-var (gensym)))
724    `(let ((,ok-var nil) (,conn-var ,conn) (,tag-var ,remote-tag))
725       (send-event ,conn-var `(:return ,,tag-var
726                                       ,@(unwind-protect
727                                             (prog1 (progn ,@body) (setq ,ok-var t))
728                                           (unless ,ok-var
729                                             (send-event-if-open ,conn-var `(:cancel-return ,,tag-var))
730                                             ,@abort-forms)))))))
731
732
733;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
734;;
735;; inspector support.
736
737(defmethod ccl::ui-object-do-operation ((o server-ui-object) (operation (eql :inspect)) &rest args)
738  (let ((conn (connection-for-process *current-process*)))
739    (if conn
740      (apply #'remote-inspect conn args)
741      (call-next-method))))
742
743(defvar $inspector-segment-size 100)
744
745(defstruct (icell (:constructor %make-icell))
746  inspector
747  string
748  count
749  (segments nil) ;; line inspectors, in equal-sized segments.
750  (process *current-process*))
751
752(defmethod marshall-argument ((conn connection) (icell icell))
753  ;; Send the count and string since they need that right away anyhow.
754  (list* (tag-object conn icell) (icell-count icell) (icell-string icell)))
755
756(defun make-icell (inspector)
757  (let* ((count (or (inspector::inspector-line-count inspector)
758                    (inspector::update-line-count inspector)))
759         (seg-size (min count $inspector-segment-size)))
760    (%make-icell :inspector inspector
761                 :count count
762                 :string (inspector::inspector-object-string inspector)
763                 :segments (and (> seg-size 0) ;; pre-reserve the initial segment.
764                                (list (cons 0 seg-size))))))
765
766(defun icell-seg-size (icell)
767  (length (cdar (icell-segments icell))))
768
769(defun iseg-end (seg)
770  (destructuring-bind (start . ln) seg
771    (+ start (if (integerp ln) ln (length ln)))))
772
773(defun compute-lines (icell seg)
774  (let* ((inspector::*inspector-disassembly* t)
775         (inspector (icell-inspector icell))
776         (start-index (car seg))
777         (seg-count (cdr seg)))
778    (unless (integerp seg-count)
779      (warn-and-log "Duplicate request for ~s line ~s" icell seg)
780      (setq seg-count (length seg-count)))
781    (let ((strings (make-array seg-count))
782          (lines (make-array seg-count)))
783      (loop for index from 0 below seg-count
784            do (multiple-value-bind (line-inspector label-string value-string)
785                                    (inspector::inspector-line inspector (+ start-index index))
786                 (setf (aref lines index) line-inspector)
787                 (setf (aref strings index) (cons label-string value-string))))
788      (setf (cdr seg) lines)
789      strings)))
790
791(defmethod remote-inspect ((conn server-connection) thing)
792  (let* ((inspector (let ((inspector::*inspector-disassembly* t))
793                      (inspector::make-inspector thing)))
794         (icell (make-icell inspector)))
795    (send-event conn `(:inspect ,icell))
796    (when (icell-segments icell)
797      (send-inspector-data conn icell))
798    thing))
799
800(defun send-inspector-data (conn icell &optional (seg (car (icell-segments icell))))
801  (let ((strings (compute-lines icell seg)))
802    (send-event conn `(:inspector-data ,(object-tag conn icell) (,(car seg) . ,strings))))
803  ;; arrange to send the rest later
804  (enqueue-internal-request conn `(maybe-send-inspector-data ,icell)))
805
806;; Segment management.
807;; Only the control process messes with icell-segments, so don't need to lock.
808(defun reserve-next-segment (icell)
809  (let* ((segments (icell-segments icell))
810         (count (icell-count icell))
811         (gapptr nil))
812    (loop for last = nil then segs as segs = segments then (cdr segs) while segs
813      when (and last (> (caar last) (iseg-end (car segs)))) do (setq gapptr last))
814    (when gapptr
815      (setq count (caar gapptr) segments (cdr gapptr)))
816    (let* ((start-index (iseg-end (car segments)))
817           (seg-size (min (icell-seg-size icell) (- count start-index)))
818           (new (and (> seg-size 0) (cons start-index seg-size))))
819      ;; gapptr = ((5000 . line) (200 . line) ... (0 . line))
820      (when new
821        (if (null gapptr)
822          (setf (icell-segments icell) (cons new segments))
823          (setf (cdr gapptr) (cons new segments)))
824        new))))
825
826;; Returns NIL if already reserved
827(defun reserve-segment-for-index (icell index)
828  (let* ((seg-size (icell-seg-size icell))
829         (seg-start (- index (mod index seg-size))))
830    (loop for last = nil then segs as segs = (icell-segments icell) then (cdr segs)
831      while (< seg-start (caar segs)) ;; last seg is always 0.
832      finally (return (unless (eql seg-start (caar segs)) ;; already exists.
833                        (let ((this-end (iseg-end (car segs)))
834                              (new (cons seg-start seg-size)))
835                          (assert (>= seg-start this-end))
836                          (if (null last)
837                            (push new (icell-segments icell))
838                            (push new (cdr last)))
839                          new))))))
840
841(defun icell-line-inspector (icell index)
842  (loop for seg in (icell-segments icell)
843    when (and (<= (car seg) index) (< index (iseg-end seg)))
844    return (and (vectorp (cdr seg)) (aref (cdr seg) (- index (car seg))))))
845
846(defun maybe-send-inspector-data (conn icell &optional (seg (car (icell-segments icell))))
847  (when seg
848    (let* ((process (icell-process icell))
849           (thread (ccl::process-ui-object process)))
850      (if (typep thread 'server-thread)
851        ;; Why not just interrupt like any random process?
852        (signal-event thread `(send-inspector-data ,icell ,seg))
853        (process-interrupt process #'send-inspector-data conn icell seg)))))
854
855(defmethod handle-event ((conn server-connection) event)
856  (log-event "handle-event (global): ~s" event)
857  (destructure-case event
858
859    ((:end-connection condition)
860     (declare (ignore condition))
861     (close-connection conn))
862
863    ((:spawn-repl name)
864     (spawn-repl conn name))
865
866    ((:return local-tag &rest values)
867     (apply #'invoke-callback conn local-tag values))
868
869    ((:connection-info remote-tag)
870     (with-return-values (conn remote-tag)
871       (list `(:pid ,(ccl::getpid)
872                    :lisp-implementation-type ,(lisp-implementation-type)
873                    :lisp-implementation-version ,(lisp-implementation-version)
874                    :machine-instance ,(machine-instance)
875                    :machine-type ,(machine-type)
876                    :machine-version ,(machine-version)))))
877
878    ((:describe-more icell-tag index)
879     (let* ((icell (tagged-object conn icell-tag :keep-tagged t))
880            (seg (reserve-segment-for-index icell index)))
881       (when seg
882         (maybe-send-inspector-data conn icell seg))))
883
884    ((:line-inspector icell-tag index return-tag)
885     (let ((new-icell nil))
886       (with-return-values (conn return-tag)
887         (let* ((icell (tagged-object conn icell-tag :keep-tagged t))
888                (line-inspector  (or (icell-line-inspector icell index)
889                                     (error "Requesting undescribed line ~s ~s" icell index))))
890           (setq new-icell (make-icell line-inspector))
891           (list new-icell)))
892       (maybe-send-inspector-data conn new-icell)))
893
894    ((:refresh-inspector icell-tag return-tag)
895     (let ((new-icell nil))
896       (with-return-values (conn return-tag)
897         (let* ((icell (tagged-object conn icell-tag :keep-tagged t))
898                (new-inspector (inspector::refresh-inspector (icell-inspector icell))))
899           (setq new-icell (make-icell new-inspector))
900           (list new-icell)))
901       (maybe-send-inspector-data conn new-icell)))
902
903    ((:inspecting-item icell-tag)
904     (loop with icell = (tagged-object conn icell-tag :keep-tagged t)
905       for thread in (connection-threads conn)
906       when (thread-io thread)
907       do (signal-event thread `(inspecting-item ,icell))))
908
909    ;; Internal event to send data in segments so it's interruptible
910    ((maybe-send-inspector-data icell)
911     (let ((seg (reserve-next-segment icell)))
912       (when seg
913         (maybe-send-inspector-data conn icell seg))))
914
915    #+remote-eval
916    ((:eval form)
917       ;; It's the caller's responsibility to make this quick...  If they want return values
918       ;; or whatever, they can put that in the form.
919       (eval form))))
920 
921
922;; TODO: toplevel-eval checks package change and invokes application-ui-operation, need to send that back.
923
924
925;; Eval all forms in string without printing intermediate results
926(defun read-eval-all-print-last (string package-name)
927  (if package-name
928    (let ((*package* (or (find-package package-name) *package*)))
929      (read-eval-all-print-last string nil))
930    (with-input-from-string (sstream string)
931      (let ((values nil))
932        (loop
933          (let ((form (ccl::read-toplevel-form sstream :eof-value sstream)))
934            (when (eq form sstream)
935              (ccl::toplevel-print values)
936              (force-output)
937              (return))
938            (unless (ccl::check-toplevel-command form)
939              (setq values (ccl::toplevel-eval form nil))
940              (setq /// // // / / values)
941              (unless (eq (car values) (ccl::%unbound-marker))
942                (setq *** ** ** * *  (car values))))))
943        (values)))))
944
945
946(defun read-eval-print-one (conn sstream package)
947  (if package
948    (let ((*package* package))
949      (read-eval-print-one conn sstream nil))
950    (let ((form (ccl::read-toplevel-form sstream :eof-value sstream)))
951      (unless (eq form sstream)
952        (unless (ccl::check-toplevel-command form)
953          (ccl::toplevel-print (ccl::toplevel-eval form nil))))
954      (cond ((listen sstream)
955             (tag-object conn (cons sstream package)))
956            (t
957             (close sstream)
958             nil)))))
959
960
961;; Events from client to specific thread.  This is running at a safe point inside a repl thread.
962(defmethod handle-event ((thread thread) event)
963  (log-event "handle-event (thread ~s): ~s" (process-serial-number *current-process*) event)
964  (let ((conn (thread-connection thread)))
965    (destructure-case event
966     
967      ((:read-eval-all-print-last string package-name remote-tag)
968       (with-return-values (conn remote-tag)
969         (read-eval-all-print-last string package-name)))
970     
971      ((:read-eval-print-one string package-name remote-tag)
972       (let* ((sstream (make-string-input-stream string))
973              (package (and package-name (or (find-package package-name) *package*))))
974         (with-return-values (conn remote-tag (close sstream))
975           (read-eval-print-one conn sstream package))))
976     
977      ((:read-eval-print-next state remote-tag)
978       (destructuring-bind (sstream . package) (tagged-object conn state)
979         (with-return-values (conn remote-tag (close sstream))
980           (read-eval-print-one conn sstream package))))
981
982      ;; Internal events
983      ((send-inspector-data icell seg)
984       (send-inspector-data conn icell seg))
985      ((inspecting-item icell)
986       (inspector::note-inspecting-item (icell-inspector icell)))
987
988      ((:interrupt)
989       (ccl::force-break-in-listener *current-process*))
990
991      ((:invoke-restart restart-name)
992       (invoke-restart restart-name))
993     
994      ((:invoke-restart-in-context index)
995       (invoke-restart-interactively (nth index (ccl::backtrace-context-restarts *bt-context*))))
996
997      ((:toplevel)
998       (toplevel)))))
999
1000(let (using-swink-globally select-hook debugger-hook break-hook ui-object)
1001  (defun use-swink-globally (yes-or-no)
1002    (log-event "use-swink-globally: ~s" yes-or-no)
1003    (if yes-or-no
1004      (unless using-swink-globally
1005        (setq select-hook *select-interactive-process-hook*)
1006        (setq *select-interactive-process-hook*
1007              (if select-hook
1008                (lambda () (or (select-interactive-process) (funcall select-hook)))
1009                'select-interactive-process))
1010        (setq debugger-hook *debugger-hook*)
1011        (setq *debugger-hook*
1012              (if debugger-hook
1013                (lambda (condition hook)
1014                  (swink-debugger-hook condition hook)
1015                  (funcall debugger-hook condition hook))
1016                'swink-debugger-hook))
1017        (setq break-hook *break-hook*)
1018        (setq *break-hook*
1019              (if break-hook
1020                (lambda (condition hook)
1021                  (swink-debugger-hook condition hook)
1022                  (funcall break-hook condition hook))
1023                'swink-debugger-hook))
1024        ;; This probably should be controlled by something other than use-swink-globally because
1025        ;; might want to use gui inspector even if not using global debugger.
1026        (setq ui-object (ccl::application-ui-object *application*))
1027        (setf (ccl::application-ui-object *application*) (make-instance 'server-ui-object))
1028        (setq using-swink-globally t))
1029      (when using-swink-globally
1030        (setf *select-interactive-process-hook* select-hook
1031              *debugger-hook* debugger-hook
1032              *break-hook* break-hook
1033              (ccl::application-ui-object *application*) ui-object)
1034        (setq using-swink-globally nil)))))
1035
1036
1037;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1038
1039;; Simple buffered stream with a user input/output function.
1040(defclass swink-stream ()
1041  ((thread :initarg :thread :reader stream-thread)
1042   (lock :initform (make-lock))
1043   (buffer :initform "" :initarg :buffer)
1044   (index :initform 0)
1045   (column :initform 0 :reader stream-line-column)
1046   (line-length :initform ccl::*default-right-margin* :accessor stream-line-length)))
1047 
1048(defmethod stream-thread ((stream two-way-stream))
1049  (stream-thread (two-way-stream-input-stream stream)))
1050
1051(defmethod stream-thread ((stream stream))
1052  nil)
1053
1054
1055(defmacro with-swink-stream (slots stream &body body)
1056  `(with-slots (lock ,@slots) ,stream
1057     (with-lock-grabbed (lock)
1058       ,@body)))
1059
1060(defclass swink-output-stream (swink-stream fundamental-character-output-stream)
1061  ((output-fn :initarg :output-fn)
1062   (buffer :initform (make-string 8000) :initarg :buffer)))
1063
1064(defun make-output-stream (thread output-fn)
1065  (make-instance 'swink-output-stream :thread thread :output-fn output-fn))
1066
1067(defun output-stream-output (stream string start end)
1068  (with-slots (output-fn thread) stream
1069    (let ((conn (thread-connection thread)))
1070      (handler-bind ((stream-error (lambda (c)
1071                                     (when (eql (stream-error-stream c)
1072                                                (connection-control-stream conn))
1073                                       (with-slots (ccl::stream) c
1074                                         (setf ccl::stream stream))))))
1075        (funcall output-fn thread string start end)))))
1076
1077
1078(defmethod flush-buffer ((stream swink-output-stream)) ;; called with lock hold
1079  (with-slots (buffer index) stream
1080    (unless (eql index 0)
1081      (output-stream-output stream buffer 0 index)
1082      (setf index 0))))
1083
1084(defmethod stream-write-char ((stream swink-output-stream) char)
1085  (with-swink-stream (buffer index column) stream
1086    (when (eql index (length buffer))
1087      (flush-buffer stream))
1088    (setf (schar buffer index) char)
1089    (incf index)
1090    (if (eql char #\newline)
1091      (setf column 0)
1092      (incf column)))
1093  char)
1094
1095(defmethod stream-write-string ((stream swink-output-stream) string &optional start end)
1096  (with-swink-stream (buffer index column) stream
1097    (let* ((len (length buffer))
1098           (start (or start 0))
1099           (end (ccl::check-sequence-bounds string start end))
1100           (count (- end start))
1101           (free (- len index)))
1102      (when (>= count free)
1103        (flush-buffer stream))
1104      (cond ((< count len)
1105             (replace buffer string :start1 index :start2 start :end2 end)
1106             (incf index count))
1107            (t (output-stream-output stream string start end)))
1108      (let ((last-newline (position #\newline string :from-end t
1109                                    :start start :end end)))
1110        (setf column (if last-newline 
1111                       (- end last-newline 1)
1112                       (+ column count))))))
1113  string)
1114
1115(defmethod stream-force-output ((stream swink-output-stream))
1116  (with-swink-stream () stream
1117    (flush-buffer stream)))
1118
1119(defmethod ccl::stream-finish-output ((stream swink-output-stream))
1120  (stream-force-output stream))
1121
1122(defclass swink-input-stream (swink-stream fundamental-character-input-stream)
1123  ((input-fn :initarg :input-fn)))
1124
1125(defun make-input-stream (thread input-fn)
1126  (make-instance 'swink-input-stream :thread thread :input-fn input-fn))
1127
1128(defun input-stream-input (stream)
1129  (with-slots (input-fn thread) stream
1130    (let ((conn (thread-connection thread)))
1131      (handler-bind ((stream-error (lambda (c)
1132                                     (when (eql (stream-error-stream c)
1133                                                (connection-control-stream conn))
1134                                       (with-slots (ccl::stream) c
1135                                         (setf ccl::stream stream))))))
1136        (funcall input-fn thread)))))
1137
1138(defmethod stream-read-char ((stream swink-input-stream))
1139  (with-swink-stream (buffer index column) stream
1140    (unless (< index (length buffer))
1141      (let ((string (input-stream-input stream)))
1142        (cond ((eql (length string) 0)
1143               (return-from stream-read-char :eof))
1144              (t
1145               (setf buffer string  index 0)))))
1146    (let ((char (aref buffer index)))
1147      (incf index)
1148      (if (eql char #\Newline)
1149        (setf column 0)
1150        (incf column))
1151      char)))
1152
1153(defmethod stream-read-char-no-hang ((stream swink-input-stream))
1154  (with-swink-stream (buffer index column) stream
1155    (when (< index (length buffer))
1156      (let ((char (aref buffer index)))
1157        (incf index)
1158        (if (eql char #\Newline)
1159          (setf column 0)
1160          (incf column))
1161        char))))
1162
1163(defmethod stream-listen ((stream swink-input-stream))
1164  (with-swink-stream (buffer index) stream
1165    (< index (length buffer))))
1166
1167(defmethod stream-unread-char ((stream swink-input-stream) char)
1168  (with-swink-stream (buffer index) stream
1169    (if (eql (length buffer) 0) ;; perhaps did clear-input.
1170      (setf buffer (make-string 1 :initial-element char))
1171      (if (> index 0)
1172        (decf index)
1173        (error "Unread with no preceeding read")))))
1174
1175(defmethod stream-clear-input ((stream swink-input-stream))
1176  (with-swink-stream (buffer index) stream
1177    (setf buffer "" index 0))
1178  nil)
1179
1180
1181
Note: See TracBrowser for help on using the repository browser.