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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5