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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.73 - (hide annotations)
Fri Mar 5 14:26:14 2004 UTC (10 years, 1 month ago) by mbaringer
Branch: MAIN
CVS Tags: SLIME-0-11
Branch point for: package-split
Changes since 1.72: +5 -6 lines
See ChangeLog entry 2004-03-05 Marco Baringer
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 mbaringer 1.73 :name (sb-di:debug-var-symbol v)
589 dbarlow 1.1 :id (sb-di:debug-var-id v)
590 mbaringer 1.73 :value (if (eq (sb-di:debug-var-validity v location)
591     :valid)
592     (sb-di:debug-var-value v frame)
593     "<not-available>")))))
594 dbarlow 1.1
595 lgorrie 1.54 (defimplementation frame-catch-tags (index)
596 dbarlow 1.1 (loop for (tag . code-location) in (sb-di:frame-catches (nth-frame index))
597     collect `(,tag . ,(safe-source-location-for-emacs code-location))))
598    
599     (defslimefun invoke-nth-restart (index)
600 heller 1.33 (invoke-restart-interactively (nth-restart index)))
601 dbarlow 1.1
602     (defslimefun sldb-abort ()
603     (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))
604 lgorrie 1.50
605 heller 1.56 (defimplementation eval-in-frame (form index)
606     (let ((frame (nth-frame index)))
607 heller 1.58 (funcall (the function
608     (sb-di:preprocess-for-eval form
609     (sb-di:frame-code-location frame)))
610 heller 1.56 frame)))
611    
612     (defun sb-debug-catch-tag-p (tag)
613     (and (symbolp tag)
614     (not (symbol-package tag))
615     (string= tag :sb-debug-catch-tag)))
616    
617     (defimplementation return-from-frame (index form)
618     (let* ((frame (nth-frame index))
619     (form (from-string form))
620     (probe (assoc-if #'sb-debug-catch-tag-p
621     (sb-di::frame-catches frame))))
622     (cond (probe (throw (car probe) (eval-in-frame form index)))
623     (t (format nil "Cannot return from frame: ~S" frame)))))
624    
625 heller 1.57
626     ;;;; Profiling
627    
628     (defimplementation profile (fname)
629     (when fname (eval `(sb-profile:profile ,fname))))
630    
631     (defimplementation unprofile (fname)
632     (when fname (eval `(sb-profile:unprofile ,fname))))
633    
634     (defimplementation unprofile-all ()
635     (sb-profile:unprofile)
636     "All functions unprofiled.")
637    
638     (defimplementation profile-report ()
639     (sb-profile:report))
640    
641     (defimplementation profile-reset ()
642     (sb-profile:reset)
643     "Reset profiling counters.")
644    
645     (defimplementation profiled-functions ()
646     (sb-profile:profile))
647    
648    
649 heller 1.64 ;;;; Inspector
650 heller 1.63
651 heller 1.64 (defmethod inspected-parts (o)
652     (cond ((sb-di::indirect-value-cell-p o)
653     (inspected-parts-of-value-cell o))
654     (t
655     (multiple-value-bind (text labeledp parts)
656     (sb-impl::inspected-parts o)
657     (let ((parts (if labeledp
658     (loop for (label . value) in parts
659     collect (cons (string label) value))
660     (loop for value in parts
661     for i from 0
662     collect (cons (format nil "~D" i) value)))))
663     (values text parts))))))
664    
665     (defun inspected-parts-of-value-cell (o)
666     (values (format nil "~A~% is a value cell." o)
667     (list (cons "Value" (sb-kernel:value-cell-ref o)))))
668    
669     (defmethod inspected-parts ((o function))
670     (let ((header (sb-kernel:widetag-of o)))
671     (cond ((= header sb-vm:simple-fun-header-widetag)
672     (values
673     (format nil "~A~% is a simple-fun." o)
674     (list (cons "Self" (sb-kernel:%simple-fun-self o))
675     (cons "Next" (sb-kernel:%simple-fun-next o))
676     (cons "Name" (sb-kernel:%simple-fun-name o))
677     (cons "Arglist" (sb-kernel:%simple-fun-arglist o))
678     (cons "Type" (sb-kernel:%simple-fun-type o))
679     (cons "Code Object" (sb-kernel:fun-code-header o)))))
680     ((= header sb-vm:closure-header-widetag)
681     (values (format nil "~A~% is a closure." o)
682     (list*
683     (cons "Function" (sb-kernel:%closure-fun o))
684     (loop for i from 0
685     below (- (sb-kernel:get-closure-length o)
686     (1- sb-vm:closure-info-offset))
687     collect (cons (format nil "~D" i)
688     (sb-kernel:%closure-index-ref o i))))))
689     (t (call-next-method o)))))
690    
691     (defmethod inspected-parts ((o sb-kernel:code-component))
692     (values (format nil "~A~% is a code data-block." o)
693     `(("First entry point" . ,(sb-kernel:%code-entry-points o))
694     ,@(loop for i from sb-vm:code-constants-offset
695     below (sb-kernel:get-header-data o)
696     collect (cons (format nil "Constant#~D" i)
697     (sb-kernel:code-header-ref o i)))
698     ("Debug info" . ,(sb-kernel:%code-debug-info o))
699     ("Instructions" . ,(sb-kernel:code-instructions o)))))
700    
701     (defmethod inspected-parts ((o sb-kernel:fdefn))
702     (values (format nil "~A~% is a fdefn object." o)
703     `(("Name" . ,(sb-kernel:fdefn-name o))
704     ("Function" . ,(sb-kernel:fdefn-fun o)))))
705    
706    
707     (defmethod inspected-parts ((o generic-function))
708     (values (format nil "~A~% is a generic function." o)
709     (list
710     (cons "Method-Class" (sb-pcl:generic-function-method-class o))
711     (cons "Methods" (sb-pcl:generic-function-methods o))
712     (cons "Name" (sb-pcl:generic-function-name o))
713     (cons "Declarations" (sb-pcl:generic-function-declarations o))
714     (cons "Method-Combination"
715     (sb-pcl:generic-function-method-combination o))
716     (cons "Lambda-List" (sb-pcl:generic-function-lambda-list o))
717     (cons "Precedence-Order"
718     (sb-pcl:generic-function-argument-precedence-order o))
719     (cons "Pretty-Arglist"
720     (sb-pcl::generic-function-pretty-arglist o))
721     (cons "Initial-Methods"
722     (sb-pcl::generic-function-initial-methods o)))))
723 heller 1.63
724    
725 lgorrie 1.50 ;;;; Multiprocessing
726    
727     #+SB-THREAD
728     (progn
729 lgorrie 1.54 (defimplementation spawn (fn &key name)
730 lgorrie 1.50 (declare (ignore name))
731     (sb-thread:make-thread fn))
732    
733 lgorrie 1.54 (defimplementation startup-multiprocessing ()
734 lgorrie 1.50 (setq *swank-in-background* :spawn))
735    
736 heller 1.63 (defimplementation thread-name (thread)
737     (format nil "Thread ~D" thread))
738 lgorrie 1.50
739 heller 1.63 (defimplementation thread-status (thread)
740     (declare (ignore thread))
741     "???")
742 lgorrie 1.50
743 lgorrie 1.54 (defimplementation make-lock (&key name)
744 lgorrie 1.50 (sb-thread:make-mutex :name name))
745    
746 lgorrie 1.54 (defimplementation call-with-lock-held (lock function)
747 heller 1.58 (declare (type function function))
748 lgorrie 1.50 (sb-thread:with-mutex (lock) (funcall function)))
749 heller 1.59
750     (defimplementation current-thread ()
751     (sb-thread:current-thread-id))
752    
753 heller 1.63 (defimplementation all-threads ()
754 heller 1.59 (sb-thread::mapcar-threads
755     (lambda (sap)
756     (sb-sys:sap-ref-32 sap (* sb-vm:n-word-bytes
757     sb-vm::thread-pid-slot)))))
758    
759     (defimplementation interrupt-thread (thread fn)
760     (sb-thread:interrupt-thread thread fn))
761    
762 heller 1.70 (defimplementation kill-thread (thread)
763     (sb-thread:terminate-thread thread))
764    
765     ;; XXX there is some deadlock / race condition here (with old 2.4 kernels)
766 heller 1.59
767     (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))
768     (defvar *mailboxes* (list))
769 heller 1.60 (declaim (type list *mailboxes*))
770 heller 1.59
771     (defstruct (mailbox (:conc-name mailbox.))
772     thread
773     (mutex (sb-thread:make-mutex))
774     (waitqueue (sb-thread:make-waitqueue))
775     (queue '() :type list))
776    
777     (defun mailbox (thread)
778     "Return THREAD's mailbox."
779     (sb-thread:with-mutex (*mailbox-lock*)
780     (or (find thread *mailboxes* :key #'mailbox.thread)
781     (let ((mb (make-mailbox :thread thread)))
782     (push mb *mailboxes*)
783     mb))))
784    
785     (defimplementation send (thread message)
786     (let* ((mbox (mailbox thread))
787     (mutex (mailbox.mutex mbox)))
788     (sb-thread:with-mutex (mutex)
789     (setf (mailbox.queue mbox)
790     (nconc (mailbox.queue mbox) (list message)))
791     (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
792    
793     (defimplementation receive ()
794     (let* ((mbox (mailbox (sb-thread:current-thread-id)))
795     (mutex (mailbox.mutex mbox)))
796     (sb-thread:with-mutex (mutex)
797     (loop
798     (let ((q (mailbox.queue mbox)))
799     (cond (q (return (pop (mailbox.queue mbox))))
800     (t (sb-thread:condition-wait (mailbox.waitqueue mbox)
801     mutex))))))))
802    
803     )

  ViewVC Help
Powered by ViewVC 1.1.5