/[slime]/slime/swank-ecl.lisp
ViewVC logotype

Contents of /slime/swank-ecl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.27 - (hide annotations)
Mon Aug 11 17:41:55 2008 UTC (5 years, 8 months ago) by heller
Branch: MAIN
Changes since 1.26: +12 -0 lines
Improve interrupt safety for single-threaded lisps.

* slime.el (slime-interrupt): Send a :emacs-interrupt message
together with SIGINT.  SIGINT now means "check for new events"
instead of "invoke the debugger".

* swank-backend.lisp (install-sigint-handler)
(call-with-user-break-handler): New functions.

* swank.lisp (simple-serve-requests,install-fd-handler): Use it.
(read-packet, read-char): New function. Check for interrupts.
(wait-for-event/event-loop): Check for interrupts.
1 heller 1.7 ;;;; -*- indent-tabs-mode: nil -*-
2 jgarcia 1.1 ;;;
3     ;;; swank-ecl.lisp --- SLIME backend for ECL.
4 heller 1.7 ;;;
5     ;;; This code has been placed in the Public Domain. All warranties
6     ;;; are disclaimed.
7     ;;;
8 jgarcia 1.1
9     ;;; Administrivia
10    
11     (in-package :swank-backend)
12    
13 gcarncross 1.19 (defvar *tmp*)
14    
15 gcarncross 1.15 (if (find-package :gray)
16     (import-from :gray *gray-stream-symbols* :swank-backend)
17     (import-from :ext *gray-stream-symbols* :swank-backend))
18 jgarcia 1.1
19     (swank-backend::import-swank-mop-symbols :clos
20     '(:eql-specializer
21     :eql-specializer-object
22     :generic-function-declarations
23     :specializer-direct-methods
24     :compute-applicable-methods-using-classes))
25    
26    
27     ;;;; TCP Server
28    
29     (require 'sockets)
30    
31     (defun resolve-hostname (name)
32     (car (sb-bsd-sockets:host-ent-addresses
33     (sb-bsd-sockets:get-host-by-name name))))
34    
35     (defimplementation create-socket (host port)
36     (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
37     :type :stream
38     :protocol :tcp)))
39     (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
40     (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port)
41     (sb-bsd-sockets:socket-listen socket 5)
42     socket))
43    
44     (defimplementation local-port (socket)
45     (nth-value 1 (sb-bsd-sockets:socket-name socket)))
46    
47     (defimplementation close-socket (socket)
48     (sb-bsd-sockets:socket-close socket))
49    
50     (defimplementation accept-connection (socket
51 heller 1.6 &key external-format
52 dcrosher 1.5 buffering timeout)
53 heller 1.7 (declare (ignore buffering timeout external-format))
54     (make-socket-io-stream (accept socket)))
55 jgarcia 1.1
56 heller 1.7 (defun make-socket-io-stream (socket)
57 jgarcia 1.1 (sb-bsd-sockets:socket-make-stream socket
58     :output t
59     :input t
60     :element-type 'base-char))
61    
62     (defun accept (socket)
63     "Like socket-accept, but retry on EAGAIN."
64     (loop (handler-case
65     (return (sb-bsd-sockets:socket-accept socket))
66     (sb-bsd-sockets:interrupted-error ()))))
67    
68     (defimplementation preferred-communication-style ()
69     (values nil))
70    
71    
72     ;;;; Unix signals
73    
74 heller 1.27 (defimplementation install-sigint-handler (handler)
75     (let ((old-handler (symbol-function 'si:terminal-interrupt)))
76     (setf (symbol-function 'si:terminal-interrupt)
77     (if (consp handler)
78     (car handler)
79     (lambda (&rest args)
80     (declare (ignore args))
81     (funcall handler)
82     (continue))))
83     (list old-handler)))
84    
85    
86 jgarcia 1.1 (defimplementation getpid ()
87     (si:getpid))
88    
89     #+nil
90     (defimplementation set-default-directory (directory)
91     (ext::chdir (namestring directory))
92     ;; Setting *default-pathname-defaults* to an absolute directory
93     ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive.
94     (setf *default-pathname-defaults* (ext::getcwd))
95     (default-directory))
96    
97     #+nil
98     (defimplementation default-directory ()
99     (namestring (ext:getcwd)))
100    
101     (defimplementation quit-lisp ()
102     (ext:quit))
103    
104    
105     ;;;; Compilation
106    
107     (defvar *buffer-name* nil)
108     (defvar *buffer-start-position*)
109     (defvar *buffer-string*)
110     (defvar *compile-filename*)
111    
112     (defun signal-compiler-condition (&rest args)
113     (signal (apply #'make-condition 'compiler-condition args)))
114    
115     (defun handle-compiler-warning (condition)
116     (signal-compiler-condition
117     :original-condition condition
118     :message (format nil "~A" condition)
119     :severity :warning
120     :location
121     (if *buffer-name*
122     (make-location (list :buffer *buffer-name*)
123     (list :position *buffer-start-position*))
124     ;; ;; compiler::*current-form*
125     ;; (if compiler::*current-function*
126     ;; (make-location (list :file *compile-filename*)
127     ;; (list :function-name
128     ;; (symbol-name
129     ;; (slot-value compiler::*current-function*
130     ;; 'compiler::name))))
131     (list :error "No location found.")
132     ;; )
133     )))
134    
135     (defimplementation call-with-compilation-hooks (function)
136     (handler-bind ((warning #'handle-compiler-warning))
137     (funcall function)))
138    
139     (defimplementation swank-compile-file (*compile-filename* load-p
140 heller 1.7 external-format)
141 jgarcia 1.1 (declare (ignore external-format))
142     (with-compilation-hooks ()
143     (let ((*buffer-name* nil))
144     (multiple-value-bind (fn warn fail)
145     (compile-file *compile-filename*)
146     (when load-p (unless fail (load fn)))))))
147    
148 heller 1.16 (defimplementation swank-compile-string (string &key buffer position directory
149     debug)
150     (declare (ignore directory debug))
151 jgarcia 1.1 (with-compilation-hooks ()
152     (let ((*buffer-name* buffer)
153     (*buffer-start-position* position)
154     (*buffer-string* string))
155     (with-input-from-string (s string)
156     (compile-from-stream s :load t)))))
157    
158     (defun compile-from-stream (stream &rest args)
159     (let ((file (si::mkstemp "TMP:ECLXXXXXX")))
160     (with-open-file (s file :direction :output :if-exists :overwrite)
161     (do ((line (read-line stream nil) (read-line stream nil)))
162 trittweiler 1.8 ((not line))
163 jgarcia 1.1 (write-line line s)))
164     (unwind-protect
165     (apply #'compile-file file args)
166     (delete-file file))))
167    
168    
169     ;;;; Documentation
170    
171     (defimplementation arglist (name)
172     (or (functionp name) (setf name (symbol-function name)))
173     (if (functionp name)
174     (typecase name
175     (generic-function
176     (clos::generic-function-lambda-list name))
177 gcarncross 1.10 (compiled-function
178     ; most of the compiled functions have an Args: line in their docs
179     (with-input-from-string (s (or
180     (si::get-documentation
181     (si:compiled-function-name name) 'function)
182     ""))
183     (do ((line (read-line s nil) (read-line s nil)))
184     ((not line) :not-available)
185     (ignore-errors
186     (if (string= (subseq line 0 6) "Args: ")
187     (return-from nil
188     (read-from-string (subseq line 6))))))))
189     ;
190 jgarcia 1.1 (function
191     (let ((fle (function-lambda-expression name)))
192     (case (car fle)
193     (si:lambda-block (caddr fle))
194     (t :not-available)))))
195     :not-available))
196    
197 heller 1.6 (defimplementation function-name (f)
198 jgarcia 1.1 (si:compiled-function-name f))
199    
200     (defimplementation macroexpand-all (form)
201     ;;; FIXME! This is not the same as a recursive macroexpansion!
202     (macroexpand form))
203    
204     (defimplementation describe-symbol-for-emacs (symbol)
205     (let ((result '()))
206     (dolist (type '(:VARIABLE :FUNCTION :CLASS))
207     (let ((doc (describe-definition symbol type)))
208     (when doc
209     (setf result (list* type doc result)))))
210     result))
211    
212     (defimplementation describe-definition (name type)
213     (case type
214     (:variable (documentation name 'variable))
215     (:function (documentation name 'function))
216     (:class (documentation name 'class))
217     (t nil)))
218    
219     ;;; Debugging
220    
221     (import
222 gcarncross 1.20 '(si::*break-env*
223     si::*ihs-top*
224 jgarcia 1.1 si::*ihs-current*
225     si::*ihs-base*
226     si::*frs-base*
227     si::*frs-top*
228     si::*tpl-commands*
229     si::*tpl-level*
230     si::frs-top
231     si::ihs-top
232 gcarncross 1.20 si::ihs-fun
233     si::ihs-env
234 jgarcia 1.1 si::sch-frs-base
235     si::set-break-env
236     si::set-current-ihs
237     si::tpl-commands))
238    
239 gcarncross 1.20 (defvar *backtrace* '())
240    
241 gcarncross 1.21 (defun in-swank-package-p (x)
242 gcarncross 1.22 (and
243     (symbolp x)
244     (member (symbol-package x)
245     (list #.(find-package :swank)
246     #.(find-package :swank-backend)
247     #.(ignore-errors (find-package :swank-mop))
248     #.(ignore-errors (find-package :swank-loader))))
249     t))
250    
251     (defun is-swank-source-p (name)
252     (setf name (pathname name))
253     (pathname-match-p
254     name
255     (make-pathname :defaults swank-loader::*source-directory*
256     :name (pathname-name name)
257     :type (pathname-type name)
258     :version (pathname-version name))))
259    
260     (defun is-ignorable-fun-p (x)
261     (or
262     (in-swank-package-p (frame-name x))
263     (multiple-value-bind (file position)
264     (ignore-errors (si::bc-file (car x)))
265     (declare (ignore position))
266     (if file (is-swank-source-p file)))))
267 gcarncross 1.21
268 jgarcia 1.1 (defimplementation call-with-debugging-environment (debugger-loop-fn)
269     (declare (type function debugger-loop-fn))
270     (let* ((*tpl-commands* si::tpl-commands)
271     (*ihs-top* (ihs-top 'call-with-debugging-environment))
272     (*ihs-current* *ihs-top*)
273     (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top))))
274     (*frs-top* (frs-top))
275     (*read-suppress* nil)
276 gcarncross 1.20 (*tpl-level* (1+ *tpl-level*))
277     (*backtrace* (loop for ihs from *ihs-base* below *ihs-top*
278 gcarncross 1.21 collect (list (si::ihs-fun ihs)
279 gcarncross 1.20 (si::ihs-env ihs)
280     nil))))
281     (loop for f from *frs-base* until *frs-top*
282     do (let ((i (- (si::frs-ihs f) *ihs-base* 1)))
283     (when (plusp i)
284     (let* ((x (elt *backtrace* i))
285     (name (si::frs-tag f)))
286 gcarncross 1.23 (unless (si::fixnump name)
287 gcarncross 1.20 (push name (third x)))))))
288 gcarncross 1.22 (setf *backtrace* (remove-if #'is-ignorable-fun-p (nreverse *backtrace*)))
289     (Setf *tmp* *backtrace*)
290 jgarcia 1.1 (set-break-env)
291     (set-current-ihs)
292 gcarncross 1.20 (let ((*ihs-base* *ihs-top*))
293     (funcall debugger-loop-fn))))
294    
295     (defimplementation call-with-debugger-hook (hook fun)
296     (let ((*debugger-hook* hook)
297     (*ihs-base*(si::ihs-top 'call-with-debugger-hook)))
298     (funcall fun)))
299 jgarcia 1.1
300     (defimplementation compute-backtrace (start end)
301 gcarncross 1.20 (when (numberp end)
302     (setf end (min end (length *backtrace*))))
303     (subseq *backtrace* start end))
304    
305     (defun frame-name (frame)
306     (let ((x (first frame)))
307     (if (symbolp x)
308     x
309     (function-name x))))
310    
311     (defun function-position (fun)
312     (multiple-value-bind (file position)
313     (si::bc-file fun)
314     (and file (make-location `(:file ,file) `(:position ,position)))))
315    
316     (defun frame-function (frame)
317     (let* ((x (first frame))
318     fun position)
319     (etypecase x
320     (symbol (and (fboundp x)
321     (setf fun (fdefinition x)
322     position (function-position fun))))
323     (function (setf fun x position (function-position x))))
324     (values fun position)))
325    
326     (defun frame-decode-env (frame)
327     (let ((functions '())
328     (blocks '())
329     (variables '()))
330     (dolist (record (second frame))
331     (let* ((record0 (car record))
332     (record1 (cdr record)))
333     (cond ((symbolp record0)
334     (setq variables (acons record0 record1 variables)))
335 gcarncross 1.23 ((not (si::fixnump record0))
336 gcarncross 1.20 (push record1 functions))
337     ((symbolp record1)
338     (push record1 blocks))
339     (t
340     ))))
341     (values functions blocks variables)))
342 jgarcia 1.1
343     (defimplementation print-frame (frame stream)
344 gcarncross 1.20 (format stream "~A" (first frame)))
345    
346     (defimplementation frame-source-location-for-emacs (frame-number)
347     (nth-value 1 (frame-function (elt *backtrace* frame-number))))
348    
349     (defimplementation frame-catch-tags (frame-number)
350     (third (elt *backtrace* frame-number)))
351    
352     (defimplementation frame-locals (frame-number)
353     (loop for (name . value) in (nth-value 2 (frame-decode-env (elt *backtrace* frame-number)))
354     with i = 0
355     collect (list :name name :id (prog1 i (incf i)) :value value)))
356    
357     (defimplementation frame-var-value (frame-number var-id)
358     (elt (nth-value 2 (frame-decode-env (elt *backtrace* frame-number)))
359     var-id))
360    
361     (defimplementation disassemble-frame (frame-number)
362     (let ((fun (frame-fun (elt *backtrace* frame-number))))
363     (disassemble fun)))
364    
365     (defimplementation eval-in-frame (form frame-number)
366     (let ((env (second (elt *backtrace* frame-number))))
367     (si:eval-with-env form env)))
368 jgarcia 1.1
369     ;;;; Inspector
370    
371 heller 1.13 (defmethod emacs-inspect ((o t))
372 gcarncross 1.11 ; ecl clos support leaves some to be desired
373     (cond
374     ((streamp o)
375 heller 1.14 (list*
376     (format nil "~S is an ordinary stream~%" o)
377 gcarncross 1.11 (append
378     (list
379     "Open for "
380     (cond
381     ((ignore-errors (interactive-stream-p o)) "Interactive")
382     ((and (input-stream-p o) (output-stream-p o)) "Input and output")
383     ((input-stream-p o) "Input")
384     ((output-stream-p o) "Output"))
385     `(:newline) `(:newline))
386     (label-value-line*
387     ("Element type" (stream-element-type o))
388     ("External format" (stream-external-format o)))
389     (ignore-errors (label-value-line*
390     ("Broadcast streams" (broadcast-stream-streams o))))
391     (ignore-errors (label-value-line*
392     ("Concatenated streams" (concatenated-stream-streams o))))
393     (ignore-errors (label-value-line*
394     ("Echo input stream" (echo-stream-input-stream o))))
395     (ignore-errors (label-value-line*
396     ("Echo output stream" (echo-stream-output-stream o))))
397     (ignore-errors (label-value-line*
398     ("Output String" (get-output-stream-string o))))
399     (ignore-errors (label-value-line*
400     ("Synonym symbol" (synonym-stream-symbol o))))
401     (ignore-errors (label-value-line*
402     ("Input stream" (two-way-stream-input-stream o))))
403     (ignore-errors (label-value-line*
404     ("Output stream" (two-way-stream-output-stream o)))))))
405     (t
406     (let* ((cl (si:instance-class o))
407     (slots (clos:class-slots cl)))
408 heller 1.14 (list* (format nil "~S is an instance of class ~A~%"
409 gcarncross 1.11 o (clos::class-name cl))
410     (loop for x in slots append
411     (let* ((name (clos:slot-definition-name x))
412     (value (clos::slot-value o name)))
413     (list
414     (format nil "~S: " name)
415     `(:value ,value)
416     `(:newline)))))))))
417    
418 jgarcia 1.1 ;;;; Definitions
419    
420 gcarncross 1.19 (defimplementation find-definitions (name)
421     (if (fboundp name)
422     (let ((tmp (find-source-location (symbol-function name))))
423     `(((defun ,name) ,tmp)))))
424 gcarncross 1.9
425 gcarncross 1.17 (defimplementation find-source-location (obj)
426 gcarncross 1.19 (setf *tmp* obj)
427 gcarncross 1.17 (or
428     (typecase obj
429     (function
430 gcarncross 1.20 (multiple-value-bind (file pos) (ignore-errors (si::bc-file obj))
431 gcarncross 1.17 (if (and file pos)
432 gcarncross 1.18 (make-location
433 gcarncross 1.19 `(:file ,(namestring file))
434 gcarncross 1.18 `(:position ,pos)
435     `(:snippet
436     ,(with-open-file (s file)
437     (skip-toplevel-forms pos s)
438     (skip-comments-and-whitespace s)
439     (read-snippet s))))))))
440 gcarncross 1.17 `(:error (format nil "Source definition of ~S not found" obj))))
441    
442 gcarncross 1.9 ;;;; Threads
443    
444     #+threads
445     (progn
446     (defvar *thread-id-counter* 0)
447    
448     (defvar *thread-id-counter-lock*
449     (mp:make-lock :name "thread id counter lock"))
450    
451     (defun next-thread-id ()
452     (mp:with-lock (*thread-id-counter-lock*)
453     (incf *thread-id-counter*)))
454    
455     (defparameter *thread-id-map* (make-hash-table))
456 heller 1.26 (defparameter *id-thread-map* (make-hash-table))
457 gcarncross 1.9
458     (defvar *thread-id-map-lock*
459     (mp:make-lock :name "thread id map lock"))
460    
461     ; ecl doesn't have weak pointers
462     (defimplementation spawn (fn &key name)
463     (let ((thread (mp:make-process :name name))
464     (id (next-thread-id)))
465     (mp:process-preset
466     thread
467     #'(lambda ()
468     (unwind-protect
469     (mp:with-lock (*thread-id-map-lock*)
470 heller 1.26 (setf (gethash id *thread-id-map*) thread)
471     (setf (gethash thread *id-thread-map*) id))
472 gcarncross 1.9 (funcall fn)
473     (mp:with-lock (*thread-id-map-lock*)
474 heller 1.26 (remhash thread *id-thread-map*)
475 gcarncross 1.9 (remhash id *thread-id-map*)))))
476     (mp:process-enable thread)))
477    
478     (defimplementation thread-id (thread)
479     (block thread-id
480     (mp:with-lock (*thread-id-map-lock*)
481 heller 1.26 (or (gethash thread *id-thread-map*)
482     (let ((id (next-thread-id)))
483     (setf (gethash id *thread-id-map*) thread)
484     (setf (gethash thread *id-thread-map*) id)
485     id)))))
486 gcarncross 1.9
487     (defimplementation find-thread (id)
488     (mp:with-lock (*thread-id-map-lock*)
489     (gethash id *thread-id-map*)))
490    
491     (defimplementation thread-name (thread)
492     (mp:process-name thread))
493    
494     (defimplementation thread-status (thread)
495     (if (mp:process-active-p thread)
496     "RUNNING"
497     "STOPPED"))
498    
499     (defimplementation make-lock (&key name)
500     (mp:make-lock :name name))
501    
502     (defimplementation call-with-lock-held (lock function)
503     (declare (type function function))
504     (mp:with-lock (lock) (funcall function)))
505    
506     (defimplementation current-thread ()
507     mp:*current-process*)
508    
509     (defimplementation all-threads ()
510     (mp:all-processes))
511    
512     (defimplementation interrupt-thread (thread fn)
513     (mp:interrupt-process thread fn))
514    
515     (defimplementation kill-thread (thread)
516     (mp:process-kill thread))
517    
518     (defimplementation thread-alive-p (thread)
519     (mp:process-active-p thread))
520    
521     (defvar *mailbox-lock* (mp:make-lock :name "mailbox lock"))
522    
523     (defstruct (mailbox (:conc-name mailbox.))
524     (mutex (mp:make-lock :name "process mailbox"))
525     (queue '() :type list))
526    
527     (defun mailbox (thread)
528     "Return THREAD's mailbox."
529     (mp:with-lock (*mailbox-lock*)
530     (or (find thread *mailboxes* :key #'mailbox.thread)
531     (let ((mb (make-mailbox :thread thread)))
532     (push mb *mailboxes*)
533     mb))))
534    
535     (defimplementation send (thread message)
536     (let* ((mbox (mailbox thread))
537     (mutex (mailbox.mutex mbox)))
538     (mp:interrupt-process
539     thread
540     (lambda ()
541     (mp:with-lock (mutex)
542     (setf (mailbox.queue mbox)
543     (nconc (mailbox.queue mbox) (list message))))))))
544    
545     (defimplementation receive ()
546     (block got-mail
547     (let* ((mbox (mailbox mp:*current-process*))
548     (mutex (mailbox.mutex mbox)))
549     (loop
550     (mp:with-lock (mutex)
551     (if (mailbox.queue mbox)
552     (return-from got-mail (pop (mailbox.queue mbox)))))
553     ;interrupt-process will halt this if it takes longer than 1sec
554     (sleep 1)))))
555    
556     (defmethod stream-finish-output ((stream stream))
557     (finish-output stream))
558    
559     )
560    

  ViewVC Help
Powered by ViewVC 1.1.5