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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5