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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.68 - (hide annotations)
Tue Feb 24 23:31:34 2004 UTC (10 years, 1 month ago) by heller
Branch: MAIN
Changes since 1.67: +3 -0 lines
* slime.el: Various bits of support for maintaining multiple SLIME
connections to different Lisp implementations simultaneously.

* swank-{backend,cmucl,sbcl,clisp,lispworks,openmcl}.lisp
(lisp-implementation-type-name): Add function to
return simple name of lisp implementation; used by new
multi-connection functionality in slime.el.
1 heller 1.60 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
2 dbarlow 1.1 ;;;
3     ;;; swank-sbcl.lisp --- SLIME backend for SBCL.
4     ;;;
5     ;;; Created 2003, Daniel Barlow <dan@metacircles.com>
6     ;;;
7     ;;; This code has been placed in the Public Domain. All warranties are
8     ;;; disclaimed.
9    
10 dbarlow 1.30 ;;; This is a Slime backend for SBCL. Requires SBCL 0.8.5 or later
11     ;;; for the SB-INTROSPECT contrib
12 dbarlow 1.1
13     ;;; Cursory testing has found that the following appear to work
14     ;;;
15     ;;; * Symbol completion.
16     ;;; * Evaluation of forms with C-M-x
17     ;;; * Apropos
18     ;;; * Compilation of defuns with C-c C-c
19     ;;; * File compilation with C-c C-k, apparently including error parsing
20     ;;; * Disassembling the symbol at point with C-c M-d
21     ;;; * Describing symbol at point with C-c C-d
22     ;;; * Macroexpanding with C-c RET
23     ;;; * find-definition, using sb-introspect
24     ;;; * Basic debugger stuff: restarts, backtrace, toggle details
25     ;;; * Can now interrupt a busy sbcl with C-c C-g
26     ;;; * Most of the tests
27     ;;;
28     ;;; Things that aren't done/don't work yet:
29     ;;;
30     ;;; * Cross-referencing (nor is it likely, absent XREF port to SBCL)
31     ;;; * testsuite can't find LOOP, reports bogus failure on some arglist lookups
32     ;;; * eval-in-frame
33     ;;; * A slime command to load an asdf system. Note that this might involve
34     ;;; compiling/loading files that Emacs has no buffers for
35     ;;; * Dealing with multiple threads
36    
37     ;;; Administrivia
38    
39     (eval-when (:compile-toplevel :load-toplevel :execute)
40     (require 'sb-bsd-sockets)
41 heller 1.59 (require 'sb-introspect)
42 heller 1.60 (require 'sb-posix)
43 heller 1.59 )
44 dbarlow 1.1
45     (declaim (optimize (debug 3)))
46     (in-package :swank)
47    
48 heller 1.23 (import
49     '(sb-gray:fundamental-character-output-stream
50     sb-gray:stream-write-char
51     sb-gray:stream-line-length
52     sb-gray:stream-force-output
53     sb-gray:fundamental-character-input-stream
54     sb-gray:stream-read-char
55     sb-gray:stream-listen
56     sb-gray:stream-unread-char
57     sb-gray:stream-clear-input
58     sb-gray:stream-line-column
59     sb-gray:stream-line-length))
60    
61 dbarlow 1.1 ;;; TCP Server
62    
63 heller 1.59 (setq *swank-in-background* :sigio)
64 heller 1.49
65 heller 1.65 (defun resolve-hostname (name)
66     (car (sb-bsd-sockets:host-ent-addresses
67     (sb-bsd-sockets:get-host-by-name name))))
68    
69     (defimplementation create-socket (host port)
70 dbarlow 1.6 (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
71     :type :stream
72     :protocol :tcp)))
73 heller 1.48 (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
74 heller 1.65 (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port)
75 dbarlow 1.6 (sb-bsd-sockets:socket-listen socket 5)
76 heller 1.29 socket))
77    
78 lgorrie 1.54 (defimplementation local-port (socket)
79 lgorrie 1.46 (nth-value 1 (sb-bsd-sockets:socket-name socket)))
80    
81 lgorrie 1.54 (defimplementation close-socket (socket)
82 heller 1.48 (sb-bsd-sockets:socket-close socket))
83    
84 lgorrie 1.54 (defimplementation accept-connection (socket)
85 heller 1.48 (make-socket-io-stream (accept socket)))
86    
87 heller 1.59 (defvar *sigio-handlers* '()
88     "List of (key . fn) pairs to be called on SIGIO.")
89    
90     (defun sigio-handler (signal code scp)
91 heller 1.60 (declare (ignore signal code scp))
92     (mapc (lambda (handler)
93     (funcall (the function (cdr handler))))
94     *sigio-handlers*))
95 heller 1.59
96     (defun set-sigio-handler ()
97     (sb-sys:enable-interrupt sb-unix:SIGIO (lambda (signal code scp)
98     (sigio-handler signal code scp))))
99    
100 heller 1.62
101    
102     ;;;; XXX remove fcntl kludge when SBCL with sb-posix:fcntl is more
103     ;;;; widely available.
104     (defconstant +o_async+ 8192)
105     (defconstant +f_setown+ 8)
106     (defconstant +f_setfl+ 4)
107    
108     (unless (find-symbol (string :fcntl) :sb-posix)
109     (warn "No binding for fctnl(2) in sb-posix.
110     Please upgrade to SBCL 0.8.7.36 or later."))
111    
112     (defun enable-sigio-on-fd (fd)
113     (cond ((fboundp (find-symbol (string :fcntl) :sb-posix))
114     (funcall
115     (eval
116     (read-from-string
117     "(lambda (fd)
118     (sb-posix:fcntl fd sb-posix::f-setfl sb-posix::o-async)
119     (sb-posix:fcntl fd sb-posix::f-setown (sb-unix:unix-getpid)))"))
120     fd))
121     (t
122     (unless (sb-int:featurep :linux)
123     (warn "~
124 heller 1.66 You aren't running Linux. The values of +o_async+ etc are probably bogus."))
125 heller 1.62 (let ((fcntl (sb-alien:extern-alien
126     "fcntl"
127     (function sb-alien:int sb-alien:int
128     sb-alien:int sb-alien:int))))
129     ;; XXX error checking
130     (sb-alien:alien-funcall fcntl fd +f_setfl+ +o_async+)
131     (sb-alien:alien-funcall fcntl fd +f_setown+
132     (sb-unix:unix-getpid))))))
133    
134 heller 1.67 (defimplementation add-sigio-handler (socket fn)
135 heller 1.62 (set-sigio-handler)
136     (let ((fd (socket-fd socket)))
137     (format *debug-io* "Adding sigio handler: ~S ~%" fd)
138     (enable-sigio-on-fd fd)
139     (push (cons fd fn) *sigio-handlers*)))
140    
141     #+(or)
142 heller 1.67 (defimplementation add-sigio-handler (socket fn)
143 heller 1.61 (set-sigio-handler)
144 heller 1.59 (let ((fd (socket-fd socket)))
145     (format *debug-io* "Adding sigio handler: ~S ~%" fd)
146 heller 1.61 (sb-posix:fcntl fd sb-posix::f-setfl sb-posix::o-async)
147     (sb-posix:fcntl fd sb-posix::f-setown (sb-unix:unix-getpid))
148     (push (cons fd fn) *sigio-handlers*)))
149 heller 1.60
150 heller 1.67 (defimplementation remove-sigio-handlers (socket)
151 heller 1.59 (let ((fd (socket-fd socket)))
152     (setf *sigio-handlers* (delete fd *sigio-handlers* :key #'car))
153     (sb-sys:invalidate-descriptor fd))
154 heller 1.51 (close socket))
155 heller 1.67
156     (defimplementation add-fd-handler (socket fn)
157     (declare (type function fn))
158     (let ((fd (socket-fd socket)))
159     (format *debug-io* "; Adding fd handler: ~S ~%" fd)
160     (sb-sys:add-fd-handler fd :input (lambda (_)
161     _
162     (funcall fn)))))
163    
164     (defimplementation remove-fd-handlers (socket)
165     (sb-sys:invalidate-descriptor (socket-fd socket)))
166 heller 1.51
167 heller 1.48 (defun socket-fd (socket)
168     (etypecase socket
169     (fixnum socket)
170     (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket))
171     (file-stream (sb-sys:fd-stream-fd socket))))
172    
173 lgorrie 1.46 (defun make-socket-io-stream (socket)
174     (sb-bsd-sockets:socket-make-stream socket
175     :output t
176     :input t
177     :element-type 'base-char))
178    
179 heller 1.29 (defun accept (socket)
180     "Like socket-accept, but retry on EAGAIN."
181     (loop (handler-case
182     (return (sb-bsd-sockets:socket-accept socket))
183     (sb-bsd-sockets:interrupted-error ()))))
184 dbarlow 1.6
185 heller 1.52 (defmethod call-without-interrupts (fn)
186 heller 1.58 (declare (type function fn))
187 heller 1.52 (sb-sys:without-interrupts (funcall fn)))
188    
189     (defmethod getpid ()
190     (sb-unix:unix-getpid))
191    
192 heller 1.68 (defimplementation lisp-implementation-type-name ()
193     "sbcl")
194    
195 dbarlow 1.1 ;;; Utilities
196    
197 dbarlow 1.4 (defvar *swank-debugger-stack-frame*)
198 dbarlow 1.1
199     ;;; adapted from cmucl
200     (defslimefun set-default-directory (directory)
201     (setf *default-pathname-defaults* (merge-pathnames directory))
202     (namestring *default-pathname-defaults*))
203    
204 lgorrie 1.54 (defimplementation arglist-string (fname)
205 heller 1.52 (format-arglist fname #'sb-introspect:function-arglist))
206 dbarlow 1.1
207 dbarlow 1.42 (defvar *buffer-name* nil)
208 dbarlow 1.1 (defvar *buffer-offset*)
209    
210 lgorrie 1.24 (defvar *previous-compiler-condition* nil
211     "Used to detect duplicates.")
212    
213 dbarlow 1.1 (defun handle-notification-condition (condition)
214     "Handle a condition caused by a compiler warning.
215     This traps all compiler conditions at a lower-level than using
216     C:*COMPILER-NOTIFICATION-FUNCTION*. The advantage is that we get to
217     craft our own error messages, which can omit a lot of redundant
218     information."
219     (let ((context (sb-c::find-error-context nil)))
220 heller 1.36 (unless (eq condition *previous-compiler-condition*)
221 dbarlow 1.1 (setq *previous-compiler-condition* condition)
222 lgorrie 1.24 (signal-compiler-condition condition context))))
223    
224     (defun signal-compiler-condition (condition context)
225     (signal (make-condition
226     'compiler-condition
227     :original-condition condition
228     :severity (etypecase condition
229     (sb-c:compiler-error :error)
230     (sb-ext:compiler-note :note)
231     (style-warning :style-warning)
232     (warning :warning))
233 heller 1.66 :short-message (brief-compiler-message-for-emacs condition)
234     :message (long-compiler-message-for-emacs condition context)
235 lgorrie 1.24 :location (compiler-note-location context))))
236    
237 dbarlow 1.44
238    
239 lgorrie 1.24 (defun compiler-note-location (context)
240 dbarlow 1.42 (cond (context
241     (resolve-note-location
242     *buffer-name*
243     (sb-c::compiler-error-context-file-name context)
244     (sb-c::compiler-error-context-file-position context)
245     (current-compiler-error-source-path context)
246     (sb-c::compiler-error-context-original-source context)))
247     (t
248     (resolve-note-location *buffer-name* nil nil nil nil))))
249    
250     (defgeneric resolve-note-location (buffer file-name file-position
251     source-path source))
252    
253     (defmethod resolve-note-location ((b (eql nil)) (f pathname) pos path source)
254     (make-location
255 dbarlow 1.43 `(:file ,(namestring (truename f)))
256 dbarlow 1.42 `(:position ,(1+ (source-path-file-position path f)))))
257    
258     (defmethod resolve-note-location ((b string) (f (eql :stream)) pos path source)
259     (make-location
260     `(:buffer ,b)
261     `(:position ,(+ *buffer-offset*
262     (source-path-string-position path *buffer-substring*)))))
263    
264     (defmethod resolve-note-location (b (f (eql :lisp)) pos path (source string))
265     (make-location
266     `(:source-form ,source)
267     `(:position 1)))
268    
269     (defmethod resolve-note-location (buffer
270     (file (eql nil))
271     (pos (eql nil))
272     (path (eql nil))
273     (source (eql nil)))
274     (cond (buffer
275     (make-location (list :buffer buffer)
276     (list :position *buffer-offset*)))
277     (*compile-file-truename*
278     (make-location (list :file (namestring *compile-file-truename*))
279     (list :position 0)))
280     (t
281     (list :error "No error location available"))))
282    
283 heller 1.66 (defun brief-compiler-message-for-emacs (condition)
284 dbarlow 1.1 "Briefly describe a compiler error for Emacs.
285     When Emacs presents the message it already has the source popped up
286     and the source form highlighted. This makes much of the information in
287     the error-context redundant."
288 heller 1.66 (princ-to-string condition))
289    
290     (defun long-compiler-message-for-emacs (condition error-context)
291     "Describe a compiler error for Emacs including context information."
292 heller 1.45 (declare (type (or sb-c::compiler-error-context null) error-context))
293 heller 1.66 (multiple-value-bind (enclosing source)
294     (if error-context
295     (values (sb-c::compiler-error-context-enclosing-source error-context)
296     (sb-c::compiler-error-context-source error-context)))
297     (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~^~%~}~]~A"
298     enclosing source condition)))
299 dbarlow 1.1
300     (defun current-compiler-error-source-path (context)
301     "Return the source-path for the current compiler error.
302     Returns NIL if this cannot be determined by examining internal
303     compiler state."
304     (cond ((sb-c::node-p context)
305     (reverse
306     (sb-c::source-path-original-source
307     (sb-c::node-source-path context))))
308     ((sb-c::compiler-error-context-p context)
309     (reverse
310     (sb-c::compiler-error-context-original-source-path context)))))
311    
312 lgorrie 1.54 (defimplementation call-with-compilation-hooks (function)
313 heller 1.58 (declare (type function function))
314 dbarlow 1.41 (handler-bind ((sb-c:compiler-error #'handle-notification-condition)
315     (sb-ext:compiler-note #'handle-notification-condition)
316     (style-warning #'handle-notification-condition)
317     (warning #'handle-notification-condition))
318     (funcall function)))
319 lgorrie 1.24
320 lgorrie 1.54 (defimplementation compile-file-for-emacs (filename load-p)
321 lgorrie 1.24 (with-compilation-hooks ()
322 dbarlow 1.41 (multiple-value-bind (fasl-file w-p f-p) (compile-file filename)
323 heller 1.58 (declare (ignore w-p))
324 dbarlow 1.41 (cond ((and fasl-file (not f-p) load-p)
325 heller 1.36 (load fasl-file))
326     (t fasl-file)))))
327 dbarlow 1.41
328 lgorrie 1.54 (defimplementation compile-system-for-emacs (system-name)
329 dbarlow 1.41 (with-compilation-hooks ()
330     (asdf:operate 'asdf:load-op system-name)))
331 lgorrie 1.24
332 lgorrie 1.54 (defimplementation compile-string-for-emacs (string &key buffer position)
333 lgorrie 1.24 (with-compilation-hooks ()
334 heller 1.32 (let ((*package* *buffer-package*)
335 dbarlow 1.42 (*buffer-name* buffer)
336 heller 1.32 (*buffer-offset* position))
337     (eval (from-string
338     (format nil "(funcall (compile nil '(lambda () ~A)))"
339     string))))))
340 dbarlow 1.1
341     ;;;; xref stuff doesn't exist for sbcl yet
342    
343     (defslimefun-unimplemented who-calls (function-name))
344    
345     (defslimefun-unimplemented who-references (variable))
346    
347     (defslimefun-unimplemented who-binds (variable))
348    
349     (defslimefun-unimplemented who-sets (variable))
350    
351     (defslimefun-unimplemented who-macroexpands (macro))
352    
353     ;;;; Definitions
354    
355     (defvar *debug-definition-finding* nil
356     "When true don't handle errors while looking for definitions.
357     This is useful when debugging the definition-finding code.")
358    
359     ;;; FIXME we don't handle the compiled-interactively case yet. That
360     ;;; should have NIL :filename & :position, and non-NIL :source-form
361 heller 1.36 (defun function-source-location (function &optional name)
362 dbarlow 1.1 "Try to find the canonical source location of FUNCTION."
363     (let* ((def (sb-introspect:find-definition-source function))
364     (pathname (sb-introspect:definition-source-pathname def))
365 heller 1.32 (path (sb-introspect:definition-source-form-path def))
366     (position (sb-introspect:definition-source-character-offset def)))
367     (unless pathname
368     (return-from function-source-location
369 heller 1.36 (list :error (format nil "No filename for: ~S" function))))
370 heller 1.32 (multiple-value-bind (truename condition)
371     (ignore-errors (truename pathname))
372     (when condition
373     (return-from function-source-location
374     (list :error (format nil "~A" condition))))
375     (make-location
376     (list :file (namestring truename))
377     ;; source-paths depend on the file having been compiled with
378     ;; lotsa debugging. If not present, return the function name
379     ;; for emacs to attempt to find with a regex
380     (cond (path (list :source-path path position))
381 heller 1.36 (t (list :function-name
382     (or (and name (string name))
383     (sb-kernel:%fun-name function)))))))))
384 dbarlow 1.1
385 lgorrie 1.54 (defimplementation find-function-locations (fname-string)
386 heller 1.36 (let* ((symbol (from-string fname-string)))
387     (labels ((finder (fun)
388     (cond ((and (symbolp fun) (macro-function fun))
389 heller 1.35 (list
390 heller 1.36 (function-source-location (macro-function fun)
391     symbol)))
392     ((typep fun 'sb-mop:generic-function)
393 dbarlow 1.34 (list*
394 heller 1.36 (function-source-location fun symbol)
395 dbarlow 1.34 (mapcar
396 heller 1.36 (lambda (x) (function-source-location x symbol))
397     (sb-mop:generic-function-methods fun))))
398     ((functionp fun)
399 heller 1.35 (list
400 heller 1.36 (function-source-location fun symbol)))
401     ((sb-introspect:valid-function-name-p fun)
402     (finder (fdefinition fun)))
403     (t (list
404     (list :error "Not a function: ~A" fun))))))
405 dbarlow 1.1 (if *debug-definition-finding*
406 heller 1.36 (finder symbol)
407     (handler-case (finder symbol)
408 heller 1.32 (error (e)
409 heller 1.36 (list (list :error (format nil "Error: ~A" e)))))))))
410 lgorrie 1.24
411 lgorrie 1.54 (defimplementation describe-symbol-for-emacs (symbol)
412 dbarlow 1.1 "Return a plist describing SYMBOL.
413     Return NIL if the symbol is unbound."
414     (let ((result '()))
415 lgorrie 1.24 (labels ((doc (kind)
416     (or (documentation symbol kind) :not-documented))
417 dbarlow 1.1 (maybe-push (property value)
418     (when value
419     (setf result (list* property value result)))))
420     (maybe-push
421     :variable (multiple-value-bind (kind recorded-p)
422     (sb-int:info :variable :kind symbol)
423     (declare (ignore kind))
424     (if (or (boundp symbol) recorded-p)
425     (doc 'variable))))
426     (maybe-push
427     :function (if (fboundp symbol)
428     (doc 'function)))
429     (maybe-push
430     :setf (if (or (sb-int:info :setf :inverse symbol)
431     (sb-int:info :setf :expander symbol))
432     (doc 'setf)))
433     (maybe-push
434     :type (if (sb-int:info :type :kind symbol)
435     (doc 'type)))
436 lgorrie 1.24 result)))
437 dbarlow 1.1
438 lgorrie 1.54 (defimplementation describe-definition (symbol-name type)
439     (case type
440     (:variable
441     (describe-symbol symbol-name))
442     (:setf
443     (print-description-to-string `(setf ,(from-string symbol-name))))
444     (:class
445     (print-description-to-string (find-class (from-string symbol-name) nil)))
446     (:type
447     (print-description-to-string
448     (sb-kernel:values-specifier-type (from-string symbol-name))))))
449 dbarlow 1.1
450 dbarlow 1.4 ;;; macroexpansion
451 dbarlow 1.1
452 lgorrie 1.54 (defimplementation macroexpand-all (form)
453 heller 1.21 (let ((sb-walker:*walk-form-expand-macros-p* t))
454     (sb-walker:walk-form form)))
455 lgorrie 1.25
456 dbarlow 1.1
457     ;;; Debugging
458    
459     (defvar *sldb-stack-top*)
460 heller 1.58 (defvar *sldb-restarts* nil)
461     (declaim (type list *sldb-restarts*))
462 dbarlow 1.1
463 lgorrie 1.54 (defimplementation call-with-debugging-environment (debugger-loop-fn)
464 heller 1.58 (declare (type function debugger-loop-fn))
465 lgorrie 1.25 (let* ((*sldb-stack-top* (or sb-debug:*stack-top-hint* (sb-di:top-frame)))
466 dbarlow 1.1 (*sldb-restarts* (compute-restarts *swank-debugger-condition*))
467     (sb-debug:*stack-top-hint* nil)
468     (*debugger-hook* nil)
469     (*readtable* (or sb-debug:*debug-readtable* *readtable*))
470 heller 1.36 (*print-level* 4 #+nil sb-debug:*debug-print-level*)
471     (*print-length* 10 #+nil sb-debug:*debug-print-length*)
472 heller 1.32 (*print-readably* nil))
473 dbarlow 1.1 (handler-bind ((sb-di:debug-condition
474     (lambda (condition)
475 lgorrie 1.25 (signal (make-condition
476     'sldb-condition
477     :original-condition condition)))))
478     (funcall debugger-loop-fn))))
479 dbarlow 1.1
480     (defun format-restarts-for-emacs ()
481     "Return a list of restarts for *swank-debugger-condition* in a
482     format suitable for Emacs."
483     (loop for restart in *sldb-restarts*
484     collect (list (princ-to-string (restart-name restart))
485     (princ-to-string restart))))
486    
487     (defun nth-frame (index)
488     (do ((frame *sldb-stack-top* (sb-di:frame-down frame))
489     (i index (1- i)))
490     ((zerop i) frame)))
491    
492     (defun nth-restart (index)
493     (nth index *sldb-restarts*))
494    
495 heller 1.45 (defun format-frame-for-emacs (number frame)
496     (print-with-frame-label
497     number (lambda (*standard-output*)
498     (sb-debug::print-frame-call frame :verbosity 1 :number nil))))
499 dbarlow 1.1
500     (defun compute-backtrace (start end)
501     "Return a list of frames starting with frame number START and
502     continuing to frame number END or, if END is nil, the last frame on the
503     stack."
504     (let ((end (or end most-positive-fixnum)))
505 heller 1.45 (loop for f = (nth-frame start) then (sb-di:frame-down f)
506     for i from start below end
507     while f
508     collect (cons i f))))
509 dbarlow 1.1
510 lgorrie 1.54 (defimplementation backtrace (start end)
511 heller 1.45 (loop for (n . frame) in (compute-backtrace start end)
512     collect (list n (format-frame-for-emacs n frame))))
513 dbarlow 1.1
514 lgorrie 1.54 (defimplementation debugger-info-for-emacs (start end)
515 heller 1.45 (list (debugger-condition-for-emacs)
516 dbarlow 1.1 (format-restarts-for-emacs)
517 lgorrie 1.26 (backtrace start end)))
518 dbarlow 1.1
519     (defun code-location-source-path (code-location)
520     (let* ((location (sb-debug::maybe-block-start-location code-location))
521     (form-num (sb-di:code-location-form-number location)))
522     (let ((translations (sb-debug::get-toplevel-form location)))
523     (unless (< form-num (length translations))
524     (error "Source path no longer exists."))
525     (reverse (cdr (svref translations form-num))))))
526    
527     (defun code-location-file-position (code-location)
528     (let* ((debug-source (sb-di:code-location-debug-source code-location))
529     (filename (sb-di:debug-source-name debug-source))
530     (path (code-location-source-path code-location)))
531     (source-path-file-position path filename)))
532    
533 dbarlow 1.44 ;;; source-path-file-position and friends are in swank-source-path-parser
534 dbarlow 1.1
535     (defun debug-source-info-from-emacs-buffer-p (debug-source)
536     (let ((info (sb-c::debug-source-info debug-source)))
537     (and info
538     (consp info)
539     (eq :emacs-buffer (car info)))))
540    
541     (defun source-location-for-emacs (code-location)
542     (let* ((debug-source (sb-di:code-location-debug-source code-location))
543     (from (sb-di:debug-source-from debug-source))
544     (name (sb-di:debug-source-name debug-source)))
545 heller 1.32 (ecase from
546     (:file
547 heller 1.36 (let ((source-path (ignore-errors
548     (code-location-source-path code-location))))
549     (cond (source-path
550     ;; XXX: code-location-source-path reads the source !!
551     (let ((position (code-location-file-position code-location)))
552     (make-location
553     (list :file (namestring (truename name)))
554     (list :source-path source-path position))))
555     (t
556     (let* ((dfn (sb-di:code-location-debug-fun code-location))
557     (fn (sb-di:debug-fun-fun dfn)))
558     (unless fn
559     (error "Cannot find source location for: ~A "
560     code-location))
561     (function-source-location
562     fn (sb-di:debug-fun-name dfn)))))))
563    
564 heller 1.32 (:lisp
565     (make-location
566     (list :source-form (with-output-to-string (*standard-output*)
567     (sb-debug::print-code-location-source-form
568     code-location 100)))
569     (list :position 0))))))
570 dbarlow 1.1
571     (defun safe-source-location-for-emacs (code-location)
572     (handler-case (source-location-for-emacs code-location)
573 heller 1.36 (error (c) (list :error (format nil "~A" c)))))
574    
575 lgorrie 1.54 (defimplementation frame-source-location-for-emacs (index)
576 heller 1.22 (safe-source-location-for-emacs
577     (sb-di:frame-code-location (nth-frame index))))
578 dbarlow 1.1
579     #+nil
580 lgorrie 1.54 (defimplementation eval-in-frame (form index)
581 lgorrie 1.26 (sb-di:eval-in-frame (nth-frame index) string))
582 dbarlow 1.1
583 lgorrie 1.54 (defimplementation frame-locals (index)
584 dbarlow 1.1 (let* ((frame (nth-frame index))
585     (location (sb-di:frame-code-location frame))
586     (debug-function (sb-di:frame-debug-fun frame))
587     (debug-variables (sb-di::debug-fun-debug-vars debug-function)))
588 heller 1.58 (declare (type (or null simple-vector) debug-variables))
589 dbarlow 1.1 (loop for v across debug-variables
590     collect (list
591 heller 1.45 :name (to-string (sb-di:debug-var-symbol v))
592 dbarlow 1.1 :id (sb-di:debug-var-id v)
593     :value-string
594     (if (eq (sb-di:debug-var-validity v location)
595     :valid)
596     (to-string (sb-di:debug-var-value v frame))
597     "<not-available>")))))
598    
599 lgorrie 1.54 (defimplementation frame-catch-tags (index)
600 dbarlow 1.1 (loop for (tag . code-location) in (sb-di:frame-catches (nth-frame index))
601     collect `(,tag . ,(safe-source-location-for-emacs code-location))))
602    
603     (defslimefun invoke-nth-restart (index)
604 heller 1.33 (invoke-restart-interactively (nth-restart index)))
605 dbarlow 1.1
606     (defslimefun sldb-abort ()
607     (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))
608 lgorrie 1.50
609 heller 1.56 (defimplementation eval-in-frame (form index)
610     (let ((frame (nth-frame index)))
611 heller 1.58 (funcall (the function
612     (sb-di:preprocess-for-eval form
613     (sb-di:frame-code-location frame)))
614 heller 1.56 frame)))
615    
616     (defun sb-debug-catch-tag-p (tag)
617     (and (symbolp tag)
618     (not (symbol-package tag))
619     (string= tag :sb-debug-catch-tag)))
620    
621     (defimplementation return-from-frame (index form)
622     (let* ((frame (nth-frame index))
623     (form (from-string form))
624     (probe (assoc-if #'sb-debug-catch-tag-p
625     (sb-di::frame-catches frame))))
626     (cond (probe (throw (car probe) (eval-in-frame form index)))
627     (t (format nil "Cannot return from frame: ~S" frame)))))
628    
629 heller 1.57
630     ;;;; Profiling
631    
632     (defimplementation profile (fname)
633     (when fname (eval `(sb-profile:profile ,fname))))
634    
635     (defimplementation unprofile (fname)
636     (when fname (eval `(sb-profile:unprofile ,fname))))
637    
638     (defimplementation unprofile-all ()
639     (sb-profile:unprofile)
640     "All functions unprofiled.")
641    
642     (defimplementation profile-report ()
643     (sb-profile:report))
644    
645     (defimplementation profile-reset ()
646     (sb-profile:reset)
647     "Reset profiling counters.")
648    
649     (defimplementation profiled-functions ()
650     (sb-profile:profile))
651    
652    
653 heller 1.64 ;;;; Inspector
654 heller 1.63
655 heller 1.64 (defimplementation describe-primitive-type (object)
656     (declare (ignore object))
657     "NYI")
658 heller 1.63
659 heller 1.64 (defmethod inspected-parts (o)
660     (cond ((sb-di::indirect-value-cell-p o)
661     (inspected-parts-of-value-cell o))
662     (t
663     (multiple-value-bind (text labeledp parts)
664     (sb-impl::inspected-parts o)
665     (let ((parts (if labeledp
666     (loop for (label . value) in parts
667     collect (cons (string label) value))
668     (loop for value in parts
669     for i from 0
670     collect (cons (format nil "~D" i) value)))))
671     (values text parts))))))
672    
673     (defun inspected-parts-of-value-cell (o)
674     (values (format nil "~A~% is a value cell." o)
675     (list (cons "Value" (sb-kernel:value-cell-ref o)))))
676    
677     (defmethod inspected-parts ((o function))
678     (let ((header (sb-kernel:widetag-of o)))
679     (cond ((= header sb-vm:simple-fun-header-widetag)
680     (values
681     (format nil "~A~% is a simple-fun." o)
682     (list (cons "Self" (sb-kernel:%simple-fun-self o))
683     (cons "Next" (sb-kernel:%simple-fun-next o))
684     (cons "Name" (sb-kernel:%simple-fun-name o))
685     (cons "Arglist" (sb-kernel:%simple-fun-arglist o))
686     (cons "Type" (sb-kernel:%simple-fun-type o))
687     (cons "Code Object" (sb-kernel:fun-code-header o)))))
688     ((= header sb-vm:closure-header-widetag)
689     (values (format nil "~A~% is a closure." o)
690     (list*
691     (cons "Function" (sb-kernel:%closure-fun o))
692     (loop for i from 0
693     below (- (sb-kernel:get-closure-length o)
694     (1- sb-vm:closure-info-offset))
695     collect (cons (format nil "~D" i)
696     (sb-kernel:%closure-index-ref o i))))))
697     (t (call-next-method o)))))
698    
699     (defmethod inspected-parts ((o sb-kernel:code-component))
700     (values (format nil "~A~% is a code data-block." o)
701     `(("First entry point" . ,(sb-kernel:%code-entry-points o))
702     ,@(loop for i from sb-vm:code-constants-offset
703     below (sb-kernel:get-header-data o)
704     collect (cons (format nil "Constant#~D" i)
705     (sb-kernel:code-header-ref o i)))
706     ("Debug info" . ,(sb-kernel:%code-debug-info o))
707     ("Instructions" . ,(sb-kernel:code-instructions o)))))
708    
709     (defmethod inspected-parts ((o sb-kernel:fdefn))
710     (values (format nil "~A~% is a fdefn object." o)
711     `(("Name" . ,(sb-kernel:fdefn-name o))
712     ("Function" . ,(sb-kernel:fdefn-fun o)))))
713    
714    
715     (defmethod inspected-parts ((o generic-function))
716     (values (format nil "~A~% is a generic function." o)
717     (list
718     (cons "Method-Class" (sb-pcl:generic-function-method-class o))
719     (cons "Methods" (sb-pcl:generic-function-methods o))
720     (cons "Name" (sb-pcl:generic-function-name o))
721     (cons "Declarations" (sb-pcl:generic-function-declarations o))
722     (cons "Method-Combination"
723     (sb-pcl:generic-function-method-combination o))
724     (cons "Lambda-List" (sb-pcl:generic-function-lambda-list o))
725     (cons "Precedence-Order"
726     (sb-pcl:generic-function-argument-precedence-order o))
727     (cons "Pretty-Arglist"
728     (sb-pcl::generic-function-pretty-arglist o))
729     (cons "Initial-Methods"
730     (sb-pcl::generic-function-initial-methods o)))))
731 heller 1.63
732    
733 lgorrie 1.50 ;;;; Multiprocessing
734    
735     #+SB-THREAD
736     (progn
737 lgorrie 1.54 (defimplementation spawn (fn &key name)
738 lgorrie 1.50 (declare (ignore name))
739     (sb-thread:make-thread fn))
740    
741 lgorrie 1.54 (defimplementation startup-multiprocessing ()
742 lgorrie 1.50 (setq *swank-in-background* :spawn))
743    
744 heller 1.63 (defimplementation thread-name (thread)
745     (format nil "Thread ~D" thread))
746 lgorrie 1.50
747 heller 1.63 (defimplementation thread-status (thread)
748     (declare (ignore thread))
749     "???")
750 lgorrie 1.50
751 lgorrie 1.54 (defimplementation make-lock (&key name)
752 lgorrie 1.50 (sb-thread:make-mutex :name name))
753    
754 lgorrie 1.54 (defimplementation call-with-lock-held (lock function)
755 heller 1.58 (declare (type function function))
756 lgorrie 1.50 (sb-thread:with-mutex (lock) (funcall function)))
757 heller 1.59
758     (defimplementation current-thread ()
759     (sb-thread:current-thread-id))
760    
761 heller 1.63 (defimplementation all-threads ()
762 heller 1.59 (sb-thread::mapcar-threads
763     (lambda (sap)
764     (sb-sys:sap-ref-32 sap (* sb-vm:n-word-bytes
765     sb-vm::thread-pid-slot)))))
766    
767     (defimplementation interrupt-thread (thread fn)
768     (sb-thread:interrupt-thread thread fn))
769    
770     ;; XXX there is some deadlock / race condition here
771    
772     (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))
773     (defvar *mailboxes* (list))
774 heller 1.60 (declaim (type list *mailboxes*))
775 heller 1.59
776     (defstruct (mailbox (:conc-name mailbox.))
777     thread
778     (mutex (sb-thread:make-mutex))
779     (waitqueue (sb-thread:make-waitqueue))
780     (queue '() :type list))
781    
782     (defun mailbox (thread)
783     "Return THREAD's mailbox."
784     (sb-thread:with-mutex (*mailbox-lock*)
785     (or (find thread *mailboxes* :key #'mailbox.thread)
786     (let ((mb (make-mailbox :thread thread)))
787     (push mb *mailboxes*)
788     mb))))
789    
790     (defimplementation send (thread message)
791     (let* ((mbox (mailbox thread))
792     (mutex (mailbox.mutex mbox)))
793     (sb-thread:with-mutex (mutex)
794     (setf (mailbox.queue mbox)
795     (nconc (mailbox.queue mbox) (list message)))
796     (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
797    
798     (defimplementation receive ()
799     (let* ((mbox (mailbox (sb-thread:current-thread-id)))
800     (mutex (mailbox.mutex mbox)))
801     (sb-thread:with-mutex (mutex)
802     (loop
803     (let ((q (mailbox.queue mbox)))
804     (cond (q (return (pop (mailbox.queue mbox))))
805     (t (sb-thread:condition-wait (mailbox.waitqueue mbox)
806     mutex))))))))
807    
808     )
809 dbarlow 1.1
810     ;;; Local Variables:
811     ;;; eval: (font-lock-add-keywords 'lisp-mode '(("(\\(defslimefun\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)" (1 font-lock-keyword-face) (2 font-lock-function-name-face))))
812     ;;; End:

  ViewVC Help
Powered by ViewVC 1.1.5