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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.79 - (hide annotations)
Mon Mar 22 13:57:00 2004 UTC (10 years, 1 month ago) by lgorrie
Branch: MAIN
Changes since 1.78: +1 -1 lines
(*communication-style*): New name for *swank-in-background*.
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 dbarlow 1.30 ;;; This is a Slime backend for SBCL. Requires SBCL 0.8.5 or later
11     ;;; for the SB-INTROSPECT contrib
12 dbarlow 1.1
13     ;;; Cursory testing has found that the following appear to work
14     ;;;
15     ;;; * Symbol completion.
16     ;;; * Evaluation of forms with C-M-x
17     ;;; * Apropos
18     ;;; * Compilation of defuns with C-c C-c
19     ;;; * File compilation with C-c C-k, apparently including error parsing
20     ;;; * Disassembling the symbol at point with C-c M-d
21     ;;; * Describing symbol at point with C-c C-d
22     ;;; * Macroexpanding with C-c RET
23     ;;; * find-definition, using sb-introspect
24     ;;; * Basic debugger stuff: restarts, backtrace, toggle details
25     ;;; * Can now interrupt a busy sbcl with C-c C-g
26     ;;; * Most of the tests
27     ;;;
28     ;;; Things that aren't done/don't work yet:
29     ;;;
30     ;;; * Cross-referencing (nor is it likely, absent XREF port to SBCL)
31     ;;; * testsuite can't find LOOP, reports bogus failure on some arglist lookups
32     ;;; * eval-in-frame
33     ;;; * A slime command to load an asdf system. Note that this might involve
34     ;;; compiling/loading files that Emacs has no buffers for
35     ;;; * Dealing with multiple threads
36    
37     ;;; Administrivia
38    
39     (eval-when (:compile-toplevel :load-toplevel :execute)
40     (require 'sb-bsd-sockets)
41 heller 1.59 (require 'sb-introspect)
42 heller 1.60 (require 'sb-posix)
43 heller 1.59 )
44 dbarlow 1.1
45     (declaim (optimize (debug 3)))
46 heller 1.74 (in-package :swank-backend)
47 dbarlow 1.1
48 heller 1.23 (import
49     '(sb-gray:fundamental-character-output-stream
50     sb-gray:stream-write-char
51     sb-gray:stream-line-length
52     sb-gray:stream-force-output
53     sb-gray:fundamental-character-input-stream
54     sb-gray:stream-read-char
55     sb-gray:stream-listen
56     sb-gray:stream-unread-char
57     sb-gray:stream-clear-input
58     sb-gray:stream-line-column
59     sb-gray:stream-line-length))
60    
61 dbarlow 1.1 ;;; TCP Server
62    
63 heller 1.74 (defimplementation preferred-communication-style ()
64     :sigio)
65 heller 1.49
66 heller 1.65 (defun resolve-hostname (name)
67     (car (sb-bsd-sockets:host-ent-addresses
68     (sb-bsd-sockets:get-host-by-name name))))
69    
70     (defimplementation create-socket (host port)
71 dbarlow 1.6 (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
72     :type :stream
73     :protocol :tcp)))
74 heller 1.48 (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
75 heller 1.65 (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port)
76 dbarlow 1.6 (sb-bsd-sockets:socket-listen socket 5)
77 heller 1.29 socket))
78    
79 lgorrie 1.54 (defimplementation local-port (socket)
80 lgorrie 1.46 (nth-value 1 (sb-bsd-sockets:socket-name socket)))
81    
82 lgorrie 1.54 (defimplementation close-socket (socket)
83 heller 1.48 (sb-bsd-sockets:socket-close socket))
84    
85 lgorrie 1.54 (defimplementation accept-connection (socket)
86 heller 1.48 (make-socket-io-stream (accept socket)))
87    
88 heller 1.59 (defvar *sigio-handlers* '()
89     "List of (key . fn) pairs to be called on SIGIO.")
90    
91     (defun sigio-handler (signal code scp)
92 heller 1.60 (declare (ignore signal code scp))
93     (mapc (lambda (handler)
94     (funcall (the function (cdr handler))))
95     *sigio-handlers*))
96 heller 1.59
97     (defun set-sigio-handler ()
98     (sb-sys:enable-interrupt sb-unix:SIGIO (lambda (signal code scp)
99     (sigio-handler signal code scp))))
100    
101 heller 1.62
102    
103     ;;;; XXX remove fcntl kludge when SBCL with sb-posix:fcntl is more
104     ;;;; widely available.
105 heller 1.78 (defconstant +o_async+ #+linux 8192 #+bsd #x40)
106     (defconstant +f_setown+ #+linux 8 #+bsd 6)
107     (defconstant +f_setfl+ #+(or linux bsd) 4)
108 heller 1.62
109     (unless (find-symbol (string :fcntl) :sb-posix)
110     (warn "No binding for fctnl(2) in sb-posix.
111     Please upgrade to SBCL 0.8.7.36 or later."))
112    
113     (defun enable-sigio-on-fd (fd)
114     (cond ((fboundp (find-symbol (string :fcntl) :sb-posix))
115     (funcall
116     (eval
117     (read-from-string
118     "(lambda (fd)
119     (sb-posix:fcntl fd sb-posix::f-setfl sb-posix::o-async)
120     (sb-posix:fcntl fd sb-posix::f-setown (sb-unix:unix-getpid)))"))
121     fd))
122     (t
123 heller 1.78 (unless (or (sb-int:featurep :linux)
124     (sb-int:featurep :bsd))
125     (warn "You aren't running Linux or *BSD.~
126     ~%The values of +o_async+ etc are probably bogus."))
127 heller 1.62 (let ((fcntl (sb-alien:extern-alien
128     "fcntl"
129     (function sb-alien:int sb-alien:int
130     sb-alien:int sb-alien:int))))
131     ;; XXX error checking
132     (sb-alien:alien-funcall fcntl fd +f_setfl+ +o_async+)
133     (sb-alien:alien-funcall fcntl fd +f_setown+
134     (sb-unix:unix-getpid))))))
135    
136 heller 1.67 (defimplementation add-sigio-handler (socket fn)
137 heller 1.62 (set-sigio-handler)
138     (let ((fd (socket-fd socket)))
139     (format *debug-io* "Adding sigio handler: ~S ~%" fd)
140     (enable-sigio-on-fd fd)
141     (push (cons fd fn) *sigio-handlers*)))
142    
143     #+(or)
144 heller 1.67 (defimplementation add-sigio-handler (socket fn)
145 heller 1.61 (set-sigio-handler)
146 heller 1.59 (let ((fd (socket-fd socket)))
147     (format *debug-io* "Adding sigio handler: ~S ~%" fd)
148 heller 1.61 (sb-posix:fcntl fd sb-posix::f-setfl sb-posix::o-async)
149     (sb-posix:fcntl fd sb-posix::f-setown (sb-unix:unix-getpid))
150     (push (cons fd fn) *sigio-handlers*)))
151 heller 1.60
152 heller 1.67 (defimplementation remove-sigio-handlers (socket)
153 heller 1.59 (let ((fd (socket-fd socket)))
154     (setf *sigio-handlers* (delete fd *sigio-handlers* :key #'car))
155     (sb-sys:invalidate-descriptor fd))
156 heller 1.51 (close socket))
157 heller 1.67
158     (defimplementation add-fd-handler (socket fn)
159     (declare (type function fn))
160     (let ((fd (socket-fd socket)))
161     (format *debug-io* "; Adding fd handler: ~S ~%" fd)
162     (sb-sys:add-fd-handler fd :input (lambda (_)
163     _
164     (funcall fn)))))
165    
166     (defimplementation remove-fd-handlers (socket)
167     (sb-sys:invalidate-descriptor (socket-fd socket)))
168 heller 1.51
169 heller 1.48 (defun socket-fd (socket)
170     (etypecase socket
171     (fixnum socket)
172     (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket))
173     (file-stream (sb-sys:fd-stream-fd socket))))
174    
175 lgorrie 1.46 (defun make-socket-io-stream (socket)
176     (sb-bsd-sockets:socket-make-stream socket
177     :output t
178     :input t
179     :element-type 'base-char))
180    
181 heller 1.29 (defun accept (socket)
182     "Like socket-accept, but retry on EAGAIN."
183     (loop (handler-case
184     (return (sb-bsd-sockets:socket-accept socket))
185     (sb-bsd-sockets:interrupted-error ()))))
186 dbarlow 1.6
187 heller 1.52 (defmethod call-without-interrupts (fn)
188 heller 1.58 (declare (type function fn))
189 heller 1.52 (sb-sys:without-interrupts (funcall fn)))
190    
191     (defmethod getpid ()
192     (sb-unix:unix-getpid))
193    
194 heller 1.68 (defimplementation lisp-implementation-type-name ()
195     "sbcl")
196    
197 dbarlow 1.1 ;;; Utilities
198    
199 dbarlow 1.4 (defvar *swank-debugger-stack-frame*)
200 dbarlow 1.1
201 heller 1.74 (defimplementation arglist (fname)
202     (sb-introspect:function-arglist fname))
203 dbarlow 1.1
204 dbarlow 1.42 (defvar *buffer-name* nil)
205 dbarlow 1.1 (defvar *buffer-offset*)
206 heller 1.70 (defvar *buffer-substring* nil)
207 dbarlow 1.1
208 lgorrie 1.24 (defvar *previous-compiler-condition* nil
209     "Used to detect duplicates.")
210    
211 dbarlow 1.1 (defun handle-notification-condition (condition)
212     "Handle a condition caused by a compiler warning.
213     This traps all compiler conditions at a lower-level than using
214     C:*COMPILER-NOTIFICATION-FUNCTION*. The advantage is that we get to
215     craft our own error messages, which can omit a lot of redundant
216     information."
217     (let ((context (sb-c::find-error-context nil)))
218 heller 1.36 (unless (eq condition *previous-compiler-condition*)
219 dbarlow 1.1 (setq *previous-compiler-condition* condition)
220 lgorrie 1.24 (signal-compiler-condition condition context))))
221    
222     (defun signal-compiler-condition (condition context)
223     (signal (make-condition
224     'compiler-condition
225     :original-condition condition
226     :severity (etypecase condition
227     (sb-c:compiler-error :error)
228     (sb-ext:compiler-note :note)
229     (style-warning :style-warning)
230     (warning :warning))
231 heller 1.66 :short-message (brief-compiler-message-for-emacs condition)
232     :message (long-compiler-message-for-emacs condition context)
233 lgorrie 1.24 :location (compiler-note-location context))))
234    
235 dbarlow 1.44
236    
237 lgorrie 1.24 (defun compiler-note-location (context)
238 dbarlow 1.42 (cond (context
239     (resolve-note-location
240     *buffer-name*
241     (sb-c::compiler-error-context-file-name context)
242     (sb-c::compiler-error-context-file-position context)
243     (current-compiler-error-source-path context)
244     (sb-c::compiler-error-context-original-source context)))
245     (t
246     (resolve-note-location *buffer-name* nil nil nil nil))))
247    
248     (defgeneric resolve-note-location (buffer file-name file-position
249     source-path source))
250    
251     (defmethod resolve-note-location ((b (eql nil)) (f pathname) pos path source)
252     (make-location
253 dbarlow 1.43 `(:file ,(namestring (truename f)))
254 dbarlow 1.42 `(:position ,(1+ (source-path-file-position path f)))))
255    
256     (defmethod resolve-note-location ((b string) (f (eql :stream)) pos path source)
257     (make-location
258     `(:buffer ,b)
259     `(:position ,(+ *buffer-offset*
260     (source-path-string-position path *buffer-substring*)))))
261    
262     (defmethod resolve-note-location (b (f (eql :lisp)) pos path (source string))
263     (make-location
264     `(:source-form ,source)
265     `(:position 1)))
266    
267     (defmethod resolve-note-location (buffer
268     (file (eql nil))
269     (pos (eql nil))
270     (path (eql nil))
271     (source (eql nil)))
272     (cond (buffer
273     (make-location (list :buffer buffer)
274     (list :position *buffer-offset*)))
275     (*compile-file-truename*
276     (make-location (list :file (namestring *compile-file-truename*))
277     (list :position 0)))
278     (t
279     (list :error "No error location available"))))
280    
281 heller 1.66 (defun brief-compiler-message-for-emacs (condition)
282 dbarlow 1.1 "Briefly describe a compiler error for Emacs.
283     When Emacs presents the message it already has the source popped up
284     and the source form highlighted. This makes much of the information in
285     the error-context redundant."
286 heller 1.66 (princ-to-string condition))
287    
288     (defun long-compiler-message-for-emacs (condition error-context)
289     "Describe a compiler error for Emacs including context information."
290 heller 1.45 (declare (type (or sb-c::compiler-error-context null) error-context))
291 heller 1.66 (multiple-value-bind (enclosing source)
292     (if error-context
293     (values (sb-c::compiler-error-context-enclosing-source error-context)
294     (sb-c::compiler-error-context-source error-context)))
295     (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~^~%~}~]~A"
296     enclosing source condition)))
297 dbarlow 1.1
298     (defun current-compiler-error-source-path (context)
299     "Return the source-path for the current compiler error.
300     Returns NIL if this cannot be determined by examining internal
301     compiler state."
302     (cond ((sb-c::node-p context)
303     (reverse
304     (sb-c::source-path-original-source
305     (sb-c::node-source-path context))))
306     ((sb-c::compiler-error-context-p context)
307     (reverse
308     (sb-c::compiler-error-context-original-source-path context)))))
309    
310 lgorrie 1.54 (defimplementation call-with-compilation-hooks (function)
311 heller 1.58 (declare (type function function))
312 dbarlow 1.41 (handler-bind ((sb-c:compiler-error #'handle-notification-condition)
313     (sb-ext:compiler-note #'handle-notification-condition)
314     (style-warning #'handle-notification-condition)
315     (warning #'handle-notification-condition))
316     (funcall function)))
317 lgorrie 1.24
318 heller 1.74 (defimplementation swank-compile-file (filename load-p)
319 lgorrie 1.24 (with-compilation-hooks ()
320 heller 1.74 (let ((fasl-file (compile-file filename)))
321     (when (and load-p fasl-file)
322     (load fasl-file)))))
323 dbarlow 1.41
324 heller 1.74 (defimplementation swank-compile-system (system-name)
325 dbarlow 1.41 (with-compilation-hooks ()
326     (asdf:operate 'asdf:load-op system-name)))
327 lgorrie 1.24
328 heller 1.74 (defimplementation swank-compile-string (string &key buffer position)
329 lgorrie 1.24 (with-compilation-hooks ()
330 heller 1.74 (let ((*buffer-name* buffer)
331 heller 1.70 (*buffer-offset* position)
332     (*buffer-substring* string))
333 heller 1.74 (funcall (compile nil (read-from-string
334 heller 1.77 (format nil "(~S () ~A)" 'lambda string)))))))
335 dbarlow 1.1
336     ;;;; Definitions
337    
338     (defvar *debug-definition-finding* nil
339     "When true don't handle errors while looking for definitions.
340     This is useful when debugging the definition-finding code.")
341    
342     ;;; FIXME we don't handle the compiled-interactively case yet. That
343     ;;; should have NIL :filename & :position, and non-NIL :source-form
344 heller 1.36 (defun function-source-location (function &optional name)
345 dbarlow 1.1 "Try to find the canonical source location of FUNCTION."
346     (let* ((def (sb-introspect:find-definition-source function))
347     (pathname (sb-introspect:definition-source-pathname def))
348 heller 1.32 (path (sb-introspect:definition-source-form-path def))
349     (position (sb-introspect:definition-source-character-offset def)))
350     (unless pathname
351     (return-from function-source-location
352 heller 1.36 (list :error (format nil "No filename for: ~S" function))))
353 heller 1.32 (multiple-value-bind (truename condition)
354     (ignore-errors (truename pathname))
355     (when condition
356     (return-from function-source-location
357     (list :error (format nil "~A" condition))))
358     (make-location
359     (list :file (namestring truename))
360     ;; source-paths depend on the file having been compiled with
361     ;; lotsa debugging. If not present, return the function name
362     ;; for emacs to attempt to find with a regex
363     (cond (path (list :source-path path position))
364 heller 1.36 (t (list :function-name
365     (or (and name (string name))
366 heller 1.74 (string (sb-kernel:%fun-name function))))))))))
367    
368     (defun safe-function-source-location (fun name)
369     (if *debug-definition-finding*
370     (function-source-location fun name)
371     (handler-case (function-source-location fun name)
372     (error (e)
373     (list (list :error (format nil "Error: ~A" e)))))))
374    
375     (defun method-definitions (gf)
376     (let ((methods (sb-mop:generic-function-methods gf))
377     (name (sb-mop:generic-function-name gf)))
378     (loop for method in methods
379 heller 1.75 collect (list `(method ,name ,(sb-pcl::unparse-specializers method))
380 heller 1.74 (safe-function-source-location method name)))))
381    
382     (defun function-definitions (symbol)
383     (flet ((loc (fun name) (safe-function-source-location fun name)))
384     (cond ((macro-function symbol)
385 heller 1.76 (list (list `(defmacro ,symbol)
386     (loc (macro-function symbol) symbol))))
387 heller 1.74 ((fboundp symbol)
388     (let ((fun (symbol-function symbol)))
389     (cond ((typep fun 'sb-mop:generic-function)
390 heller 1.76 (cons (list `(defgeneric ,symbol) (loc fun symbol))
391 heller 1.74 (method-definitions fun)))
392     (t
393 heller 1.76 (list (list `(function ,symbol) (loc fun symbol))))))))))
394 heller 1.74
395     (defimplementation find-definitions (symbol)
396     (function-definitions symbol))
397 lgorrie 1.24
398 lgorrie 1.54 (defimplementation describe-symbol-for-emacs (symbol)
399 dbarlow 1.1 "Return a plist describing SYMBOL.
400     Return NIL if the symbol is unbound."
401     (let ((result '()))
402 lgorrie 1.24 (labels ((doc (kind)
403     (or (documentation symbol kind) :not-documented))
404 dbarlow 1.1 (maybe-push (property value)
405     (when value
406     (setf result (list* property value result)))))
407     (maybe-push
408     :variable (multiple-value-bind (kind recorded-p)
409     (sb-int:info :variable :kind symbol)
410     (declare (ignore kind))
411     (if (or (boundp symbol) recorded-p)
412     (doc 'variable))))
413     (maybe-push
414     :function (if (fboundp symbol)
415     (doc 'function)))
416     (maybe-push
417     :setf (if (or (sb-int:info :setf :inverse symbol)
418     (sb-int:info :setf :expander symbol))
419     (doc 'setf)))
420     (maybe-push
421     :type (if (sb-int:info :type :kind symbol)
422     (doc 'type)))
423 lgorrie 1.24 result)))
424 dbarlow 1.1
425 heller 1.74 (defimplementation describe-definition (symbol type)
426 lgorrie 1.54 (case type
427     (:variable
428 heller 1.74 (describe symbol))
429     (:function
430     (describe (symbol-function symbol)))
431 lgorrie 1.54 (:setf
432 heller 1.74 (describe (or (sb-int:info :setf :inverse symbol)
433     (sb-int:info :setf :expander symbol))))
434 lgorrie 1.54 (:class
435 heller 1.74 (describe (find-class symbol)))
436 lgorrie 1.54 (:type
437 heller 1.74 (describe (sb-kernel:values-specifier-type symbol)))))
438 dbarlow 1.1
439 dbarlow 1.4 ;;; macroexpansion
440 dbarlow 1.1
441 lgorrie 1.54 (defimplementation macroexpand-all (form)
442 heller 1.21 (let ((sb-walker:*walk-form-expand-macros-p* t))
443     (sb-walker:walk-form form)))
444 lgorrie 1.25
445 dbarlow 1.1
446     ;;; Debugging
447    
448     (defvar *sldb-stack-top*)
449    
450 lgorrie 1.54 (defimplementation call-with-debugging-environment (debugger-loop-fn)
451 heller 1.58 (declare (type function debugger-loop-fn))
452 lgorrie 1.25 (let* ((*sldb-stack-top* (or sb-debug:*stack-top-hint* (sb-di:top-frame)))
453 heller 1.71 (sb-debug:*stack-top-hint* nil))
454 dbarlow 1.1 (handler-bind ((sb-di:debug-condition
455     (lambda (condition)
456 lgorrie 1.25 (signal (make-condition
457     'sldb-condition
458     :original-condition condition)))))
459     (funcall debugger-loop-fn))))
460 dbarlow 1.1
461     (defun nth-frame (index)
462     (do ((frame *sldb-stack-top* (sb-di:frame-down frame))
463     (i index (1- i)))
464     ((zerop i) frame)))
465    
466 heller 1.74 (defimplementation compute-backtrace (start end)
467 dbarlow 1.1 "Return a list of frames starting with frame number START and
468     continuing to frame number END or, if END is nil, the last frame on the
469     stack."
470     (let ((end (or end most-positive-fixnum)))
471 heller 1.45 (loop for f = (nth-frame start) then (sb-di:frame-down f)
472     for i from start below end
473     while f
474 heller 1.74 collect f)))
475 dbarlow 1.1
476 heller 1.74 (defimplementation print-frame (frame stream)
477     (let ((*standard-output* stream))
478     (sb-debug::print-frame-call frame :verbosity 1 :number nil)))
479 dbarlow 1.1
480     (defun code-location-source-path (code-location)
481     (let* ((location (sb-debug::maybe-block-start-location code-location))
482     (form-num (sb-di:code-location-form-number location)))
483     (let ((translations (sb-debug::get-toplevel-form location)))
484     (unless (< form-num (length translations))
485     (error "Source path no longer exists."))
486     (reverse (cdr (svref translations form-num))))))
487    
488     (defun code-location-file-position (code-location)
489     (let* ((debug-source (sb-di:code-location-debug-source code-location))
490     (filename (sb-di:debug-source-name debug-source))
491     (path (code-location-source-path code-location)))
492     (source-path-file-position path filename)))
493    
494 dbarlow 1.44 ;;; source-path-file-position and friends are in swank-source-path-parser
495 dbarlow 1.1
496     (defun debug-source-info-from-emacs-buffer-p (debug-source)
497     (let ((info (sb-c::debug-source-info debug-source)))
498     (and info
499     (consp info)
500     (eq :emacs-buffer (car info)))))
501    
502     (defun source-location-for-emacs (code-location)
503     (let* ((debug-source (sb-di:code-location-debug-source code-location))
504     (from (sb-di:debug-source-from debug-source))
505     (name (sb-di:debug-source-name debug-source)))
506 heller 1.32 (ecase from
507     (:file
508 heller 1.36 (let ((source-path (ignore-errors
509     (code-location-source-path code-location))))
510     (cond (source-path
511     ;; XXX: code-location-source-path reads the source !!
512     (let ((position (code-location-file-position code-location)))
513     (make-location
514     (list :file (namestring (truename name)))
515     (list :source-path source-path position))))
516     (t
517     (let* ((dfn (sb-di:code-location-debug-fun code-location))
518     (fn (sb-di:debug-fun-fun dfn)))
519     (unless fn
520     (error "Cannot find source location for: ~A "
521     code-location))
522     (function-source-location
523     fn (sb-di:debug-fun-name dfn)))))))
524    
525 heller 1.32 (:lisp
526     (make-location
527     (list :source-form (with-output-to-string (*standard-output*)
528     (sb-debug::print-code-location-source-form
529     code-location 100)))
530     (list :position 0))))))
531 dbarlow 1.1
532     (defun safe-source-location-for-emacs (code-location)
533     (handler-case (source-location-for-emacs code-location)
534 heller 1.36 (error (c) (list :error (format nil "~A" c)))))
535    
536 lgorrie 1.54 (defimplementation frame-source-location-for-emacs (index)
537 heller 1.22 (safe-source-location-for-emacs
538     (sb-di:frame-code-location (nth-frame index))))
539 dbarlow 1.1
540 lgorrie 1.54 (defimplementation frame-locals (index)
541 dbarlow 1.1 (let* ((frame (nth-frame index))
542     (location (sb-di:frame-code-location frame))
543     (debug-function (sb-di:frame-debug-fun frame))
544     (debug-variables (sb-di::debug-fun-debug-vars debug-function)))
545 heller 1.58 (declare (type (or null simple-vector) debug-variables))
546 dbarlow 1.1 (loop for v across debug-variables
547     collect (list
548 mbaringer 1.73 :name (sb-di:debug-var-symbol v)
549 dbarlow 1.1 :id (sb-di:debug-var-id v)
550 mbaringer 1.73 :value (if (eq (sb-di:debug-var-validity v location)
551     :valid)
552     (sb-di:debug-var-value v frame)
553 heller 1.74 '#:<not-available>)))))
554 dbarlow 1.1
555 lgorrie 1.54 (defimplementation frame-catch-tags (index)
556 heller 1.74 (mapcar #'car (sb-di:frame-catches (nth-frame index))))
557 lgorrie 1.50
558 heller 1.56 (defimplementation eval-in-frame (form index)
559     (let ((frame (nth-frame index)))
560 heller 1.58 (funcall (the function
561     (sb-di:preprocess-for-eval form
562     (sb-di:frame-code-location frame)))
563 heller 1.56 frame)))
564    
565     (defun sb-debug-catch-tag-p (tag)
566     (and (symbolp tag)
567     (not (symbol-package tag))
568     (string= tag :sb-debug-catch-tag)))
569    
570     (defimplementation return-from-frame (index form)
571     (let* ((frame (nth-frame index))
572     (probe (assoc-if #'sb-debug-catch-tag-p
573     (sb-di::frame-catches frame))))
574     (cond (probe (throw (car probe) (eval-in-frame form index)))
575     (t (format nil "Cannot return from frame: ~S" frame)))))
576    
577 heller 1.57
578     ;;;; Profiling
579    
580     (defimplementation profile (fname)
581     (when fname (eval `(sb-profile:profile ,fname))))
582    
583     (defimplementation unprofile (fname)
584     (when fname (eval `(sb-profile:unprofile ,fname))))
585    
586     (defimplementation unprofile-all ()
587     (sb-profile:unprofile)
588     "All functions unprofiled.")
589    
590     (defimplementation profile-report ()
591     (sb-profile:report))
592    
593     (defimplementation profile-reset ()
594     (sb-profile:reset)
595     "Reset profiling counters.")
596    
597     (defimplementation profiled-functions ()
598     (sb-profile:profile))
599    
600    
601 heller 1.64 ;;;; Inspector
602 heller 1.63
603 heller 1.64 (defmethod inspected-parts (o)
604     (cond ((sb-di::indirect-value-cell-p o)
605     (inspected-parts-of-value-cell o))
606     (t
607     (multiple-value-bind (text labeledp parts)
608     (sb-impl::inspected-parts o)
609     (let ((parts (if labeledp
610     (loop for (label . value) in parts
611     collect (cons (string label) value))
612     (loop for value in parts
613     for i from 0
614     collect (cons (format nil "~D" i) value)))))
615     (values text parts))))))
616    
617     (defun inspected-parts-of-value-cell (o)
618     (values (format nil "~A~% is a value cell." o)
619     (list (cons "Value" (sb-kernel:value-cell-ref o)))))
620    
621     (defmethod inspected-parts ((o function))
622     (let ((header (sb-kernel:widetag-of o)))
623     (cond ((= header sb-vm:simple-fun-header-widetag)
624     (values
625     (format nil "~A~% is a simple-fun." o)
626     (list (cons "Self" (sb-kernel:%simple-fun-self o))
627     (cons "Next" (sb-kernel:%simple-fun-next o))
628     (cons "Name" (sb-kernel:%simple-fun-name o))
629     (cons "Arglist" (sb-kernel:%simple-fun-arglist o))
630     (cons "Type" (sb-kernel:%simple-fun-type o))
631     (cons "Code Object" (sb-kernel:fun-code-header o)))))
632     ((= header sb-vm:closure-header-widetag)
633     (values (format nil "~A~% is a closure." o)
634     (list*
635     (cons "Function" (sb-kernel:%closure-fun o))
636     (loop for i from 0
637     below (- (sb-kernel:get-closure-length o)
638     (1- sb-vm:closure-info-offset))
639     collect (cons (format nil "~D" i)
640     (sb-kernel:%closure-index-ref o i))))))
641     (t (call-next-method o)))))
642    
643     (defmethod inspected-parts ((o sb-kernel:code-component))
644     (values (format nil "~A~% is a code data-block." o)
645     `(("First entry point" . ,(sb-kernel:%code-entry-points o))
646     ,@(loop for i from sb-vm:code-constants-offset
647     below (sb-kernel:get-header-data o)
648     collect (cons (format nil "Constant#~D" i)
649     (sb-kernel:code-header-ref o i)))
650     ("Debug info" . ,(sb-kernel:%code-debug-info o))
651     ("Instructions" . ,(sb-kernel:code-instructions o)))))
652    
653     (defmethod inspected-parts ((o sb-kernel:fdefn))
654     (values (format nil "~A~% is a fdefn object." o)
655     `(("Name" . ,(sb-kernel:fdefn-name o))
656     ("Function" . ,(sb-kernel:fdefn-fun o)))))
657    
658    
659     (defmethod inspected-parts ((o generic-function))
660     (values (format nil "~A~% is a generic function." o)
661     (list
662     (cons "Method-Class" (sb-pcl:generic-function-method-class o))
663     (cons "Methods" (sb-pcl:generic-function-methods o))
664     (cons "Name" (sb-pcl:generic-function-name o))
665     (cons "Declarations" (sb-pcl:generic-function-declarations o))
666     (cons "Method-Combination"
667     (sb-pcl:generic-function-method-combination o))
668     (cons "Lambda-List" (sb-pcl:generic-function-lambda-list o))
669     (cons "Precedence-Order"
670     (sb-pcl:generic-function-argument-precedence-order o))
671     (cons "Pretty-Arglist"
672     (sb-pcl::generic-function-pretty-arglist o))
673     (cons "Initial-Methods"
674     (sb-pcl::generic-function-initial-methods o)))))
675 heller 1.63
676    
677 lgorrie 1.50 ;;;; Multiprocessing
678    
679     #+SB-THREAD
680     (progn
681 lgorrie 1.54 (defimplementation spawn (fn &key name)
682 lgorrie 1.50 (declare (ignore name))
683     (sb-thread:make-thread fn))
684    
685 lgorrie 1.54 (defimplementation startup-multiprocessing ()
686 lgorrie 1.79 (setq *communication-style* :spawn))
687 lgorrie 1.50
688 heller 1.63 (defimplementation thread-name (thread)
689     (format nil "Thread ~D" thread))
690 lgorrie 1.50
691 heller 1.63 (defimplementation thread-status (thread)
692     (declare (ignore thread))
693     "???")
694 lgorrie 1.50
695 lgorrie 1.54 (defimplementation make-lock (&key name)
696 lgorrie 1.50 (sb-thread:make-mutex :name name))
697    
698 lgorrie 1.54 (defimplementation call-with-lock-held (lock function)
699 heller 1.58 (declare (type function function))
700 lgorrie 1.50 (sb-thread:with-mutex (lock) (funcall function)))
701 heller 1.59
702     (defimplementation current-thread ()
703     (sb-thread:current-thread-id))
704    
705 heller 1.63 (defimplementation all-threads ()
706 heller 1.59 (sb-thread::mapcar-threads
707     (lambda (sap)
708     (sb-sys:sap-ref-32 sap (* sb-vm:n-word-bytes
709     sb-vm::thread-pid-slot)))))
710    
711     (defimplementation interrupt-thread (thread fn)
712     (sb-thread:interrupt-thread thread fn))
713    
714 heller 1.70 (defimplementation kill-thread (thread)
715     (sb-thread:terminate-thread thread))
716    
717     ;; XXX there is some deadlock / race condition here (with old 2.4 kernels)
718 heller 1.59
719     (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))
720     (defvar *mailboxes* (list))
721 heller 1.60 (declaim (type list *mailboxes*))
722 heller 1.59
723     (defstruct (mailbox (:conc-name mailbox.))
724     thread
725     (mutex (sb-thread:make-mutex))
726     (waitqueue (sb-thread:make-waitqueue))
727     (queue '() :type list))
728    
729     (defun mailbox (thread)
730     "Return THREAD's mailbox."
731     (sb-thread:with-mutex (*mailbox-lock*)
732     (or (find thread *mailboxes* :key #'mailbox.thread)
733     (let ((mb (make-mailbox :thread thread)))
734     (push mb *mailboxes*)
735     mb))))
736    
737     (defimplementation send (thread message)
738     (let* ((mbox (mailbox thread))
739     (mutex (mailbox.mutex mbox)))
740     (sb-thread:with-mutex (mutex)
741     (setf (mailbox.queue mbox)
742     (nconc (mailbox.queue mbox) (list message)))
743     (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
744    
745     (defimplementation receive ()
746     (let* ((mbox (mailbox (sb-thread:current-thread-id)))
747     (mutex (mailbox.mutex mbox)))
748     (sb-thread:with-mutex (mutex)
749     (loop
750     (let ((q (mailbox.queue mbox)))
751     (cond (q (return (pop (mailbox.queue mbox))))
752     (t (sb-thread:condition-wait (mailbox.waitqueue mbox)
753     mutex))))))))
754    
755     )

  ViewVC Help
Powered by ViewVC 1.1.5