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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.81 - (hide annotations)
Sat Mar 27 20:45:09 2004 UTC (10 years ago) by heller
Branch: MAIN
Changes since 1.80: +21 -26 lines
(enable-sigio-on-fd): Use sb-posix::fcntl instead of sb-posix:fcntl to
avoid the ugly reader hack.  SBCL doesn't have package locks and even
if they add locks in the future sb-posix::fcntl will still be valid.

(getpid): Use defimplementation instead of defmethod.

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

  ViewVC Help
Powered by ViewVC 1.1.5