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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5