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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5