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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.218 - (hide annotations)
Fri Sep 12 12:27:38 2008 UTC (5 years, 7 months ago) by trittweiler
Branch: MAIN
Changes since 1.217: +11 -6 lines
	New faces: `sldb-restartable-frame-line-face',
	           `sldb-non-restartable-frame-line-face'.

	The former is the face for frames that are surely restartable, the
	latter for frames that are surely not restartable. If
	restartability of a frame cannot be reliably determined, the face
	`sldb-frame-line-face' is used.

	At the moment, determination of frame restartability is supported
	by the SBCL backend only.

	* slime.el (sldb-frame.string): New.
	(sldb-frame.number): New.
	(sldb-frame.plist): New.
	(sldb-prune-initial-frames): Use them.
	(sldb-insert-frames): Ditto.
	(sldb-compute-frame-face): New.
	(sldb-insert-frame): Use `sldb-compute-frame-face' to insert
	frames with one of the faces described above.

	* swank.lisp (defslimefun backtrace): Changed return value; each
	frame is now accompanied with a PLIST which at the moment can
	contain :RESTARTABLE NIL/T/:UNKNOWN depending on whether the frame
	is restartable, or not.

	* swank-backend.lisp (defstruct swank-frame): New structure.
	(compute-backtrace): Is now supposed to return a list of SWANK-FRAMEs.
	(print-frame): Renamed to PRINT-SWANK-FRAME.

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

  ViewVC Help
Powered by ViewVC 1.1.5