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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.205 - (hide annotations)
Tue Aug 5 17:38:44 2008 UTC (5 years, 8 months ago) by heller
Branch: MAIN
Changes since 1.204: +14 -25 lines
Drop distinction between "recursive" and non-recursive locks.

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

  ViewVC Help
Powered by ViewVC 1.1.5