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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.72 - (hide annotations)
Thu Mar 4 22:15:40 2004 UTC (10 years, 1 month ago) by heller
Branch: MAIN
Changes since 1.71: +0 -4 lines
(thread-alive-p): Add default implementation.

(describe-primitive-type): Add default implementation.
(inspected-parts): Implemented for Allegro and CLISP.
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 heller 1.70 (defvar *buffer-substring* nil)
210 dbarlow 1.1
211 lgorrie 1.24 (defvar *previous-compiler-condition* nil
212     "Used to detect duplicates.")
213    
214 dbarlow 1.1 (defun handle-notification-condition (condition)
215     "Handle a condition caused by a compiler warning.
216     This traps all compiler conditions at a lower-level than using
217     C:*COMPILER-NOTIFICATION-FUNCTION*. The advantage is that we get to
218     craft our own error messages, which can omit a lot of redundant
219     information."
220     (let ((context (sb-c::find-error-context nil)))
221 heller 1.36 (unless (eq condition *previous-compiler-condition*)
222 dbarlow 1.1 (setq *previous-compiler-condition* condition)
223 lgorrie 1.24 (signal-compiler-condition condition context))))
224    
225     (defun signal-compiler-condition (condition context)
226     (signal (make-condition
227     'compiler-condition
228     :original-condition condition
229     :severity (etypecase condition
230     (sb-c:compiler-error :error)
231     (sb-ext:compiler-note :note)
232     (style-warning :style-warning)
233     (warning :warning))
234 heller 1.66 :short-message (brief-compiler-message-for-emacs condition)
235     :message (long-compiler-message-for-emacs condition context)
236 lgorrie 1.24 :location (compiler-note-location context))))
237    
238 dbarlow 1.44
239    
240 lgorrie 1.24 (defun compiler-note-location (context)
241 dbarlow 1.42 (cond (context
242     (resolve-note-location
243     *buffer-name*
244     (sb-c::compiler-error-context-file-name context)
245     (sb-c::compiler-error-context-file-position context)
246     (current-compiler-error-source-path context)
247     (sb-c::compiler-error-context-original-source context)))
248     (t
249     (resolve-note-location *buffer-name* nil nil nil nil))))
250    
251     (defgeneric resolve-note-location (buffer file-name file-position
252     source-path source))
253    
254     (defmethod resolve-note-location ((b (eql nil)) (f pathname) pos path source)
255     (make-location
256 dbarlow 1.43 `(:file ,(namestring (truename f)))
257 dbarlow 1.42 `(:position ,(1+ (source-path-file-position path f)))))
258    
259     (defmethod resolve-note-location ((b string) (f (eql :stream)) pos path source)
260     (make-location
261     `(:buffer ,b)
262     `(:position ,(+ *buffer-offset*
263     (source-path-string-position path *buffer-substring*)))))
264    
265     (defmethod resolve-note-location (b (f (eql :lisp)) pos path (source string))
266     (make-location
267     `(:source-form ,source)
268     `(:position 1)))
269    
270     (defmethod resolve-note-location (buffer
271     (file (eql nil))
272     (pos (eql nil))
273     (path (eql nil))
274     (source (eql nil)))
275     (cond (buffer
276     (make-location (list :buffer buffer)
277     (list :position *buffer-offset*)))
278     (*compile-file-truename*
279     (make-location (list :file (namestring *compile-file-truename*))
280     (list :position 0)))
281     (t
282     (list :error "No error location available"))))
283    
284 heller 1.66 (defun brief-compiler-message-for-emacs (condition)
285 dbarlow 1.1 "Briefly describe a compiler error for Emacs.
286     When Emacs presents the message it already has the source popped up
287     and the source form highlighted. This makes much of the information in
288     the error-context redundant."
289 heller 1.66 (princ-to-string condition))
290    
291     (defun long-compiler-message-for-emacs (condition error-context)
292     "Describe a compiler error for Emacs including context information."
293 heller 1.45 (declare (type (or sb-c::compiler-error-context null) error-context))
294 heller 1.66 (multiple-value-bind (enclosing source)
295     (if error-context
296     (values (sb-c::compiler-error-context-enclosing-source error-context)
297     (sb-c::compiler-error-context-source error-context)))
298     (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~^~%~}~]~A"
299     enclosing source condition)))
300 dbarlow 1.1
301     (defun current-compiler-error-source-path (context)
302     "Return the source-path for the current compiler error.
303     Returns NIL if this cannot be determined by examining internal
304     compiler state."
305     (cond ((sb-c::node-p context)
306     (reverse
307     (sb-c::source-path-original-source
308     (sb-c::node-source-path context))))
309     ((sb-c::compiler-error-context-p context)
310     (reverse
311     (sb-c::compiler-error-context-original-source-path context)))))
312    
313 lgorrie 1.54 (defimplementation call-with-compilation-hooks (function)
314 heller 1.58 (declare (type function function))
315 dbarlow 1.41 (handler-bind ((sb-c:compiler-error #'handle-notification-condition)
316     (sb-ext:compiler-note #'handle-notification-condition)
317     (style-warning #'handle-notification-condition)
318     (warning #'handle-notification-condition))
319     (funcall function)))
320 lgorrie 1.24
321 lgorrie 1.54 (defimplementation compile-file-for-emacs (filename load-p)
322 lgorrie 1.24 (with-compilation-hooks ()
323 dbarlow 1.41 (multiple-value-bind (fasl-file w-p f-p) (compile-file filename)
324 heller 1.58 (declare (ignore w-p))
325 heller 1.69 (cond ((and load-p fasl-file)
326 heller 1.36 (load fasl-file))
327     (t fasl-file)))))
328 dbarlow 1.41
329 lgorrie 1.54 (defimplementation compile-system-for-emacs (system-name)
330 dbarlow 1.41 (with-compilation-hooks ()
331     (asdf:operate 'asdf:load-op system-name)))
332 lgorrie 1.24
333 lgorrie 1.54 (defimplementation compile-string-for-emacs (string &key buffer position)
334 lgorrie 1.24 (with-compilation-hooks ()
335 heller 1.32 (let ((*package* *buffer-package*)
336 dbarlow 1.42 (*buffer-name* buffer)
337 heller 1.70 (*buffer-offset* position)
338     (*buffer-substring* string))
339 heller 1.32 (eval (from-string
340     (format nil "(funcall (compile nil '(lambda () ~A)))"
341     string))))))
342 dbarlow 1.1
343     ;;;; xref stuff doesn't exist for sbcl yet
344    
345     (defslimefun-unimplemented who-calls (function-name))
346    
347     (defslimefun-unimplemented who-references (variable))
348    
349     (defslimefun-unimplemented who-binds (variable))
350    
351     (defslimefun-unimplemented who-sets (variable))
352    
353     (defslimefun-unimplemented who-macroexpands (macro))
354    
355     ;;;; Definitions
356    
357     (defvar *debug-definition-finding* nil
358     "When true don't handle errors while looking for definitions.
359     This is useful when debugging the definition-finding code.")
360    
361     ;;; FIXME we don't handle the compiled-interactively case yet. That
362     ;;; should have NIL :filename & :position, and non-NIL :source-form
363 heller 1.36 (defun function-source-location (function &optional name)
364 dbarlow 1.1 "Try to find the canonical source location of FUNCTION."
365     (let* ((def (sb-introspect:find-definition-source function))
366     (pathname (sb-introspect:definition-source-pathname def))
367 heller 1.32 (path (sb-introspect:definition-source-form-path def))
368     (position (sb-introspect:definition-source-character-offset def)))
369     (unless pathname
370     (return-from function-source-location
371 heller 1.36 (list :error (format nil "No filename for: ~S" function))))
372 heller 1.32 (multiple-value-bind (truename condition)
373     (ignore-errors (truename pathname))
374     (when condition
375     (return-from function-source-location
376     (list :error (format nil "~A" condition))))
377     (make-location
378     (list :file (namestring truename))
379     ;; source-paths depend on the file having been compiled with
380     ;; lotsa debugging. If not present, return the function name
381     ;; for emacs to attempt to find with a regex
382     (cond (path (list :source-path path position))
383 heller 1.36 (t (list :function-name
384     (or (and name (string name))
385     (sb-kernel:%fun-name function)))))))))
386 dbarlow 1.1
387 lgorrie 1.54 (defimplementation find-function-locations (fname-string)
388 heller 1.36 (let* ((symbol (from-string fname-string)))
389     (labels ((finder (fun)
390     (cond ((and (symbolp fun) (macro-function fun))
391 heller 1.35 (list
392 heller 1.36 (function-source-location (macro-function fun)
393     symbol)))
394     ((typep fun 'sb-mop:generic-function)
395 dbarlow 1.34 (list*
396 heller 1.36 (function-source-location fun symbol)
397 dbarlow 1.34 (mapcar
398 heller 1.36 (lambda (x) (function-source-location x symbol))
399     (sb-mop:generic-function-methods fun))))
400     ((functionp fun)
401 heller 1.35 (list
402 heller 1.36 (function-source-location fun symbol)))
403     ((sb-introspect:valid-function-name-p fun)
404     (finder (fdefinition fun)))
405     (t (list
406     (list :error "Not a function: ~A" fun))))))
407 dbarlow 1.1 (if *debug-definition-finding*
408 heller 1.36 (finder symbol)
409     (handler-case (finder symbol)
410 heller 1.32 (error (e)
411 heller 1.36 (list (list :error (format nil "Error: ~A" e)))))))))
412 lgorrie 1.24
413 lgorrie 1.54 (defimplementation describe-symbol-for-emacs (symbol)
414 dbarlow 1.1 "Return a plist describing SYMBOL.
415     Return NIL if the symbol is unbound."
416     (let ((result '()))
417 lgorrie 1.24 (labels ((doc (kind)
418     (or (documentation symbol kind) :not-documented))
419 dbarlow 1.1 (maybe-push (property value)
420     (when value
421     (setf result (list* property value result)))))
422     (maybe-push
423     :variable (multiple-value-bind (kind recorded-p)
424     (sb-int:info :variable :kind symbol)
425     (declare (ignore kind))
426     (if (or (boundp symbol) recorded-p)
427     (doc 'variable))))
428     (maybe-push
429     :function (if (fboundp symbol)
430     (doc 'function)))
431     (maybe-push
432     :setf (if (or (sb-int:info :setf :inverse symbol)
433     (sb-int:info :setf :expander symbol))
434     (doc 'setf)))
435     (maybe-push
436     :type (if (sb-int:info :type :kind symbol)
437     (doc 'type)))
438 lgorrie 1.24 result)))
439 dbarlow 1.1
440 lgorrie 1.54 (defimplementation describe-definition (symbol-name type)
441     (case type
442     (:variable
443     (describe-symbol symbol-name))
444     (:setf
445     (print-description-to-string `(setf ,(from-string symbol-name))))
446     (:class
447     (print-description-to-string (find-class (from-string symbol-name) nil)))
448     (:type
449     (print-description-to-string
450     (sb-kernel:values-specifier-type (from-string symbol-name))))))
451 dbarlow 1.1
452 dbarlow 1.4 ;;; macroexpansion
453 dbarlow 1.1
454 lgorrie 1.54 (defimplementation macroexpand-all (form)
455 heller 1.21 (let ((sb-walker:*walk-form-expand-macros-p* t))
456     (sb-walker:walk-form form)))
457 lgorrie 1.25
458 dbarlow 1.1
459     ;;; Debugging
460    
461     (defvar *sldb-stack-top*)
462 heller 1.58 (defvar *sldb-restarts* nil)
463     (declaim (type list *sldb-restarts*))
464 dbarlow 1.1
465 lgorrie 1.54 (defimplementation call-with-debugging-environment (debugger-loop-fn)
466 heller 1.58 (declare (type function debugger-loop-fn))
467 lgorrie 1.25 (let* ((*sldb-stack-top* (or sb-debug:*stack-top-hint* (sb-di:top-frame)))
468 dbarlow 1.1 (*sldb-restarts* (compute-restarts *swank-debugger-condition*))
469 heller 1.71 (sb-debug:*stack-top-hint* nil))
470 dbarlow 1.1 (handler-bind ((sb-di:debug-condition
471     (lambda (condition)
472 lgorrie 1.25 (signal (make-condition
473     'sldb-condition
474     :original-condition condition)))))
475     (funcall debugger-loop-fn))))
476 dbarlow 1.1
477     (defun format-restarts-for-emacs ()
478     "Return a list of restarts for *swank-debugger-condition* in a
479     format suitable for Emacs."
480     (loop for restart in *sldb-restarts*
481     collect (list (princ-to-string (restart-name restart))
482     (princ-to-string restart))))
483    
484     (defun nth-frame (index)
485     (do ((frame *sldb-stack-top* (sb-di:frame-down frame))
486     (i index (1- i)))
487     ((zerop i) frame)))
488    
489     (defun nth-restart (index)
490     (nth index *sldb-restarts*))
491    
492 heller 1.45 (defun format-frame-for-emacs (number frame)
493     (print-with-frame-label
494     number (lambda (*standard-output*)
495     (sb-debug::print-frame-call frame :verbosity 1 :number nil))))
496 dbarlow 1.1
497     (defun compute-backtrace (start end)
498     "Return a list of frames starting with frame number START and
499     continuing to frame number END or, if END is nil, the last frame on the
500     stack."
501     (let ((end (or end most-positive-fixnum)))
502 heller 1.45 (loop for f = (nth-frame start) then (sb-di:frame-down f)
503     for i from start below end
504     while f
505     collect (cons i f))))
506 dbarlow 1.1
507 lgorrie 1.54 (defimplementation backtrace (start end)
508 heller 1.45 (loop for (n . frame) in (compute-backtrace start end)
509     collect (list n (format-frame-for-emacs n frame))))
510 dbarlow 1.1
511 lgorrie 1.54 (defimplementation debugger-info-for-emacs (start end)
512 heller 1.45 (list (debugger-condition-for-emacs)
513 dbarlow 1.1 (format-restarts-for-emacs)
514 lgorrie 1.26 (backtrace start end)))
515 dbarlow 1.1
516     (defun code-location-source-path (code-location)
517     (let* ((location (sb-debug::maybe-block-start-location code-location))
518     (form-num (sb-di:code-location-form-number location)))
519     (let ((translations (sb-debug::get-toplevel-form location)))
520     (unless (< form-num (length translations))
521     (error "Source path no longer exists."))
522     (reverse (cdr (svref translations form-num))))))
523    
524     (defun code-location-file-position (code-location)
525     (let* ((debug-source (sb-di:code-location-debug-source code-location))
526     (filename (sb-di:debug-source-name debug-source))
527     (path (code-location-source-path code-location)))
528     (source-path-file-position path filename)))
529    
530 dbarlow 1.44 ;;; source-path-file-position and friends are in swank-source-path-parser
531 dbarlow 1.1
532     (defun debug-source-info-from-emacs-buffer-p (debug-source)
533     (let ((info (sb-c::debug-source-info debug-source)))
534     (and info
535     (consp info)
536     (eq :emacs-buffer (car info)))))
537    
538     (defun source-location-for-emacs (code-location)
539     (let* ((debug-source (sb-di:code-location-debug-source code-location))
540     (from (sb-di:debug-source-from debug-source))
541     (name (sb-di:debug-source-name debug-source)))
542 heller 1.32 (ecase from
543     (:file
544 heller 1.36 (let ((source-path (ignore-errors
545     (code-location-source-path code-location))))
546     (cond (source-path
547     ;; XXX: code-location-source-path reads the source !!
548     (let ((position (code-location-file-position code-location)))
549     (make-location
550     (list :file (namestring (truename name)))
551     (list :source-path source-path position))))
552     (t
553     (let* ((dfn (sb-di:code-location-debug-fun code-location))
554     (fn (sb-di:debug-fun-fun dfn)))
555     (unless fn
556     (error "Cannot find source location for: ~A "
557     code-location))
558     (function-source-location
559     fn (sb-di:debug-fun-name dfn)))))))
560    
561 heller 1.32 (:lisp
562     (make-location
563     (list :source-form (with-output-to-string (*standard-output*)
564     (sb-debug::print-code-location-source-form
565     code-location 100)))
566     (list :position 0))))))
567 dbarlow 1.1
568     (defun safe-source-location-for-emacs (code-location)
569     (handler-case (source-location-for-emacs code-location)
570 heller 1.36 (error (c) (list :error (format nil "~A" c)))))
571    
572 lgorrie 1.54 (defimplementation frame-source-location-for-emacs (index)
573 heller 1.22 (safe-source-location-for-emacs
574     (sb-di:frame-code-location (nth-frame index))))
575 dbarlow 1.1
576     #+nil
577 lgorrie 1.54 (defimplementation eval-in-frame (form index)
578 lgorrie 1.26 (sb-di:eval-in-frame (nth-frame index) string))
579 dbarlow 1.1
580 lgorrie 1.54 (defimplementation frame-locals (index)
581 dbarlow 1.1 (let* ((frame (nth-frame index))
582     (location (sb-di:frame-code-location frame))
583     (debug-function (sb-di:frame-debug-fun frame))
584     (debug-variables (sb-di::debug-fun-debug-vars debug-function)))
585 heller 1.58 (declare (type (or null simple-vector) debug-variables))
586 dbarlow 1.1 (loop for v across debug-variables
587     collect (list
588 heller 1.45 :name (to-string (sb-di:debug-var-symbol v))
589 dbarlow 1.1 :id (sb-di:debug-var-id v)
590     :value-string
591     (if (eq (sb-di:debug-var-validity v location)
592     :valid)
593     (to-string (sb-di:debug-var-value v frame))
594     "<not-available>")))))
595    
596 lgorrie 1.54 (defimplementation frame-catch-tags (index)
597 dbarlow 1.1 (loop for (tag . code-location) in (sb-di:frame-catches (nth-frame index))
598     collect `(,tag . ,(safe-source-location-for-emacs code-location))))
599    
600     (defslimefun invoke-nth-restart (index)
601 heller 1.33 (invoke-restart-interactively (nth-restart index)))
602 dbarlow 1.1
603     (defslimefun sldb-abort ()
604     (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))
605 lgorrie 1.50
606 heller 1.56 (defimplementation eval-in-frame (form index)
607     (let ((frame (nth-frame index)))
608 heller 1.58 (funcall (the function
609     (sb-di:preprocess-for-eval form
610     (sb-di:frame-code-location frame)))
611 heller 1.56 frame)))
612    
613     (defun sb-debug-catch-tag-p (tag)
614     (and (symbolp tag)
615     (not (symbol-package tag))
616     (string= tag :sb-debug-catch-tag)))
617    
618     (defimplementation return-from-frame (index form)
619     (let* ((frame (nth-frame index))
620     (form (from-string form))
621     (probe (assoc-if #'sb-debug-catch-tag-p
622     (sb-di::frame-catches frame))))
623     (cond (probe (throw (car probe) (eval-in-frame form index)))
624     (t (format nil "Cannot return from frame: ~S" frame)))))
625    
626 heller 1.57
627     ;;;; Profiling
628    
629     (defimplementation profile (fname)
630     (when fname (eval `(sb-profile:profile ,fname))))
631    
632     (defimplementation unprofile (fname)
633     (when fname (eval `(sb-profile:unprofile ,fname))))
634    
635     (defimplementation unprofile-all ()
636     (sb-profile:unprofile)
637     "All functions unprofiled.")
638    
639     (defimplementation profile-report ()
640     (sb-profile:report))
641    
642     (defimplementation profile-reset ()
643     (sb-profile:reset)
644     "Reset profiling counters.")
645    
646     (defimplementation profiled-functions ()
647     (sb-profile:profile))
648    
649    
650 heller 1.64 ;;;; Inspector
651 heller 1.63
652 heller 1.64 (defmethod inspected-parts (o)
653     (cond ((sb-di::indirect-value-cell-p o)
654     (inspected-parts-of-value-cell o))
655     (t
656     (multiple-value-bind (text labeledp parts)
657     (sb-impl::inspected-parts o)
658     (let ((parts (if labeledp
659     (loop for (label . value) in parts
660     collect (cons (string label) value))
661     (loop for value in parts
662     for i from 0
663     collect (cons (format nil "~D" i) value)))))
664     (values text parts))))))
665    
666     (defun inspected-parts-of-value-cell (o)
667     (values (format nil "~A~% is a value cell." o)
668     (list (cons "Value" (sb-kernel:value-cell-ref o)))))
669    
670     (defmethod inspected-parts ((o function))
671     (let ((header (sb-kernel:widetag-of o)))
672     (cond ((= header sb-vm:simple-fun-header-widetag)
673     (values
674     (format nil "~A~% is a simple-fun." o)
675     (list (cons "Self" (sb-kernel:%simple-fun-self o))
676     (cons "Next" (sb-kernel:%simple-fun-next o))
677     (cons "Name" (sb-kernel:%simple-fun-name o))
678     (cons "Arglist" (sb-kernel:%simple-fun-arglist o))
679     (cons "Type" (sb-kernel:%simple-fun-type o))
680     (cons "Code Object" (sb-kernel:fun-code-header o)))))
681     ((= header sb-vm:closure-header-widetag)
682     (values (format nil "~A~% is a closure." o)
683     (list*
684     (cons "Function" (sb-kernel:%closure-fun o))
685     (loop for i from 0
686     below (- (sb-kernel:get-closure-length o)
687     (1- sb-vm:closure-info-offset))
688     collect (cons (format nil "~D" i)
689     (sb-kernel:%closure-index-ref o i))))))
690     (t (call-next-method o)))))
691    
692     (defmethod inspected-parts ((o sb-kernel:code-component))
693     (values (format nil "~A~% is a code data-block." o)
694     `(("First entry point" . ,(sb-kernel:%code-entry-points o))
695     ,@(loop for i from sb-vm:code-constants-offset
696     below (sb-kernel:get-header-data o)
697     collect (cons (format nil "Constant#~D" i)
698     (sb-kernel:code-header-ref o i)))
699     ("Debug info" . ,(sb-kernel:%code-debug-info o))
700     ("Instructions" . ,(sb-kernel:code-instructions o)))))
701    
702     (defmethod inspected-parts ((o sb-kernel:fdefn))
703     (values (format nil "~A~% is a fdefn object." o)
704     `(("Name" . ,(sb-kernel:fdefn-name o))
705     ("Function" . ,(sb-kernel:fdefn-fun o)))))
706    
707    
708     (defmethod inspected-parts ((o generic-function))
709     (values (format nil "~A~% is a generic function." o)
710     (list
711     (cons "Method-Class" (sb-pcl:generic-function-method-class o))
712     (cons "Methods" (sb-pcl:generic-function-methods o))
713     (cons "Name" (sb-pcl:generic-function-name o))
714     (cons "Declarations" (sb-pcl:generic-function-declarations o))
715     (cons "Method-Combination"
716     (sb-pcl:generic-function-method-combination o))
717     (cons "Lambda-List" (sb-pcl:generic-function-lambda-list o))
718     (cons "Precedence-Order"
719     (sb-pcl:generic-function-argument-precedence-order o))
720     (cons "Pretty-Arglist"
721     (sb-pcl::generic-function-pretty-arglist o))
722     (cons "Initial-Methods"
723     (sb-pcl::generic-function-initial-methods o)))))
724 heller 1.63
725    
726 lgorrie 1.50 ;;;; Multiprocessing
727    
728     #+SB-THREAD
729     (progn
730 lgorrie 1.54 (defimplementation spawn (fn &key name)
731 lgorrie 1.50 (declare (ignore name))
732     (sb-thread:make-thread fn))
733    
734 lgorrie 1.54 (defimplementation startup-multiprocessing ()
735 lgorrie 1.50 (setq *swank-in-background* :spawn))
736    
737 heller 1.63 (defimplementation thread-name (thread)
738     (format nil "Thread ~D" thread))
739 lgorrie 1.50
740 heller 1.63 (defimplementation thread-status (thread)
741     (declare (ignore thread))
742     "???")
743 lgorrie 1.50
744 lgorrie 1.54 (defimplementation make-lock (&key name)
745 lgorrie 1.50 (sb-thread:make-mutex :name name))
746    
747 lgorrie 1.54 (defimplementation call-with-lock-held (lock function)
748 heller 1.58 (declare (type function function))
749 lgorrie 1.50 (sb-thread:with-mutex (lock) (funcall function)))
750 heller 1.59
751     (defimplementation current-thread ()
752     (sb-thread:current-thread-id))
753    
754 heller 1.63 (defimplementation all-threads ()
755 heller 1.59 (sb-thread::mapcar-threads
756     (lambda (sap)
757     (sb-sys:sap-ref-32 sap (* sb-vm:n-word-bytes
758     sb-vm::thread-pid-slot)))))
759    
760     (defimplementation interrupt-thread (thread fn)
761     (sb-thread:interrupt-thread thread fn))
762    
763 heller 1.70 (defimplementation kill-thread (thread)
764     (sb-thread:terminate-thread thread))
765    
766     ;; XXX there is some deadlock / race condition here (with old 2.4 kernels)
767 heller 1.59
768     (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))
769     (defvar *mailboxes* (list))
770 heller 1.60 (declaim (type list *mailboxes*))
771 heller 1.59
772     (defstruct (mailbox (:conc-name mailbox.))
773     thread
774     (mutex (sb-thread:make-mutex))
775     (waitqueue (sb-thread:make-waitqueue))
776     (queue '() :type list))
777    
778     (defun mailbox (thread)
779     "Return THREAD's mailbox."
780     (sb-thread:with-mutex (*mailbox-lock*)
781     (or (find thread *mailboxes* :key #'mailbox.thread)
782     (let ((mb (make-mailbox :thread thread)))
783     (push mb *mailboxes*)
784     mb))))
785    
786     (defimplementation send (thread message)
787     (let* ((mbox (mailbox thread))
788     (mutex (mailbox.mutex mbox)))
789     (sb-thread:with-mutex (mutex)
790     (setf (mailbox.queue mbox)
791     (nconc (mailbox.queue mbox) (list message)))
792     (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
793    
794     (defimplementation receive ()
795     (let* ((mbox (mailbox (sb-thread:current-thread-id)))
796     (mutex (mailbox.mutex mbox)))
797     (sb-thread:with-mutex (mutex)
798     (loop
799     (let ((q (mailbox.queue mbox)))
800     (cond (q (return (pop (mailbox.queue mbox))))
801     (t (sb-thread:condition-wait (mailbox.waitqueue mbox)
802     mutex))))))))
803    
804     )

  ViewVC Help
Powered by ViewVC 1.1.5