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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.172 - (hide annotations)
Tue Dec 5 04:46:06 2006 UTC (7 years, 4 months ago) by jsnellman
Branch: MAIN
Changes since 1.171: +69 -20 lines
	Xref support for SBCL (requires SBCL 1.0.0.18).

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

  ViewVC Help
Powered by ViewVC 1.1.5