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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5