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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5