source: trunk/source/library/remote-lisp.lisp @ 15065

Last change on this file since 15065 was 15065, checked in by gz, 8 years ago

Support for recursive readloops in remote listener. There are stll some problems with prompt printing but the basic mechanisms work

File size: 46.3 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2011 Clozure Associates
4;;;   This file is part of Clozure CL. 
5;;;
6;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with Clozure CL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16;;;
17
18(in-package :ccl)
19
20;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
21;;
22;; Client-side remote lisp support
23;;
24;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
25
26;; (export '(remote-lisp-thread remote-listener-function toplevel-form-text))
27
28(defclass remote-lisp-connection ()
29  ((lock :initform (make-lock) :reader rlisp-lock)
30   (server-process :initform nil :accessor rlisp-server-process)
31   (object-counter :initform most-negative-fixnum :accessor rlisp-object-counter)
32   (objects :initform () :accessor rlisp-objects)
33   (threads :initform () :accessor rlisp-threads)
34
35   (features :initform nil :accessor rlisp-features)
36   (lisp-implementation-type :initform "???" :accessor rlisp-lisp-implementation-type)
37   (lisp-implementation-version :initform "???" :accessor rlisp-lisp-implementation-version)
38   (machine-instance :initform "???" :accessor rlisp-machine-instance)))
39
40(defmacro with-rlisp-lock ((conn &rest args) &body body)
41  `(with-lock-grabbed ((rlisp-lock ,conn) ,@args)
42     (without-interrupts ;; without callbacks
43      ,@body)))
44
45(defmethod update-rlisp-connection-info ((conn remote-lisp-connection)
46                                         &key lisp-implementation-type
47                                              lisp-implementation-version
48                                              machine-instance
49                                              (features nil featuresp))
50  (with-rlisp-lock (conn)
51    (when featuresp
52      (setf (rlisp-features conn) features))
53    (when machine-instance
54      (setf (rlisp-machine-instance conn) machine-instance))
55    (when lisp-implementation-type
56      (setf (rlisp-lisp-implementation-type conn) lisp-implementation-type))
57    (when lisp-implementation-version
58      (setf (rlisp-lisp-implementation-version conn) lisp-implementation-version))))
59
60(defun register-rlisp-object (conn object)
61  (with-rlisp-lock (conn)
62    (let* ((id (incf (rlisp-object-counter conn))))
63      (push (cons id object) (rlisp-objects conn))
64      id)))
65
66(defun find-rlisp-object (conn id)
67  (with-rlisp-lock (conn)
68    (let ((cell (assoc id (rlisp-objects conn))))
69      (unless cell
70        (warn "Missing remote object ~s" id))
71      (setf (rlisp-objects conn) (delq cell (rlisp-objects conn)))
72      (cdr cell))))
73
74(defun remove-rlisp-object (conn id)
75  (with-rlisp-lock (conn)
76    (setf (rlisp-objects conn) (delete id (rlisp-objects conn) :key #'car))))
77
78(defun register-rlisp-callback (conn callback)
79  (register-rlisp-object conn (cons callback *current-process*)))
80
81;; Invoke callback in the process that registered it.
82(defun invoke-rlisp-callback (conn id &rest values)
83  (declare (dynamic-extent values))
84  (destructuring-bind (callback . process) (or (find-rlisp-object conn id) '(nil . nil))
85    (when callback
86      (apply #'process-interrupt process callback values))))
87
88(defclass remote-lisp-thread ()
89  ((conn :initarg :connection :reader rlisp-thread-connection)
90   ;; Local process running the local repl: interacting with user, sending to remote for execution.
91   (thread-process :initform nil :accessor rlisp-thread-process)
92   (break-level :initform nil :accessor rlisp-thread-break-level)
93   ;; Id of remote process doing the evaluation for the local process.
94   (thread-id :initarg :thread-id :reader rlisp-thread-id)
95   (event-queue :initform nil :accessor rlisp-thread-event-queue)))
96
97(defmethod rlisp-host-description ((rthread remote-lisp-thread))
98  (rlisp-host-description (rlisp-thread-connection rthread)))
99
100(defmethod print-object ((rthread remote-lisp-thread) stream)
101  (print-unreadable-object (rthread stream :type t :identity t)
102    (format stream "~a thread ~a"
103            (rlisp-host-description rthread)
104            (rlisp-thread-id rthread))))
105
106(defmethod rlisp-thread-id ((thread-id integer)) thread-id)
107
108(defmethod rlisp-thread-id ((thread-id symbol)) (or thread-id t))
109
110(defmethod rlisp-thread ((conn remote-lisp-connection) (thread remote-lisp-thread) &key (create t))
111  (declare (ignore create))
112  thread)
113
114(defmethod rlisp-thread ((conn remote-lisp-connection) (id integer) &key (create t))
115  (with-rlisp-lock (conn)
116    (or (find id (rlisp-threads conn) :key #'rlisp-thread-id)
117        (and create
118             (let ((rthread (make-instance 'remote-lisp-thread :connection conn :thread-id id)))
119               (push rthread (rlisp-threads conn))
120               rthread)))))
121
122(defmethod rlisp-thread ((conn remote-lisp-connection) (process process) &key (create nil))
123  (with-rlisp-lock (conn)
124    (or (find process (rlisp-threads conn) :key #'rlisp-thread-process)
125        (and create
126             (assert (not create))))))
127
128(defmethod rlisp/invoke-restart ((rthread remote-lisp-thread) name &key)
129  (rlisp/invoke-restart (rlisp-thread-connection rthread) name :thread rthread))
130
131(defmethod rlisp/toplevel ((rthread remote-lisp-thread) &key)
132  (rlisp/toplevel (rlisp-thread-connection rthread) :thread rthread))
133
134(defmethod rlisp/execute ((rthread remote-lisp-thread) form continuation &key)
135  (rlisp/execute (rlisp-thread-connection rthread) form continuation :thread rthread))
136
137(defmethod rlisp/interrupt ((rthread remote-lisp-thread) &key)
138  (rlisp/interrupt (rlisp-thread-connection rthread) :thread rthread))
139
140(defmethod remote-listener-eval ((rthread remote-lisp-thread) text &rest keys &key &allow-other-keys)
141  (apply #'remote-listener-eval (rlisp-thread-connection rthread) text :thread rthread keys))
142
143(defclass swank-rlisp-connection (remote-lisp-connection)
144  (
145   ;; The socket to the swank server.  Only the connection process reads from it, without locking.
146   ;;  Anyone can write, but should grab the connection lock.
147   (command-stream :initarg :stream :reader swank-command-stream)
148   (read-buffer :initform (make-array 1024 :element-type 'character) :accessor swank-read-buffer)))
149
150(defmethod rlisp-host-description ((conn swank-rlisp-connection))
151  (let ((socket (swank-command-stream conn)))
152    (if (open-stream-p socket)
153      (format nil "~a:~a" (ipaddr-to-dotted (remote-host socket)) (remote-port socket))
154      ":CLOSED")))
155
156(defmethod print-object ((conn swank-rlisp-connection) stream)
157  (print-unreadable-object (conn stream :type t :identity t)
158    (format stream "~a @~a"
159            (rlisp-host-description conn)
160            (rlisp-machine-instance conn))))
161
162
163(defmethod start-rlisp-server ((conn swank-rlisp-connection))
164  ;; TODO: Make sure closing the connection kills the process or vice versa.
165  (assert (null (rlisp-server-process conn)))
166  (flet ((swank-event-loop (conn)
167           (setf (rlisp-server-process conn) *current-process*)
168           (loop
169             (let ((sexp (read-swank-event conn)))
170               (handle-swank-event conn (car sexp) (cdr sexp))))))
171    (setf (rlisp-server-process conn)
172          (process-run-function (format nil "swank-event-loop ~a" (remote-port (swank-command-stream conn)))
173                                #'swank-event-loop conn)))
174  (let ((sem (make-semaphore)) (abort nil))
175    ;; Patch up swank.  To be replaced someday by our own set of remote functions...
176    ;; TODO: advise send-to-emacs to intercept :write-string  and add in the thread id.
177    (rlisp/execute conn
178                   "(CL:LET ((CCL:*WARN-IF-REDEFINE* ()))
179                     (CL:DEFUN SWANK::SPAWN-REPL-THREAD (CONN NAME) (CCL::RDEBUG-SPAWN-REPL-THREAD CONN NAME))
180                     (CL:DEFUN SWANK::DEBUG-IN-EMACS (CONN) (CCL::RDEBUG-INVOKE-DEBUGGER CONN))
181                     (CCL:ADVISE SWANK::DISPATCH-EVENT
182                                 (CL:LET* ((EVENT (CL:CAR CCL::ARGLIST))
183                                           (COMMAND (CL:CAR EVENT)))
184                                   (CL:IF (CCL:MEMQ COMMAND '(:EMACS-REX :RETURN :EMACS-INTERRUPT
185                                                                         :EMACS-PONG :EMACS-RETURN :EMACS-RETURN-STRING
186                                                                         :EMACS-CHANNEL-SEND :END-OF-STREAM :READER-ERROR))
187                                     (:DO-IT)
188                                     (SWANK::ENCODE-MESSAGE EVENT (SWANK::CURRENT-SOCKET-IO))))
189                                 :WHEN :AROUND
190                                 :NAME CCL::UNRESTRICTED-OUTGOING-MESSAGES
191                                 :DYNAMIC-EXTENT-ARGLIST CL:T)
192                     (CCL:ADVISE SWANK::SEND-TO-EMACS
193                                 (CL:LET* ((EVENT (CL:CAR CCL::ARGLIST))
194                                           (COMMAND (CL:CAR EVENT)))
195                                   (CL:WHEN (CL:EQ COMMAND :WRITE-STRING)
196                                      (CL:SETF (CL:CDDR EVENT) (CL:LIST (SWANK::CURRENT-THREAD-ID)))))
197                                 :WHEN :BEFORE
198                                 :NAME CCL::SEND-THREAD-WITH-WRITE-STRING)
199                     (CL:DEFUN SWANK::SIMPLE-BREAK ()
200                       (CCL::FORCE-BREAK-IN-LISTENER CCL::*CURRENT-PROCESS*))
201                     (CL:SETF (CCL::APPLICATION-UI-OBJECT CCL::*APPLICATION*)
202                               (CL:MAKE-INSTANCE 'CCL::RDEBUG-UI-OBJECT :CONNECTION SWANK::*EMACS-CONNECTION*))
203
204                     (CL:SETQ CCL::*INVOKE-DEBUGGER-HOOK-ON-INTERRUPT* CL:NIL) ;; let it go thru to break.
205
206                     (CL:SETQ CCL:*SELECT-INTERACTIVE-PROCESS-HOOK* 'CCL::RDEBUG-FIND-REPL-THREAD)
207
208                     (CL:DEFUN CCL::EXIT-SWANK-LOOP (LEVEL)
209                       (SWANK::SEND-TO-EMACS `(:DEBUG-RETURN
210                                               ,(SWANK::CURRENT-THREAD-ID) ,LEVEL ,SWANK::*SLDB-STEPPING-P*))
211                       (SWANK::WAIT-FOR-EVENT `(:SLDB-RETURN ,(CL:1+ LEVEL)) CL:T)
212                       (CL:WHEN (CL:> LEVEL 1)
213                         (SWANK::SEND-EVENT (SWANK::CURRENT-THREAD) `(:SLDB-RETURN ,LEVEL))))
214
215                     (CL:DEFUN CCL::MAKE-SWANK-REPL-FOR-IDE (NAME)
216                       (SWANK::CREATE-REPL ()) ;; set up connection.env with redirect threads.
217                       (CL:LET ((THREAD (SWANK::FIND-REPL-THREAD SWANK::*EMACS-CONNECTION*)))
218                         (CL:SETF (CCL:PROCESS-NAME THREAD) NAME)
219                         (SWANK::THREAD-ID THREAD)))
220                     CL:T)"
221                   (lambda (error result)
222                     (declare (ignore result))
223                     (when error
224                       (unwind-protect
225                           (error "Error initializing SWANK: ~s" error)
226                         (setq abort t)
227                         (signal-semaphore sem)))
228                     (signal-semaphore sem)))
229    (wait-on-semaphore sem)
230    ;; TODO: should at least kill server process.
231    (when abort (return-from start-rlisp-server nil))
232    (rlisp/execute conn "(SWANK:CONNECTION-INFO)"
233                   (lambda (error info)
234                     (unless error
235                       (destructuring-bind (&key (features nil featuresp)
236                                                 machine
237                                                 lisp-implementation
238                                                 &allow-other-keys) info
239                         (let ((args nil))
240                           (when featuresp
241                             (setq args (list* :features features args)))
242                           (when (consp machine)
243                             (destructuring-bind (&key instance &allow-other-keys) machine
244                               (setq args (list* :machine-instance instance args))))
245                           (when (consp lisp-implementation)
246                             (destructuring-bind (&key type version &allow-other-keys) lisp-implementation
247                               (setq args (list* :lisp-implementation-type type
248                                                 :lisp-implementation-version version
249                                                 args))))
250                           (when args
251                             (apply #'update-rlisp-connection-info conn args)))))
252                     (signal-semaphore sem)))
253    (wait-on-semaphore sem)
254    conn))
255
256(defmethod output-stream-for-remote-lisp ((app application))
257  *standard-output*)
258
259(defmethod input-stream-for-remote-lisp ((app application))
260  *standard-input*)
261
262(defun process-output-stream (process)
263  (let ((stream (symbol-value-in-process '*standard-output* process)))
264    (loop
265      (typecase stream
266        (synonym-stream
267         (setq stream (symbol-value-in-process (synonym-stream-symbol stream) process)))
268        (two-way-stream
269         (setq stream (two-way-stream-output-stream stream)))
270        (t (return stream))))))
271
272(defvar *signal-swank-events* nil)
273
274(define-condition swank-events () ())
275
276(defmacro with-swank-events ((rthread &key abort) &body body)
277  (let ((rthread-var (gensym "RTHREAD")))
278    (if abort
279      ;; When body is no re-entrant, abort it before handling the event.
280      `(let ((,rthread-var ,rthread))
281         (loop
282           (handler-case (return (let ((*signal-swank-events* t))
283                                   (when (rlisp-thread-event-queue ,rthread-var)
284                                     (let ((*signal-swank-events* nil))
285                                       (handle-swank-events ,rthread-var)))
286                                   ,@body))
287             (swank-events () (let ((*signal-swank-events* nil))
288                                (handle-swank-events rthread))))))
289      `(let ((,rthread-var ,rthread))
290         (handler-bind ((swank-events (lambda (c)
291                                        (declare (ignore c))
292                                        (handle-swank-events ,rthread-var))))
293           (let ((*signal-swank-events* t))
294             (when (rlisp-thread-event-queue ,rthread-var)
295               (let ((*signal-swank-events* nil))
296                 (handle-swank-events ,rthread-var)))
297             ,@body))))))
298
299(defun signal-swank-event (rthread event args)
300  (with-rlisp-lock ((rlisp-thread-connection rthread)) ;; this is quick, not worth a separate lock
301    (setf (rlisp-thread-event-queue rthread)
302          (nconc (rlisp-thread-event-queue rthread) (list `(,event ,@args)))))
303  (process-interrupt (or (rlisp-thread-process rthread)
304                         (error "Got event ~s ~s for thread ~s with no process" event args rthread))
305                     (lambda ()
306                       (when *signal-swank-events*
307                         (let ((*signal-swank-events* nil))
308                           (signal 'swank-events))))))
309
310(defun handle-swank-events (rthread)
311  (loop for event = (with-rlisp-lock ((rlisp-thread-connection rthread)) ;; this is quick, not worth a separate lock
312                      (pop (rlisp-thread-event-queue rthread)))
313    while event do (handle-swank-event rthread (car event) (cdr event))))
314
315(defmethod handle-swank-event ((conn swank-rlisp-connection) event args)
316  (case event
317    (:return
318     (destructuring-bind (value id) args
319       (when id (invoke-rlisp-callback conn id value))))
320    (:invalid-rpc
321     (destructuring-bind (id message) args
322       (when id (remove-rlisp-object conn id))
323       (error "Invalid rpc: ~s" message)))
324    (:enter-break ;; Starting a new repl (possibly due to an error in a non-repl process)
325     ;; For now, this is assumed to create the listener before processing another command, so
326     ;; the remote can send commands to it right away.
327     ;; If that becomes a problem, can make a protocol so the other side will explicitly wait,
328     ;; and then we can spawn off a worker thread to do this.
329     (destructuring-bind (thread-id break-level) args
330       (let ((rthread (rlisp-thread conn thread-id)))
331         (enter-rlisp-listener rthread break-level)
332         ;; TODO: this isn't really right.  Need to wait for process context to be set up.  Perhaps
333         ;; make sure thread-process is not set until the process is running in full context.
334         (process-wait "REPL startup" #'rlisp-thread-process rthread)
335         ;(signal-swank-event rthread event (cdr args))
336         )))
337    (:exit-break
338     (destructuring-bind (thread-id) args
339       (let ((rthread (rlisp-thread conn thread-id)))
340         (when (and rthread (rlisp-thread-process rthread))
341           (exit-rlisp-listener rthread)))))
342    ((:read-loop :values :debug-return :debug-condition :read-aborted)
343     ;; TODO: this needs to make sure the process is in the right dynamic state (with all restarts established etc)
344     ;;  Need our own interrupt queue, with-event-handling macro...
345     (destructuring-bind (thread-id &rest event-args) args
346       (let ((rthread (rlisp-thread conn thread-id)))
347         (signal-swank-event rthread event event-args))))
348    (:new-features
349     (destructuring-bind (features) args
350       (update-rlisp-connection-info conn :features features)))
351    (:indentation-update
352     (destructuring-bind (name-indent-alist) args
353       (declare (ignore name-indent-alist))))
354    ;; TODO: make the i/o streams be thread-specific, so we know which listener to use even if some other
355    ;; thread is doing the i/o.  I.e. this should send a thread id of the owner of the stream, not of the
356    ;; thread that happens to write it, so it will always be a listener thread.
357    (:write-string
358     (destructuring-bind (string thread-id) args
359       (let* ((rthread (rlisp-thread conn thread-id :create nil))
360              (stream (if (and rthread (rlisp-thread-process rthread))
361                        (process-output-stream (rlisp-thread-process rthread))
362                        (output-stream-for-remote-lisp *application*))))
363         (if (> (length string) 500)
364           (process-run-function "Long Remote Output" #'write-string string stream)
365           (write-string string stream)))))
366    (:ping ;; flow control for output
367     (destructuring-bind (thread-id tag) args
368       ;; TODO: I guess we're supposed to wait til the previous output is finished or something.
369       (send-sexp-to-swank conn `(:emacs-pong ,thread-id ,tag))))
370    (:read-string
371     (destructuring-bind (thread-id tag) args
372       (let ((rthread (rlisp-thread conn thread-id :create nil)))
373         (if (and rthread (rlisp-thread-process rthread))
374           (signal-swank-event rthread event (cdr args))
375           ;; not a listener thread.
376           ;; TODO: this needs to be wrapped in some error handling.
377           (process-run-function (format nil "Remote Input (~s)" thread-id)
378                                 #'rlisp-read-string
379                                 conn
380                                 (input-stream-for-remote-lisp *application*)
381                                 thread-id
382                                 tag)))))
383    (t (warn "Received unknown event ~s with args ~s" event args))))
384
385
386
387(define-condition rlisp-read-aborted ()
388  ((tag :initarg :tag :reader rlisp-read-aborted-tag)))
389
390(defun rlisp-read-string (conn stream thread-id tag)
391  (handler-bind ((rlisp-read-aborted (lambda (c)
392                                       (when (eql tag (rlisp-read-aborted-tag c))
393                                         (return-from rlisp-read-string)))))
394    (peek-char t stream) ;; wait for first one, error if none.
395    (let ((text (and (peek-char t stream nil) ;; wait for first one, nil means eof
396                     (read-available-text stream))))
397      (send-sexp-to-swank conn `(:emacs-return-string ,thread-id ,tag ,text)))))
398
399(defmethod handle-swank-event ((rthread remote-lisp-thread) event args)
400  (assert (eq (rlisp-thread-process rthread) *current-process*))
401  (ecase event
402    (:read-string
403     (destructuring-bind (tag) args
404       (rlisp-read-string (rlisp-thread-connection rthread) *standard-input* (rlisp-thread-id rthread) tag)))
405    (:read-aborted  ;; huh?
406     (destructuring-bind (tag) args
407       (signal 'rlisp-read-aborted :tag tag)))
408    (:read-loop ;; enter (or re-enter after an abort) a break loop.
409     (destructuring-bind (level) args
410       (when (eql level *break-level*) ;; restart at same level, aborted current expression.
411         (invoke-restart 'debug-restart level))
412       (unless (eql level (1+ *break-level*))
413         (warn ":READ-LOOP level confusion got ~s expected ~s" level (1+ *break-level*)))
414       ;(format t "~&Error: ~a" condition-text)
415       ;(when *show-restarts-on-break*
416       ;  (format t "~&Remote restarts:")
417       ;  (loop for (name description) in restarts
418       ;    do (format t "~&~a ~a" name description))
419       ;  (fresh-line))
420       (rlisp-read-loop rthread :break-level level)))
421     (:debug-condition ;; This seems to have something to do with errors in the debugger
422         (destructuring-bind (message) args
423           (format t "~&Swank error: ~s" message)))
424     (:debug-return ;; return from level LEVEL read loop
425      (destructuring-bind (level stepping-p) args
426        (declare (ignore stepping-p))
427        (invoke-restart 'debug-return level)))
428     (:values ;; intermediate values when multiple forms in selection.
429      (destructuring-bind (values) args
430        (when values
431          (fresh-line)
432          (dolist (val values) (write val) (terpri)))
433        (force-output)
434        (print-listener-prompt *standard-output*)))))
435
436
437;; This assumes connection process is the only thing that reads from the socket stream and uses
438;; the read-buffer, so don't need locking.
439(defun read-swank-event (conn)
440  (assert (eq (rlisp-server-process conn) *current-process*))
441  (let* ((stream (swank-command-stream conn))
442         (buffer (swank-read-buffer conn)))
443    (multiple-value-bind (form updated-buffer) (read-remote-event stream buffer)
444      (unless (eq updated-buffer buffer)
445        (setf (swank-read-buffer conn) updated-buffer))
446      form)))
447
448(defun read-remote-event (stream &optional buffer)
449  (let* ((header (or buffer (make-string 6)))
450         (count (stream-read-vector stream header 0 6)))
451    (when (< count 6) (signal-eof-error stream))
452    (setq count (parse-integer header :end 6 :radix 16))
453    (assert (> count 0))
454    (when (< (length buffer) count)
455      (setq buffer (make-string count)))
456    (let ((len (stream-read-vector stream buffer 0 count)))
457      (when (< len count) (signal-eof-error stream))
458      ;; TODO: check that there aren't more forms in the string.
459      (values (handler-case
460                  (with-standard-io-syntax
461                      (let ((*package* +swank-io-package+)
462                            (*read-eval* nil))
463                        (read-from-string buffer t nil :end count)))
464                (reader-error (c) `(:reader-error ,(copy-seq buffer) ,c)))
465              buffer))))
466
467(defmethod make-rrepl-thread ((conn swank-rlisp-connection) name)
468  (let* ((semaphore (make-semaphore))
469         (return-error nil)
470         (return-id nil))
471    (rlisp/execute conn (format nil "(CCL::MAKE-SWANK-REPL-FOR-IDE ~s)" name)
472                   (lambda (error id)
473                     (setf return-error error)
474                     (setq return-id id)
475                     (signal-semaphore semaphore)))
476    (wait-on-semaphore semaphore)
477    (when return-error
478      (error "Remote eval error ~s" return-error))
479    (rlisp-thread conn return-id)))
480
481;; TODO: "coding-system".
482(defun connect-to-swank (host port &key (secret-file "home:.slime-secret"))
483  (let* ((socket (make-socket :remote-host host :remote-port port :nodelay t))
484         (conn (make-instance 'swank-rlisp-connection :stream socket)))
485    (when secret-file
486      (with-open-file (stream secret-file :if-does-not-exist nil)
487        (when stream
488          (let ((secret (read-line stream nil nil)))
489            (when secret
490              (send-string-to-swank conn secret))))))
491    (start-rlisp-server conn)))
492
493(defmethod close ((conn swank-rlisp-connection) &key abort)
494  ;; TODO: kill process.
495  (close (swank-command-stream conn) :abort abort))
496
497(defun send-string-to-swank (conn string)
498  (let ((stream (swank-command-stream conn)))
499    (with-rlisp-lock (conn)
500      (format stream "~6,'0,X" (length string))
501      (write-string string stream))
502    (force-output stream)))
503
504(defvar +swank-io-package+ 
505  (loop as name = (gensym "SwankIO/") while (find-package name)
506    finally (let ((package (make-package name :use nil)))
507              (import '(nil t quote) package)
508              (return package))))
509
510(defun send-sexp-to-swank (conn sexp)
511  (send-string-to-swank conn (with-standard-io-syntax
512                                 (let ((*package* +swank-io-package+))
513                                   (prin1-to-string sexp)))))
514
515(defun format-for-swank (fmt-string fmt-args)
516  (with-standard-io-syntax
517      (let ((*package* +swank-io-package+))
518        (apply #'format nil fmt-string fmt-args))))
519
520(defun thread-id-for-execute (thread)
521  (typecase thread
522    (null t) ;; don't care
523    (remote-lisp-thread (rlisp-thread-id thread))
524    (t thread)))
525
526
527;; Continuation will be executed in the current process.
528(defmethod rlisp/execute ((conn swank-rlisp-connection) form-or-string continuation &key thread)
529  (flet ((continuation (result)
530           (ecase (car result)
531             (:ok (apply continuation nil (cdr result)))
532             (:abort (apply continuation (or (cadr result) '"NIL") (or (cddr result) '(nil)))))))
533    (let* ((sexp `(:emacs-rex ,form-or-string
534                              nil
535                              ,(thread-id-for-execute thread)
536                              ,(and continuation (register-rlisp-callback conn #'continuation)))))
537      (if (stringp form-or-string)
538        (send-string-to-swank conn (format-for-swank "(~s ~a ~s ~s ~s)" sexp))
539        (send-sexp-to-swank conn sexp)))))
540
541(defmethod rlisp/invoke-restart ((conn swank-rlisp-connection) name &key thread)
542  ;; TODO: if had a way to harvest old continuations, could check for error.  But since this
543  ;; will normally not return, don't register a continuation for it.
544  (rlisp/execute conn `(invoke-restart ',name) nil :thread thread))
545
546(defmethod rlisp/toplevel ((conn swank-rlisp-connection) &key thread)
547  (rlisp/execute conn `(toplevel) nil :thread thread))
548
549(defmethod rlisp/interrupt ((conn swank-rlisp-connection) &key thread)
550  (send-sexp-to-swank conn `(:emacs-interrupt ,(thread-id-for-execute thread))))
551
552(defun read-available-text (stream)
553  (loop with buffer = (make-array 100 :element-type 'character :adjustable t :fill-pointer 0)
554    for ch = (stream-read-char-no-hang stream)
555    until (or (eq ch :eof) (null ch))
556    do (vector-push-extend ch buffer)
557    finally (return buffer)))
558
559;; Return text for remote evaluation.
560(defmethod toplevel-form-text ((stream input-stream))
561  (when (peek-char t stream nil) ;; wait for the first one.
562    (read-available-text stream)))
563
564(defmethod toplevel-form-text ((stream synonym-stream))
565  (toplevel-form-text (symbol-value (synonym-stream-symbol stream))))
566
567(defmethod toplevel-form-text ((stream two-way-stream))
568  (if (typep stream 'echo-stream)
569    (call-next-method)
570    (toplevel-form-text (two-way-stream-input-stream stream))))
571
572;; pass this as the initial-function in make-mcl-listener-process
573(defmethod remote-listener-function ((rthread remote-lisp-thread))
574  (setf (rlisp-thread-process rthread) *current-process*)
575  (unless (or *inhibit-greeting* *quiet-flag*)
576    (let ((conn (rlisp-thread-connection rthread)))
577      (format t "~&Welcome to ~A ~A on ~A!"
578              (rlisp-lisp-implementation-type conn)
579              (rlisp-lisp-implementation-version conn)
580              (rlisp-machine-instance conn))))
581  (rlisp-read-loop rthread :break-level (rlisp-thread-break-level rthread)))
582
583;; This can be invoked when the connection dies or break-loop is exited in a non-repl process.
584(defmethod exit-rlisp-listener ((rthread remote-lisp-thread))
585  (application-ui-operation *application* :deactivate-rlisp-listener rthread) ;; deactivate listener
586  (let ((process (rlisp-thread-process rthread)))
587    (setf (rlisp-thread-process rthread) nil)
588    (process-kill process)))
589
590(defmethod enter-rlisp-listener ((rthread remote-lisp-thread) break-level)
591  (when (rlisp-thread-process rthread)
592    (error "Attempting to re-enter active listener"))
593  (setf (rlisp-thread-break-level rthread) break-level)
594  ;; The process creation would be a little different
595  (create-rlisp-listener *application* rthread))
596
597(defmethod create-rlisp-listener ((application application) rthread)
598  (assert (null (rlisp-thread-process rthread)))
599  ;; see make-mcl-listener-process
600  (error "Not implemented yet"))
601
602;; IDE read-loop with remote evaluation.
603(defmethod rlisp-read-loop ((rthread remote-lisp-thread) &key break-level)
604  (let* ((*break-level* break-level)  ;; used by prompt printing
605         (*last-break-level* break-level)  ;; ditto
606         (debug-return nil))
607    (unwind-protect
608        (loop
609          (setf (rlisp-thread-break-level rthread) break-level)
610          (restart-case
611              ;; There are some UI actions that invoke local restarts by name, e.g. cmd-/ will invoke 'continue.
612              ;; Catch those and just pass them to the remote.  The remote will then do whatever the restart
613              ;; does, and will send back unwinding directions if appropriate.
614              ;; Do continue with a restart-bind because don't want to abort whatever form is
615              ;; about to be sent for evaluation, just in case the continue doesn't end up doing
616              ;; anything on the remote end.
617              (restart-bind ((continue (lambda () (rlisp/invoke-restart rthread 'continue))))
618                (catch :toplevel
619                  (loop
620                    (catch :abort
621                      (loop
622                        (catch-cancel ;; exactly like :abort except prints Cancelled.
623                         (rlisp-read-loop-internal rthread))
624                        (rlisp/invoke-restart rthread 'abort)
625                        (format *terminal-io* "~&Cancelled")))
626                    (rlisp/invoke-restart rthread 'abort)))
627                (rlisp/toplevel rthread))
628            ;; These are invoked via invoke-restart-no-return, so must take non-local exit.
629            (abort () (rlisp/invoke-restart rthread 'abort))
630            (abort-break () (if (eql break-level 0)
631                              (rlisp/invoke-restart rthread 'abort)
632                              (rlisp/invoke-restart rthread 'abort-break)))
633            ;; This is invoked when remote unwinds
634            (debug-return (target-level)
635               (setq debug-return t)
636               (when (eql target-level break-level)
637                 (return-from rlisp-read-loop))
638               (when (> target-level break-level)
639                 (error "Missed target level in debug-return - want ~s have ~s" target-level break-level))
640               (invoke-restart 'debug-return target-level))
641            (debug-restart (target-level)
642               (unless (eql target-level break-level)
643                 (when (> target-level break-level)
644                   (error "Missed target level in debug-restart - want ~s have ~s" target-level break-level))
645                 (setq debug-return t)
646                 (invoke-restart 'debug-restart target-level))))
647          (clear-input)
648          (fresh-line))
649      (unless debug-return
650        (warn "Unknown exit from rlisp-read-loop!")))))
651
652(defmethod rlisp-read-loop-internal ((rthread remote-lisp-thread))
653  (let* ((input-stream *standard-input*)
654         (output-stream *standard-output*)
655         (sem (make-semaphore))
656         (eof-count 0))
657    (loop
658      (force-output output-stream)
659      (print-listener-prompt output-stream t)
660
661      (multiple-value-bind (text env)
662                           ;; Reading is not re-entrant so events during reading need
663                           ;; to abort the read to be handled.
664                           (with-swank-events (rthread  :abort t)
665                             (toplevel-form-text input-stream))
666        (if (null text) ;; eof
667          (progn
668            (when (> (incf eof-count) *consecutive-eof-limit*)
669              (#_ _exit 0))
670            (unless (and (not *batch-flag*)
671                         (not *quit-on-eof*)
672                         (stream-eof-transient-p input-stream))
673              (exit-interactive-process *current-process*))
674            (stream-clear-input input-stream)
675            (rlisp/invoke-restart rthread 'abort-break))
676          (progn
677            (setq eof-count 0)
678            ;;(let* ((values (toplevel-eval form env)))
679            ;;      (if print-result (toplevel-print values)))
680            (let* ((package-name (loop for sym in (car env) for val in (cdr env)
681                                  when (eq sym '*package*) do (return val)))
682                   (values (remote-listener-eval rthread text :package package-name :semaphore sem)))
683              (fresh-line output-stream)
684              (dolist (val values) (princ val output-stream) (terpri output-stream)))))))))
685
686
687(defmethod remote-listener-eval ((conn swank-rlisp-connection) text
688                                 &key package thread (semaphore (make-semaphore)))
689  (assert thread)
690  (let* ((form (format nil "(CCL::RDEBUG-LISTENER-EVAL ~s ~s ~s)"
691                       text package 
692                       ;; This will send intermediate :values messages
693                       (and *verbose-eval-selection* t)))
694         (return-values nil))
695    (rlisp/execute conn
696                   form
697                   (lambda (error values)
698                     ;; Error just means evaluation was aborted but we don't yet know why.  We will
699                     ;; be told to either restart a readloop or exit it.  Stay in semaphore wait
700                     ;; until then.
701                     (unless error
702                       (setq return-values values)
703                       (signal-semaphore semaphore)))
704                   :thread thread)
705    (with-swank-events (thread)
706      (wait-on-semaphore semaphore))
707    ;; a list of strings representing each return value
708    return-values))
709
710;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
711;;
712;; Server-side: support for a remote debugger
713;;
714;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
715
716
717;;TODO: This is per application but we may want to allow multiple remote debuggers, and have this track
718;; all connections.   See also process-ui-object.
719(defclass rdebug-ui-object (ui-object)
720  ((connection :initarg :connection :accessor rdebug-ui-connection)))
721
722;; Currently built on swank.
723
724(defun swankvar (name &optional (package :swank))
725  (symbol-value (find-symbol name package)))
726
727(defun (setf swankvar) (value name &optional (package :swank))
728  (let ((sym (find-symbol name package)))
729    (if (null sym)
730      (warn "Couldn't find ~a::~a" package name)
731      (set sym value))))
732
733(defun swankfun (name &optional (package :swank))
734  (symbol-function (find-symbol name package)))
735
736#-bootstrapped
737(declaim (special *read-loop-function*))
738
739(defun rdebug-send (event)
740  (funcall (swankfun "SEND-TO-EMACS")
741           (mapcar (lambda (x) (if (processp x) (funcall (swankfun "THREAD-ID") x) x)) event)))
742
743(defun rdebug-listener-eval (string package-name verbose-eval-selection)
744  (if package-name
745    (let ((*package* (or (find-package package-name) *package*)))
746      (rdebug-listener-eval string nil verbose-eval-selection))
747    (with-input-from-string (sstream string)
748      (let ((values nil))
749        (loop
750          (let ((form (read-toplevel-form sstream :eof-value sstream)))
751            (when (eq form sstream)
752              (finish-output)
753              (return values))
754            (when verbose-eval-selection
755              (rdebug-send `(:values ,*current-process* ,values)))
756            ;; there is more.
757            (unless (check-toplevel-command form)
758              ;; TODO: toplevel-eval checks package change and invokes application-ui-operation, need to send that back.
759              (setq values (toplevel-eval form nil))
760              (setq /// // // / / values)
761              (unless (eq (car values) (%unbound-marker))
762                (setq *** ** ** * *  (%car values)))
763              (setq values (mapcar #'write-to-string values)))))))))
764
765(defun rdebug-spawn-repl-thread (conn name)
766  (process-run-function name
767                        (lambda ()
768                          (funcall (swankfun "CALL-WITH-CONNECTION") conn
769                                   (lambda ()
770                                     (rdebug-send `(:enter-break ,*current-process* 0))
771                                     (let ((*read-loop-function* 'rdebug-read-loop)
772                                           (*debugger-hook* nil)
773                                           (*break-hook* nil))
774                                       (unwind-protect
775                                           (toplevel-loop)
776                                         (rdebug-send `(:exit-break ,*current-process*)))))))))
777
778;; Debugger invoked in a non-repl process.  This is called with all swank stuff already set up.
779(defun rdebug-invoke-debugger (condition)
780   (when (eq *read-loop-function* 'rdebug-read-loop)
781      (return-from rdebug-invoke-debugger))
782    (rdebug-send `(:enter-break ,*current-process* 1))
783    (unwind-protect
784        (let ((*read-loop-function* 'rdebug-read-loop)
785              (*debugger-hook* nil)
786              (*break-hook* nil))
787          (%break-message *break-loop-type* condition)
788          ;; Like toplevel-loop but run break-loop to set up error context before going into read-loop
789          (loop
790            (catch :toplevel
791              (break-loop condition))
792            (when (eq *current-process* *initial-process*)
793              (toplevel))))
794      (rdebug-send `(:exit-break ,*current-process*))))
795
796
797;; swank-like read loop except with all the standard ccl restarts and catches.
798;; TODO: try to make the standard read-loop customizable enough to do this so don't have to replace it.
799(defun rdebug-read-loop (&key (break-level 0) &allow-other-keys)
800  ;; CCL calls this with :input-stream/:output-stream *debug-io*, but that won't do anything even if those
801  ;; are set to something non-standard, since swank doesn't hang its protocol on the streams.
802  (let ((*break-level* break-level)
803        (*loading-file-source-file* nil)
804        (*loading-toplevel-location* nil)
805        *** ** * +++ ++ + /// // / -)
806    (flet ((repl-until-abort ()
807             (rdebug-send `(:read-loop ,*current-process* ,break-level))
808             (restart-case
809                 (catch :abort
810                   (catch-cancel
811                    (loop
812                      (setq *break-level* break-level)
813                      (let ((event (funcall (swankfun "WAIT-FOR-EVENT")
814                                            `(or (:emacs-rex . _)
815                                                 ;; some internal swank kludge...
816                                                 (:sldb-return ,(1+ break-level))))))
817                        (when (eql (car event) :sldb-return)
818                          (abort))
819                        ;; Execute some basic protocol function (not user code).
820                        (apply (swankfun "EVAL-FOR-EMACS") (cdr event))))))
821               (abort ()
822                 :report (lambda (stream)
823                           (if (eq break-level 0)
824                             (format stream "Return to toplevel")
825                             (format stream "Return to break level ~D" break-level)))
826                 nil)
827               (abort-break () (unless (eql break-level 0) (abort))))))
828      (declare (ftype (function) exit-swank-loop))
829      (unwind-protect
830          (loop
831            (repl-until-abort)
832            ;(clear-input)
833            ;(terpri)
834            )
835        (exit-swank-loop break-level)))))
836
837 (defun safe-condition-string (condition)
838   (or (ignore-errors (princ-to-string condition))
839       (ignore-errors (prin1-to-string condition))
840       (ignore-errors (format nil "Condition of type ~s"
841                              (type-of condition)))
842       (ignore-errors (and (typep condition 'error)
843                           "<Unprintable error>"))
844       "<Unprintable condition>"))
845
846;; Find process to handle interactive abort, i.e. a local ^c.
847(defun rdebug-find-repl-thread ()
848  (let ((conn (funcall (swankfun "DEFAULT-CONNECTION"))))
849    (when conn
850      ;; TODO: select the frontmost listener (this selects the last created one).
851      (funcall (swankfun "FIND-REPL-THREAD") conn))))
852
853
854;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
855;;
856;; Standard swank startup
857;;
858;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
859
860;; (export '(load-swank start-swank-server start-swank-loader stop-swank-loader))
861
862(defun load-swank (load-path)
863  (when (find-package :swank-loader) (delete-package :swank-loader)) ;; so can tell if loaded
864  (load (merge-pathnames load-path "swank-loader.lisp"))
865  (unless (and (find-package :swank-loader)
866               (find-symbol "INIT" :swank-loader))
867    (error "~s is not a swank loader path" load-path))
868  (funcall (find-symbol "INIT" :swank-loader))
869  (unless (and (find-package :swank)
870               (find-symbol "CREATE-SERVER" :swank))
871    (error "Incompatible swank version loaded from ~s" load-path)))
872
873(defun start-swank-server (&key
874                           (port (swankvar "DEFAULT-SERVER-PORT"))
875                           (debug (swankvar "*LOG-EVENTS*"))
876                           (dedicated-output-port (and (swankvar "*USE-DEDICATED-OUTPUT-STREAM*")
877                                                       (swankvar "*DEDICATED-OUTPUT-STREAM-PORT*")))
878                           (globally-redirect-io (swankvar "*GLOBALLY-REDIRECT-IO*"))
879                           (global-debugger (swankvar "*GLOBAL-DEBUGGER*"))
880                           (indentation-updates (swankvar "*CONFIGURE-EMACS-INDENTATION*"))
881                           (dont-close (swankvar "*DONT-CLOSE*"))
882                           (coding-system "iso-latin-1-unix")
883                           (style :spawn))
884  "Assuming SWANK is already loaded, create a swank server on the specified port"
885  (when debug
886    (setf (swankvar "*LOG-EVENTS*" :swank-rpc) t)
887    (setf (swankvar "*SWANK-DEBUG-P*") t)
888    (setf (swankvar "*DEBUG-ON-SWANK-PROTOCOL-ERROR*") t))
889  (when (setf (swankvar "*USE-DEDICATED-OUTPUT-STREAM*") (not (null dedicated-output-port)))
890    (setf (swankvar "*DEDICATED-OUTPUT-STREAM-PORT*") dedicated-output-port))
891  (setf (swankvar "*GLOBALLY-REDIRECT-IO*") globally-redirect-io)
892  (setf (swankvar "*GLOBAL-DEBUGGER*") global-debugger)
893  (setf (swankvar "*CONFIGURE-EMACS-INDENTATION*") indentation-updates)
894  (funcall (swankfun "CREATE-SERVER")
895           :style style
896           :port port
897           :dont-close dont-close
898           :coding-system coding-system))
899
900
901(defun swank-port-active? (port)
902  (and (find-package :swank) (getf (swankvar "*LISTENER-SOCKETS*") port)))
903
904
905;; Special ccl slime extension to allow the client to specify the swank path
906
907(defvar *swank-loader-process* nil)
908(defparameter $emacs-ccl-swank-request-marker "[emacs-ccl-swank-request]")
909(defparameter *default-swank-loader-port* 4884)
910
911(defun stop-swank-loader ()
912  (when *swank-loader-process*
913    (process-kill (shiftf *swank-loader-process* nil))))
914
915(defun start-swank-loader (&optional (port *default-swank-loader-port*))
916  (ignore-errors (stop-swank-loader))
917  (let ((semaphore (make-semaphore))
918        (errorp nil))
919    (setq *swank-loader-process*
920          ;; Wait for either a swank client to connect or the special ccl slime kludge
921          (process-run-function "Swank Loader"
922                                (lambda (sem)
923                                  (setq *swank-loader-process* *current-process*)
924                                  (unwind-protect
925                                      (with-open-socket (socket :connect :passive :local-port port
926                                                                :reuse-address t)
927                                        (signal-semaphore (shiftf sem nil))
928                                        (loop
929                                          (let* ((stream (accept-connection socket))
930                                                 (line (read-line stream nil)))
931                                            (multiple-value-bind (path port)
932                                                                 (parse-emacs-ccl-swank-request line)
933                                              (let ((message (handler-case
934                                                                 (if (swank-port-active? port)
935                                                                   (format nil "Swank is already active on port ~s" port)
936                                                                   (progn
937                                                                     (load-swank path)
938                                                                     (start-swank-server :port port)
939                                                                     nil))
940                                                               (error (c) (princ-to-string c)))))
941                                                (prin1 `(:active (and (swank-port-active? port) t)
942                                                                 :loader ,path
943                                                                 :message ,message
944                                                                 :port ,port)
945                                                       stream)
946                                                (finish-output stream))))))
947                                    (when sem ;; in case exit before finished startup
948                                      (setq errorp t)
949                                      (signal-semaphore sem))))
950                                semaphore))
951    (wait-on-semaphore semaphore)
952    (when errorp
953      (ignore-errors (process-kill (shiftf *swank-loader-process* nil))))
954    *swank-loader-process*))
955
956(defun parse-emacs-ccl-swank-request (line)
957  (let ((start (length $emacs-ccl-swank-request-marker)))
958    (when (and (< start (length line))
959               (string= $emacs-ccl-swank-request-marker line :end2 start))
960      (let* ((split-pos (position #\: line :start start))
961             (port (parse-integer line :junk-allowed nil :start start :end split-pos))
962             (path-pos (position-if-not #'whitespacep line
963                                        :start (if split-pos (1+ split-pos) start)))
964             (path (subseq line path-pos
965                           (1+ (position-if-not #'whitespacep line :from-end t)))))
966        (values path port)))))
967
968
969
970
Note: See TracBrowser for help on using the repository browser.