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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5