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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.143 - (hide annotations)
Mon Aug 29 11:23:55 2005 UTC (8 years, 7 months ago) by jsnellman
Branch: MAIN
Changes since 1.142: +5 -0 lines
swank-sbcl.lisp (make-weak-key-hash-table): Remove the implementation;
SBCL doesn't actually support weak hash-tables.
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 crhodes 1.141 collect (list `(method ,name ,@(method-qualifiers method)
523     ,(sb-pcl::unparse-specializers method))
524 heller 1.126 (method-source-location method)))))
525 heller 1.74
526 heller 1.126 (defun method-source-location (method)
527     (safe-function-source-location (or (sb-pcl::method-fast-function method)
528     (sb-pcl:method-function method))
529     nil))
530    
531 lgorrie 1.122 ;;;;; Compiler definitions
532    
533     (defun compiler-definitions (name)
534     (let ((fun-info (sb-int:info :function :info name)))
535     (when fun-info
536     (append (transform-definitions fun-info name)
537     (optimizer-definitions fun-info name)))))
538 heller 1.105
539     (defun transform-definitions (fun-info name)
540     (loop for xform in (sb-c::fun-info-transforms fun-info)
541     for loc = (safe-function-source-location
542     (sb-c::transform-function xform) name)
543     for typespec = (sb-kernel:type-specifier (sb-c::transform-type xform))
544     for note = (sb-c::transform-note xform)
545     for spec = (if (consp typespec)
546     `(sb-c:deftransform ,(second typespec) ,note)
547     `(sb-c:deftransform ,note))
548     collect `(,spec ,loc)))
549    
550     (defun optimizer-definitions (fun-info fun-name)
551     (let ((otypes '((sb-c::fun-info-derive-type . sb-c:derive-type)
552     (sb-c::fun-info-ltn-annotate . sb-c:ltn-annotate)
553     (sb-c::fun-info-ltn-annotate . sb-c:ltn-annotate)
554     (sb-c::fun-info-optimizer . sb-c:optimizer))))
555     (loop for (reader . name) in otypes
556     for fn = (funcall reader fun-info)
557     when fn collect `((sb-c:defoptimizer ,name)
558     ,(safe-function-source-location fn fun-name)))))
559    
560 lgorrie 1.54 (defimplementation describe-symbol-for-emacs (symbol)
561 dbarlow 1.1 "Return a plist describing SYMBOL.
562     Return NIL if the symbol is unbound."
563     (let ((result '()))
564 heller 1.133 (flet ((doc (kind)
565     (or (documentation symbol kind) :not-documented))
566     (maybe-push (property value)
567     (when value
568     (setf result (list* property value result)))))
569 dbarlow 1.1 (maybe-push
570     :variable (multiple-value-bind (kind recorded-p)
571     (sb-int:info :variable :kind symbol)
572     (declare (ignore kind))
573     (if (or (boundp symbol) recorded-p)
574     (doc 'variable))))
575 heller 1.133 (when (fboundp symbol)
576     (maybe-push
577     (cond ((macro-function symbol) :macro)
578     ((special-operator-p symbol) :special-operator)
579     ((typep (fdefinition symbol) 'generic-function)
580     :generic-function)
581     (t :function))
582     (doc 'function)))
583 dbarlow 1.1 (maybe-push
584     :setf (if (or (sb-int:info :setf :inverse symbol)
585     (sb-int:info :setf :expander symbol))
586     (doc 'setf)))
587     (maybe-push
588     :type (if (sb-int:info :type :kind symbol)
589     (doc 'type)))
590 lgorrie 1.24 result)))
591 dbarlow 1.1
592 heller 1.74 (defimplementation describe-definition (symbol type)
593 lgorrie 1.54 (case type
594     (:variable
595 heller 1.74 (describe symbol))
596     (:function
597     (describe (symbol-function symbol)))
598 lgorrie 1.54 (:setf
599 heller 1.74 (describe (or (sb-int:info :setf :inverse symbol)
600     (sb-int:info :setf :expander symbol))))
601 lgorrie 1.54 (:class
602 heller 1.74 (describe (find-class symbol)))
603 lgorrie 1.54 (:type
604 heller 1.74 (describe (sb-kernel:values-specifier-type symbol)))))
605 dbarlow 1.1
606 heller 1.97 (defimplementation list-callers (symbol)
607     (let ((fn (fdefinition symbol)))
608     (mapcar #'function-dspec (sb-introspect:find-function-callers fn))))
609    
610     (defimplementation list-callees (symbol)
611     (let ((fn (fdefinition symbol)))
612     (mapcar #'function-dspec (sb-introspect:find-function-callees fn))))
613    
614 lgorrie 1.122 (defun function-dspec (fn)
615     "Describe where the function FN was defined.
616     Return a list of the form (NAME LOCATION)."
617     (let ((name (sb-kernel:%fun-name fn)))
618     (list name (safe-function-source-location fn name))))
619    
620 dbarlow 1.4 ;;; macroexpansion
621 dbarlow 1.1
622 lgorrie 1.54 (defimplementation macroexpand-all (form)
623 heller 1.21 (let ((sb-walker:*walk-form-expand-macros-p* t))
624     (sb-walker:walk-form form)))
625 lgorrie 1.25
626 dbarlow 1.1
627     ;;; Debugging
628    
629     (defvar *sldb-stack-top*)
630    
631 lgorrie 1.54 (defimplementation call-with-debugging-environment (debugger-loop-fn)
632 heller 1.58 (declare (type function debugger-loop-fn))
633 lgorrie 1.25 (let* ((*sldb-stack-top* (or sb-debug:*stack-top-hint* (sb-di:top-frame)))
634 heller 1.71 (sb-debug:*stack-top-hint* nil))
635 dbarlow 1.1 (handler-bind ((sb-di:debug-condition
636     (lambda (condition)
637 lgorrie 1.25 (signal (make-condition
638     'sldb-condition
639     :original-condition condition)))))
640     (funcall debugger-loop-fn))))
641 dbarlow 1.1
642 heller 1.118 (defimplementation call-with-debugger-hook (hook fun)
643     (let ((sb-ext:*invoke-debugger-hook* hook))
644     (funcall fun)))
645    
646 dbarlow 1.1 (defun nth-frame (index)
647     (do ((frame *sldb-stack-top* (sb-di:frame-down frame))
648     (i index (1- i)))
649     ((zerop i) frame)))
650    
651 heller 1.74 (defimplementation compute-backtrace (start end)
652 dbarlow 1.1 "Return a list of frames starting with frame number START and
653     continuing to frame number END or, if END is nil, the last frame on the
654     stack."
655     (let ((end (or end most-positive-fixnum)))
656 heller 1.45 (loop for f = (nth-frame start) then (sb-di:frame-down f)
657     for i from start below end
658     while f
659 heller 1.74 collect f)))
660 dbarlow 1.1
661 heller 1.74 (defimplementation print-frame (frame stream)
662 nsiivola 1.134 (sb-debug::print-frame-call frame stream))
663 dbarlow 1.1
664 heller 1.124 ;;;; Code-location -> source-location translation
665    
666 heller 1.129 ;;; If debug-block info is avaibale, we determine the file position of
667     ;;; the source-path for a code-location. If the code was compiled
668     ;;; with C-c C-c, we have to search the position in the source string.
669     ;;; If there's no debug-block info, we return the (less precise)
670     ;;; source-location of the corresponding function.
671    
672 nsiivola 1.134 (defun code-location-source-location (code-location)
673     (let* ((dsource (sb-di:code-location-debug-source code-location))
674     (plist (sb-c::debug-source-plist dsource)))
675     (if (getf plist :emacs-buffer)
676     (emacs-buffer-source-location code-location plist)
677     (ecase (sb-di:debug-source-from dsource)
678     (:file (file-source-location code-location))
679     (:lisp (lisp-source-location code-location))))))
680    
681     ;;; FIXME: The naming policy of source-location functions is a bit
682     ;;; fuzzy: we have FUNCTION-SOURCE-LOCATION which returns the
683     ;;; source-location for a function, and we also have FILE-SOURCE-LOCATION &co
684     ;;; which returns the source location for a _code-location_.
685     ;;;
686     ;;; Maybe these should be named code-location-file-source-location,
687 heller 1.139 ;;; etc, turned into generic functions, or something. In the very
688     ;;; least the names should indicate the main entry point vs. helper
689     ;;; status.
690 heller 1.124
691 nsiivola 1.134 (defun file-source-location (code-location)
692     (if (code-location-has-debug-block-info-p code-location)
693     (source-file-source-location code-location)
694     (fallback-source-location code-location)))
695    
696     (defun fallback-source-location (code-location)
697     (let ((fun (code-location-debug-fun-fun code-location)))
698     (cond (fun (function-source-location fun))
699     (t (error "Cannot find source location for: ~A " code-location)))))
700    
701 heller 1.124 (defun lisp-source-location (code-location)
702 nsiivola 1.134 (let ((source (prin1-to-string
703     (sb-debug::code-location-source-form code-location 100))))
704 heller 1.124 (make-location `(:source-form ,source) '(:position 0))))
705    
706 nsiivola 1.134 (defun emacs-buffer-source-location (code-location plist)
707     (if (code-location-has-debug-block-info-p code-location)
708     (destructuring-bind (&key emacs-buffer emacs-position emacs-string) plist
709     (let* ((pos (string-source-position code-location emacs-string))
710     (snipped (with-input-from-string (s emacs-string)
711     (read-snippet s pos))))
712     (make-location `(:buffer ,emacs-buffer)
713     `(:position ,(+ emacs-position pos))
714     `(:snippet ,snipped))))
715     (fallback-source-location code-location)))
716    
717 heller 1.124 (defun source-file-source-location (code-location)
718     (let* ((code-date (code-location-debug-source-created code-location))
719     (filename (code-location-debug-source-name code-location))
720 heller 1.126 (source-code (get-source-code filename code-date)))
721 heller 1.124 (with-input-from-string (s source-code)
722 heller 1.128 (let* ((pos (stream-source-position code-location s))
723     (snippet (read-snippet s pos)))
724 heller 1.124 (make-location `(:file ,filename)
725 heller 1.128 `(:position ,(1+ pos))
726     `(:snippet ,snippet))))))
727 heller 1.124
728     (defun code-location-debug-source-name (code-location)
729     (sb-c::debug-source-name (sb-di::code-location-debug-source code-location)))
730    
731     (defun code-location-debug-source-created (code-location)
732     (sb-c::debug-source-created
733     (sb-di::code-location-debug-source code-location)))
734    
735     (defun code-location-debug-fun-fun (code-location)
736     (sb-di:debug-fun-fun (sb-di:code-location-debug-fun code-location)))
737    
738     (defun code-location-has-debug-block-info-p (code-location)
739     (handler-case
740     (progn (sb-di:code-location-debug-block code-location)
741     t)
742     (sb-di:no-debug-blocks () nil)))
743    
744     (defun stream-source-position (code-location stream)
745     (let* ((cloc (sb-debug::maybe-block-start-location code-location))
746 heller 1.128 (tlf-number (sb-di::code-location-toplevel-form-offset cloc))
747 heller 1.124 (form-number (sb-di::code-location-form-number cloc)))
748     (multiple-value-bind (tlf pos-map) (read-source-form tlf-number stream)
749     (let* ((path-table (sb-di::form-number-translations tlf 0))
750 heller 1.128 (path (cond ((<= (length path-table) form-number)
751 heller 1.129 (warn "inconsistent form-number-translations")
752 heller 1.128 (list 0))
753     (t
754     (reverse (cdr (aref path-table form-number)))))))
755     (source-path-source-position path tlf pos-map)))))
756    
757     (defun string-source-position (code-location string)
758     (with-input-from-string (s string)
759     (stream-source-position code-location s)))
760 dbarlow 1.1
761 dbarlow 1.44 ;;; source-path-file-position and friends are in swank-source-path-parser
762 lgorrie 1.121
763 dbarlow 1.1 (defun safe-source-location-for-emacs (code-location)
764 heller 1.126 (if *debug-definition-finding*
765     (code-location-source-location code-location)
766     (handler-case (code-location-source-location code-location)
767     (error (c) (list :error (format nil "~A" c))))))
768 heller 1.36
769 lgorrie 1.54 (defimplementation frame-source-location-for-emacs (index)
770 heller 1.22 (safe-source-location-for-emacs
771     (sb-di:frame-code-location (nth-frame index))))
772 dbarlow 1.1
773 heller 1.92 (defun frame-debug-vars (frame)
774     "Return a vector of debug-variables in frame."
775     (sb-di::debug-fun-debug-vars (sb-di:frame-debug-fun frame)))
776    
777     (defun debug-var-value (var frame location)
778     (ecase (sb-di:debug-var-validity var location)
779     (:valid (sb-di:debug-var-value var frame))
780     ((:invalid :unknown) ':<not-available>)))
781    
782 lgorrie 1.54 (defimplementation frame-locals (index)
783 dbarlow 1.1 (let* ((frame (nth-frame index))
784 heller 1.92 (loc (sb-di:frame-code-location frame))
785     (vars (frame-debug-vars frame)))
786     (loop for v across vars collect
787     (list :name (sb-di:debug-var-symbol v)
788     :id (sb-di:debug-var-id v)
789     :value (debug-var-value v frame loc)))))
790    
791     (defimplementation frame-var-value (frame var)
792     (let* ((frame (nth-frame frame))
793     (dvar (aref (frame-debug-vars frame) var)))
794     (debug-var-value dvar frame (sb-di:frame-code-location frame))))
795 dbarlow 1.1
796 lgorrie 1.54 (defimplementation frame-catch-tags (index)
797 heller 1.74 (mapcar #'car (sb-di:frame-catches (nth-frame index))))
798 lgorrie 1.50
799 heller 1.56 (defimplementation eval-in-frame (form index)
800     (let ((frame (nth-frame index)))
801 heller 1.58 (funcall (the function
802     (sb-di:preprocess-for-eval form
803     (sb-di:frame-code-location frame)))
804 heller 1.56 frame)))
805    
806     (defun sb-debug-catch-tag-p (tag)
807     (and (symbolp tag)
808     (not (symbol-package tag))
809     (string= tag :sb-debug-catch-tag)))
810    
811     (defimplementation return-from-frame (index form)
812     (let* ((frame (nth-frame index))
813     (probe (assoc-if #'sb-debug-catch-tag-p
814     (sb-di::frame-catches frame))))
815     (cond (probe (throw (car probe) (eval-in-frame form index)))
816     (t (format nil "Cannot return from frame: ~S" frame)))))
817    
818 lgorrie 1.87 ;;;;; reference-conditions
819    
820     (defimplementation format-sldb-condition (condition)
821     (let ((sb-int:*print-condition-references* nil))
822     (princ-to-string condition)))
823    
824     (defimplementation condition-references (condition)
825     (if (typep condition 'sb-int:reference-condition)
826     (sb-int:reference-condition-references condition)
827     '()))
828    
829 heller 1.57
830     ;;;; Profiling
831    
832     (defimplementation profile (fname)
833     (when fname (eval `(sb-profile:profile ,fname))))
834    
835     (defimplementation unprofile (fname)
836     (when fname (eval `(sb-profile:unprofile ,fname))))
837    
838     (defimplementation unprofile-all ()
839     (sb-profile:unprofile)
840     "All functions unprofiled.")
841    
842     (defimplementation profile-report ()
843     (sb-profile:report))
844    
845     (defimplementation profile-reset ()
846     (sb-profile:reset)
847     "Reset profiling counters.")
848    
849     (defimplementation profiled-functions ()
850     (sb-profile:profile))
851    
852 heller 1.116 (defimplementation profile-package (package callers methods)
853     (declare (ignore callers methods))
854     (eval `(sb-profile:profile ,(package-name (find-package package)))))
855    
856 heller 1.57
857 heller 1.64 ;;;; Inspector
858 heller 1.63
859 mbaringer 1.102 (defclass sbcl-inspector (inspector)
860     ())
861    
862     (defimplementation make-default-inspector ()
863     (make-instance 'sbcl-inspector))
864    
865     (defmethod inspect-for-emacs ((o t) (inspector sbcl-inspector))
866     (declare (ignore inspector))
867 heller 1.64 (cond ((sb-di::indirect-value-cell-p o)
868 heller 1.126 (values "A value cell." (label-value-line*
869     (:value (sb-kernel:value-cell-ref o)))))
870 heller 1.64 (t
871 heller 1.126 (multiple-value-bind (text label parts) (sb-impl::inspected-parts o)
872     (if label
873     (values text (loop for (l . v) in parts
874     append (label-value-line l v)))
875     (values text (loop for value in parts for i from 0
876     append (label-value-line i value))))))))
877 heller 1.64
878 mbaringer 1.102 (defmethod inspect-for-emacs ((o function) (inspector sbcl-inspector))
879     (declare (ignore inspector))
880 heller 1.64 (let ((header (sb-kernel:widetag-of o)))
881     (cond ((= header sb-vm:simple-fun-header-widetag)
882 heller 1.126 (values "A simple-fun."
883     (label-value-line*
884     (:name (sb-kernel:%simple-fun-name o))
885     (:arglist (sb-kernel:%simple-fun-arglist o))
886     (:self (sb-kernel:%simple-fun-self o))
887     (:next (sb-kernel:%simple-fun-next o))
888     (:type (sb-kernel:%simple-fun-type o))
889     (:code (sb-kernel:fun-code-header o)))))
890 heller 1.64 ((= header sb-vm:closure-header-widetag)
891 mbaringer 1.102 (values "A closure."
892 heller 1.126 (append
893     (label-value-line :function (sb-kernel:%closure-fun o))
894     `("Closed over values:" (:newline))
895     (loop for i below (1- (sb-kernel:get-closure-length o))
896     append (label-value-line
897     i (sb-kernel:%closure-index-ref o i))))))
898 heller 1.64 (t (call-next-method o)))))
899    
900 heller 1.113 (defmethod inspect-for-emacs ((o sb-kernel:code-component) (_ sbcl-inspector))
901     (declare (ignore _))
902     (values (format nil "~A is a code data-block." o)
903     (append
904     (label-value-line*
905     (:code-size (sb-kernel:%code-code-size o))
906     (:entry-points (sb-kernel:%code-entry-points o))
907     (:debug-info (sb-kernel:%code-debug-info o))
908     (:trace-table-offset (sb-kernel:code-header-ref
909     o sb-vm:code-trace-table-offset-slot)))
910     `("Constants:" (:newline))
911     (loop for i from sb-vm:code-constants-offset
912 mbaringer 1.102 below (sb-kernel:get-header-data o)
913 heller 1.113 append (label-value-line i (sb-kernel:code-header-ref o i)))
914     `("Code:" (:newline)
915     , (with-output-to-string (s)
916     (cond ((sb-kernel:%code-debug-info o)
917     (sb-disassem:disassemble-code-component o :stream s))
918     (t
919     (sb-disassem:disassemble-memory
920     (sb-disassem::align
921     (+ (logandc2 (sb-kernel:get-lisp-obj-address o)
922     sb-vm:lowtag-mask)
923 heller 1.126 (* sb-vm:code-constants-offset
924     sb-vm:n-word-bytes))
925 heller 1.113 (ash 1 sb-vm:n-lowtag-bits))
926     (ash (sb-kernel:%code-code-size o) sb-vm:word-shift)
927     :stream s))))))))
928 mbaringer 1.102
929     (defmethod inspect-for-emacs ((o sb-kernel:fdefn) (inspector sbcl-inspector))
930 mbaringer 1.104 (declare (ignore inspector))
931 mbaringer 1.102 (values "A fdefn object."
932 heller 1.126 (label-value-line*
933     (:name (sb-kernel:fdefn-name o))
934     (:function (sb-kernel:fdefn-fun o)))))
935 mbaringer 1.102
936 heller 1.126 (defmethod inspect-for-emacs :around ((o generic-function)
937     (inspector sbcl-inspector))
938 mbaringer 1.102 (declare (ignore inspector))
939 heller 1.126 (multiple-value-bind (title contents) (call-next-method)
940 mbaringer 1.102 (values title
941 heller 1.126 (append
942     contents
943     (label-value-line*
944     (:pretty-arglist (sb-pcl::generic-function-pretty-arglist o))
945     (:initial-methods (sb-pcl::generic-function-initial-methods o))
946     )))))
947 heller 1.90
948 heller 1.63
949 lgorrie 1.50 ;;;; Multiprocessing
950    
951 crhodes 1.136 #+(and sb-thread
952     #.(cl:if (cl:find-symbol "THREAD-NAME" "SB-THREAD") '(and) '(or)))
953     (progn
954     (defvar *thread-id-counter* 0)
955    
956     (defvar *thread-id-counter-lock*
957     (sb-thread:make-mutex :name "thread id counter lock"))
958    
959     (defun next-thread-id ()
960     (sb-thread:with-mutex (*thread-id-counter-lock*)
961     (incf *thread-id-counter*)))
962    
963     (defparameter *thread-id-map* (make-hash-table))
964    
965     ;; This should be a thread -> id map but as weak keys are not
966     ;; supported it is id -> map instead.
967     (defvar *thread-id-map-lock*
968     (sb-thread:make-mutex :name "thread id map lock"))
969    
970     (defimplementation spawn (fn &key name)
971     (sb-thread:make-thread fn :name name))
972    
973     (defimplementation startup-multiprocessing ())
974    
975     (defimplementation thread-id (thread)
976     (sb-thread:with-mutex (*thread-id-map-lock*)
977     (loop for id being the hash-key in *thread-id-map*
978     using (hash-value thread-pointer)
979     do
980     (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
981     (cond ((null maybe-thread)
982     ;; the value is gc'd, remove it manually
983     (remhash id *thread-id-map*))
984     ((eq thread maybe-thread)
985     (return-from thread-id id)))))
986     ;; lazy numbering
987     (let ((id (next-thread-id)))
988     (setf (gethash id *thread-id-map*) (sb-ext:make-weak-pointer thread))
989     id)))
990    
991     (defimplementation find-thread (id)
992     (sb-thread:with-mutex (*thread-id-map-lock*)
993     (let ((thread-pointer (gethash id *thread-id-map*)))
994     (if thread-pointer
995     (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
996     (if maybe-thread
997     maybe-thread
998     ;; the value is gc'd, remove it manually
999     (progn
1000     (remhash id *thread-id-map*)
1001     nil)))
1002     nil))))
1003    
1004     (defimplementation thread-name (thread)
1005     ;; sometimes the name is not a string (e.g. NIL)
1006     (princ-to-string (sb-thread:thread-name thread)))
1007    
1008     (defimplementation thread-status (thread)
1009     (if (sb-thread:thread-alive-p thread)
1010     "RUNNING"
1011     "STOPPED"))
1012    
1013     (defimplementation make-lock (&key name)
1014     (sb-thread:make-mutex :name name))
1015    
1016     (defimplementation call-with-lock-held (lock function)
1017     (declare (type function function))
1018     (sb-thread:with-mutex (lock) (funcall function)))
1019    
1020     (defimplementation current-thread ()
1021     sb-thread:*current-thread*)
1022    
1023     (defimplementation all-threads ()
1024     (sb-thread:list-all-threads))
1025    
1026     (defimplementation interrupt-thread (thread fn)
1027     (sb-thread:interrupt-thread thread fn))
1028    
1029     (defimplementation kill-thread (thread)
1030     (sb-thread:terminate-thread thread))
1031    
1032     (defimplementation thread-alive-p (thread)
1033     (sb-thread:thread-alive-p thread))
1034    
1035     (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))
1036     (defvar *mailboxes* (list))
1037     (declaim (type list *mailboxes*))
1038    
1039     (defstruct (mailbox (:conc-name mailbox.))
1040     thread
1041     (mutex (sb-thread:make-mutex))
1042     (waitqueue (sb-thread:make-waitqueue))
1043     (queue '() :type list))
1044    
1045     (defun mailbox (thread)
1046     "Return THREAD's mailbox."
1047     (sb-thread:with-mutex (*mailbox-lock*)
1048     (or (find thread *mailboxes* :key #'mailbox.thread)
1049     (let ((mb (make-mailbox :thread thread)))
1050     (push mb *mailboxes*)
1051     mb))))
1052    
1053     (defimplementation send (thread message)
1054     (let* ((mbox (mailbox thread))
1055     (mutex (mailbox.mutex mbox)))
1056     (sb-thread:with-mutex (mutex)
1057     (setf (mailbox.queue mbox)
1058     (nconc (mailbox.queue mbox) (list message)))
1059     (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
1060    
1061     (defimplementation receive ()
1062     (let* ((mbox (mailbox (current-thread)))
1063     (mutex (mailbox.mutex mbox)))
1064     (sb-thread:with-mutex (mutex)
1065     (loop
1066     (let ((q (mailbox.queue mbox)))
1067     (cond (q (return (pop (mailbox.queue mbox))))
1068     (t (sb-thread:condition-wait (mailbox.waitqueue mbox)
1069     mutex))))))))
1070    
1071     )
1072    
1073     #+(and sb-thread
1074     #.(cl:if (cl:find-symbol "THREAD-NAME" "SB-THREAD") '(or) '(and)))
1075 lgorrie 1.50 (progn
1076 lgorrie 1.54 (defimplementation spawn (fn &key name)
1077 lgorrie 1.50 (declare (ignore name))
1078     (sb-thread:make-thread fn))
1079    
1080 heller 1.85 (defimplementation startup-multiprocessing ())
1081 lgorrie 1.50
1082 heller 1.93 (defimplementation thread-id (thread)
1083 crhodes 1.135 (assert (eql (ash (ash thread -5) 5) thread))
1084     (ash thread -5))
1085 heller 1.93
1086     (defimplementation find-thread (id)
1087 crhodes 1.135 (when (member (ash id 5) (all-threads))
1088     (ash id 5)))
1089 heller 1.93
1090 heller 1.63 (defimplementation thread-name (thread)
1091 crhodes 1.135 (format nil "Thread ~D" (thread-id thread)))
1092 lgorrie 1.50
1093 heller 1.114 (defun %thread-state-slot (thread)
1094     (sb-sys:without-gcing
1095     (sb-kernel:make-lisp-obj
1096     (sb-sys:sap-int
1097     (sb-sys:sap-ref-sap (sb-thread::thread-sap-from-id thread)
1098     (* sb-vm::thread-state-slot
1099     sb-vm::n-word-bytes))))))
1100    
1101     (defun %thread-state (thread)
1102     (ecase (%thread-state-slot thread)
1103     (0 :running)
1104     (1 :stopping)
1105     (2 :stopped)
1106     (3 :dead)))
1107    
1108 heller 1.63 (defimplementation thread-status (thread)
1109 heller 1.114 (string (%thread-state thread)))
1110 lgorrie 1.50
1111 lgorrie 1.54 (defimplementation make-lock (&key name)
1112 lgorrie 1.50 (sb-thread:make-mutex :name name))
1113    
1114 lgorrie 1.54 (defimplementation call-with-lock-held (lock function)
1115 heller 1.58 (declare (type function function))
1116 lgorrie 1.50 (sb-thread:with-mutex (lock) (funcall function)))
1117 heller 1.59
1118     (defimplementation current-thread ()
1119     (sb-thread:current-thread-id))
1120    
1121 heller 1.63 (defimplementation all-threads ()
1122 crhodes 1.135 (let ((tids (sb-sys:without-gcing
1123 heller 1.114 (sb-thread::mapcar-threads
1124     (lambda (sap)
1125 crhodes 1.135 (sb-sys:sap-ref-32 sap
1126     (* sb-vm:n-word-bytes
1127     sb-vm::thread-os-thread-slot)))))))
1128     (remove :dead tids :key #'%thread-state)))
1129 heller 1.59
1130     (defimplementation interrupt-thread (thread fn)
1131     (sb-thread:interrupt-thread thread fn))
1132    
1133 heller 1.70 (defimplementation kill-thread (thread)
1134     (sb-thread:terminate-thread thread))
1135 heller 1.59
1136 heller 1.126 (defimplementation thread-alive-p (thread)
1137     (ignore-errors (sb-thread:interrupt-thread thread (lambda ())) t))
1138    
1139 heller 1.59 (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))
1140     (defvar *mailboxes* (list))
1141 heller 1.60 (declaim (type list *mailboxes*))
1142 heller 1.59
1143     (defstruct (mailbox (:conc-name mailbox.))
1144     thread
1145     (mutex (sb-thread:make-mutex))
1146     (waitqueue (sb-thread:make-waitqueue))
1147     (queue '() :type list))
1148    
1149     (defun mailbox (thread)
1150     "Return THREAD's mailbox."
1151     (sb-thread:with-mutex (*mailbox-lock*)
1152     (or (find thread *mailboxes* :key #'mailbox.thread)
1153     (let ((mb (make-mailbox :thread thread)))
1154     (push mb *mailboxes*)
1155     mb))))
1156    
1157     (defimplementation send (thread message)
1158     (let* ((mbox (mailbox thread))
1159     (mutex (mailbox.mutex mbox)))
1160     (sb-thread:with-mutex (mutex)
1161     (setf (mailbox.queue mbox)
1162     (nconc (mailbox.queue mbox) (list message)))
1163     (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
1164    
1165     (defimplementation receive ()
1166     (let* ((mbox (mailbox (sb-thread:current-thread-id)))
1167     (mutex (mailbox.mutex mbox)))
1168     (sb-thread:with-mutex (mutex)
1169     (loop
1170     (let ((q (mailbox.queue mbox)))
1171     (cond (q (return (pop (mailbox.queue mbox))))
1172     (t (sb-thread:condition-wait (mailbox.waitqueue mbox)
1173     mutex))))))))
1174    
1175     )
1176 heller 1.126
1177     (defimplementation quit-lisp ()
1178     #+sb-thread
1179     (dolist (thread (remove (current-thread) (all-threads)))
1180 heller 1.133 (ignore-errors (sb-thread:interrupt-thread
1181     thread (lambda () (sb-ext:quit :recklessly-p t)))))
1182 heller 1.126 (sb-ext:quit))
1183 heller 1.133
1184 mbaringer 1.117
1185 heller 1.118
1186 mbaringer 1.117 ;;Trace implementations
1187     ;;In SBCL, we have:
1188     ;; (trace <name>)
1189 heller 1.118 ;; (trace :methods '<name>) ;to trace all methods of the gf <name>
1190 mbaringer 1.117 ;; (trace (method <name> <qualifier>? (<specializer>+)))
1191     ;; <name> can be a normal name or a (setf name)
1192    
1193 heller 1.119 (defun toggle-trace-aux (fspec &rest args)
1194 mbaringer 1.117 (cond ((member fspec (eval '(trace)) :test #'equal)
1195     (eval `(untrace ,fspec))
1196     (format nil "~S is now untraced." fspec))
1197     (t
1198     (eval `(trace ,@(if args `(:encapsulate nil) (list)) ,fspec ,@args))
1199     (format nil "~S is now traced." fspec))))
1200    
1201     (defun process-fspec (fspec)
1202     (cond ((consp fspec)
1203     (ecase (first fspec)
1204     ((:defun :defgeneric) (second fspec))
1205     ((:defmethod) `(method ,@(rest fspec)))
1206     ((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec)))
1207     ((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec)))))
1208     (t
1209     fspec)))
1210    
1211 heller 1.119 (defimplementation toggle-trace (spec)
1212     (ecase (car spec)
1213     ((setf)
1214     (toggle-trace-aux spec))
1215     ((:defmethod)
1216     (toggle-trace-aux `(sb-pcl::fast-method ,@(rest (process-fspec spec)))))
1217     ((:defgeneric)
1218     (toggle-trace-aux (second spec) :methods t))
1219     ((:call)
1220     (destructuring-bind (caller callee) (cdr spec)
1221     (toggle-trace-aux callee :wherein (list (process-fspec caller)))))))
1222 mkoeppe 1.142
1223     ;;; Weak datastructures
1224    
1225 jsnellman 1.143
1226     ;; SBCL doesn't actually implement weak hash-tables, the WEAK-P
1227     ;; keyword is just a decoy. Leave this here, but commented out,
1228     ;; so that no-one tries adding it back.
1229     #+(or)
1230 mkoeppe 1.142 (defimplementation make-weak-key-hash-table (&rest args)
1231     (apply #'make-hash-table :weak-p t args))
1232    

  ViewVC Help
Powered by ViewVC 1.1.5