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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5