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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.88 - (hide annotations)
Thu Jun 10 17:56:41 2004 UTC (9 years, 10 months ago) by heller
Branch: MAIN
Changes since 1.87: +65 -1 lines
(call-with-syntax-hooks): Add hooks to fix SB!-style package names.

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

  ViewVC Help
Powered by ViewVC 1.1.5