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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.197 - (hide annotations)
Fri Jul 4 22:04:12 2008 UTC (5 years, 9 months ago) by trittweiler
Branch: MAIN
Changes since 1.196: +12 -2 lines
* swank-sbcl.lisp (code-location-source-location),
  (code-location-debug-source-name): Patched for incompatible
  structure change in SBCL 1.0.18.10.
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 jsnellman 1.158 ;;; This code has been placed in the Public Domain. All warranties are
8 dbarlow 1.1 ;;; disclaimed.
9    
10 heller 1.106 ;;; Requires the SB-INTROSPECT contrib.
11 dbarlow 1.1
12     ;;; Administrivia
13    
14 heller 1.146 (in-package :swank-backend)
15    
16 dbarlow 1.1 (eval-when (:compile-toplevel :load-toplevel :execute)
17     (require 'sb-bsd-sockets)
18 heller 1.59 (require 'sb-introspect)
19 trittweiler 1.179 (require 'sb-posix)
20     (require 'sb-cltl2))
21 heller 1.107
22 heller 1.196 (declaim (optimize (debug 2)
23     (sb-c::insert-step-conditions 0)
24     (sb-c::insert-debug-catch 0)
25     (sb-c::merge-tail-calls 2)))
26 dbarlow 1.1
27 heller 1.146 (import-from :sb-gray *gray-stream-symbols* :swank-backend)
28 heller 1.23
29 jsnellman 1.166 ;;; backwards compability tests
30    
31     (eval-when (:compile-toplevel :load-toplevel :execute)
32     ;; Generate a form suitable for testing for stepper support (0.9.17)
33     ;; with #+.
34     (defun sbcl-with-new-stepper-p ()
35     (if (find-symbol "ENABLE-STEPPING" "SB-IMPL")
36 jsnellman 1.174 '(:and)
37     '(:or)))
38 nsiivola 1.170 ;; Ditto for weak hash-tables
39     (defun sbcl-with-weak-hash-tables ()
40     (if (find-symbol "HASH-TABLE-WEAKNESS" "SB-EXT")
41 jsnellman 1.174 '(:and)
42     '(:or)))
43 jsnellman 1.172 ;; And for xref support (1.0.1)
44     (defun sbcl-with-xref-p ()
45     (if (find-symbol "WHO-CALLS" "SB-INTROSPECT")
46 jsnellman 1.174 '(:and)
47     '(:or)))
48     ;; ... for restart-frame support (1.0.2)
49     (defun sbcl-with-restart-frame ()
50     (if (find-symbol "FRAME-HAS-DEBUG-TAG-P" "SB-DEBUG")
51     '(:and)
52 heller 1.196 '(:or)))
53     (defun sbcl-with-symbol (name package)
54     (if (find-symbol (string name) (string package))
55     '(:and)
56     '(:or)))
57     )
58 jsnellman 1.166
59 mbaringer 1.100 ;;; swank-mop
60    
61 heller 1.106 (import-swank-mop-symbols :sb-mop '(:slot-definition-documentation))
62 mbaringer 1.100
63 mbaringer 1.101 (defun swank-mop:slot-definition-documentation (slot)
64 jsnellman 1.158 (sb-pcl::documentation slot t))
65 mbaringer 1.100
66 trittweiler 1.194 ;;; Connection info
67    
68     (defimplementation lisp-implementation-type-name ()
69     "sbcl")
70    
71     ;; Declare return type explicitly to shut up STYLE-WARNINGS about
72     ;; %SAP-ALIEN in ENABLE-SIGIO-ON-FD below.
73     (declaim (ftype (function () (values (signed-byte 32) &optional)) getpid))
74     (defimplementation getpid ()
75     (sb-posix:getpid))
76    
77 dbarlow 1.1 ;;; TCP Server
78    
79 lgorrie 1.132 (defimplementation preferred-communication-style ()
80 crhodes 1.155 (cond
81     ;; fixme: when SBCL/win32 gains better select() support, remove
82     ;; this.
83     ((member :win32 *features*) nil)
84 jsnellman 1.159 ((member :sb-thread *features*) :spawn)
85 crhodes 1.155 (t :fd-handler)))
86 jsnellman 1.158
87 heller 1.65 (defun resolve-hostname (name)
88     (car (sb-bsd-sockets:host-ent-addresses
89     (sb-bsd-sockets:get-host-by-name name))))
90    
91     (defimplementation create-socket (host port)
92 dbarlow 1.6 (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
93     :type :stream
94     :protocol :tcp)))
95 heller 1.48 (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
96 heller 1.65 (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port)
97 dbarlow 1.6 (sb-bsd-sockets:socket-listen socket 5)
98 heller 1.29 socket))
99    
100 lgorrie 1.54 (defimplementation local-port (socket)
101 lgorrie 1.46 (nth-value 1 (sb-bsd-sockets:socket-name socket)))
102    
103 lgorrie 1.54 (defimplementation close-socket (socket)
104 lgorrie 1.86 (sb-sys:invalidate-descriptor (socket-fd socket))
105 heller 1.48 (sb-bsd-sockets:socket-close socket))
106    
107 jsnellman 1.158 (defimplementation accept-connection (socket &key
108 heller 1.160 external-format
109     buffering timeout)
110 dcrosher 1.153 (declare (ignore timeout))
111 heller 1.160 (make-socket-io-stream (accept socket)
112     (or external-format :iso-latin-1-unix)
113     (or buffering :full)))
114 heller 1.48
115 heller 1.59 (defvar *sigio-handlers* '()
116     "List of (key . fn) pairs to be called on SIGIO.")
117    
118     (defun sigio-handler (signal code scp)
119 heller 1.60 (declare (ignore signal code scp))
120     (mapc (lambda (handler)
121     (funcall (the function (cdr handler))))
122     *sigio-handlers*))
123 heller 1.59
124     (defun set-sigio-handler ()
125 heller 1.82 (sb-sys:enable-interrupt sb-unix:sigio (lambda (signal code scp)
126 heller 1.59 (sigio-handler signal code scp))))
127    
128 heller 1.62 (defun enable-sigio-on-fd (fd)
129 heller 1.82 (sb-posix::fcntl fd sb-posix::f-setfl sb-posix::o-async)
130 trittweiler 1.194 (sb-posix::fcntl fd sb-posix::f-setown (getpid))
131     (values))
132 heller 1.62
133 heller 1.67 (defimplementation add-sigio-handler (socket fn)
134 heller 1.62 (set-sigio-handler)
135     (let ((fd (socket-fd socket)))
136     (format *debug-io* "Adding sigio handler: ~S ~%" fd)
137     (enable-sigio-on-fd fd)
138     (push (cons fd fn) *sigio-handlers*)))
139    
140 heller 1.67 (defimplementation remove-sigio-handlers (socket)
141 heller 1.59 (let ((fd (socket-fd socket)))
142     (setf *sigio-handlers* (delete fd *sigio-handlers* :key #'car))
143 jsnellman 1.158 (sb-sys:invalidate-descriptor fd))
144 heller 1.51 (close socket))
145 heller 1.67
146     (defimplementation add-fd-handler (socket fn)
147     (declare (type function fn))
148     (let ((fd (socket-fd socket)))
149     (format *debug-io* "; Adding fd handler: ~S ~%" fd)
150 jsnellman 1.158 (sb-sys:add-fd-handler fd :input (lambda (_)
151 heller 1.67 _
152     (funcall fn)))))
153    
154     (defimplementation remove-fd-handlers (socket)
155     (sb-sys:invalidate-descriptor (socket-fd socket)))
156 heller 1.51
157 heller 1.48 (defun socket-fd (socket)
158     (etypecase socket
159     (fixnum socket)
160     (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket))
161     (file-stream (sb-sys:fd-stream-fd socket))))
162    
163 heller 1.171 (defvar *external-format-to-coding-system*
164     '((:iso-8859-1
165     "latin-1" "latin-1-unix" "iso-latin-1-unix"
166     "iso-8859-1" "iso-8859-1-unix")
167     (:utf-8 "utf-8" "utf-8-unix")
168     (:euc-jp "euc-jp" "euc-jp-unix")
169     (:us-ascii "us-ascii" "us-ascii-unix")))
170    
171     (defimplementation find-external-format (coding-system)
172     (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
173     *external-format-to-coding-system*)))
174 heller 1.137
175 heller 1.150 (defun make-socket-io-stream (socket external-format buffering)
176 heller 1.171 (sb-bsd-sockets:socket-make-stream socket
177     :output t
178     :input t
179     :element-type 'character
180     :buffering buffering
181     #+sb-unicode :external-format
182     #+sb-unicode external-format
183     ))
184 lgorrie 1.46
185 heller 1.29 (defun accept (socket)
186     "Like socket-accept, but retry on EAGAIN."
187 jsnellman 1.158 (loop (handler-case
188 heller 1.29 (return (sb-bsd-sockets:socket-accept socket))
189     (sb-bsd-sockets:interrupted-error ()))))
190 dbarlow 1.6
191 jsnellman 1.163 (defimplementation call-without-interrupts (fn)
192 heller 1.58 (declare (type function fn))
193 heller 1.52 (sb-sys:without-interrupts (funcall fn)))
194    
195 heller 1.68
196 heller 1.124
197     ;;;; Support for SBCL syntax
198    
199 heller 1.129 ;;; SBCL's source code is riddled with #! reader macros. Also symbols
200     ;;; containing `!' have special meaning. We have to work long and
201     ;;; hard to be able to read the source. To deal with #! reader
202     ;;; macros, we use a special readtable. The special symbols are
203     ;;; converted by a condition handler.
204    
205 heller 1.124 (defun feature-in-list-p (feature list)
206     (etypecase feature
207     (symbol (member feature list :test #'eq))
208     (cons (flet ((subfeature-in-list-p (subfeature)
209     (feature-in-list-p subfeature list)))
210     (ecase (first feature)
211     (:or (some #'subfeature-in-list-p (rest feature)))
212     (:and (every #'subfeature-in-list-p (rest feature)))
213     (:not (destructuring-bind (e) (cdr feature)
214     (not (subfeature-in-list-p e)))))))))
215    
216     (defun shebang-reader (stream sub-character infix-parameter)
217     (declare (ignore sub-character))
218     (when infix-parameter
219     (error "illegal read syntax: #~D!" infix-parameter))
220     (let ((next-char (read-char stream)))
221     (unless (find next-char "+-")
222     (error "illegal read syntax: #!~C" next-char))
223     ;; When test is not satisfied
224     ;; FIXME: clearer if order of NOT-P and (NOT NOT-P) were reversed? then
225     ;; would become "unless test is satisfied"..
226     (when (let* ((*package* (find-package "KEYWORD"))
227     (*read-suppress* nil)
228     (not-p (char= next-char #\-))
229     (feature (read stream)))
230     (if (feature-in-list-p feature *features*)
231     not-p
232     (not not-p)))
233     ;; Read (and discard) a form from input.
234     (let ((*read-suppress* t))
235     (read stream t nil t))))
236     (values))
237    
238 jsnellman 1.158 (defvar *shebang-readtable*
239 heller 1.124 (let ((*readtable* (copy-readtable nil)))
240 jsnellman 1.158 (set-dispatch-macro-character #\# #\!
241 heller 1.124 (lambda (s c n) (shebang-reader s c n))
242     *readtable*)
243     *readtable*))
244    
245     (defun shebang-readtable ()
246     *shebang-readtable*)
247    
248     (defun sbcl-package-p (package)
249     (let ((name (package-name package)))
250     (eql (mismatch "SB-" name) 3)))
251    
252 heller 1.126 (defun sbcl-source-file-p (filename)
253 nsiivola 1.187 (when filename
254     (loop for (_ pattern) in (logical-pathname-translations "SYS")
255     thereis (pathname-match-p filename pattern))))
256 heller 1.126
257     (defun guess-readtable-for-filename (filename)
258     (if (sbcl-source-file-p filename)
259     (shebang-readtable)
260     *readtable*))
261    
262 heller 1.124 (defvar *debootstrap-packages* t)
263    
264 heller 1.126 (defun call-with-debootstrapping (fun)
265 jsnellman 1.158 (handler-bind ((sb-int:bootstrap-package-not-found
266 heller 1.126 #'sb-int:debootstrap-package))
267     (funcall fun)))
268    
269 heller 1.124 (defmacro with-debootstrapping (&body body)
270 heller 1.126 `(call-with-debootstrapping (lambda () ,@body)))
271 heller 1.124
272     (defimplementation call-with-syntax-hooks (fn)
273 jsnellman 1.158 (cond ((and *debootstrap-packages*
274 heller 1.124 (sbcl-package-p *package*))
275     (with-debootstrapping (funcall fn)))
276     (t
277     (funcall fn))))
278    
279     (defimplementation default-readtable-alist ()
280     (let ((readtable (shebang-readtable)))
281     (loop for p in (remove-if-not #'sbcl-package-p (list-all-packages))
282     collect (cons (package-name p) readtable))))
283    
284 dbarlow 1.1 ;;; Utilities
285    
286 heller 1.160 (defimplementation arglist (fname)
287 heller 1.74 (sb-introspect:function-arglist fname))
288 mbaringer 1.100
289 heller 1.160 (defimplementation function-name (f)
290     (check-type f function)
291 mbaringer 1.100 (sb-impl::%fun-name f))
292 dbarlow 1.1
293 trittweiler 1.179 (defmethod declaration-arglist ((decl-identifier (eql 'optimize)))
294     (flet ((ensure-list (thing) (if (listp thing) thing (list thing))))
295     (let* ((flags (sb-cltl2:declaration-information decl-identifier)))
296     (if flags
297     ;; Symbols aren't printed with package qualifiers, but the FLAGS would
298     ;; have to be fully qualified when used inside a declaration. So we
299     ;; strip those as long as there's no better way. (FIXME)
300     `(&any ,@(remove-if-not #'(lambda (qualifier)
301     (find-symbol (symbol-name (first qualifier)) :cl))
302     flags :key #'ensure-list))
303     (call-next-method)))))
304    
305 dbarlow 1.42 (defvar *buffer-name* nil)
306 dbarlow 1.1 (defvar *buffer-offset*)
307 heller 1.70 (defvar *buffer-substring* nil)
308 dbarlow 1.1
309 lgorrie 1.24 (defvar *previous-compiler-condition* nil
310     "Used to detect duplicates.")
311    
312 dbarlow 1.1 (defun handle-notification-condition (condition)
313     "Handle a condition caused by a compiler warning.
314     This traps all compiler conditions at a lower-level than using
315     C:*COMPILER-NOTIFICATION-FUNCTION*. The advantage is that we get to
316     craft our own error messages, which can omit a lot of redundant
317     information."
318     (let ((context (sb-c::find-error-context nil)))
319 heller 1.36 (unless (eq condition *previous-compiler-condition*)
320 dbarlow 1.1 (setq *previous-compiler-condition* condition)
321 lgorrie 1.24 (signal-compiler-condition condition context))))
322    
323     (defun signal-compiler-condition (condition context)
324     (signal (make-condition
325     'compiler-condition
326     :original-condition condition
327     :severity (etypecase condition
328     (sb-c:compiler-error :error)
329     (sb-ext:compiler-note :note)
330     (style-warning :style-warning)
331 lgorrie 1.96 (warning :warning)
332     (error :error))
333 heller 1.66 :short-message (brief-compiler-message-for-emacs condition)
334 heller 1.107 :references (condition-references (real-condition condition))
335 heller 1.66 :message (long-compiler-message-for-emacs condition context)
336 lgorrie 1.24 :location (compiler-note-location context))))
337 heller 1.107
338     (defun real-condition (condition)
339     "Return the encapsulated condition or CONDITION itself."
340     (typecase condition
341     (sb-int:encapsulated-condition (sb-int:encapsulated-condition condition))
342     (t condition)))
343 lgorrie 1.24
344 heller 1.184 (defun condition-references (condition)
345     (if (typep condition 'sb-int:reference-condition)
346     (externalize-reference
347     (sb-int:reference-condition-references condition))))
348    
349 lgorrie 1.24 (defun compiler-note-location (context)
350 heller 1.124 (if context
351 heller 1.127 (locate-compiler-note
352     (sb-c::compiler-error-context-file-name context)
353     (compiler-source-path context)
354     (sb-c::compiler-error-context-original-source context))
355 heller 1.124 (list :error "No error location available")))
356    
357 heller 1.127 (defun locate-compiler-note (file source-path source)
358 jsnellman 1.158 (cond ((and (not (eq file :lisp)) *buffer-name*)
359 heller 1.124 ;; Compiling from a buffer
360     (let ((position (+ *buffer-offset*
361     (source-path-string-position
362 jsnellman 1.158 source-path *buffer-substring*))))
363 heller 1.124 (make-location (list :buffer *buffer-name*)
364     (list :position position))))
365     ((and (pathnamep file) (null *buffer-name*))
366     ;; Compiling from a file
367     (make-location (list :file (namestring file))
368     (list :position
369 jsnellman 1.158 (1+ (source-path-file-position
370 heller 1.124 source-path file)))))
371 heller 1.127 ((and (eq file :lisp) (stringp source))
372     ;; Compiling macro generated code
373     (make-location (list :source-form source)
374     (list :position 1)))
375 dbarlow 1.42 (t
376 mbaringer 1.165 (error "unhandled case in compiler note ~S ~S ~S" file source-path source))))
377 dbarlow 1.42
378 heller 1.66 (defun brief-compiler-message-for-emacs (condition)
379 dbarlow 1.1 "Briefly describe a compiler error for Emacs.
380     When Emacs presents the message it already has the source popped up
381     and the source form highlighted. This makes much of the information in
382     the error-context redundant."
383 crhodes 1.95 (let ((sb-int:*print-condition-references* nil))
384     (princ-to-string condition)))
385 heller 1.66
386     (defun long-compiler-message-for-emacs (condition error-context)
387     "Describe a compiler error for Emacs including context information."
388 heller 1.45 (declare (type (or sb-c::compiler-error-context null) error-context))
389 heller 1.66 (multiple-value-bind (enclosing source)
390     (if error-context
391     (values (sb-c::compiler-error-context-enclosing-source error-context)
392     (sb-c::compiler-error-context-source error-context)))
393 crhodes 1.95 (let ((sb-int:*print-condition-references* nil))
394     (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~%~}~]~A"
395     enclosing source condition))))
396 dbarlow 1.1
397 heller 1.124 (defun compiler-source-path (context)
398 dbarlow 1.1 "Return the source-path for the current compiler error.
399     Returns NIL if this cannot be determined by examining internal
400     compiler state."
401     (cond ((sb-c::node-p context)
402     (reverse
403     (sb-c::source-path-original-source
404     (sb-c::node-source-path context))))
405     ((sb-c::compiler-error-context-p context)
406     (reverse
407     (sb-c::compiler-error-context-original-source-path context)))))
408    
409 lgorrie 1.54 (defimplementation call-with-compilation-hooks (function)
410 heller 1.58 (declare (type function function))
411 lgorrie 1.96 (handler-bind ((sb-c:fatal-compiler-error #'handle-file-compiler-termination)
412     (sb-c:compiler-error #'handle-notification-condition)
413 dbarlow 1.41 (sb-ext:compiler-note #'handle-notification-condition)
414     (style-warning #'handle-notification-condition)
415     (warning #'handle-notification-condition))
416     (funcall function)))
417 lgorrie 1.24
418 lgorrie 1.96 (defun handle-file-compiler-termination (condition)
419     "Handle a condition that caused the file compiler to terminate."
420     (handle-notification-condition
421     (sb-int:encapsulated-condition condition)))
422    
423 heller 1.91 (defvar *trap-load-time-warnings* nil)
424    
425 heller 1.171 (defimplementation swank-compile-file (filename load-p external-format)
426     (handler-case
427     (let ((output-file (with-compilation-hooks ()
428     (compile-file filename
429     :external-format external-format))))
430     (when output-file
431     ;; Cache the latest source file for definition-finding.
432     (source-cache-get filename (file-write-date filename))
433     (when load-p
434     (load output-file))))
435     (sb-c:fatal-compiler-error () nil)))
436 lgorrie 1.24
437 heller 1.124 ;;;; compile-string
438    
439 heller 1.156 ;;; We copy the string to a temporary file in order to get adequate
440     ;;; semantics for :COMPILE-TOPLEVEL and :LOAD-TOPLEVEL EVAL-WHEN forms
441     ;;; which the previous approach using
442     ;;; (compile nil `(lambda () ,(read-from-string string)))
443     ;;; did not provide.
444    
445     (sb-alien:define-alien-routine "tmpnam" sb-alien:c-string
446     (dest (* sb-alien:c-string)))
447    
448     (defun temp-file-name ()
449     "Return a temporary file name to compile strings into."
450     (concatenate 'string (tmpnam nil) ".lisp"))
451    
452 heller 1.195 (defimplementation swank-compile-string (string &key buffer position directory
453     debug)
454 heller 1.156 (let ((*buffer-name* buffer)
455     (*buffer-offset* position)
456     (*buffer-substring* string)
457 heller 1.195 (filename (temp-file-name))
458 heller 1.196 #+#.(swank-backend::sbcl-with-symbol 'restrict-compiler-policy 'sb-ext)
459     (old-min-debug (assoc 'debug (sb-ext:restrict-compiler-policy)))
460     )
461     #+#.(swank-backend::sbcl-with-symbol 'restrict-compiler-policy 'sb-ext)
462 heller 1.195 (when debug
463     (sb-ext:restrict-compiler-policy 'debug 3))
464 jsnellman 1.158 (flet ((compile-it (fn)
465 heller 1.139 (with-compilation-hooks ()
466 heller 1.156 (with-compilation-unit
467     (:source-plist (list :emacs-buffer buffer
468 nsiivola 1.176 :emacs-directory directory
469 heller 1.156 :emacs-string string
470     :emacs-position position))
471     (funcall fn (compile-file filename))))))
472     (with-open-file (s filename :direction :output :if-exists :error)
473     (write-string string s))
474     (unwind-protect
475     (if *trap-load-time-warnings*
476     (compile-it #'load)
477     (load (compile-it #'identity)))
478     (ignore-errors
479 heller 1.196 #+#.(swank-backend::sbcl-with-symbol
480     'restrict-compiler-policy 'sb-ext)
481 heller 1.195 (sb-ext:restrict-compiler-policy 'debug (or old-min-debug 0))
482 heller 1.156 (delete-file filename)
483     (delete-file (compile-file-pathname filename)))))))
484 dbarlow 1.1
485     ;;;; Definitions
486    
487     (defvar *debug-definition-finding* nil
488     "When true don't handle errors while looking for definitions.
489     This is useful when debugging the definition-finding code.")
490    
491 jsnellman 1.149 (defparameter *definition-types*
492     '(:variable defvar
493     :constant defconstant
494     :type deftype
495     :symbol-macro define-symbol-macro
496     :macro defmacro
497     :compiler-macro define-compiler-macro
498     :function defun
499     :generic-function defgeneric
500     :method defmethod
501     :setf-expander define-setf-expander
502     :structure defstruct
503 jsnellman 1.159 :condition define-condition
504 jsnellman 1.149 :class defclass
505     :method-combination define-method-combination
506     :package defpackage
507     :transform :deftransform
508     :optimizer :defoptimizer
509     :vop :define-vop
510     :source-transform :define-source-transform)
511     "Map SB-INTROSPECT definition type names to Slime-friendly forms")
512    
513     (defimplementation find-definitions (name)
514     (loop for type in *definition-types* by #'cddr
515     for locations = (sb-introspect:find-definition-sources-by-name
516     name type)
517     append (loop for source-location in locations collect
518     (make-source-location-specification type name
519     source-location))))
520    
521 trittweiler 1.193 (defimplementation find-source-location (obj)
522     (flet ((general-type-of (obj)
523     (typecase obj
524     (method :method)
525     (generic-function :generic-function)
526     (function :function)
527     (structure-class :structure-class)
528     (class :class)
529     (method-combination :method-combination)
530     (structure-object :structure-object)
531     (standard-object :standard-object)
532     (condition :condition)
533     (t :thing)))
534     (to-string (obj)
535     (typecase obj
536     ((or structure-object standard-object condition)
537     (with-output-to-string (s)
538     (print-unreadable-object (obj s :type t :identity t))))
539     (t (format nil "~A" obj)))))
540     (handler-case
541     (make-definition-source-location
542     (sb-introspect:find-definition-source obj) (general-type-of obj) (to-string obj))
543     (error (e)
544     (list :error (format nil "Error: ~A" e))))))
545    
546    
547 jsnellman 1.149 (defun make-source-location-specification (type name source-location)
548     (list (list* (getf *definition-types* type)
549     name
550     (sb-introspect::definition-source-description source-location))
551     (if *debug-definition-finding*
552     (make-definition-source-location source-location type name)
553 nsiivola 1.176 (handler-case
554     (make-definition-source-location source-location type name)
555 jsnellman 1.149 (error (e)
556 nsiivola 1.176 (list :error (format nil "Error: ~A" e)))))))
557 jsnellman 1.149
558     (defun make-definition-source-location (definition-source type name)
559     (with-struct (sb-introspect::definition-source-
560     pathname form-path character-offset plist
561     file-write-date)
562     definition-source
563 nsiivola 1.176 (destructuring-bind (&key emacs-buffer emacs-position emacs-directory
564 jsnellman 1.149 emacs-string &allow-other-keys)
565     plist
566     (cond
567     (emacs-buffer
568 nsiivola 1.176 (let* ((*readtable* (guess-readtable-for-filename emacs-directory))
569     (pos (if form-path
570 jsnellman 1.172 (with-debootstrapping
571     (source-path-string-position form-path emacs-string))
572     character-offset))
573     (snippet (string-path-snippet emacs-string form-path pos)))
574 jsnellman 1.149 (make-location `(:buffer ,emacs-buffer)
575     `(:position ,(+ pos emacs-position))
576 jsnellman 1.172 `(:snippet ,snippet))))
577 jsnellman 1.149 ((not pathname)
578 trittweiler 1.192 `(:error ,(format nil "Source definition of ~A ~A not found"
579 jsnellman 1.149 (string-downcase type) name)))
580     (t
581     (let* ((namestring (namestring (translate-logical-pathname pathname)))
582 jsnellman 1.172 (pos (source-file-position namestring file-write-date form-path
583     character-offset))
584     (snippet (source-hint-snippet namestring file-write-date pos)))
585 jsnellman 1.149 (make-location `(:file ,namestring)
586 trittweiler 1.192 ;; /file positions/ in Common Lisp start
587     ;; from 0, in Emacs they start from 1.
588     `(:position ,(1+ pos))
589 jsnellman 1.149 `(:snippet ,snippet))))))))
590    
591 jsnellman 1.172 (defun string-path-snippet (string form-path position)
592     (if form-path
593     ;; If we have a form-path, use it to derive a more accurate
594     ;; snippet, so that we can point to the individual form rather
595     ;; than just the toplevel form.
596     (multiple-value-bind (data end)
597     (let ((*read-suppress* t))
598     (read-from-string string nil nil :start position))
599     (declare (ignore data))
600     (subseq string position end))
601     string))
602    
603     (defun source-file-position (filename write-date form-path character-offset)
604     (let ((source (get-source-code filename write-date))
605     (*readtable* (guess-readtable-for-filename filename)))
606 trittweiler 1.192 (with-debootstrapping
607     (if form-path
608     (source-path-string-position form-path source)
609     (or character-offset 0)))))
610 jsnellman 1.172
611 jsnellman 1.149 (defun source-hint-snippet (filename write-date position)
612     (let ((source (get-source-code filename write-date)))
613     (with-input-from-string (s source)
614     (read-snippet s position))))
615    
616 jsnellman 1.151 (defun function-source-location (function &optional name)
617     (declare (type function function))
618     (let ((location (sb-introspect:find-definition-source function)))
619     (make-definition-source-location location :function name)))
620    
621     (defun safe-function-source-location (fun name)
622     (if *debug-definition-finding*
623     (function-source-location fun name)
624     (handler-case (function-source-location fun name)
625     (error (e)
626     (list :error (format nil "Error: ~A" e))))))
627 heller 1.105
628 lgorrie 1.54 (defimplementation describe-symbol-for-emacs (symbol)
629 dbarlow 1.1 "Return a plist describing SYMBOL.
630     Return NIL if the symbol is unbound."
631     (let ((result '()))
632 heller 1.133 (flet ((doc (kind)
633     (or (documentation symbol kind) :not-documented))
634     (maybe-push (property value)
635     (when value
636     (setf result (list* property value result)))))
637 dbarlow 1.1 (maybe-push
638     :variable (multiple-value-bind (kind recorded-p)
639     (sb-int:info :variable :kind symbol)
640     (declare (ignore kind))
641     (if (or (boundp symbol) recorded-p)
642     (doc 'variable))))
643 heller 1.133 (when (fboundp symbol)
644     (maybe-push
645     (cond ((macro-function symbol) :macro)
646     ((special-operator-p symbol) :special-operator)
647     ((typep (fdefinition symbol) 'generic-function)
648     :generic-function)
649     (t :function))
650     (doc 'function)))
651 dbarlow 1.1 (maybe-push
652     :setf (if (or (sb-int:info :setf :inverse symbol)
653     (sb-int:info :setf :expander symbol))
654     (doc 'setf)))
655     (maybe-push
656     :type (if (sb-int:info :type :kind symbol)
657     (doc 'type)))
658 lgorrie 1.24 result)))
659 dbarlow 1.1
660 heller 1.74 (defimplementation describe-definition (symbol type)
661 lgorrie 1.54 (case type
662     (:variable
663 heller 1.74 (describe symbol))
664     (:function
665     (describe (symbol-function symbol)))
666 lgorrie 1.54 (:setf
667 heller 1.74 (describe (or (sb-int:info :setf :inverse symbol)
668     (sb-int:info :setf :expander symbol))))
669 lgorrie 1.54 (:class
670 heller 1.74 (describe (find-class symbol)))
671 lgorrie 1.54 (:type
672 heller 1.74 (describe (sb-kernel:values-specifier-type symbol)))))
673 jsnellman 1.172
674     #+#.(swank-backend::sbcl-with-xref-p)
675     (progn
676     (defmacro defxref (name)
677     `(defimplementation ,name (what)
678     (sanitize-xrefs
679     (mapcar #'source-location-for-xref-data
680     (,(find-symbol (symbol-name name) "SB-INTROSPECT")
681     what)))))
682     (defxref who-calls)
683     (defxref who-binds)
684     (defxref who-sets)
685     (defxref who-references)
686     (defxref who-macroexpands))
687    
688     (defun source-location-for-xref-data (xref-data)
689     (let ((name (car xref-data))
690     (source-location (cdr xref-data)))
691     (list name
692     (handler-case (make-definition-source-location source-location
693     'function
694     name)
695     (error (e)
696     (list :error (format nil "Error: ~A" e)))))))
697 dbarlow 1.1
698 heller 1.97 (defimplementation list-callers (symbol)
699     (let ((fn (fdefinition symbol)))
700 heller 1.168 (sanitize-xrefs
701     (mapcar #'function-dspec (sb-introspect:find-function-callers fn)))))
702 heller 1.97
703     (defimplementation list-callees (symbol)
704     (let ((fn (fdefinition symbol)))
705 heller 1.168 (sanitize-xrefs
706     (mapcar #'function-dspec (sb-introspect:find-function-callees fn)))))
707 heller 1.97
708 jsnellman 1.172 (defun sanitize-xrefs (xrefs)
709 heller 1.168 (remove-duplicates
710     (remove-if (lambda (f)
711     (member f (ignored-xref-function-names)))
712 jsnellman 1.172 (loop for entry in xrefs
713     for name = (car entry)
714     collect (if (and (consp name)
715     (member (car name)
716     '(sb-pcl::fast-method
717     sb-pcl::slow-method
718     sb-pcl::method)))
719     (cons (cons 'defmethod (cdr name))
720     (cdr entry))
721     entry))
722 heller 1.168 :key #'car)
723     :test (lambda (a b)
724     (and (eq (first a) (first b))
725     (equal (second a) (second b))))))
726    
727     (defun ignored-xref-function-names ()
728     #-#.(swank-backend::sbcl-with-new-stepper-p)
729     '(nil sb-c::step-form sb-c::step-values)
730     #+#.(swank-backend::sbcl-with-new-stepper-p)
731     '(nil))
732 jsnellman 1.166
733 lgorrie 1.122 (defun function-dspec (fn)
734     "Describe where the function FN was defined.
735     Return a list of the form (NAME LOCATION)."
736     (let ((name (sb-kernel:%fun-name fn)))
737     (list name (safe-function-source-location fn name))))
738    
739 dbarlow 1.4 ;;; macroexpansion
740 dbarlow 1.1
741 lgorrie 1.54 (defimplementation macroexpand-all (form)
742 heller 1.21 (let ((sb-walker:*walk-form-expand-macros-p* t))
743     (sb-walker:walk-form form)))
744 lgorrie 1.25
745 dbarlow 1.1
746     ;;; Debugging
747    
748     (defvar *sldb-stack-top*)
749    
750 trittweiler 1.194 (defun make-invoke-debugger-hook (hook)
751     #'(lambda (condition old-hook)
752     ;; Notice that *INVOKE-DEBUGGER-HOOK* is tried before
753     ;; *DEBUGGER-HOOK*, so we have to make sure that the latter gets
754     ;; run when it was established locally by a user.
755     (if *debugger-hook*
756     (funcall *debugger-hook* condition old-hook)
757     (funcall hook condition old-hook))))
758    
759 heller 1.148 (defimplementation install-debugger-globally (function)
760 trittweiler 1.194 (setq *debugger-hook* function)
761     (setq sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook function)))
762 heller 1.148
763 jsnellman 1.162 (defimplementation condition-extras (condition)
764 heller 1.183 (cond #+#.(swank-backend::sbcl-with-new-stepper-p)
765     ((typep condition 'sb-impl::step-form-condition)
766     `((:show-frame-source 0)))
767     ((typep condition 'sb-int:reference-condition)
768     (let ((refs (sb-int:reference-condition-references condition)))
769     (if refs
770     `((:references ,(externalize-reference refs))))))))
771    
772     (defun externalize-reference (ref)
773     (etypecase ref
774     (null nil)
775     (cons (cons (externalize-reference (car ref))
776     (externalize-reference (cdr ref))))
777     ((or string number) ref)
778     (symbol
779     (cond ((eq (symbol-package ref) (symbol-package :test))
780     ref)
781     (t (symbol-name ref))))))
782 jsnellman 1.162
783 lgorrie 1.54 (defimplementation call-with-debugging-environment (debugger-loop-fn)
784 heller 1.58 (declare (type function debugger-loop-fn))
785 lgorrie 1.25 (let* ((*sldb-stack-top* (or sb-debug:*stack-top-hint* (sb-di:top-frame)))
786 heller 1.71 (sb-debug:*stack-top-hint* nil))
787 jsnellman 1.158 (handler-bind ((sb-di:debug-condition
788 dbarlow 1.1 (lambda (condition)
789 lgorrie 1.25 (signal (make-condition
790     'sldb-condition
791     :original-condition condition)))))
792     (funcall debugger-loop-fn))))
793 dbarlow 1.1
794 jsnellman 1.162 #+#.(swank-backend::sbcl-with-new-stepper-p)
795     (progn
796     (defimplementation activate-stepping (frame)
797     (declare (ignore frame))
798     (sb-impl::enable-stepping))
799     (defimplementation sldb-stepper-condition-p (condition)
800     (typep condition 'sb-ext:step-form-condition))
801     (defimplementation sldb-step-into ()
802     (invoke-restart 'sb-ext:step-into))
803     (defimplementation sldb-step-next ()
804     (invoke-restart 'sb-ext:step-next))
805     (defimplementation sldb-step-out ()
806     (invoke-restart 'sb-ext:step-out)))
807    
808 heller 1.118 (defimplementation call-with-debugger-hook (hook fun)
809 trittweiler 1.194 (let ((*debugger-hook* hook)
810     (sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook))
811 jsnellman 1.162 #+#.(swank-backend::sbcl-with-new-stepper-p)
812     (sb-ext:*stepper-hook*
813     (lambda (condition)
814 jsnellman 1.164 (typecase condition
815     (sb-ext:step-form-condition
816     (let ((sb-debug:*stack-top-hint* (sb-di::find-stepped-frame)))
817     (sb-impl::invoke-debugger condition)))))))
818     (handler-bind (#+#.(swank-backend::sbcl-with-new-stepper-p)
819     (sb-ext:step-condition #'sb-impl::invoke-stepper))
820 jsnellman 1.163 (funcall fun))))
821 heller 1.118
822 dbarlow 1.1 (defun nth-frame (index)
823     (do ((frame *sldb-stack-top* (sb-di:frame-down frame))
824     (i index (1- i)))
825     ((zerop i) frame)))
826    
827 heller 1.74 (defimplementation compute-backtrace (start end)
828 dbarlow 1.1 "Return a list of frames starting with frame number START and
829     continuing to frame number END or, if END is nil, the last frame on the
830     stack."
831     (let ((end (or end most-positive-fixnum)))
832 heller 1.45 (loop for f = (nth-frame start) then (sb-di:frame-down f)
833     for i from start below end
834     while f
835 heller 1.74 collect f)))
836 dbarlow 1.1
837 heller 1.74 (defimplementation print-frame (frame stream)
838 nsiivola 1.134 (sb-debug::print-frame-call frame stream))
839 dbarlow 1.1
840 heller 1.124 ;;;; Code-location -> source-location translation
841    
842 heller 1.129 ;;; If debug-block info is avaibale, we determine the file position of
843     ;;; the source-path for a code-location. If the code was compiled
844     ;;; with C-c C-c, we have to search the position in the source string.
845     ;;; If there's no debug-block info, we return the (less precise)
846     ;;; source-location of the corresponding function.
847    
848 nsiivola 1.134 (defun code-location-source-location (code-location)
849     (let* ((dsource (sb-di:code-location-debug-source code-location))
850     (plist (sb-c::debug-source-plist dsource)))
851     (if (getf plist :emacs-buffer)
852     (emacs-buffer-source-location code-location plist)
853 trittweiler 1.197 #+#.(swank-backend::sbcl-with-symbol 'debug-source-from 'sb-di)
854 nsiivola 1.134 (ecase (sb-di:debug-source-from dsource)
855     (:file (file-source-location code-location))
856 trittweiler 1.197 (:lisp (lisp-source-location code-location)))
857     #-#.(swank-backend::sbcl-with-symbol 'debug-source-from 'sb-di)
858     (if (sb-di:debug-source-namestring dsource)
859     (file-source-location code-location)
860     (lisp-source-location code-location)))))
861 nsiivola 1.134
862     ;;; FIXME: The naming policy of source-location functions is a bit
863     ;;; fuzzy: we have FUNCTION-SOURCE-LOCATION which returns the
864     ;;; source-location for a function, and we also have FILE-SOURCE-LOCATION &co
865     ;;; which returns the source location for a _code-location_.
866 jsnellman 1.158 ;;;
867 nsiivola 1.134 ;;; Maybe these should be named code-location-file-source-location,
868 heller 1.139 ;;; etc, turned into generic functions, or something. In the very
869     ;;; least the names should indicate the main entry point vs. helper
870     ;;; status.
871 heller 1.124
872 nsiivola 1.134 (defun file-source-location (code-location)
873     (if (code-location-has-debug-block-info-p code-location)
874     (source-file-source-location code-location)
875     (fallback-source-location code-location)))
876    
877     (defun fallback-source-location (code-location)
878     (let ((fun (code-location-debug-fun-fun code-location)))
879     (cond (fun (function-source-location fun))
880 heller 1.182 (t (error "Cannot find source location for: ~A " code-location)))))
881 nsiivola 1.134
882 heller 1.124 (defun lisp-source-location (code-location)
883 jsnellman 1.158 (let ((source (prin1-to-string
884 nsiivola 1.134 (sb-debug::code-location-source-form code-location 100))))
885 heller 1.124 (make-location `(:source-form ,source) '(:position 0))))
886    
887 nsiivola 1.134 (defun emacs-buffer-source-location (code-location plist)
888     (if (code-location-has-debug-block-info-p code-location)
889 nsiivola 1.177 (destructuring-bind (&key emacs-buffer emacs-position emacs-string
890     &allow-other-keys)
891     plist
892 nsiivola 1.134 (let* ((pos (string-source-position code-location emacs-string))
893     (snipped (with-input-from-string (s emacs-string)
894     (read-snippet s pos))))
895 jsnellman 1.158 (make-location `(:buffer ,emacs-buffer)
896     `(:position ,(+ emacs-position pos))
897 nsiivola 1.134 `(:snippet ,snipped))))
898     (fallback-source-location code-location)))
899    
900 heller 1.124 (defun source-file-source-location (code-location)
901     (let* ((code-date (code-location-debug-source-created code-location))
902     (filename (code-location-debug-source-name code-location))
903 jsnellman 1.186 (*readtable* (guess-readtable-for-filename filename))
904 heller 1.126 (source-code (get-source-code filename code-date)))
905 jsnellman 1.186 (with-debootstrapping
906     (with-input-from-string (s source-code)
907     (let* ((pos (stream-source-position code-location s))
908     (snippet (read-snippet s pos)))
909     (make-location `(:file ,filename)
910     `(:position ,(1+ pos))
911     `(:snippet ,snippet)))))))
912 heller 1.124
913     (defun code-location-debug-source-name (code-location)
914 trittweiler 1.197 (namestring (truename (#+#.(swank-backend::sbcl-with-symbol
915     'debug-source-name 'sb-di)
916     sb-c::debug-source-name
917     #-#.(swank-backend::sbcl-with-symbol
918     'debug-source-name 'sb-di)
919     sb-c::debug-source-namestring
920 jsnellman 1.186 (sb-di::code-location-debug-source code-location)))))
921 heller 1.124
922     (defun code-location-debug-source-created (code-location)
923 jsnellman 1.158 (sb-c::debug-source-created
924 heller 1.124 (sb-di::code-location-debug-source code-location)))
925    
926     (defun code-location-debug-fun-fun (code-location)
927     (sb-di:debug-fun-fun (sb-di:code-location-debug-fun code-location)))
928    
929     (defun code-location-has-debug-block-info-p (code-location)
930 jsnellman 1.158 (handler-case
931 heller 1.124 (progn (sb-di:code-location-debug-block code-location)
932     t)
933     (sb-di:no-debug-blocks () nil)))
934    
935     (defun stream-source-position (code-location stream)
936     (let* ((cloc (sb-debug::maybe-block-start-location code-location))
937 heller 1.128 (tlf-number (sb-di::code-location-toplevel-form-offset cloc))
938 heller 1.124 (form-number (sb-di::code-location-form-number cloc)))
939     (multiple-value-bind (tlf pos-map) (read-source-form tlf-number stream)
940     (let* ((path-table (sb-di::form-number-translations tlf 0))
941 heller 1.128 (path (cond ((<= (length path-table) form-number)
942 heller 1.129 (warn "inconsistent form-number-translations")
943 heller 1.128 (list 0))
944     (t
945     (reverse (cdr (aref path-table form-number)))))))
946     (source-path-source-position path tlf pos-map)))))
947    
948     (defun string-source-position (code-location string)
949     (with-input-from-string (s string)
950     (stream-source-position code-location s)))
951 dbarlow 1.1
952 dbarlow 1.44 ;;; source-path-file-position and friends are in swank-source-path-parser
953 lgorrie 1.121
954 dbarlow 1.1 (defun safe-source-location-for-emacs (code-location)
955 heller 1.126 (if *debug-definition-finding*
956     (code-location-source-location code-location)
957     (handler-case (code-location-source-location code-location)
958     (error (c) (list :error (format nil "~A" c))))))
959 jsnellman 1.158
960 lgorrie 1.54 (defimplementation frame-source-location-for-emacs (index)
961 jsnellman 1.158 (safe-source-location-for-emacs
962 heller 1.22 (sb-di:frame-code-location (nth-frame index))))
963 dbarlow 1.1
964 heller 1.92 (defun frame-debug-vars (frame)
965     "Return a vector of debug-variables in frame."
966     (sb-di::debug-fun-debug-vars (sb-di:frame-debug-fun frame)))
967    
968     (defun debug-var-value (var frame location)
969     (ecase (sb-di:debug-var-validity var location)
970     (:valid (sb-di:debug-var-value var frame))
971     ((:invalid :unknown) ':<not-available>)))
972    
973 lgorrie 1.54 (defimplementation frame-locals (index)
974 dbarlow 1.1 (let* ((frame (nth-frame index))
975 heller 1.92 (loc (sb-di:frame-code-location frame))
976     (vars (frame-debug-vars frame)))
977     (loop for v across vars collect
978     (list :name (sb-di:debug-var-symbol v)
979     :id (sb-di:debug-var-id v)
980     :value (debug-var-value v frame loc)))))
981    
982     (defimplementation frame-var-value (frame var)
983     (let* ((frame (nth-frame frame))
984     (dvar (aref (frame-debug-vars frame) var)))
985     (debug-var-value dvar frame (sb-di:frame-code-location frame))))
986 dbarlow 1.1
987 lgorrie 1.54 (defimplementation frame-catch-tags (index)
988 heller 1.74 (mapcar #'car (sb-di:frame-catches (nth-frame index))))
989 lgorrie 1.50
990 heller 1.56 (defimplementation eval-in-frame (form index)
991     (let ((frame (nth-frame index)))
992 heller 1.58 (funcall (the function
993 jsnellman 1.158 (sb-di:preprocess-for-eval form
994 heller 1.58 (sb-di:frame-code-location frame)))
995 heller 1.56 frame)))
996    
997 jsnellman 1.174 #+#.(swank-backend::sbcl-with-restart-frame)
998     (progn
999     (defimplementation return-from-frame (index form)
1000     (let* ((frame (nth-frame index)))
1001     (cond ((sb-debug:frame-has-debug-tag-p frame)
1002     (let ((values (multiple-value-list (eval-in-frame form index))))
1003     (sb-debug:unwind-to-frame-and-call frame
1004     (lambda ()
1005     (values-list values)))))
1006     (t (format nil "Cannot return from frame: ~S" frame)))))
1007    
1008     (defimplementation restart-frame (index)
1009     (let* ((frame (nth-frame index)))
1010     (cond ((sb-debug:frame-has-debug-tag-p frame)
1011     (let* ((call-list (sb-debug::frame-call-as-list frame))
1012     (fun (fdefinition (car call-list)))
1013     (thunk (lambda ()
1014     ;; Ensure that the thunk gets tail-call-optimized
1015     (declare (optimize (debug 1)))
1016     (apply fun (cdr call-list)))))
1017     (sb-debug:unwind-to-frame-and-call frame thunk)))
1018     (t (format nil "Cannot restart frame: ~S" frame))))))
1019 heller 1.152
1020     ;; FIXME: this implementation doesn't unwind the stack before
1021     ;; re-invoking the function, but it's better than no implementation at
1022     ;; all.
1023 jsnellman 1.174 #-#.(swank-backend::sbcl-with-restart-frame)
1024     (progn
1025     (defun sb-debug-catch-tag-p (tag)
1026     (and (symbolp tag)
1027     (not (symbol-package tag))
1028     (string= tag :sb-debug-catch-tag)))
1029    
1030     (defimplementation return-from-frame (index form)
1031     (let* ((frame (nth-frame index))
1032     (probe (assoc-if #'sb-debug-catch-tag-p
1033     (sb-di::frame-catches frame))))
1034     (cond (probe (throw (car probe) (eval-in-frame form index)))
1035     (t (format nil "Cannot return from frame: ~S" frame)))))
1036    
1037     (defimplementation restart-frame (index)
1038     (let ((frame (nth-frame index)))
1039     (return-from-frame index (sb-debug::frame-call-as-list frame)))))
1040 jsnellman 1.158
1041 lgorrie 1.87 ;;;;; reference-conditions
1042    
1043     (defimplementation format-sldb-condition (condition)
1044     (let ((sb-int:*print-condition-references* nil))
1045     (princ-to-string condition)))
1046    
1047 heller 1.57
1048     ;;;; Profiling
1049    
1050     (defimplementation profile (fname)
1051     (when fname (eval `(sb-profile:profile ,fname))))
1052    
1053     (defimplementation unprofile (fname)
1054     (when fname (eval `(sb-profile:unprofile ,fname))))
1055    
1056     (defimplementation unprofile-all ()
1057     (sb-profile:unprofile)
1058     "All functions unprofiled.")
1059    
1060     (defimplementation profile-report ()
1061     (sb-profile:report))
1062    
1063     (defimplementation profile-reset ()
1064     (sb-profile:reset)
1065     "Reset profiling counters.")
1066    
1067     (defimplementation profiled-functions ()
1068     (sb-profile:profile))
1069    
1070 heller 1.116 (defimplementation profile-package (package callers methods)
1071     (declare (ignore callers methods))
1072     (eval `(sb-profile:profile ,(package-name (find-package package)))))
1073    
1074 heller 1.57
1075 heller 1.64 ;;;; Inspector
1076 heller 1.63
1077 heller 1.190 (defmethod emacs-inspect ((o t))
1078 heller 1.64 (cond ((sb-di::indirect-value-cell-p o)
1079 heller 1.191 (label-value-line* (:value (sb-kernel:value-cell-ref o))))
1080 heller 1.64 (t
1081 heller 1.126 (multiple-value-bind (text label parts) (sb-impl::inspected-parts o)
1082 heller 1.191 (list* (format nil "~a~%" text)
1083     (if label
1084     (loop for (l . v) in parts
1085     append (label-value-line l v))
1086     (loop for value in parts for i from 0
1087     append (label-value-line i value))))))))
1088 heller 1.64
1089 heller 1.190 (defmethod emacs-inspect ((o function))
1090 heller 1.64 (let ((header (sb-kernel:widetag-of o)))
1091     (cond ((= header sb-vm:simple-fun-header-widetag)
1092 heller 1.126 (label-value-line*
1093     (:name (sb-kernel:%simple-fun-name o))
1094     (:arglist (sb-kernel:%simple-fun-arglist o))
1095     (:self (sb-kernel:%simple-fun-self o))
1096     (:next (sb-kernel:%simple-fun-next o))
1097     (:type (sb-kernel:%simple-fun-type o))
1098 heller 1.191 (:code (sb-kernel:fun-code-header o))))
1099 heller 1.64 ((= header sb-vm:closure-header-widetag)
1100 jsnellman 1.158 (append
1101 heller 1.126 (label-value-line :function (sb-kernel:%closure-fun o))
1102     `("Closed over values:" (:newline))
1103     (loop for i below (1- (sb-kernel:get-closure-length o))
1104 jsnellman 1.158 append (label-value-line
1105 heller 1.191 i (sb-kernel:%closure-index-ref o i)))))
1106 heller 1.64 (t (call-next-method o)))))
1107    
1108 heller 1.190 (defmethod emacs-inspect ((o sb-kernel:code-component))
1109 jsnellman 1.158 (append
1110     (label-value-line*
1111 heller 1.113 (:code-size (sb-kernel:%code-code-size o))
1112     (:entry-points (sb-kernel:%code-entry-points o))
1113     (:debug-info (sb-kernel:%code-debug-info o))
1114 jsnellman 1.158 (:trace-table-offset (sb-kernel:code-header-ref
1115 heller 1.113 o sb-vm:code-trace-table-offset-slot)))
1116     `("Constants:" (:newline))
1117 jsnellman 1.158 (loop for i from sb-vm:code-constants-offset
1118 mbaringer 1.102 below (sb-kernel:get-header-data o)
1119 heller 1.113 append (label-value-line i (sb-kernel:code-header-ref o i)))
1120     `("Code:" (:newline)
1121     , (with-output-to-string (s)
1122     (cond ((sb-kernel:%code-debug-info o)
1123     (sb-disassem:disassemble-code-component o :stream s))
1124     (t
1125 jsnellman 1.158 (sb-disassem:disassemble-memory
1126     (sb-disassem::align
1127 heller 1.113 (+ (logandc2 (sb-kernel:get-lisp-obj-address o)
1128     sb-vm:lowtag-mask)
1129 heller 1.126 (* sb-vm:code-constants-offset
1130     sb-vm:n-word-bytes))
1131 heller 1.113 (ash 1 sb-vm:n-lowtag-bits))
1132     (ash (sb-kernel:%code-code-size o) sb-vm:word-shift)
1133 heller 1.191 :stream s)))))))
1134 mbaringer 1.102
1135 heller 1.190 (defmethod emacs-inspect ((o sb-ext:weak-pointer))
1136 mbaringer 1.167 (label-value-line*
1137 heller 1.191 (:value (sb-ext:weak-pointer-value o))))
1138 mbaringer 1.167
1139 heller 1.190 (defmethod emacs-inspect ((o sb-kernel:fdefn))
1140 heller 1.126 (label-value-line*
1141     (:name (sb-kernel:fdefn-name o))
1142 heller 1.191 (:function (sb-kernel:fdefn-fun o))))
1143 mbaringer 1.102
1144 heller 1.190 (defmethod emacs-inspect :around ((o generic-function))
1145 jsnellman 1.158 (append
1146 heller 1.191 (call-next-method)
1147 heller 1.126 (label-value-line*
1148     (:pretty-arglist (sb-pcl::generic-function-pretty-arglist o))
1149     (:initial-methods (sb-pcl::generic-function-initial-methods o))
1150 heller 1.191 )))
1151 heller 1.90
1152 heller 1.63
1153 lgorrie 1.50 ;;;; Multiprocessing
1154    
1155 crhodes 1.136 #+(and sb-thread
1156     #.(cl:if (cl:find-symbol "THREAD-NAME" "SB-THREAD") '(and) '(or)))
1157     (progn
1158     (defvar *thread-id-counter* 0)
1159 jsnellman 1.158
1160 crhodes 1.136 (defvar *thread-id-counter-lock*
1161     (sb-thread:make-mutex :name "thread id counter lock"))
1162    
1163     (defun next-thread-id ()
1164     (sb-thread:with-mutex (*thread-id-counter-lock*)
1165     (incf *thread-id-counter*)))
1166 jsnellman 1.158
1167 crhodes 1.136 (defparameter *thread-id-map* (make-hash-table))
1168    
1169     ;; This should be a thread -> id map but as weak keys are not
1170     ;; supported it is id -> map instead.
1171     (defvar *thread-id-map-lock*
1172     (sb-thread:make-mutex :name "thread id map lock"))
1173 jsnellman 1.158
1174 crhodes 1.136 (defimplementation spawn (fn &key name)
1175     (sb-thread:make-thread fn :name name))
1176    
1177     (defimplementation thread-id (thread)
1178 heller 1.160 (block thread-id
1179     (sb-thread:with-mutex (*thread-id-map-lock*)
1180     (loop for id being the hash-key in *thread-id-map*
1181     using (hash-value thread-pointer)
1182     do
1183     (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
1184     (cond ((null maybe-thread)
1185     ;; the value is gc'd, remove it manually
1186     (remhash id *thread-id-map*))
1187     ((eq thread maybe-thread)
1188     (return-from thread-id id)))))
1189     ;; lazy numbering
1190     (let ((id (next-thread-id)))
1191     (setf (gethash id *thread-id-map*) (sb-ext:make-weak-pointer thread))
1192     id))))
1193 crhodes 1.136
1194     (defimplementation find-thread (id)
1195     (sb-thread:with-mutex (*thread-id-map-lock*)
1196     (let ((thread-pointer (gethash id *thread-id-map*)))
1197     (if thread-pointer
1198     (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
1199     (if maybe-thread
1200     maybe-thread
1201     ;; the value is gc'd, remove it manually
1202     (progn
1203     (remhash id *thread-id-map*)
1204     nil)))
1205     nil))))
1206 jsnellman 1.158
1207 crhodes 1.136 (defimplementation thread-name (thread)
1208     ;; sometimes the name is not a string (e.g. NIL)
1209     (princ-to-string (sb-thread:thread-name thread)))
1210    
1211     (defimplementation thread-status (thread)
1212     (if (sb-thread:thread-alive-p thread)
1213     "RUNNING"
1214     "STOPPED"))
1215    
1216     (defimplementation make-lock (&key name)
1217     (sb-thread:make-mutex :name name))
1218    
1219     (defimplementation call-with-lock-held (lock function)
1220     (declare (type function function))
1221     (sb-thread:with-mutex (lock) (funcall function)))
1222    
1223 nsiivola 1.154 (defimplementation make-recursive-lock (&key name)
1224     (sb-thread:make-mutex :name name))
1225    
1226     (defimplementation call-with-recursive-lock-held (lock function)
1227     (declare (type function function))
1228     (sb-thread:with-recursive-lock (lock) (funcall function)))
1229    
1230 crhodes 1.136 (defimplementation current-thread ()
1231     sb-thread:*current-thread*)
1232    
1233     (defimplementation all-threads ()
1234     (sb-thread:list-all-threads))
1235 jsnellman 1.158
1236 crhodes 1.136 (defimplementation interrupt-thread (thread fn)
1237     (sb-thread:interrupt-thread thread fn))
1238    
1239     (defimplementation kill-thread (thread)
1240     (sb-thread:terminate-thread thread))
1241    
1242     (defimplementation thread-alive-p (thread)
1243     (sb-thread:thread-alive-p thread))
1244    
1245     (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))
1246     (defvar *mailboxes* (list))
1247     (declaim (type list *mailboxes*))
1248    
1249 jsnellman 1.158 (defstruct (mailbox (:conc-name mailbox.))
1250 crhodes 1.136 thread
1251     (mutex (sb-thread:make-mutex))
1252     (waitqueue (sb-thread:make-waitqueue))
1253     (queue '() :type list))
1254    
1255     (defun mailbox (thread)
1256     "Return THREAD's mailbox."
1257     (sb-thread:with-mutex (*mailbox-lock*)
1258     (or (find thread *mailboxes* :key #'mailbox.thread)
1259     (let ((mb (make-mailbox :thread thread)))
1260     (push mb *mailboxes*)
1261     mb))))
1262    
1263     (defimplementation send (thread message)
1264     (let* ((mbox (mailbox thread))
1265     (mutex (mailbox.mutex mbox)))
1266     (sb-thread:with-mutex (mutex)
1267     (setf (mailbox.queue mbox)
1268     (nconc (mailbox.queue mbox) (list message)))
1269     (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
1270    
1271     (defimplementation receive ()
1272     (let* ((mbox (mailbox (current-thread)))
1273     (mutex (mailbox.mutex mbox)))
1274     (sb-thread:with-mutex (mutex)
1275     (loop
1276     (let ((q (mailbox.queue mbox)))
1277     (cond (q (return (pop (mailbox.queue mbox))))
1278     (t (sb-thread:condition-wait (mailbox.waitqueue mbox)
1279     mutex))))))))
1280    
1281    
1282 mbaringer 1.178 ;; Auto-flush streams
1283 lgorrie 1.50
1284 mbaringer 1.178 (defvar *auto-flush-interval* 0.15
1285     "How often to flush interactive streams. This valu is passed
1286     directly to cl:sleep.")
1287    
1288     (defvar *auto-flush-lock* (make-recursive-lock :name "auto flush"))
1289 jsnellman 1.158
1290 heller 1.147 (defvar *auto-flush-thread* nil)
1291 heller 1.59
1292 mbaringer 1.178 (defvar *auto-flush-streams* '())
1293    
1294 heller 1.147 (defimplementation make-stream-interactive (stream)
1295 mbaringer 1.178 (call-with-recursive-lock-held
1296     *auto-flush-lock*
1297     (lambda ()
1298     (pushnew stream *auto-flush-streams*)
1299     (unless *auto-flush-thread*
1300     (setq *auto-flush-thread*
1301     (sb-thread:make-thread #'flush-streams
1302     :name "auto-flush-thread"))))))
1303 heller 1.147
1304     (defun flush-streams ()
1305     (loop
1306 mbaringer 1.178 (call-with-recursive-lock-held
1307     *auto-flush-lock*
1308     (lambda ()
1309     (setq *auto-flush-streams*
1310     (remove-if (lambda (x)
1311     (not (and (open-stream-p x)
1312     (output-stream-p x))))
1313     *auto-flush-streams*))
1314     (mapc #'finish-output *auto-flush-streams*)))
1315     (sleep *auto-flush-interval*)))
1316 heller 1.59
1317     )
1318 heller 1.126
1319     (defimplementation quit-lisp ()
1320     #+sb-thread
1321     (dolist (thread (remove (current-thread) (all-threads)))
1322 jsnellman 1.158 (ignore-errors (sb-thread:interrupt-thread
1323 heller 1.133 thread (lambda () (sb-ext:quit :recklessly-p t)))))
1324 heller 1.126 (sb-ext:quit))
1325 heller 1.133
1326 mbaringer 1.117
1327 heller 1.118
1328 mbaringer 1.117 ;;Trace implementations
1329     ;;In SBCL, we have:
1330     ;; (trace <name>)
1331 heller 1.118 ;; (trace :methods '<name>) ;to trace all methods of the gf <name>
1332 mbaringer 1.117 ;; (trace (method <name> <qualifier>? (<specializer>+)))
1333     ;; <name> can be a normal name or a (setf name)
1334    
1335 heller 1.119 (defun toggle-trace-aux (fspec &rest args)
1336 mbaringer 1.117 (cond ((member fspec (eval '(trace)) :test #'equal)
1337     (eval `(untrace ,fspec))
1338     (format nil "~S is now untraced." fspec))
1339     (t
1340     (eval `(trace ,@(if args `(:encapsulate nil) (list)) ,fspec ,@args))
1341     (format nil "~S is now traced." fspec))))
1342    
1343     (defun process-fspec (fspec)
1344     (cond ((consp fspec)
1345     (ecase (first fspec)
1346     ((:defun :defgeneric) (second fspec))
1347     ((:defmethod) `(method ,@(rest fspec)))
1348     ((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec)))
1349     ((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec)))))
1350     (t
1351     fspec)))
1352    
1353 heller 1.119 (defimplementation toggle-trace (spec)
1354     (ecase (car spec)
1355 jsnellman 1.158 ((setf)
1356 heller 1.119 (toggle-trace-aux spec))
1357     ((:defmethod)
1358     (toggle-trace-aux `(sb-pcl::fast-method ,@(rest (process-fspec spec)))))
1359     ((:defgeneric)
1360     (toggle-trace-aux (second spec) :methods t))
1361     ((:call)
1362     (destructuring-bind (caller callee) (cdr spec)
1363     (toggle-trace-aux callee :wherein (list (process-fspec caller)))))))
1364 mkoeppe 1.142
1365     ;;; Weak datastructures
1366    
1367 nsiivola 1.170 (defimplementation make-weak-key-hash-table (&rest args)
1368     #+#.(swank-backend::sbcl-with-weak-hash-tables)
1369     (apply #'make-hash-table :weakness :key args)
1370     #-#.(swank-backend::sbcl-with-weak-hash-tables)
1371     (apply #'make-hash-table args))
1372 mkoeppe 1.142
1373 mbaringer 1.169 (defimplementation make-weak-value-hash-table (&rest args)
1374 nsiivola 1.170 #+#.(swank-backend::sbcl-with-weak-hash-tables)
1375     (apply #'make-hash-table :weakness :value args)
1376     #-#.(swank-backend::sbcl-with-weak-hash-tables)
1377     (apply #'make-hash-table args))
1378 alendvai 1.173
1379     (defimplementation hash-table-weakness (hashtable)
1380     #+#.(swank-backend::sbcl-with-weak-hash-tables)
1381     (sb-ext:hash-table-weakness hashtable))

  ViewVC Help
Powered by ViewVC 1.1.5