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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5