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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.113 - (show annotations)
Wed Nov 24 19:58:37 2004 UTC (9 years, 4 months ago) by heller
Branch: MAIN
Changes since 1.112: +26 -14 lines
(inspect-for-emacs)[code-component]: Disassemble code-components too.
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 ;;; Requires the SB-INTROSPECT contrib.
11
12 ;;; Administrivia
13
14 (eval-when (:compile-toplevel :load-toplevel :execute)
15 (require 'sb-bsd-sockets)
16 (require 'sb-introspect)
17 (require 'sb-posix)
18 )
19
20
21 (in-package :swank-backend)
22 (declaim (optimize (debug 2)))
23
24 (import
25 '(sb-gray:fundamental-character-output-stream
26 sb-gray:stream-write-char
27 sb-gray:stream-line-length
28 sb-gray:stream-force-output
29 sb-gray:fundamental-character-input-stream
30 sb-gray:stream-read-char
31 sb-gray:stream-listen
32 sb-gray:stream-unread-char
33 sb-gray:stream-clear-input
34 sb-gray:stream-line-column
35 sb-gray:stream-line-length))
36
37 ;;; swank-mop
38
39 (import-swank-mop-symbols :sb-mop '(:slot-definition-documentation))
40
41 (defun swank-mop:slot-definition-documentation (slot)
42 (sb-pcl::documentation slot t))
43
44 ;;; TCP Server
45
46 (defimplementation preferred-communication-style ()
47 (if (and (sb-int:featurep :sb-thread)
48 (sb-int:featurep :sb-futex))
49 :spawn
50 :fd-handler))
51
52 (defun resolve-hostname (name)
53 (car (sb-bsd-sockets:host-ent-addresses
54 (sb-bsd-sockets:get-host-by-name name))))
55
56 (defimplementation create-socket (host port)
57 (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
58 :type :stream
59 :protocol :tcp)))
60 (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
61 (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port)
62 (sb-bsd-sockets:socket-listen socket 5)
63 socket))
64
65 (defimplementation local-port (socket)
66 (nth-value 1 (sb-bsd-sockets:socket-name socket)))
67
68 (defimplementation close-socket (socket)
69 (sb-sys:invalidate-descriptor (socket-fd socket))
70 (sb-bsd-sockets:socket-close socket))
71
72 (defimplementation accept-connection (socket &key external-format)
73 (make-socket-io-stream (accept socket) external-format))
74
75 (defvar *sigio-handlers* '()
76 "List of (key . fn) pairs to be called on SIGIO.")
77
78 (defun sigio-handler (signal code scp)
79 (declare (ignore signal code scp))
80 (mapc (lambda (handler)
81 (funcall (the function (cdr handler))))
82 *sigio-handlers*))
83
84 (defun set-sigio-handler ()
85 (sb-sys:enable-interrupt sb-unix:sigio (lambda (signal code scp)
86 (sigio-handler signal code scp))))
87
88 (defun enable-sigio-on-fd (fd)
89 (sb-posix::fcntl fd sb-posix::f-setfl sb-posix::o-async)
90 (sb-posix::fcntl fd sb-posix::f-setown (getpid)))
91
92 (defimplementation add-sigio-handler (socket fn)
93 (set-sigio-handler)
94 (let ((fd (socket-fd socket)))
95 (format *debug-io* "Adding sigio handler: ~S ~%" fd)
96 (enable-sigio-on-fd fd)
97 (push (cons fd fn) *sigio-handlers*)))
98
99 (defimplementation remove-sigio-handlers (socket)
100 (let ((fd (socket-fd socket)))
101 (setf *sigio-handlers* (delete fd *sigio-handlers* :key #'car))
102 (sb-sys:invalidate-descriptor fd))
103 (close socket))
104
105 (defimplementation add-fd-handler (socket fn)
106 (declare (type function fn))
107 (let ((fd (socket-fd socket)))
108 (format *debug-io* "; Adding fd handler: ~S ~%" fd)
109 (sb-sys:add-fd-handler fd :input (lambda (_)
110 _
111 (funcall fn)))))
112
113 (defimplementation remove-fd-handlers (socket)
114 (sb-sys:invalidate-descriptor (socket-fd socket)))
115
116 (defun socket-fd (socket)
117 (etypecase socket
118 (fixnum socket)
119 (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket))
120 (file-stream (sb-sys:fd-stream-fd socket))))
121
122 (defun make-socket-io-stream (socket external-format)
123 (let ((encoding (ecase external-format
124 (:iso-latin-1-unix :iso-8859-1)
125 #+sb-unicode
126 (:utf-8-unix :utf-8))))
127 (sb-bsd-sockets:socket-make-stream socket
128 :output t
129 :input t
130 :element-type 'character
131 #+sb-unicode :external-format
132 #+sb-unicode encoding
133 )))
134
135 (defun accept (socket)
136 "Like socket-accept, but retry on EAGAIN."
137 (loop (handler-case
138 (return (sb-bsd-sockets:socket-accept socket))
139 (sb-bsd-sockets:interrupted-error ()))))
140
141 (defimplementation emacs-connected ()
142 (setq sb-ext:*invoke-debugger-hook*
143 (find-symbol (string :swank-debugger-hook) (find-package :swank))))
144
145 (defmethod call-without-interrupts (fn)
146 (declare (type function fn))
147 (sb-sys:without-interrupts (funcall fn)))
148
149 (defimplementation getpid ()
150 (sb-posix:getpid))
151
152 (defimplementation lisp-implementation-type-name ()
153 "sbcl")
154
155 (defimplementation quit-lisp ()
156 (sb-ext:quit))
157
158 ;;; Utilities
159
160 (defvar *swank-debugger-stack-frame*)
161
162 (defimplementation arglist ((fname t))
163 (sb-introspect:function-arglist fname))
164
165 (defimplementation function-name ((f function))
166 (sb-impl::%fun-name f))
167
168 (defvar *buffer-name* nil)
169 (defvar *buffer-offset*)
170 (defvar *buffer-substring* nil)
171
172 (defvar *previous-compiler-condition* nil
173 "Used to detect duplicates.")
174
175 (defun handle-notification-condition (condition)
176 "Handle a condition caused by a compiler warning.
177 This traps all compiler conditions at a lower-level than using
178 C:*COMPILER-NOTIFICATION-FUNCTION*. The advantage is that we get to
179 craft our own error messages, which can omit a lot of redundant
180 information."
181 (let ((context (sb-c::find-error-context nil)))
182 (unless (eq condition *previous-compiler-condition*)
183 (setq *previous-compiler-condition* condition)
184 (signal-compiler-condition condition context))))
185
186 (defun signal-compiler-condition (condition context)
187 (signal (make-condition
188 'compiler-condition
189 :original-condition condition
190 :severity (etypecase condition
191 (sb-c:compiler-error :error)
192 (sb-ext:compiler-note :note)
193 (style-warning :style-warning)
194 (warning :warning)
195 (error :error))
196 :short-message (brief-compiler-message-for-emacs condition)
197 :references (condition-references (real-condition condition))
198 :message (long-compiler-message-for-emacs condition context)
199 :location (compiler-note-location context))))
200
201 (defun real-condition (condition)
202 "Return the encapsulated condition or CONDITION itself."
203 (typecase condition
204 (sb-int:encapsulated-condition (sb-int:encapsulated-condition condition))
205 (t condition)))
206
207 (defun compiler-note-location (context)
208 (cond (context
209 (resolve-note-location
210 *buffer-name*
211 (sb-c::compiler-error-context-file-name context)
212 (sb-c::compiler-error-context-file-position context)
213 (current-compiler-error-source-path context)
214 (sb-c::compiler-error-context-original-source context)))
215 (t
216 (resolve-note-location *buffer-name* nil nil nil nil))))
217
218 (defgeneric resolve-note-location (buffer file-name file-position
219 source-path source))
220
221 (defmethod resolve-note-location ((b (eql nil)) (f pathname) pos path source)
222 (make-location
223 `(:file ,(namestring (truename f)))
224 `(:position ,(1+ (source-path-file-position path f)))))
225
226 ;; SBCL doesn't have compile-from-stream, so C-c C-c ends up here
227 (defmethod resolve-note-location ((b string) (f (eql :lisp)) pos path source)
228 ;; Remove the surrounding lambda from the path (was added by
229 ;; swank-compile-string)
230 (destructuring-bind (_ form &rest rest) path
231 (declare (ignore _))
232 (make-location
233 `(:buffer ,b)
234 `(:position ,(+ *buffer-offset*
235 (source-path-string-position (list* (- form 2) rest)
236 *buffer-substring*))))))
237
238 (defmethod resolve-note-location (b (f (eql :lisp)) pos path (source string))
239 (make-location
240 `(:source-form ,source)
241 `(:position 1)))
242
243 (defmethod resolve-note-location (buffer
244 (file (eql nil))
245 (pos (eql nil))
246 (path (eql nil))
247 (source (eql nil)))
248 (list :error "No error location available"))
249
250 (defun brief-compiler-message-for-emacs (condition)
251 "Briefly describe a compiler error for Emacs.
252 When Emacs presents the message it already has the source popped up
253 and the source form highlighted. This makes much of the information in
254 the error-context redundant."
255 (let ((sb-int:*print-condition-references* nil))
256 (princ-to-string condition)))
257
258 (defun long-compiler-message-for-emacs (condition error-context)
259 "Describe a compiler error for Emacs including context information."
260 (declare (type (or sb-c::compiler-error-context null) error-context))
261 (multiple-value-bind (enclosing source)
262 (if error-context
263 (values (sb-c::compiler-error-context-enclosing-source error-context)
264 (sb-c::compiler-error-context-source error-context)))
265 (let ((sb-int:*print-condition-references* nil))
266 (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~%~}~]~A"
267 enclosing source condition))))
268
269 (defun current-compiler-error-source-path (context)
270 "Return the source-path for the current compiler error.
271 Returns NIL if this cannot be determined by examining internal
272 compiler state."
273 (cond ((sb-c::node-p context)
274 (reverse
275 (sb-c::source-path-original-source
276 (sb-c::node-source-path context))))
277 ((sb-c::compiler-error-context-p context)
278 (reverse
279 (sb-c::compiler-error-context-original-source-path context)))))
280
281 (defimplementation call-with-compilation-hooks (function)
282 (declare (type function function))
283 (handler-bind ((sb-c:fatal-compiler-error #'handle-file-compiler-termination)
284 (sb-c:compiler-error #'handle-notification-condition)
285 (sb-ext:compiler-note #'handle-notification-condition)
286 (style-warning #'handle-notification-condition)
287 (warning #'handle-notification-condition))
288 (funcall function)))
289
290 (defun handle-file-compiler-termination (condition)
291 "Handle a condition that caused the file compiler to terminate."
292 (handle-notification-condition
293 (sb-int:encapsulated-condition condition)))
294
295 (defvar *trap-load-time-warnings* nil)
296
297 (defimplementation swank-compile-file (filename load-p)
298 (handler-case
299 (let ((output-file (with-compilation-hooks ()
300 (compile-file filename))))
301 (when (and load-p output-file)
302 (load output-file)))
303 (sb-c:fatal-compiler-error () nil)))
304
305 (defimplementation swank-compile-string (string &key buffer position directory)
306 (declare (ignore directory))
307 (let ((form (read-from-string (format nil "(~S () ~A)" 'lambda string))))
308 (flet ((compileit (cont)
309 (with-compilation-hooks ()
310 (let ((*buffer-name* buffer)
311 (*buffer-offset* position)
312 (*buffer-substring* string))
313 (funcall cont (compile nil form))))))
314 (cond (*trap-load-time-warnings*
315 (compileit #'funcall))
316 (t
317 (funcall (compileit #'identity)))))))
318
319 ;;;; Definitions
320
321 (defvar *debug-definition-finding* nil
322 "When true don't handle errors while looking for definitions.
323 This is useful when debugging the definition-finding code.")
324
325 ;;; FIXME we don't handle the compiled-interactively case yet. That
326 ;;; should have NIL :filename & :position, and non-NIL :source-form
327 (defun function-source-location (function &optional name)
328 "Try to find the canonical source location of FUNCTION."
329 (let* ((def (sb-introspect:find-definition-source function))
330 (pathname (sb-introspect:definition-source-pathname def))
331 (path (sb-introspect:definition-source-form-path def))
332 (position (sb-introspect:definition-source-character-offset def)))
333 (unless pathname
334 (return-from function-source-location
335 (list :error (format nil "No filename for: ~S" function))))
336 (multiple-value-bind (truename condition)
337 (ignore-errors (truename pathname))
338 (when condition
339 (return-from function-source-location
340 (list :error (format nil "~A" condition))))
341 (make-location
342 (list :file (namestring truename))
343 ;; source-paths depend on the file having been compiled with
344 ;; lotsa debugging. If not present, return the function name
345 ;; for emacs to attempt to find with a regex
346 (cond (path (list :source-path path position))
347 (t (list :function-name
348 (or (and name (string name))
349 (string (sb-kernel:%fun-name function))))))))))
350
351 (defun safe-function-source-location (fun name)
352 (if *debug-definition-finding*
353 (function-source-location fun name)
354 (handler-case (function-source-location fun name)
355 (error (e)
356 (list (list :error (format nil "Error: ~A" e)))))))
357
358 (defun method-definitions (gf)
359 (let ((methods (sb-mop:generic-function-methods gf))
360 (name (sb-mop:generic-function-name gf)))
361 (loop for method in methods
362 collect (list `(method ,name ,(sb-pcl::unparse-specializers method))
363 (safe-function-source-location method name)))))
364
365 (defun function-definitions (name)
366 (flet ((loc (fn name) (safe-function-source-location fn name)))
367 (append
368 (cond ((and (symbolp name) (macro-function name))
369 (list (list `(defmacro ,name)
370 (loc (macro-function name) name))))
371 ((fboundp name)
372 (let ((fn (fdefinition name)))
373 (typecase fn
374 (generic-function
375 (cons (list `(defgeneric ,name) (loc fn name))
376 (method-definitions fn)))
377 (t
378 (list (list `(function ,name) (loc fn name))))))))
379 (when (compiler-macro-function name)
380 (list (list `(define-compiler-macro ,name)
381 (loc (compiler-macro-function name) name)))))))
382
383 (defun transform-definitions (fun-info name)
384 (loop for xform in (sb-c::fun-info-transforms fun-info)
385 for loc = (safe-function-source-location
386 (sb-c::transform-function xform) name)
387 for typespec = (sb-kernel:type-specifier (sb-c::transform-type xform))
388 for note = (sb-c::transform-note xform)
389 for spec = (if (consp typespec)
390 `(sb-c:deftransform ,(second typespec) ,note)
391 `(sb-c:deftransform ,note))
392 collect `(,spec ,loc)))
393
394 (defun optimizer-definitions (fun-info fun-name)
395 (let ((otypes '((sb-c::fun-info-derive-type . sb-c:derive-type)
396 (sb-c::fun-info-ltn-annotate . sb-c:ltn-annotate)
397 (sb-c::fun-info-ltn-annotate . sb-c:ltn-annotate)
398 (sb-c::fun-info-optimizer . sb-c:optimizer))))
399 (loop for (reader . name) in otypes
400 for fn = (funcall reader fun-info)
401 when fn collect `((sb-c:defoptimizer ,name)
402 ,(safe-function-source-location fn fun-name)))))
403
404 (defun compiler-definitions (name)
405 (let ((fun-info (sb-int:info :function :info name)))
406 (when fun-info
407 (append (transform-definitions fun-info name)
408 (optimizer-definitions fun-info name)))))
409
410 (defimplementation find-definitions (name)
411 (append (function-definitions name)
412 (compiler-definitions name)))
413
414 (defimplementation describe-symbol-for-emacs (symbol)
415 "Return a plist describing SYMBOL.
416 Return NIL if the symbol is unbound."
417 (let ((result '()))
418 (labels ((doc (kind)
419 (or (documentation symbol kind) :not-documented))
420 (maybe-push (property value)
421 (when value
422 (setf result (list* property value result)))))
423 (maybe-push
424 :variable (multiple-value-bind (kind recorded-p)
425 (sb-int:info :variable :kind symbol)
426 (declare (ignore kind))
427 (if (or (boundp symbol) recorded-p)
428 (doc 'variable))))
429 (maybe-push
430 :function (if (fboundp symbol)
431 (doc 'function)))
432 (maybe-push
433 :setf (if (or (sb-int:info :setf :inverse symbol)
434 (sb-int:info :setf :expander symbol))
435 (doc 'setf)))
436 (maybe-push
437 :type (if (sb-int:info :type :kind symbol)
438 (doc 'type)))
439 result)))
440
441 (defimplementation describe-definition (symbol type)
442 (case type
443 (:variable
444 (describe symbol))
445 (:function
446 (describe (symbol-function symbol)))
447 (:setf
448 (describe (or (sb-int:info :setf :inverse symbol)
449 (sb-int:info :setf :expander symbol))))
450 (:class
451 (describe (find-class symbol)))
452 (:type
453 (describe (sb-kernel:values-specifier-type symbol)))))
454
455 (defun function-dspec (fn)
456 "Describe where the function FN was defined.
457 Return a list of the form (NAME LOCATION)."
458 (let ((name (sb-kernel:%fun-name fn)))
459 (list name (safe-function-source-location fn name))))
460
461 (defimplementation list-callers (symbol)
462 (let ((fn (fdefinition symbol)))
463 (mapcar #'function-dspec (sb-introspect:find-function-callers fn))))
464
465 (defimplementation list-callees (symbol)
466 (let ((fn (fdefinition symbol)))
467 (mapcar #'function-dspec (sb-introspect:find-function-callees fn))))
468
469 ;;; macroexpansion
470
471 (defimplementation macroexpand-all (form)
472 (let ((sb-walker:*walk-form-expand-macros-p* t))
473 (sb-walker:walk-form form)))
474
475
476 ;;; Debugging
477
478 (defvar *sldb-stack-top*)
479
480 (defimplementation call-with-debugging-environment (debugger-loop-fn)
481 (declare (type function debugger-loop-fn))
482 (let* ((*sldb-stack-top* (or sb-debug:*stack-top-hint* (sb-di:top-frame)))
483 (sb-debug:*stack-top-hint* nil))
484 (handler-bind ((sb-di:debug-condition
485 (lambda (condition)
486 (signal (make-condition
487 'sldb-condition
488 :original-condition condition)))))
489 (funcall debugger-loop-fn))))
490
491 (defun nth-frame (index)
492 (do ((frame *sldb-stack-top* (sb-di:frame-down frame))
493 (i index (1- i)))
494 ((zerop i) frame)))
495
496 (defimplementation compute-backtrace (start end)
497 "Return a list of frames starting with frame number START and
498 continuing to frame number END or, if END is nil, the last frame on the
499 stack."
500 (let ((end (or end most-positive-fixnum)))
501 (loop for f = (nth-frame start) then (sb-di:frame-down f)
502 for i from start below end
503 while f
504 collect f)))
505
506 (defimplementation print-frame (frame stream)
507 (let ((*standard-output* stream))
508 (sb-debug::print-frame-call frame :verbosity 1 :number nil)))
509
510 (defun code-location-source-path (code-location)
511 (let* ((location (sb-debug::maybe-block-start-location code-location))
512 (form-num (sb-di:code-location-form-number location)))
513 (let ((translations (sb-debug::get-toplevel-form location)))
514 (unless (< form-num (length translations))
515 (error "Source path no longer exists."))
516 (reverse (cdr (svref translations form-num))))))
517
518 (defun code-location-file-position (code-location)
519 (let* ((debug-source (sb-di:code-location-debug-source code-location))
520 (filename (sb-di:debug-source-name debug-source))
521 (path (code-location-source-path code-location)))
522 (source-path-file-position path filename)))
523
524 ;;; source-path-file-position and friends are in swank-source-path-parser
525
526 (defun debug-source-info-from-emacs-buffer-p (debug-source)
527 (let ((info (sb-c::debug-source-info debug-source)))
528 (and info
529 (consp info)
530 (eq :emacs-buffer (car info)))))
531
532 (defun source-location-for-emacs (code-location)
533 (let* ((debug-source (sb-di:code-location-debug-source code-location))
534 (from (sb-di:debug-source-from debug-source))
535 (name (sb-di:debug-source-name debug-source)))
536 (ecase from
537 (:file
538 (let ((source-path (ignore-errors
539 (code-location-source-path code-location))))
540 (cond (source-path
541 ;; XXX: code-location-source-path reads the source !!
542 (let ((position (code-location-file-position code-location)))
543 (make-location
544 (list :file (namestring (truename name)))
545 (list :source-path source-path position))))
546 (t
547 (let* ((dfn (sb-di:code-location-debug-fun code-location))
548 (fn (sb-di:debug-fun-fun dfn)))
549 (unless fn
550 (error "Cannot find source location for: ~A "
551 code-location))
552 (function-source-location
553 fn (sb-di:debug-fun-name dfn)))))))
554
555 (:lisp
556 (make-location
557 (list :source-form (with-output-to-string (*standard-output*)
558 (sb-debug::print-code-location-source-form
559 code-location 100)))
560 (list :position 0))))))
561
562 (defun safe-source-location-for-emacs (code-location)
563 (handler-case (source-location-for-emacs code-location)
564 (error (c) (list :error (format nil "~A" c)))))
565
566 (defimplementation frame-source-location-for-emacs (index)
567 (safe-source-location-for-emacs
568 (sb-di:frame-code-location (nth-frame index))))
569
570 (defun frame-debug-vars (frame)
571 "Return a vector of debug-variables in frame."
572 (sb-di::debug-fun-debug-vars (sb-di:frame-debug-fun frame)))
573
574 (defun debug-var-value (var frame location)
575 (ecase (sb-di:debug-var-validity var location)
576 (:valid (sb-di:debug-var-value var frame))
577 ((:invalid :unknown) ':<not-available>)))
578
579 (defimplementation frame-locals (index)
580 (let* ((frame (nth-frame index))
581 (loc (sb-di:frame-code-location frame))
582 (vars (frame-debug-vars frame)))
583 (loop for v across vars collect
584 (list :name (sb-di:debug-var-symbol v)
585 :id (sb-di:debug-var-id v)
586 :value (debug-var-value v frame loc)))))
587
588 (defimplementation frame-var-value (frame var)
589 (let* ((frame (nth-frame frame))
590 (dvar (aref (frame-debug-vars frame) var)))
591 (debug-var-value dvar frame (sb-di:frame-code-location frame))))
592
593 (defimplementation frame-catch-tags (index)
594 (mapcar #'car (sb-di:frame-catches (nth-frame index))))
595
596 (defimplementation eval-in-frame (form index)
597 (let ((frame (nth-frame index)))
598 (funcall (the function
599 (sb-di:preprocess-for-eval form
600 (sb-di:frame-code-location frame)))
601 frame)))
602
603 (defun sb-debug-catch-tag-p (tag)
604 (and (symbolp tag)
605 (not (symbol-package tag))
606 (string= tag :sb-debug-catch-tag)))
607
608 (defimplementation return-from-frame (index form)
609 (let* ((frame (nth-frame index))
610 (probe (assoc-if #'sb-debug-catch-tag-p
611 (sb-di::frame-catches frame))))
612 (cond (probe (throw (car probe) (eval-in-frame form index)))
613 (t (format nil "Cannot return from frame: ~S" frame)))))
614
615 ;;;;; reference-conditions
616
617 (defimplementation format-sldb-condition (condition)
618 (let ((sb-int:*print-condition-references* nil))
619 (princ-to-string condition)))
620
621 (defimplementation condition-references (condition)
622 (if (typep condition 'sb-int:reference-condition)
623 (sb-int:reference-condition-references condition)
624 '()))
625
626
627 ;;;; Profiling
628
629 (defimplementation profile (fname)
630 (when fname (eval `(sb-profile:profile ,fname))))
631
632 (defimplementation unprofile (fname)
633 (when fname (eval `(sb-profile:unprofile ,fname))))
634
635 (defimplementation unprofile-all ()
636 (sb-profile:unprofile)
637 "All functions unprofiled.")
638
639 (defimplementation profile-report ()
640 (sb-profile:report))
641
642 (defimplementation profile-reset ()
643 (sb-profile:reset)
644 "Reset profiling counters.")
645
646 (defimplementation profiled-functions ()
647 (sb-profile:profile))
648
649
650 ;;;; Inspector
651
652 (defclass sbcl-inspector (inspector)
653 ())
654
655 (defimplementation make-default-inspector ()
656 (make-instance 'sbcl-inspector))
657
658 (defmethod inspect-for-emacs ((o t) (inspector sbcl-inspector))
659 (declare (ignore inspector))
660 (cond ((sb-di::indirect-value-cell-p o)
661 (values "A value cell."
662 `("Value: " (:value ,(sb-kernel:value-cell-ref o)))))
663 (t
664 (multiple-value-bind (text labeledp parts)
665 (sb-impl::inspected-parts o)
666 (if labeledp
667 (values text
668 (loop for (label . value) in parts
669 collect `(:value ,label)
670 collect " = "
671 collect `(:value ,value)
672 collect '(:newline)))
673 (values text
674 (loop for value in parts
675 for i from 0
676 collect (princ-to-string i)
677 collect " = "
678 collect `(:value ,value)
679 collect '(:newline))))))))
680
681 (defmethod inspect-for-emacs ((o function) (inspector sbcl-inspector))
682 (declare (ignore inspector))
683 (let ((header (sb-kernel:widetag-of o)))
684 (cond ((= header sb-vm:simple-fun-header-widetag)
685 (values "A simple-fun."
686 `("Name: " (:value ,(sb-kernel:%simple-fun-name o))
687 (:newline)
688 "Arglist: " (:value ,(sb-kernel:%simple-fun-arglist o))
689 (:newline)
690 ,@(when (documentation o t)
691 `("Documentation: " (:newline) ,(documentation o t) (:newline)))
692 "Self: " (:value ,(sb-kernel:%simple-fun-self o))
693 (:newline)
694 "Next: " (:value ,(sb-kernel:%simple-fun-next o))
695 (:newline)
696 "Type: " (:value ,(sb-kernel:%simple-fun-type o))
697 (:newline)
698 "Code Object: " (:value ,(sb-kernel:fun-code-header o)))))
699 ((= header sb-vm:closure-header-widetag)
700 (values "A closure."
701 `("Function: " (:value ,(sb-kernel:%closure-fun o))
702 (:newline)
703 ,@(when (documentation o t)
704 `("Documentation: " (:newline) ,(documentation o t) (:newline)))
705 "Closed over values:"
706 (:newline)
707 ,@(loop for i from 0
708 below (- (sb-kernel:get-closure-length o)
709 (1- sb-vm:closure-info-offset))
710 collect (princ-to-string i)
711 collect " = "
712 collect `(:value ,(sb-kernel:%closure-index-ref o i))
713 collect '(:newline)))))
714 (t (call-next-method o)))))
715
716 (defmethod inspect-for-emacs ((o sb-kernel:code-component) (_ sbcl-inspector))
717 (declare (ignore _))
718 (values (format nil "~A is a code data-block." o)
719 (append
720 (label-value-line*
721 (:code-size (sb-kernel:%code-code-size o))
722 (:entry-points (sb-kernel:%code-entry-points o))
723 (:debug-info (sb-kernel:%code-debug-info o))
724 (:trace-table-offset (sb-kernel:code-header-ref
725 o sb-vm:code-trace-table-offset-slot)))
726 `("Constants:" (:newline))
727 (loop for i from sb-vm:code-constants-offset
728 below (sb-kernel:get-header-data o)
729 append (label-value-line i (sb-kernel:code-header-ref o i)))
730 `("Code:" (:newline)
731 , (with-output-to-string (s)
732 (cond ((sb-kernel:%code-debug-info o)
733 (sb-disassem:disassemble-code-component o :stream s))
734 (t
735 (sb-disassem:disassemble-memory
736 (sb-disassem::align
737 (+ (logandc2 (sb-kernel:get-lisp-obj-address o)
738 sb-vm:lowtag-mask)
739 (* sb-vm:code-constants-offset sb-vm:n-word-bytes))
740 (ash 1 sb-vm:n-lowtag-bits))
741 (ash (sb-kernel:%code-code-size o) sb-vm:word-shift)
742 :stream s))))))))
743
744 (defmethod inspect-for-emacs ((o sb-kernel:fdefn) (inspector sbcl-inspector))
745 (declare (ignore inspector))
746 (values "A fdefn object."
747 `("Name: " (:value ,(sb-kernel:fdefn-name o))
748 (:newline)
749 "Function" (:value,(sb-kernel:fdefn-fun o))
750 (:newline)
751 ,@(when (documentation o t)
752 `("Documentation: " (:newline) ,(documentation o t) (:newline))))))
753
754 (defmethod inspect-for-emacs :around ((o generic-function) (inspector sbcl-inspector))
755 (declare (ignore inspector))
756 (multiple-value-bind (title contents)
757 (call-next-method)
758 (values title
759 (append contents
760 `("Pretty arglist: " (:value ,(sb-pcl::generic-function-pretty-arglist o))
761 (:newline)
762 "Initial methods: " (:value ,(sb-pcl::generic-function-initial-methods o)))))))
763
764
765 ;;;; Support for SBCL syntax
766
767 (defun feature-in-list-p (feature list)
768 (etypecase feature
769 (symbol (member feature list :test #'eq))
770 (cons (flet ((subfeature-in-list-p (subfeature)
771 (feature-in-list-p subfeature list)))
772 (ecase (first feature)
773 (:or (some #'subfeature-in-list-p (rest feature)))
774 (:and (every #'subfeature-in-list-p (rest feature)))
775 (:not (let ((rest (cdr feature)))
776 (if (or (null (car rest)) (cdr rest))
777 (error "wrong number of terms in compound feature ~S"
778 feature)
779 (not (subfeature-in-list-p (second feature)))))))))))
780
781 (defun shebang-reader (stream sub-character infix-parameter)
782 (declare (ignore sub-character))
783 (when infix-parameter
784 (error "illegal read syntax: #~D!" infix-parameter))
785 (let ((next-char (read-char stream)))
786 (unless (find next-char "+-")
787 (error "illegal read syntax: #!~C" next-char))
788 ;; When test is not satisfied
789 ;; FIXME: clearer if order of NOT-P and (NOT NOT-P) were reversed? then
790 ;; would become "unless test is satisfied"..
791 (when (let* ((*package* (find-package "KEYWORD"))
792 (*read-suppress* nil)
793 (not-p (char= next-char #\-))
794 (feature (read stream)))
795 (if (feature-in-list-p feature *features*)
796 not-p
797 (not not-p)))
798 ;; Read (and discard) a form from input.
799 (let ((*read-suppress* t))
800 (read stream t nil t))))
801 (values))
802
803 (defvar *shebang-readtable*
804 (let ((*readtable* (copy-readtable nil)))
805 (set-dispatch-macro-character #\# #\!
806 (lambda (s c n) (shebang-reader s c n))
807 *readtable*)
808 *readtable*))
809
810 (defun shebang-readtable ()
811 *shebang-readtable*)
812
813 (defun sbcl-package-p (package)
814 (let ((name (package-name package)))
815 (eql (mismatch "SB-" name) 3)))
816
817 (defvar *debootstrap-packages* t)
818
819 (defmacro with-debootstrapping (&body body)
820 (let ((not-found (find-symbol "BOOTSTRAP-PACKAGE-NOT-FOUND" "SB-INT"))
821 (debootstrap (find-symbol "DEBOOTSTRAP-PACKAGE" "SB-INT")))
822 (if (and not-found debootstrap)
823 `(handler-bind ((,not-found #',debootstrap)) ,@body)
824 `(progn ,@body))))
825
826 (defimplementation call-with-syntax-hooks (fn)
827 (cond ((and *debootstrap-packages*
828 (sbcl-package-p *package*))
829 (with-debootstrapping (funcall fn)))
830 (t
831 (funcall fn))))
832
833 (defimplementation default-readtable-alist ()
834 (let ((readtable (shebang-readtable)))
835 (loop for p in (remove-if-not #'sbcl-package-p (list-all-packages))
836 collect (cons (package-name p) readtable))))
837
838
839 ;;;; Multiprocessing
840
841 #+sb-thread
842 (progn
843 (defimplementation spawn (fn &key name)
844 (declare (ignore name))
845 (sb-thread:make-thread fn))
846
847 (defimplementation startup-multiprocessing ())
848
849 (defimplementation thread-id (thread)
850 thread)
851
852 (defimplementation find-thread (id)
853 (if (member id (all-threads))
854 id))
855
856 (defimplementation thread-name (thread)
857 (format nil "Thread ~D" thread))
858
859 (defimplementation thread-status (thread)
860 (sb-sys:without-gcing
861 (let ((thread (sb-thread::thread-sap-from-id thread)))
862 (cond (thread
863 (let* ((sap (sb-sys:sap-ref-sap thread
864 (* sb-vm::thread-state-slot
865 sb-vm::n-word-bytes)))
866 (state (ash (sb-sys:sap-int sap)
867 (- sb-vm::n-fixnum-tag-bits))))
868 (case state
869 (0 "running")
870 (1 "stopping")
871 (2 "stopped")
872 (3 "dead")
873 (t (format nil "??? ~A" state)))))
874 (t "??? ???")))))
875
876 (defimplementation make-lock (&key name)
877 (sb-thread:make-mutex :name name))
878
879 (defimplementation call-with-lock-held (lock function)
880 (declare (type function function))
881 (sb-thread:with-mutex (lock) (funcall function)))
882
883 (defimplementation current-thread ()
884 (sb-thread:current-thread-id))
885
886 (defimplementation all-threads ()
887 (sb-thread::mapcar-threads
888 (lambda (sap)
889 (sb-sys:sap-ref-32 sap (* sb-vm:n-word-bytes
890 sb-vm::thread-pid-slot)))))
891
892 (defimplementation interrupt-thread (thread fn)
893 (sb-thread:interrupt-thread thread fn))
894
895 (defimplementation kill-thread (thread)
896 (sb-thread:terminate-thread thread))
897
898 (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))
899 (defvar *mailboxes* (list))
900 (declaim (type list *mailboxes*))
901
902 (defstruct (mailbox (:conc-name mailbox.))
903 thread
904 (mutex (sb-thread:make-mutex))
905 (waitqueue (sb-thread:make-waitqueue))
906 (queue '() :type list))
907
908 (defun mailbox (thread)
909 "Return THREAD's mailbox."
910 (sb-thread:with-mutex (*mailbox-lock*)
911 (or (find thread *mailboxes* :key #'mailbox.thread)
912 (let ((mb (make-mailbox :thread thread)))
913 (push mb *mailboxes*)
914 mb))))
915
916 (defimplementation send (thread message)
917 (let* ((mbox (mailbox thread))
918 (mutex (mailbox.mutex mbox)))
919 (sb-thread:with-mutex (mutex)
920 (setf (mailbox.queue mbox)
921 (nconc (mailbox.queue mbox) (list message)))
922 (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
923
924 (defimplementation receive ()
925 (let* ((mbox (mailbox (sb-thread:current-thread-id)))
926 (mutex (mailbox.mutex mbox)))
927 (sb-thread:with-mutex (mutex)
928 (loop
929 (let ((q (mailbox.queue mbox)))
930 (cond (q (return (pop (mailbox.queue mbox))))
931 (t (sb-thread:condition-wait (mailbox.waitqueue mbox)
932 mutex))))))))
933
934 )

  ViewVC Help
Powered by ViewVC 1.1.5