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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.118 - (show annotations)
Thu Feb 24 18:10:02 2005 UTC (9 years, 1 month ago) by heller
Branch: MAIN
Changes since 1.117: +6 -7 lines
(call-with-debugger-hook): Bind sb-ext:*invoke-debugger-hook* instead
of setting it in emacs-connected.
(emacs-connected): Deleted.
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
73 &key (external-format :iso-latin-1-unix))
74 (make-socket-io-stream (accept socket) external-format))
75
76 (defvar *sigio-handlers* '()
77 "List of (key . fn) pairs to be called on SIGIO.")
78
79 (defun sigio-handler (signal code scp)
80 (declare (ignore signal code scp))
81 (mapc (lambda (handler)
82 (funcall (the function (cdr handler))))
83 *sigio-handlers*))
84
85 (defun set-sigio-handler ()
86 (sb-sys:enable-interrupt sb-unix:sigio (lambda (signal code scp)
87 (sigio-handler signal code scp))))
88
89 (defun enable-sigio-on-fd (fd)
90 (sb-posix::fcntl fd sb-posix::f-setfl sb-posix::o-async)
91 (sb-posix::fcntl fd sb-posix::f-setown (getpid)))
92
93 (defimplementation add-sigio-handler (socket fn)
94 (set-sigio-handler)
95 (let ((fd (socket-fd socket)))
96 (format *debug-io* "Adding sigio handler: ~S ~%" fd)
97 (enable-sigio-on-fd fd)
98 (push (cons fd fn) *sigio-handlers*)))
99
100 (defimplementation remove-sigio-handlers (socket)
101 (let ((fd (socket-fd socket)))
102 (setf *sigio-handlers* (delete fd *sigio-handlers* :key #'car))
103 (sb-sys:invalidate-descriptor fd))
104 (close socket))
105
106 (defimplementation add-fd-handler (socket fn)
107 (declare (type function fn))
108 (let ((fd (socket-fd socket)))
109 (format *debug-io* "; Adding fd handler: ~S ~%" fd)
110 (sb-sys:add-fd-handler fd :input (lambda (_)
111 _
112 (funcall fn)))))
113
114 (defimplementation remove-fd-handlers (socket)
115 (sb-sys:invalidate-descriptor (socket-fd socket)))
116
117 (defun socket-fd (socket)
118 (etypecase socket
119 (fixnum socket)
120 (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket))
121 (file-stream (sb-sys:fd-stream-fd socket))))
122
123 (defun make-socket-io-stream (socket external-format)
124 (let ((encoding (ecase external-format
125 (:iso-latin-1-unix :iso-8859-1)
126 #+sb-unicode
127 (:utf-8-unix :utf-8))))
128 (sb-bsd-sockets:socket-make-stream socket
129 :output t
130 :input t
131 :element-type 'character
132 #+sb-unicode :external-format
133 #+sb-unicode encoding
134 )))
135
136 (defun accept (socket)
137 "Like socket-accept, but retry on EAGAIN."
138 (loop (handler-case
139 (return (sb-bsd-sockets:socket-accept socket))
140 (sb-bsd-sockets:interrupted-error ()))))
141
142 (defmethod call-without-interrupts (fn)
143 (declare (type function fn))
144 (sb-sys:without-interrupts (funcall fn)))
145
146 (defimplementation getpid ()
147 (sb-posix:getpid))
148
149 (defimplementation lisp-implementation-type-name ()
150 "sbcl")
151
152 (defimplementation quit-lisp ()
153 (sb-ext:quit))
154
155 ;;; Utilities
156
157 (defimplementation arglist ((fname t))
158 (sb-introspect:function-arglist fname))
159
160 (defimplementation function-name ((f function))
161 (sb-impl::%fun-name f))
162
163 (defvar *buffer-name* nil)
164 (defvar *buffer-offset*)
165 (defvar *buffer-substring* nil)
166
167 (defvar *previous-compiler-condition* nil
168 "Used to detect duplicates.")
169
170 (defun handle-notification-condition (condition)
171 "Handle a condition caused by a compiler warning.
172 This traps all compiler conditions at a lower-level than using
173 C:*COMPILER-NOTIFICATION-FUNCTION*. The advantage is that we get to
174 craft our own error messages, which can omit a lot of redundant
175 information."
176 (let ((context (sb-c::find-error-context nil)))
177 (unless (eq condition *previous-compiler-condition*)
178 (setq *previous-compiler-condition* condition)
179 (signal-compiler-condition condition context))))
180
181 (defun signal-compiler-condition (condition context)
182 (signal (make-condition
183 'compiler-condition
184 :original-condition condition
185 :severity (etypecase condition
186 (sb-c:compiler-error :error)
187 (sb-ext:compiler-note :note)
188 (style-warning :style-warning)
189 (warning :warning)
190 (error :error))
191 :short-message (brief-compiler-message-for-emacs condition)
192 :references (condition-references (real-condition condition))
193 :message (long-compiler-message-for-emacs condition context)
194 :location (compiler-note-location context))))
195
196 (defun real-condition (condition)
197 "Return the encapsulated condition or CONDITION itself."
198 (typecase condition
199 (sb-int:encapsulated-condition (sb-int:encapsulated-condition condition))
200 (t condition)))
201
202 (defun compiler-note-location (context)
203 (cond (context
204 (resolve-note-location
205 *buffer-name*
206 (sb-c::compiler-error-context-file-name context)
207 (sb-c::compiler-error-context-file-position context)
208 (current-compiler-error-source-path context)
209 (sb-c::compiler-error-context-original-source context)))
210 (t
211 (resolve-note-location *buffer-name* nil nil nil nil))))
212
213 (defgeneric resolve-note-location (buffer file-name file-position
214 source-path source))
215
216 (defmethod resolve-note-location ((b (eql nil)) (f pathname) pos path source)
217 (make-location
218 `(:file ,(namestring (truename f)))
219 `(:position ,(1+ (source-path-file-position path f)))))
220
221 ;; SBCL doesn't have compile-from-stream, so C-c C-c ends up here
222 (defmethod resolve-note-location ((b string) (f (eql :lisp)) pos path source)
223 ;; Remove the surrounding lambda from the path (was added by
224 ;; swank-compile-string)
225 (destructuring-bind (_ form &rest rest) path
226 (declare (ignore _))
227 (make-location
228 `(:buffer ,b)
229 `(:position ,(+ *buffer-offset*
230 (source-path-string-position (list* (- form 2) rest)
231 *buffer-substring*))))))
232
233 (defmethod resolve-note-location (b (f (eql :lisp)) pos path (source string))
234 (make-location
235 `(:source-form ,source)
236 `(:position 1)))
237
238 (defmethod resolve-note-location (buffer
239 (file (eql nil))
240 (pos (eql nil))
241 (path (eql nil))
242 (source (eql nil)))
243 (list :error "No error location available"))
244
245 (defun brief-compiler-message-for-emacs (condition)
246 "Briefly describe a compiler error for Emacs.
247 When Emacs presents the message it already has the source popped up
248 and the source form highlighted. This makes much of the information in
249 the error-context redundant."
250 (let ((sb-int:*print-condition-references* nil))
251 (princ-to-string condition)))
252
253 (defun long-compiler-message-for-emacs (condition error-context)
254 "Describe a compiler error for Emacs including context information."
255 (declare (type (or sb-c::compiler-error-context null) error-context))
256 (multiple-value-bind (enclosing source)
257 (if error-context
258 (values (sb-c::compiler-error-context-enclosing-source error-context)
259 (sb-c::compiler-error-context-source error-context)))
260 (let ((sb-int:*print-condition-references* nil))
261 (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~%~}~]~A"
262 enclosing source condition))))
263
264 (defun current-compiler-error-source-path (context)
265 "Return the source-path for the current compiler error.
266 Returns NIL if this cannot be determined by examining internal
267 compiler state."
268 (cond ((sb-c::node-p context)
269 (reverse
270 (sb-c::source-path-original-source
271 (sb-c::node-source-path context))))
272 ((sb-c::compiler-error-context-p context)
273 (reverse
274 (sb-c::compiler-error-context-original-source-path context)))))
275
276 (defimplementation call-with-compilation-hooks (function)
277 (declare (type function function))
278 (handler-bind ((sb-c:fatal-compiler-error #'handle-file-compiler-termination)
279 (sb-c:compiler-error #'handle-notification-condition)
280 (sb-ext:compiler-note #'handle-notification-condition)
281 (style-warning #'handle-notification-condition)
282 (warning #'handle-notification-condition))
283 (funcall function)))
284
285 (defun handle-file-compiler-termination (condition)
286 "Handle a condition that caused the file compiler to terminate."
287 (handle-notification-condition
288 (sb-int:encapsulated-condition condition)))
289
290 (defvar *trap-load-time-warnings* nil)
291
292 (defimplementation swank-compile-file (filename load-p)
293 (handler-case
294 (let ((output-file (with-compilation-hooks ()
295 (compile-file filename))))
296 (when (and load-p output-file)
297 (load output-file)))
298 (sb-c:fatal-compiler-error () nil)))
299
300 (defimplementation swank-compile-string (string &key buffer position directory)
301 (declare (ignore directory))
302 (let ((form (read-from-string (format nil "(~S () ~A)" 'lambda string))))
303 (flet ((compileit (cont)
304 (with-compilation-hooks ()
305 (let ((*buffer-name* buffer)
306 (*buffer-offset* position)
307 (*buffer-substring* string))
308 (funcall cont (compile nil form))))))
309 (cond (*trap-load-time-warnings*
310 (compileit #'funcall))
311 (t
312 (funcall (compileit #'identity)))))))
313
314 ;;;; Definitions
315
316 (defvar *debug-definition-finding* nil
317 "When true don't handle errors while looking for definitions.
318 This is useful when debugging the definition-finding code.")
319
320 ;;; FIXME we don't handle the compiled-interactively case yet. That
321 ;;; should have NIL :filename & :position, and non-NIL :source-form
322 (defun function-source-location (function &optional name)
323 "Try to find the canonical source location of FUNCTION."
324 (let* ((def (sb-introspect:find-definition-source function))
325 (pathname (sb-introspect:definition-source-pathname def))
326 (path (sb-introspect:definition-source-form-path def))
327 (position (sb-introspect:definition-source-character-offset def)))
328 (unless pathname
329 (return-from function-source-location
330 (list :error (format nil "No filename for: ~S" function))))
331 (multiple-value-bind (truename condition)
332 (ignore-errors (truename pathname))
333 (when condition
334 (return-from function-source-location
335 (list :error (format nil "~A" condition))))
336 (make-location
337 (list :file (namestring truename))
338 ;; source-paths depend on the file having been compiled with
339 ;; lotsa debugging. If not present, return the function name
340 ;; for emacs to attempt to find with a regex
341 (cond (path (list :source-path path position))
342 (t (list :function-name
343 (or (and name (string name))
344 (string (sb-kernel:%fun-name function))))))))))
345
346 (defun safe-function-source-location (fun name)
347 (if *debug-definition-finding*
348 (function-source-location fun name)
349 (handler-case (function-source-location fun name)
350 (error (e)
351 (list (list :error (format nil "Error: ~A" e)))))))
352
353 (defun method-definitions (gf)
354 (let ((methods (sb-mop:generic-function-methods gf))
355 (name (sb-mop:generic-function-name gf)))
356 (loop for method in methods
357 collect (list `(method ,name ,(sb-pcl::unparse-specializers method))
358 (safe-function-source-location method name)))))
359
360 (defun function-definitions (name)
361 (flet ((loc (fn name) (safe-function-source-location fn name)))
362 (append
363 (cond ((and (symbolp name) (macro-function name))
364 (list (list `(defmacro ,name)
365 (loc (macro-function name) name))))
366 ((fboundp name)
367 (let ((fn (fdefinition name)))
368 (typecase fn
369 (generic-function
370 (cons (list `(defgeneric ,name) (loc fn name))
371 (method-definitions fn)))
372 (t
373 (list (list `(function ,name) (loc fn name))))))))
374 (when (compiler-macro-function name)
375 (list (list `(define-compiler-macro ,name)
376 (loc (compiler-macro-function name) name)))))))
377
378 (defun transform-definitions (fun-info name)
379 (loop for xform in (sb-c::fun-info-transforms fun-info)
380 for loc = (safe-function-source-location
381 (sb-c::transform-function xform) name)
382 for typespec = (sb-kernel:type-specifier (sb-c::transform-type xform))
383 for note = (sb-c::transform-note xform)
384 for spec = (if (consp typespec)
385 `(sb-c:deftransform ,(second typespec) ,note)
386 `(sb-c:deftransform ,note))
387 collect `(,spec ,loc)))
388
389 (defun optimizer-definitions (fun-info fun-name)
390 (let ((otypes '((sb-c::fun-info-derive-type . sb-c:derive-type)
391 (sb-c::fun-info-ltn-annotate . sb-c:ltn-annotate)
392 (sb-c::fun-info-ltn-annotate . sb-c:ltn-annotate)
393 (sb-c::fun-info-optimizer . sb-c:optimizer))))
394 (loop for (reader . name) in otypes
395 for fn = (funcall reader fun-info)
396 when fn collect `((sb-c:defoptimizer ,name)
397 ,(safe-function-source-location fn fun-name)))))
398
399 (defun compiler-definitions (name)
400 (let ((fun-info (sb-int:info :function :info name)))
401 (when fun-info
402 (append (transform-definitions fun-info name)
403 (optimizer-definitions fun-info name)))))
404
405 (defimplementation find-definitions (name)
406 (append (function-definitions name)
407 (compiler-definitions name)))
408
409 (defimplementation describe-symbol-for-emacs (symbol)
410 "Return a plist describing SYMBOL.
411 Return NIL if the symbol is unbound."
412 (let ((result '()))
413 (labels ((doc (kind)
414 (or (documentation symbol kind) :not-documented))
415 (maybe-push (property value)
416 (when value
417 (setf result (list* property value result)))))
418 (maybe-push
419 :variable (multiple-value-bind (kind recorded-p)
420 (sb-int:info :variable :kind symbol)
421 (declare (ignore kind))
422 (if (or (boundp symbol) recorded-p)
423 (doc 'variable))))
424 (maybe-push
425 :function (if (fboundp symbol)
426 (doc 'function)))
427 (maybe-push
428 :setf (if (or (sb-int:info :setf :inverse symbol)
429 (sb-int:info :setf :expander symbol))
430 (doc 'setf)))
431 (maybe-push
432 :type (if (sb-int:info :type :kind symbol)
433 (doc 'type)))
434 result)))
435
436 (defimplementation describe-definition (symbol type)
437 (case type
438 (:variable
439 (describe symbol))
440 (:function
441 (describe (symbol-function symbol)))
442 (:setf
443 (describe (or (sb-int:info :setf :inverse symbol)
444 (sb-int:info :setf :expander symbol))))
445 (:class
446 (describe (find-class symbol)))
447 (:type
448 (describe (sb-kernel:values-specifier-type symbol)))))
449
450 (defun function-dspec (fn)
451 "Describe where the function FN was defined.
452 Return a list of the form (NAME LOCATION)."
453 (let ((name (sb-kernel:%fun-name fn)))
454 (list name (safe-function-source-location fn name))))
455
456 (defimplementation list-callers (symbol)
457 (let ((fn (fdefinition symbol)))
458 (mapcar #'function-dspec (sb-introspect:find-function-callers fn))))
459
460 (defimplementation list-callees (symbol)
461 (let ((fn (fdefinition symbol)))
462 (mapcar #'function-dspec (sb-introspect:find-function-callees fn))))
463
464 ;;; macroexpansion
465
466 (defimplementation macroexpand-all (form)
467 (let ((sb-walker:*walk-form-expand-macros-p* t))
468 (sb-walker:walk-form form)))
469
470
471 ;;; Debugging
472
473 (defvar *sldb-stack-top*)
474
475 (defimplementation call-with-debugging-environment (debugger-loop-fn)
476 (declare (type function debugger-loop-fn))
477 (let* ((*sldb-stack-top* (or sb-debug:*stack-top-hint* (sb-di:top-frame)))
478 (sb-debug:*stack-top-hint* nil))
479 (handler-bind ((sb-di:debug-condition
480 (lambda (condition)
481 (signal (make-condition
482 'sldb-condition
483 :original-condition condition)))))
484 (funcall debugger-loop-fn))))
485
486 (defimplementation call-with-debugger-hook (hook fun)
487 (let ((sb-ext:*invoke-debugger-hook* hook))
488 (funcall fun)))
489
490 (defun nth-frame (index)
491 (do ((frame *sldb-stack-top* (sb-di:frame-down frame))
492 (i index (1- i)))
493 ((zerop i) frame)))
494
495 (defimplementation compute-backtrace (start end)
496 "Return a list of frames starting with frame number START and
497 continuing to frame number END or, if END is nil, the last frame on the
498 stack."
499 (let ((end (or end most-positive-fixnum)))
500 (loop for f = (nth-frame start) then (sb-di:frame-down f)
501 for i from start below end
502 while f
503 collect f)))
504
505 (defimplementation print-frame (frame stream)
506 (let ((*standard-output* stream))
507 (sb-debug::print-frame-call frame :verbosity 1 :number nil)))
508
509 (defun code-location-source-path (code-location)
510 (let* ((location (sb-debug::maybe-block-start-location code-location))
511 (form-num (sb-di:code-location-form-number location)))
512 (let ((translations (sb-debug::get-toplevel-form location)))
513 (unless (< form-num (length translations))
514 (error "Source path no longer exists."))
515 (reverse (cdr (svref translations form-num))))))
516
517 (defun code-location-file-position (code-location)
518 (let* ((debug-source (sb-di:code-location-debug-source code-location))
519 (filename (sb-di:debug-source-name debug-source))
520 (path (code-location-source-path code-location)))
521 (source-path-file-position path filename)))
522
523 ;;; source-path-file-position and friends are in swank-source-path-parser
524
525 (defun debug-source-info-from-emacs-buffer-p (debug-source)
526 (let ((info (sb-c::debug-source-info debug-source)))
527 (and info
528 (consp info)
529 (eq :emacs-buffer (car info)))))
530
531 (defun source-location-for-emacs (code-location)
532 (let* ((debug-source (sb-di:code-location-debug-source code-location))
533 (from (sb-di:debug-source-from debug-source))
534 (name (sb-di:debug-source-name debug-source)))
535 (ecase from
536 (:file
537 (let ((source-path (ignore-errors
538 (code-location-source-path code-location))))
539 (cond (source-path
540 ;; XXX: code-location-source-path reads the source !!
541 (let ((position (code-location-file-position code-location)))
542 (make-location
543 (list :file (namestring (truename name)))
544 (list :source-path source-path position))))
545 (t
546 (let* ((dfn (sb-di:code-location-debug-fun code-location))
547 (fn (sb-di:debug-fun-fun dfn)))
548 (unless fn
549 (error "Cannot find source location for: ~A "
550 code-location))
551 (function-source-location
552 fn (sb-di:debug-fun-name dfn)))))))
553
554 (:lisp
555 (make-location
556 (list :source-form (with-output-to-string (*standard-output*)
557 (sb-debug::print-code-location-source-form
558 code-location 100)))
559 (list :position 0))))))
560
561 (defun safe-source-location-for-emacs (code-location)
562 (handler-case (source-location-for-emacs code-location)
563 (error (c) (list :error (format nil "~A" c)))))
564
565 (defimplementation frame-source-location-for-emacs (index)
566 (safe-source-location-for-emacs
567 (sb-di:frame-code-location (nth-frame index))))
568
569 (defun frame-debug-vars (frame)
570 "Return a vector of debug-variables in frame."
571 (sb-di::debug-fun-debug-vars (sb-di:frame-debug-fun frame)))
572
573 (defun debug-var-value (var frame location)
574 (ecase (sb-di:debug-var-validity var location)
575 (:valid (sb-di:debug-var-value var frame))
576 ((:invalid :unknown) ':<not-available>)))
577
578 (defimplementation frame-locals (index)
579 (let* ((frame (nth-frame index))
580 (loc (sb-di:frame-code-location frame))
581 (vars (frame-debug-vars frame)))
582 (loop for v across vars collect
583 (list :name (sb-di:debug-var-symbol v)
584 :id (sb-di:debug-var-id v)
585 :value (debug-var-value v frame loc)))))
586
587 (defimplementation frame-var-value (frame var)
588 (let* ((frame (nth-frame frame))
589 (dvar (aref (frame-debug-vars frame) var)))
590 (debug-var-value dvar frame (sb-di:frame-code-location frame))))
591
592 (defimplementation frame-catch-tags (index)
593 (mapcar #'car (sb-di:frame-catches (nth-frame index))))
594
595 (defimplementation eval-in-frame (form index)
596 (let ((frame (nth-frame index)))
597 (funcall (the function
598 (sb-di:preprocess-for-eval form
599 (sb-di:frame-code-location frame)))
600 frame)))
601
602 (defun sb-debug-catch-tag-p (tag)
603 (and (symbolp tag)
604 (not (symbol-package tag))
605 (string= tag :sb-debug-catch-tag)))
606
607 (defimplementation return-from-frame (index form)
608 (let* ((frame (nth-frame index))
609 (probe (assoc-if #'sb-debug-catch-tag-p
610 (sb-di::frame-catches frame))))
611 (cond (probe (throw (car probe) (eval-in-frame form index)))
612 (t (format nil "Cannot return from frame: ~S" frame)))))
613
614 ;;;;; reference-conditions
615
616 (defimplementation format-sldb-condition (condition)
617 (let ((sb-int:*print-condition-references* nil))
618 (princ-to-string condition)))
619
620 (defimplementation condition-references (condition)
621 (if (typep condition 'sb-int:reference-condition)
622 (sb-int:reference-condition-references condition)
623 '()))
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 (defimplementation profile-package (package callers methods)
649 (declare (ignore callers methods))
650 (eval `(sb-profile:profile ,(package-name (find-package package)))))
651
652
653 ;;;; Inspector
654
655 (defclass sbcl-inspector (inspector)
656 ())
657
658 (defimplementation make-default-inspector ()
659 (make-instance 'sbcl-inspector))
660
661 (defmethod inspect-for-emacs ((o t) (inspector sbcl-inspector))
662 (declare (ignore inspector))
663 (cond ((sb-di::indirect-value-cell-p o)
664 (values "A value cell."
665 `("Value: " (:value ,(sb-kernel:value-cell-ref o)))))
666 (t
667 (multiple-value-bind (text labeledp parts)
668 (sb-impl::inspected-parts o)
669 (if labeledp
670 (values text
671 (loop for (label . value) in parts
672 collect `(:value ,label)
673 collect " = "
674 collect `(:value ,value)
675 collect '(:newline)))
676 (values text
677 (loop for value in parts
678 for i from 0
679 collect (princ-to-string i)
680 collect " = "
681 collect `(:value ,value)
682 collect '(:newline))))))))
683
684 (defmethod inspect-for-emacs ((o function) (inspector sbcl-inspector))
685 (declare (ignore inspector))
686 (let ((header (sb-kernel:widetag-of o)))
687 (cond ((= header sb-vm:simple-fun-header-widetag)
688 (values "A simple-fun."
689 `("Name: " (:value ,(sb-kernel:%simple-fun-name o))
690 (:newline)
691 "Arglist: " (:value ,(sb-kernel:%simple-fun-arglist o))
692 (:newline)
693 ,@(when (documentation o t)
694 `("Documentation: " (:newline) ,(documentation o t) (:newline)))
695 "Self: " (:value ,(sb-kernel:%simple-fun-self o))
696 (:newline)
697 "Next: " (:value ,(sb-kernel:%simple-fun-next o))
698 (:newline)
699 "Type: " (:value ,(sb-kernel:%simple-fun-type o))
700 (:newline)
701 "Code Object: " (:value ,(sb-kernel:fun-code-header o)))))
702 ((= header sb-vm:closure-header-widetag)
703 (values "A closure."
704 `("Function: " (:value ,(sb-kernel:%closure-fun o))
705 (:newline)
706 ,@(when (documentation o t)
707 `("Documentation: " (:newline) ,(documentation o t) (:newline)))
708 "Closed over values:"
709 (:newline)
710 ,@(loop for i from 0
711 below (- (sb-kernel:get-closure-length o)
712 (1- sb-vm:closure-info-offset))
713 collect (princ-to-string i)
714 collect " = "
715 collect `(:value ,(sb-kernel:%closure-index-ref o i))
716 collect '(:newline)))))
717 (t (call-next-method o)))))
718
719 (defmethod inspect-for-emacs ((o sb-kernel:code-component) (_ sbcl-inspector))
720 (declare (ignore _))
721 (values (format nil "~A is a code data-block." o)
722 (append
723 (label-value-line*
724 (:code-size (sb-kernel:%code-code-size o))
725 (:entry-points (sb-kernel:%code-entry-points o))
726 (:debug-info (sb-kernel:%code-debug-info o))
727 (:trace-table-offset (sb-kernel:code-header-ref
728 o sb-vm:code-trace-table-offset-slot)))
729 `("Constants:" (:newline))
730 (loop for i from sb-vm:code-constants-offset
731 below (sb-kernel:get-header-data o)
732 append (label-value-line i (sb-kernel:code-header-ref o i)))
733 `("Code:" (:newline)
734 , (with-output-to-string (s)
735 (cond ((sb-kernel:%code-debug-info o)
736 (sb-disassem:disassemble-code-component o :stream s))
737 (t
738 (sb-disassem:disassemble-memory
739 (sb-disassem::align
740 (+ (logandc2 (sb-kernel:get-lisp-obj-address o)
741 sb-vm:lowtag-mask)
742 (* sb-vm:code-constants-offset sb-vm:n-word-bytes))
743 (ash 1 sb-vm:n-lowtag-bits))
744 (ash (sb-kernel:%code-code-size o) sb-vm:word-shift)
745 :stream s))))))))
746
747 (defmethod inspect-for-emacs ((o sb-kernel:fdefn) (inspector sbcl-inspector))
748 (declare (ignore inspector))
749 (values "A fdefn object."
750 `("Name: " (:value ,(sb-kernel:fdefn-name o))
751 (:newline)
752 "Function" (:value,(sb-kernel:fdefn-fun o))
753 (:newline)
754 ,@(when (documentation o t)
755 `("Documentation: " (:newline) ,(documentation o t) (:newline))))))
756
757 (defmethod inspect-for-emacs :around ((o generic-function) (inspector sbcl-inspector))
758 (declare (ignore inspector))
759 (multiple-value-bind (title contents)
760 (call-next-method)
761 (values title
762 (append contents
763 `("Pretty arglist: " (:value ,(sb-pcl::generic-function-pretty-arglist o))
764 (:newline)
765 "Initial methods: " (:value ,(sb-pcl::generic-function-initial-methods o)))))))
766
767
768 ;;;; Support for SBCL syntax
769
770 (defun feature-in-list-p (feature list)
771 (etypecase feature
772 (symbol (member feature list :test #'eq))
773 (cons (flet ((subfeature-in-list-p (subfeature)
774 (feature-in-list-p subfeature list)))
775 (ecase (first feature)
776 (:or (some #'subfeature-in-list-p (rest feature)))
777 (:and (every #'subfeature-in-list-p (rest feature)))
778 (:not (destructuring-bind (e) (cdr feature)
779 (not (subfeature-in-list-p e)))))))))
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 (defun %thread-state-slot (thread)
860 (sb-sys:without-gcing
861 (sb-kernel:make-lisp-obj
862 (sb-sys:sap-int
863 (sb-sys:sap-ref-sap (sb-thread::thread-sap-from-id thread)
864 (* sb-vm::thread-state-slot
865 sb-vm::n-word-bytes))))))
866
867 (defun %thread-state (thread)
868 (ecase (%thread-state-slot thread)
869 (0 :running)
870 (1 :stopping)
871 (2 :stopped)
872 (3 :dead)))
873
874 (defimplementation thread-status (thread)
875 (string (%thread-state thread)))
876
877 (defimplementation make-lock (&key name)
878 (sb-thread:make-mutex :name name))
879
880 (defimplementation call-with-lock-held (lock function)
881 (declare (type function function))
882 (sb-thread:with-mutex (lock) (funcall function)))
883
884 (defimplementation current-thread ()
885 (sb-thread:current-thread-id))
886
887 (defimplementation all-threads ()
888 (let ((pids (sb-sys:without-gcing
889 (sb-thread::mapcar-threads
890 (lambda (sap)
891 (sb-sys:sap-ref-32 sap (* sb-vm:n-word-bytes
892 sb-vm::thread-pid-slot)))))))
893 (remove :dead pids :key #'%thread-state)))
894
895 (defimplementation interrupt-thread (thread fn)
896 (sb-thread:interrupt-thread thread fn))
897
898 (defimplementation kill-thread (thread)
899 (sb-thread:terminate-thread thread))
900
901 (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))
902 (defvar *mailboxes* (list))
903 (declaim (type list *mailboxes*))
904
905 (defstruct (mailbox (:conc-name mailbox.))
906 thread
907 (mutex (sb-thread:make-mutex))
908 (waitqueue (sb-thread:make-waitqueue))
909 (queue '() :type list))
910
911 (defun mailbox (thread)
912 "Return THREAD's mailbox."
913 (sb-thread:with-mutex (*mailbox-lock*)
914 (or (find thread *mailboxes* :key #'mailbox.thread)
915 (let ((mb (make-mailbox :thread thread)))
916 (push mb *mailboxes*)
917 mb))))
918
919 (defimplementation send (thread message)
920 (let* ((mbox (mailbox thread))
921 (mutex (mailbox.mutex mbox)))
922 (sb-thread:with-mutex (mutex)
923 (setf (mailbox.queue mbox)
924 (nconc (mailbox.queue mbox) (list message)))
925 (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
926
927 (defimplementation receive ()
928 (let* ((mbox (mailbox (sb-thread:current-thread-id)))
929 (mutex (mailbox.mutex mbox)))
930 (sb-thread:with-mutex (mutex)
931 (loop
932 (let ((q (mailbox.queue mbox)))
933 (cond (q (return (pop (mailbox.queue mbox))))
934 (t (sb-thread:condition-wait (mailbox.waitqueue mbox)
935 mutex))))))))
936
937 )
938
939
940 ;;Trace implementations
941 ;;In SBCL, we have:
942 ;; (trace <name>)
943 ;; (trace :methods '<name>) ;to trace all methods of the gf <name>
944 ;; (trace (method <name> <qualifier>? (<specializer>+)))
945 ;; <name> can be a normal name or a (setf name)
946
947 (defun toggle-trace (fspec &rest args)
948 (cond ((member fspec (eval '(trace)) :test #'equal)
949 (eval `(untrace ,fspec))
950 (format nil "~S is now untraced." fspec))
951 (t
952 (eval `(trace ,@(if args `(:encapsulate nil) (list)) ,fspec ,@args))
953 (format nil "~S is now traced." fspec))))
954
955 (defimplementation toggle-trace-generic-function-methods (name)
956 (toggle-trace name :methods t))
957
958 (defun process-fspec (fspec)
959 (cond ((consp fspec)
960 (ecase (first fspec)
961 ((:defun :defgeneric) (second fspec))
962 ((:defmethod) `(method ,@(rest fspec)))
963 ((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec)))
964 ((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec)))))
965 (t
966 fspec)))
967
968 (defimplementation toggle-trace-function (spec)
969 (toggle-trace spec))
970
971 (defimplementation toggle-trace-method (spec)
972 (toggle-trace `(sb-pcl::fast-method ,@(rest (process-fspec spec)))))
973
974 (defimplementation toggle-trace-fdefinition-wherein (name wherein)
975 (toggle-trace name :wherein (process-fspec wherein)))

  ViewVC Help
Powered by ViewVC 1.1.5