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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5