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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.119 - (hide annotations)
Mon Feb 28 23:32:06 2005 UTC (9 years, 1 month ago) by heller
Branch: MAIN
Changes since 1.118: +12 -12 lines
(toggle-trace): Update tracing code for new interface.
1 heller 1.60 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
2 dbarlow 1.1 ;;;
3     ;;; swank-sbcl.lisp --- SLIME backend for SBCL.
4     ;;;
5     ;;; Created 2003, Daniel Barlow <dan@metacircles.com>
6     ;;;
7     ;;; This code has been placed in the Public Domain. All warranties are
8     ;;; disclaimed.
9    
10 heller 1.106 ;;; Requires the SB-INTROSPECT contrib.
11 dbarlow 1.1
12     ;;; Administrivia
13    
14     (eval-when (:compile-toplevel :load-toplevel :execute)
15     (require 'sb-bsd-sockets)
16 heller 1.59 (require 'sb-introspect)
17 heller 1.60 (require 'sb-posix)
18 heller 1.59 )
19 dbarlow 1.1
20 heller 1.107
21 heller 1.74 (in-package :swank-backend)
22 heller 1.107 (declaim (optimize (debug 2)))
23 dbarlow 1.1
24 heller 1.23 (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 mbaringer 1.100 ;;; swank-mop
38    
39 heller 1.106 (import-swank-mop-symbols :sb-mop '(:slot-definition-documentation))
40 mbaringer 1.100
41 mbaringer 1.101 (defun swank-mop:slot-definition-documentation (slot)
42     (sb-pcl::documentation slot t))
43 mbaringer 1.100
44 dbarlow 1.1 ;;; TCP Server
45    
46 heller 1.74 (defimplementation preferred-communication-style ()
47 lgorrie 1.94 (if (and (sb-int:featurep :sb-thread)
48     (sb-int:featurep :sb-futex))
49     :spawn
50     :fd-handler))
51 heller 1.82
52 heller 1.65 (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 dbarlow 1.6 (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
58     :type :stream
59     :protocol :tcp)))
60 heller 1.48 (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
61 heller 1.65 (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port)
62 dbarlow 1.6 (sb-bsd-sockets:socket-listen socket 5)
63 heller 1.29 socket))
64    
65 lgorrie 1.54 (defimplementation local-port (socket)
66 lgorrie 1.46 (nth-value 1 (sb-bsd-sockets:socket-name socket)))
67    
68 lgorrie 1.54 (defimplementation close-socket (socket)
69 lgorrie 1.86 (sb-sys:invalidate-descriptor (socket-fd socket))
70 heller 1.48 (sb-bsd-sockets:socket-close socket))
71    
72 heller 1.115 (defimplementation accept-connection (socket
73     &key (external-format :iso-latin-1-unix))
74 heller 1.110 (make-socket-io-stream (accept socket) external-format))
75 heller 1.48
76 heller 1.59 (defvar *sigio-handlers* '()
77     "List of (key . fn) pairs to be called on SIGIO.")
78    
79     (defun sigio-handler (signal code scp)
80 heller 1.60 (declare (ignore signal code scp))
81     (mapc (lambda (handler)
82     (funcall (the function (cdr handler))))
83     *sigio-handlers*))
84 heller 1.59
85     (defun set-sigio-handler ()
86 heller 1.82 (sb-sys:enable-interrupt sb-unix:sigio (lambda (signal code scp)
87 heller 1.59 (sigio-handler signal code scp))))
88    
89 heller 1.62 (defun enable-sigio-on-fd (fd)
90 heller 1.82 (sb-posix::fcntl fd sb-posix::f-setfl sb-posix::o-async)
91     (sb-posix::fcntl fd sb-posix::f-setown (getpid)))
92 heller 1.62
93 heller 1.67 (defimplementation add-sigio-handler (socket fn)
94 heller 1.62 (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 heller 1.67 (defimplementation remove-sigio-handlers (socket)
101 heller 1.59 (let ((fd (socket-fd socket)))
102     (setf *sigio-handlers* (delete fd *sigio-handlers* :key #'car))
103     (sb-sys:invalidate-descriptor fd))
104 heller 1.51 (close socket))
105 heller 1.67
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 heller 1.51
117 heller 1.48 (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 heller 1.110 (defun make-socket-io-stream (socket external-format)
124     (let ((encoding (ecase external-format
125     (:iso-latin-1-unix :iso-8859-1)
126 heller 1.112 #+sb-unicode
127 heller 1.110 (:utf-8-unix :utf-8))))
128     (sb-bsd-sockets:socket-make-stream socket
129     :output t
130     :input t
131     :element-type 'character
132 heller 1.112 #+sb-unicode :external-format
133     #+sb-unicode encoding
134     )))
135 lgorrie 1.46
136 heller 1.29 (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 dbarlow 1.6
142 heller 1.52 (defmethod call-without-interrupts (fn)
143 heller 1.58 (declare (type function fn))
144 heller 1.52 (sb-sys:without-interrupts (funcall fn)))
145    
146 heller 1.81 (defimplementation getpid ()
147 lgorrie 1.80 (sb-posix:getpid))
148 heller 1.52
149 heller 1.68 (defimplementation lisp-implementation-type-name ()
150     "sbcl")
151    
152 heller 1.85 (defimplementation quit-lisp ()
153     (sb-ext:quit))
154    
155 dbarlow 1.1 ;;; Utilities
156    
157 mbaringer 1.100 (defimplementation arglist ((fname t))
158 heller 1.74 (sb-introspect:function-arglist fname))
159 mbaringer 1.100
160     (defimplementation function-name ((f function))
161     (sb-impl::%fun-name f))
162 dbarlow 1.1
163 dbarlow 1.42 (defvar *buffer-name* nil)
164 dbarlow 1.1 (defvar *buffer-offset*)
165 heller 1.70 (defvar *buffer-substring* nil)
166 dbarlow 1.1
167 lgorrie 1.24 (defvar *previous-compiler-condition* nil
168     "Used to detect duplicates.")
169    
170 dbarlow 1.1 (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 heller 1.36 (unless (eq condition *previous-compiler-condition*)
178 dbarlow 1.1 (setq *previous-compiler-condition* condition)
179 lgorrie 1.24 (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 lgorrie 1.96 (warning :warning)
190     (error :error))
191 heller 1.66 :short-message (brief-compiler-message-for-emacs condition)
192 heller 1.107 :references (condition-references (real-condition condition))
193 heller 1.66 :message (long-compiler-message-for-emacs condition context)
194 lgorrie 1.24 :location (compiler-note-location context))))
195 heller 1.107
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 lgorrie 1.24
202     (defun compiler-note-location (context)
203 dbarlow 1.42 (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 dbarlow 1.43 `(:file ,(namestring (truename f)))
219 dbarlow 1.42 `(:position ,(1+ (source-path-file-position path f)))))
220    
221 heller 1.85 ;; 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 heller 1.88 ;; Remove the surrounding lambda from the path (was added by
224 heller 1.85 ;; 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 dbarlow 1.42 (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 heller 1.82 (list :error "No error location available"))
244 dbarlow 1.42
245 heller 1.66 (defun brief-compiler-message-for-emacs (condition)
246 dbarlow 1.1 "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 crhodes 1.95 (let ((sb-int:*print-condition-references* nil))
251     (princ-to-string condition)))
252 heller 1.66
253     (defun long-compiler-message-for-emacs (condition error-context)
254     "Describe a compiler error for Emacs including context information."
255 heller 1.45 (declare (type (or sb-c::compiler-error-context null) error-context))
256 heller 1.66 (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 crhodes 1.95 (let ((sb-int:*print-condition-references* nil))
261     (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~%~}~]~A"
262     enclosing source condition))))
263 dbarlow 1.1
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 lgorrie 1.54 (defimplementation call-with-compilation-hooks (function)
277 heller 1.58 (declare (type function function))
278 lgorrie 1.96 (handler-bind ((sb-c:fatal-compiler-error #'handle-file-compiler-termination)
279     (sb-c:compiler-error #'handle-notification-condition)
280 dbarlow 1.41 (sb-ext:compiler-note #'handle-notification-condition)
281     (style-warning #'handle-notification-condition)
282     (warning #'handle-notification-condition))
283     (funcall function)))
284 lgorrie 1.24
285 lgorrie 1.96 (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 heller 1.91 (defvar *trap-load-time-warnings* nil)
291    
292 heller 1.74 (defimplementation swank-compile-file (filename load-p)
293 lgorrie 1.96 (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 lgorrie 1.24
300 pseibel 1.98 (defimplementation swank-compile-string (string &key buffer position directory)
301     (declare (ignore directory))
302 heller 1.91 (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 dbarlow 1.1
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 heller 1.36 (defun function-source-location (function &optional name)
323 dbarlow 1.1 "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 heller 1.32 (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 heller 1.36 (list :error (format nil "No filename for: ~S" function))))
331 heller 1.32 (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 heller 1.36 (t (list :function-name
343     (or (and name (string name))
344 heller 1.74 (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 heller 1.75 collect (list `(method ,name ,(sb-pcl::unparse-specializers method))
358 heller 1.74 (safe-function-source-location method name)))))
359    
360 heller 1.81 (defun function-definitions (name)
361     (flet ((loc (fn name) (safe-function-source-location fn name)))
362 heller 1.105 (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 heller 1.74
405 heller 1.81 (defimplementation find-definitions (name)
406 heller 1.105 (append (function-definitions name)
407     (compiler-definitions name)))
408 lgorrie 1.24
409 lgorrie 1.54 (defimplementation describe-symbol-for-emacs (symbol)
410 dbarlow 1.1 "Return a plist describing SYMBOL.
411     Return NIL if the symbol is unbound."
412     (let ((result '()))
413 lgorrie 1.24 (labels ((doc (kind)
414     (or (documentation symbol kind) :not-documented))
415 dbarlow 1.1 (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 lgorrie 1.24 result)))
435 dbarlow 1.1
436 heller 1.74 (defimplementation describe-definition (symbol type)
437 lgorrie 1.54 (case type
438     (:variable
439 heller 1.74 (describe symbol))
440     (:function
441     (describe (symbol-function symbol)))
442 lgorrie 1.54 (:setf
443 heller 1.74 (describe (or (sb-int:info :setf :inverse symbol)
444     (sb-int:info :setf :expander symbol))))
445 lgorrie 1.54 (:class
446 heller 1.74 (describe (find-class symbol)))
447 lgorrie 1.54 (:type
448 heller 1.74 (describe (sb-kernel:values-specifier-type symbol)))))
449 dbarlow 1.1
450 heller 1.97 (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 dbarlow 1.4 ;;; macroexpansion
465 dbarlow 1.1
466 lgorrie 1.54 (defimplementation macroexpand-all (form)
467 heller 1.21 (let ((sb-walker:*walk-form-expand-macros-p* t))
468     (sb-walker:walk-form form)))
469 lgorrie 1.25
470 dbarlow 1.1
471     ;;; Debugging
472    
473     (defvar *sldb-stack-top*)
474    
475 lgorrie 1.54 (defimplementation call-with-debugging-environment (debugger-loop-fn)
476 heller 1.58 (declare (type function debugger-loop-fn))
477 lgorrie 1.25 (let* ((*sldb-stack-top* (or sb-debug:*stack-top-hint* (sb-di:top-frame)))
478 heller 1.71 (sb-debug:*stack-top-hint* nil))
479 dbarlow 1.1 (handler-bind ((sb-di:debug-condition
480     (lambda (condition)
481 lgorrie 1.25 (signal (make-condition
482     'sldb-condition
483     :original-condition condition)))))
484     (funcall debugger-loop-fn))))
485 dbarlow 1.1
486 heller 1.118 (defimplementation call-with-debugger-hook (hook fun)
487     (let ((sb-ext:*invoke-debugger-hook* hook))
488     (funcall fun)))
489    
490 dbarlow 1.1 (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 heller 1.74 (defimplementation compute-backtrace (start end)
496 dbarlow 1.1 "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 heller 1.45 (loop for f = (nth-frame start) then (sb-di:frame-down f)
501     for i from start below end
502     while f
503 heller 1.74 collect f)))
504 dbarlow 1.1
505 heller 1.74 (defimplementation print-frame (frame stream)
506     (let ((*standard-output* stream))
507     (sb-debug::print-frame-call frame :verbosity 1 :number nil)))
508 dbarlow 1.1
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 dbarlow 1.44 ;;; source-path-file-position and friends are in swank-source-path-parser
524 dbarlow 1.1
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 heller 1.32 (ecase from
536     (:file
537 heller 1.36 (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 heller 1.32 (: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 dbarlow 1.1
561     (defun safe-source-location-for-emacs (code-location)
562     (handler-case (source-location-for-emacs code-location)
563 heller 1.36 (error (c) (list :error (format nil "~A" c)))))
564    
565 lgorrie 1.54 (defimplementation frame-source-location-for-emacs (index)
566 heller 1.22 (safe-source-location-for-emacs
567     (sb-di:frame-code-location (nth-frame index))))
568 dbarlow 1.1
569 heller 1.92 (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 lgorrie 1.54 (defimplementation frame-locals (index)
579 dbarlow 1.1 (let* ((frame (nth-frame index))
580 heller 1.92 (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 dbarlow 1.1
592 lgorrie 1.54 (defimplementation frame-catch-tags (index)
593 heller 1.74 (mapcar #'car (sb-di:frame-catches (nth-frame index))))
594 lgorrie 1.50
595 heller 1.56 (defimplementation eval-in-frame (form index)
596     (let ((frame (nth-frame index)))
597 heller 1.58 (funcall (the function
598     (sb-di:preprocess-for-eval form
599     (sb-di:frame-code-location frame)))
600 heller 1.56 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 lgorrie 1.87 ;;;;; 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 heller 1.57
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 heller 1.116 (defimplementation profile-package (package callers methods)
649     (declare (ignore callers methods))
650     (eval `(sb-profile:profile ,(package-name (find-package package)))))
651    
652 heller 1.57
653 heller 1.64 ;;;; Inspector
654 heller 1.63
655 mbaringer 1.102 (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 heller 1.64 (cond ((sb-di::indirect-value-cell-p o)
664 mbaringer 1.102 (values "A value cell."
665     `("Value: " (:value ,(sb-kernel:value-cell-ref o)))))
666 heller 1.64 (t
667     (multiple-value-bind (text labeledp parts)
668     (sb-impl::inspected-parts o)
669 mbaringer 1.102 (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 heller 1.64
684 mbaringer 1.102 (defmethod inspect-for-emacs ((o function) (inspector sbcl-inspector))
685     (declare (ignore inspector))
686 heller 1.64 (let ((header (sb-kernel:widetag-of o)))
687     (cond ((= header sb-vm:simple-fun-header-widetag)
688 mbaringer 1.102 (values "A simple-fun."
689 mbaringer 1.103 `("Name: " (:value ,(sb-kernel:%simple-fun-name o))
690 mbaringer 1.102 (:newline)
691 mbaringer 1.103 "Arglist: " (:value ,(sb-kernel:%simple-fun-arglist o))
692 mbaringer 1.102 (:newline)
693 mbaringer 1.103 ,@(when (documentation o t)
694     `("Documentation: " (:newline) ,(documentation o t) (:newline)))
695     "Self: " (:value ,(sb-kernel:%simple-fun-self o))
696 mbaringer 1.102 (:newline)
697 mbaringer 1.103 "Next: " (:value ,(sb-kernel:%simple-fun-next o))
698 mbaringer 1.102 (:newline)
699     "Type: " (:value ,(sb-kernel:%simple-fun-type o))
700     (:newline)
701     "Code Object: " (:value ,(sb-kernel:fun-code-header o)))))
702 heller 1.64 ((= header sb-vm:closure-header-widetag)
703 mbaringer 1.102 (values "A closure."
704     `("Function: " (:value ,(sb-kernel:%closure-fun o))
705     (:newline)
706 mbaringer 1.103 ,@(when (documentation o t)
707     `("Documentation: " (:newline) ,(documentation o t) (:newline)))
708 mbaringer 1.102 "Closed over values:"
709     (:newline)
710     ,@(loop for i from 0
711 heller 1.64 below (- (sb-kernel:get-closure-length o)
712     (1- sb-vm:closure-info-offset))
713 mbaringer 1.102 collect (princ-to-string i)
714     collect " = "
715     collect `(:value ,(sb-kernel:%closure-index-ref o i))
716     collect '(:newline)))))
717 heller 1.64 (t (call-next-method o)))))
718    
719 heller 1.113 (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 mbaringer 1.102 below (sb-kernel:get-header-data o)
732 heller 1.113 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 mbaringer 1.102
747     (defmethod inspect-for-emacs ((o sb-kernel:fdefn) (inspector sbcl-inspector))
748 mbaringer 1.104 (declare (ignore inspector))
749 mbaringer 1.102 (values "A fdefn object."
750     `("Name: " (:value ,(sb-kernel:fdefn-name o))
751     (:newline)
752 mbaringer 1.103 "Function" (:value,(sb-kernel:fdefn-fun o))
753     (:newline)
754     ,@(when (documentation o t)
755     `("Documentation: " (:newline) ,(documentation o t) (:newline))))))
756 mbaringer 1.102
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 heller 1.88
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 heller 1.116 (:not (destructuring-bind (e) (cdr feature)
779     (not (subfeature-in-list-p e)))))))))
780 heller 1.88
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 heller 1.92 (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 heller 1.88 (defimplementation call-with-syntax-hooks (fn)
827 heller 1.89 (cond ((and *debootstrap-packages*
828 heller 1.88 (sbcl-package-p *package*))
829 heller 1.92 (with-debootstrapping (funcall fn)))
830 heller 1.88 (t
831     (funcall fn))))
832 heller 1.63
833 heller 1.90 (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 heller 1.63
839 lgorrie 1.50 ;;;; Multiprocessing
840    
841 heller 1.81 #+sb-thread
842 lgorrie 1.50 (progn
843 lgorrie 1.54 (defimplementation spawn (fn &key name)
844 lgorrie 1.50 (declare (ignore name))
845     (sb-thread:make-thread fn))
846    
847 heller 1.85 (defimplementation startup-multiprocessing ())
848 lgorrie 1.50
849 heller 1.93 (defimplementation thread-id (thread)
850     thread)
851    
852     (defimplementation find-thread (id)
853     (if (member id (all-threads))
854     id))
855    
856 heller 1.63 (defimplementation thread-name (thread)
857     (format nil "Thread ~D" thread))
858 lgorrie 1.50
859 heller 1.114 (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 heller 1.63 (defimplementation thread-status (thread)
875 heller 1.114 (string (%thread-state thread)))
876 lgorrie 1.50
877 lgorrie 1.54 (defimplementation make-lock (&key name)
878 lgorrie 1.50 (sb-thread:make-mutex :name name))
879    
880 lgorrie 1.54 (defimplementation call-with-lock-held (lock function)
881 heller 1.58 (declare (type function function))
882 lgorrie 1.50 (sb-thread:with-mutex (lock) (funcall function)))
883 heller 1.59
884     (defimplementation current-thread ()
885     (sb-thread:current-thread-id))
886    
887 heller 1.63 (defimplementation all-threads ()
888 heller 1.114 (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 heller 1.59
895     (defimplementation interrupt-thread (thread fn)
896     (sb-thread:interrupt-thread thread fn))
897    
898 heller 1.70 (defimplementation kill-thread (thread)
899     (sb-thread:terminate-thread thread))
900 heller 1.59
901     (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))
902     (defvar *mailboxes* (list))
903 heller 1.60 (declaim (type list *mailboxes*))
904 heller 1.59
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 mbaringer 1.117
939 heller 1.118
940 mbaringer 1.117 ;;Trace implementations
941     ;;In SBCL, we have:
942     ;; (trace <name>)
943 heller 1.118 ;; (trace :methods '<name>) ;to trace all methods of the gf <name>
944 mbaringer 1.117 ;; (trace (method <name> <qualifier>? (<specializer>+)))
945     ;; <name> can be a normal name or a (setf name)
946    
947 heller 1.119 (defun toggle-trace-aux (fspec &rest args)
948 mbaringer 1.117 (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     (defun process-fspec (fspec)
956     (cond ((consp fspec)
957     (ecase (first fspec)
958     ((:defun :defgeneric) (second fspec))
959     ((:defmethod) `(method ,@(rest fspec)))
960     ((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec)))
961     ((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec)))))
962     (t
963     fspec)))
964    
965 heller 1.119 (defimplementation toggle-trace (spec)
966     (ecase (car spec)
967     ((setf)
968     (toggle-trace-aux spec))
969     ((:defmethod)
970     (toggle-trace-aux `(sb-pcl::fast-method ,@(rest (process-fspec spec)))))
971     ((:defgeneric)
972     (toggle-trace-aux (second spec) :methods t))
973     ((:call)
974     (destructuring-bind (caller callee) (cdr spec)
975     (toggle-trace-aux callee :wherein (list (process-fspec caller)))))))

  ViewVC Help
Powered by ViewVC 1.1.5