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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5