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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.116 - (hide annotations)
Mon Jan 10 19:33:29 2005 UTC (9 years, 3 months ago) by heller
Branch: MAIN
Changes since 1.115: +6 -7 lines
(profile-package): Add implementation for SBCL.
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.108 (defimplementation emacs-connected ()
143 heller 1.91 (setq sb-ext:*invoke-debugger-hook*
144     (find-symbol (string :swank-debugger-hook) (find-package :swank))))
145    
146 heller 1.52 (defmethod call-without-interrupts (fn)
147 heller 1.58 (declare (type function fn))
148 heller 1.52 (sb-sys:without-interrupts (funcall fn)))
149    
150 heller 1.81 (defimplementation getpid ()
151 lgorrie 1.80 (sb-posix:getpid))
152 heller 1.52
153 heller 1.68 (defimplementation lisp-implementation-type-name ()
154     "sbcl")
155    
156 heller 1.85 (defimplementation quit-lisp ()
157     (sb-ext:quit))
158    
159 dbarlow 1.1 ;;; Utilities
160    
161 mbaringer 1.100 (defimplementation arglist ((fname t))
162 heller 1.74 (sb-introspect:function-arglist fname))
163 mbaringer 1.100
164     (defimplementation function-name ((f function))
165     (sb-impl::%fun-name f))
166 dbarlow 1.1
167 dbarlow 1.42 (defvar *buffer-name* nil)
168 dbarlow 1.1 (defvar *buffer-offset*)
169 heller 1.70 (defvar *buffer-substring* nil)
170 dbarlow 1.1
171 lgorrie 1.24 (defvar *previous-compiler-condition* nil
172     "Used to detect duplicates.")
173    
174 dbarlow 1.1 (defun handle-notification-condition (condition)
175     "Handle a condition caused by a compiler warning.
176     This traps all compiler conditions at a lower-level than using
177     C:*COMPILER-NOTIFICATION-FUNCTION*. The advantage is that we get to
178     craft our own error messages, which can omit a lot of redundant
179     information."
180     (let ((context (sb-c::find-error-context nil)))
181 heller 1.36 (unless (eq condition *previous-compiler-condition*)
182 dbarlow 1.1 (setq *previous-compiler-condition* condition)
183 lgorrie 1.24 (signal-compiler-condition condition context))))
184    
185     (defun signal-compiler-condition (condition context)
186     (signal (make-condition
187     'compiler-condition
188     :original-condition condition
189     :severity (etypecase condition
190     (sb-c:compiler-error :error)
191     (sb-ext:compiler-note :note)
192     (style-warning :style-warning)
193 lgorrie 1.96 (warning :warning)
194     (error :error))
195 heller 1.66 :short-message (brief-compiler-message-for-emacs condition)
196 heller 1.107 :references (condition-references (real-condition condition))
197 heller 1.66 :message (long-compiler-message-for-emacs condition context)
198 lgorrie 1.24 :location (compiler-note-location context))))
199 heller 1.107
200     (defun real-condition (condition)
201     "Return the encapsulated condition or CONDITION itself."
202     (typecase condition
203     (sb-int:encapsulated-condition (sb-int:encapsulated-condition condition))
204     (t condition)))
205 lgorrie 1.24
206     (defun compiler-note-location (context)
207 dbarlow 1.42 (cond (context
208     (resolve-note-location
209     *buffer-name*
210     (sb-c::compiler-error-context-file-name context)
211     (sb-c::compiler-error-context-file-position context)
212     (current-compiler-error-source-path context)
213     (sb-c::compiler-error-context-original-source context)))
214     (t
215     (resolve-note-location *buffer-name* nil nil nil nil))))
216    
217     (defgeneric resolve-note-location (buffer file-name file-position
218     source-path source))
219    
220     (defmethod resolve-note-location ((b (eql nil)) (f pathname) pos path source)
221     (make-location
222 dbarlow 1.43 `(:file ,(namestring (truename f)))
223 dbarlow 1.42 `(:position ,(1+ (source-path-file-position path f)))))
224    
225 heller 1.85 ;; SBCL doesn't have compile-from-stream, so C-c C-c ends up here
226     (defmethod resolve-note-location ((b string) (f (eql :lisp)) pos path source)
227 heller 1.88 ;; Remove the surrounding lambda from the path (was added by
228 heller 1.85 ;; swank-compile-string)
229     (destructuring-bind (_ form &rest rest) path
230     (declare (ignore _))
231     (make-location
232     `(:buffer ,b)
233     `(:position ,(+ *buffer-offset*
234     (source-path-string-position (list* (- form 2) rest)
235     *buffer-substring*))))))
236    
237 dbarlow 1.42 (defmethod resolve-note-location (b (f (eql :lisp)) pos path (source string))
238     (make-location
239     `(:source-form ,source)
240     `(:position 1)))
241    
242     (defmethod resolve-note-location (buffer
243     (file (eql nil))
244     (pos (eql nil))
245     (path (eql nil))
246     (source (eql nil)))
247 heller 1.82 (list :error "No error location available"))
248 dbarlow 1.42
249 heller 1.66 (defun brief-compiler-message-for-emacs (condition)
250 dbarlow 1.1 "Briefly describe a compiler error for Emacs.
251     When Emacs presents the message it already has the source popped up
252     and the source form highlighted. This makes much of the information in
253     the error-context redundant."
254 crhodes 1.95 (let ((sb-int:*print-condition-references* nil))
255     (princ-to-string condition)))
256 heller 1.66
257     (defun long-compiler-message-for-emacs (condition error-context)
258     "Describe a compiler error for Emacs including context information."
259 heller 1.45 (declare (type (or sb-c::compiler-error-context null) error-context))
260 heller 1.66 (multiple-value-bind (enclosing source)
261     (if error-context
262     (values (sb-c::compiler-error-context-enclosing-source error-context)
263     (sb-c::compiler-error-context-source error-context)))
264 crhodes 1.95 (let ((sb-int:*print-condition-references* nil))
265     (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~%~}~]~A"
266     enclosing source condition))))
267 dbarlow 1.1
268     (defun current-compiler-error-source-path (context)
269     "Return the source-path for the current compiler error.
270     Returns NIL if this cannot be determined by examining internal
271     compiler state."
272     (cond ((sb-c::node-p context)
273     (reverse
274     (sb-c::source-path-original-source
275     (sb-c::node-source-path context))))
276     ((sb-c::compiler-error-context-p context)
277     (reverse
278     (sb-c::compiler-error-context-original-source-path context)))))
279    
280 lgorrie 1.54 (defimplementation call-with-compilation-hooks (function)
281 heller 1.58 (declare (type function function))
282 lgorrie 1.96 (handler-bind ((sb-c:fatal-compiler-error #'handle-file-compiler-termination)
283     (sb-c:compiler-error #'handle-notification-condition)
284 dbarlow 1.41 (sb-ext:compiler-note #'handle-notification-condition)
285     (style-warning #'handle-notification-condition)
286     (warning #'handle-notification-condition))
287     (funcall function)))
288 lgorrie 1.24
289 lgorrie 1.96 (defun handle-file-compiler-termination (condition)
290     "Handle a condition that caused the file compiler to terminate."
291     (handle-notification-condition
292     (sb-int:encapsulated-condition condition)))
293    
294 heller 1.91 (defvar *trap-load-time-warnings* nil)
295    
296 heller 1.74 (defimplementation swank-compile-file (filename load-p)
297 lgorrie 1.96 (handler-case
298     (let ((output-file (with-compilation-hooks ()
299     (compile-file filename))))
300     (when (and load-p output-file)
301     (load output-file)))
302     (sb-c:fatal-compiler-error () nil)))
303 lgorrie 1.24
304 pseibel 1.98 (defimplementation swank-compile-string (string &key buffer position directory)
305     (declare (ignore directory))
306 heller 1.91 (let ((form (read-from-string (format nil "(~S () ~A)" 'lambda string))))
307     (flet ((compileit (cont)
308     (with-compilation-hooks ()
309     (let ((*buffer-name* buffer)
310     (*buffer-offset* position)
311     (*buffer-substring* string))
312     (funcall cont (compile nil form))))))
313     (cond (*trap-load-time-warnings*
314     (compileit #'funcall))
315     (t
316     (funcall (compileit #'identity)))))))
317 dbarlow 1.1
318     ;;;; Definitions
319    
320     (defvar *debug-definition-finding* nil
321     "When true don't handle errors while looking for definitions.
322     This is useful when debugging the definition-finding code.")
323    
324     ;;; FIXME we don't handle the compiled-interactively case yet. That
325     ;;; should have NIL :filename & :position, and non-NIL :source-form
326 heller 1.36 (defun function-source-location (function &optional name)
327 dbarlow 1.1 "Try to find the canonical source location of FUNCTION."
328     (let* ((def (sb-introspect:find-definition-source function))
329     (pathname (sb-introspect:definition-source-pathname def))
330 heller 1.32 (path (sb-introspect:definition-source-form-path def))
331     (position (sb-introspect:definition-source-character-offset def)))
332     (unless pathname
333     (return-from function-source-location
334 heller 1.36 (list :error (format nil "No filename for: ~S" function))))
335 heller 1.32 (multiple-value-bind (truename condition)
336     (ignore-errors (truename pathname))
337     (when condition
338     (return-from function-source-location
339     (list :error (format nil "~A" condition))))
340     (make-location
341     (list :file (namestring truename))
342     ;; source-paths depend on the file having been compiled with
343     ;; lotsa debugging. If not present, return the function name
344     ;; for emacs to attempt to find with a regex
345     (cond (path (list :source-path path position))
346 heller 1.36 (t (list :function-name
347     (or (and name (string name))
348 heller 1.74 (string (sb-kernel:%fun-name function))))))))))
349    
350     (defun safe-function-source-location (fun name)
351     (if *debug-definition-finding*
352     (function-source-location fun name)
353     (handler-case (function-source-location fun name)
354     (error (e)
355     (list (list :error (format nil "Error: ~A" e)))))))
356    
357     (defun method-definitions (gf)
358     (let ((methods (sb-mop:generic-function-methods gf))
359     (name (sb-mop:generic-function-name gf)))
360     (loop for method in methods
361 heller 1.75 collect (list `(method ,name ,(sb-pcl::unparse-specializers method))
362 heller 1.74 (safe-function-source-location method name)))))
363    
364 heller 1.81 (defun function-definitions (name)
365     (flet ((loc (fn name) (safe-function-source-location fn name)))
366 heller 1.105 (append
367     (cond ((and (symbolp name) (macro-function name))
368     (list (list `(defmacro ,name)
369     (loc (macro-function name) name))))
370     ((fboundp name)
371     (let ((fn (fdefinition name)))
372     (typecase fn
373     (generic-function
374     (cons (list `(defgeneric ,name) (loc fn name))
375     (method-definitions fn)))
376     (t
377     (list (list `(function ,name) (loc fn name))))))))
378     (when (compiler-macro-function name)
379     (list (list `(define-compiler-macro ,name)
380     (loc (compiler-macro-function name) name)))))))
381    
382     (defun transform-definitions (fun-info name)
383     (loop for xform in (sb-c::fun-info-transforms fun-info)
384     for loc = (safe-function-source-location
385     (sb-c::transform-function xform) name)
386     for typespec = (sb-kernel:type-specifier (sb-c::transform-type xform))
387     for note = (sb-c::transform-note xform)
388     for spec = (if (consp typespec)
389     `(sb-c:deftransform ,(second typespec) ,note)
390     `(sb-c:deftransform ,note))
391     collect `(,spec ,loc)))
392    
393     (defun optimizer-definitions (fun-info fun-name)
394     (let ((otypes '((sb-c::fun-info-derive-type . sb-c:derive-type)
395     (sb-c::fun-info-ltn-annotate . sb-c:ltn-annotate)
396     (sb-c::fun-info-ltn-annotate . sb-c:ltn-annotate)
397     (sb-c::fun-info-optimizer . sb-c:optimizer))))
398     (loop for (reader . name) in otypes
399     for fn = (funcall reader fun-info)
400     when fn collect `((sb-c:defoptimizer ,name)
401     ,(safe-function-source-location fn fun-name)))))
402    
403     (defun compiler-definitions (name)
404     (let ((fun-info (sb-int:info :function :info name)))
405     (when fun-info
406     (append (transform-definitions fun-info name)
407     (optimizer-definitions fun-info name)))))
408 heller 1.74
409 heller 1.81 (defimplementation find-definitions (name)
410 heller 1.105 (append (function-definitions name)
411     (compiler-definitions name)))
412 lgorrie 1.24
413 lgorrie 1.54 (defimplementation describe-symbol-for-emacs (symbol)
414 dbarlow 1.1 "Return a plist describing SYMBOL.
415     Return NIL if the symbol is unbound."
416     (let ((result '()))
417 lgorrie 1.24 (labels ((doc (kind)
418     (or (documentation symbol kind) :not-documented))
419 dbarlow 1.1 (maybe-push (property value)
420     (when value
421     (setf result (list* property value result)))))
422     (maybe-push
423     :variable (multiple-value-bind (kind recorded-p)
424     (sb-int:info :variable :kind symbol)
425     (declare (ignore kind))
426     (if (or (boundp symbol) recorded-p)
427     (doc 'variable))))
428     (maybe-push
429     :function (if (fboundp symbol)
430     (doc 'function)))
431     (maybe-push
432     :setf (if (or (sb-int:info :setf :inverse symbol)
433     (sb-int:info :setf :expander symbol))
434     (doc 'setf)))
435     (maybe-push
436     :type (if (sb-int:info :type :kind symbol)
437     (doc 'type)))
438 lgorrie 1.24 result)))
439 dbarlow 1.1
440 heller 1.74 (defimplementation describe-definition (symbol type)
441 lgorrie 1.54 (case type
442     (:variable
443 heller 1.74 (describe symbol))
444     (:function
445     (describe (symbol-function symbol)))
446 lgorrie 1.54 (:setf
447 heller 1.74 (describe (or (sb-int:info :setf :inverse symbol)
448     (sb-int:info :setf :expander symbol))))
449 lgorrie 1.54 (:class
450 heller 1.74 (describe (find-class symbol)))
451 lgorrie 1.54 (:type
452 heller 1.74 (describe (sb-kernel:values-specifier-type symbol)))))
453 dbarlow 1.1
454 heller 1.97 (defun function-dspec (fn)
455     "Describe where the function FN was defined.
456     Return a list of the form (NAME LOCATION)."
457     (let ((name (sb-kernel:%fun-name fn)))
458     (list name (safe-function-source-location fn name))))
459    
460     (defimplementation list-callers (symbol)
461     (let ((fn (fdefinition symbol)))
462     (mapcar #'function-dspec (sb-introspect:find-function-callers fn))))
463    
464     (defimplementation list-callees (symbol)
465     (let ((fn (fdefinition symbol)))
466     (mapcar #'function-dspec (sb-introspect:find-function-callees fn))))
467    
468 dbarlow 1.4 ;;; macroexpansion
469 dbarlow 1.1
470 lgorrie 1.54 (defimplementation macroexpand-all (form)
471 heller 1.21 (let ((sb-walker:*walk-form-expand-macros-p* t))
472     (sb-walker:walk-form form)))
473 lgorrie 1.25
474 dbarlow 1.1
475     ;;; Debugging
476    
477     (defvar *sldb-stack-top*)
478    
479 lgorrie 1.54 (defimplementation call-with-debugging-environment (debugger-loop-fn)
480 heller 1.58 (declare (type function debugger-loop-fn))
481 lgorrie 1.25 (let* ((*sldb-stack-top* (or sb-debug:*stack-top-hint* (sb-di:top-frame)))
482 heller 1.71 (sb-debug:*stack-top-hint* nil))
483 dbarlow 1.1 (handler-bind ((sb-di:debug-condition
484     (lambda (condition)
485 lgorrie 1.25 (signal (make-condition
486     'sldb-condition
487     :original-condition condition)))))
488     (funcall debugger-loop-fn))))
489 dbarlow 1.1
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 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     )

  ViewVC Help
Powered by ViewVC 1.1.5