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

Contents of /slime/swank-cmucl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.77 - (show annotations)
Fri Mar 5 14:26:14 2004 UTC (10 years, 1 month ago) by mbaringer
Branch: MAIN
Changes since 1.76: +5 -5 lines
See ChangeLog entry 2004-03-05 Marco Baringer
1 ;;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;+" -*-
2
3 (declaim (optimize (debug 2)))
4
5 (in-package :swank)
6
7 (in-package :lisp)
8
9 ;; Fix for read-sequence in 18e
10 #+cmu18e
11 (progn
12 (let ((s (find-symbol (string :*enable-package-locked-errors*) :lisp)))
13 (when s
14 (setf (symbol-value s) nil)))
15
16 (defun read-into-simple-string (s stream start end)
17 (declare (type simple-string s))
18 (declare (type stream stream))
19 (declare (type index start end))
20 (unless (subtypep (stream-element-type stream) 'character)
21 (error 'type-error
22 :datum (read-char stream nil #\Null)
23 :expected-type (stream-element-type stream)
24 :format-control "Trying to read characters from a binary stream."))
25 ;; Let's go as low level as it seems reasonable.
26 (let* ((numbytes (- end start))
27 (bytes-read (system:read-n-bytes stream s start numbytes t)))
28 (if (< bytes-read numbytes)
29 (+ start bytes-read)
30 end)))
31
32 (let ((s (find-symbol (string :*enable-package-locked-errors*) :lisp)))
33 (when s
34 (setf (symbol-value s) t)))
35
36 )
37
38 (in-package :swank)
39
40
41 ;;;; TCP server.
42
43 (setq *swank-in-background* :sigio)
44
45 (defimplementation create-socket (host port)
46 (ext:create-inet-listener port :stream
47 :reuse-address t
48 :host (resolve-hostname host)))
49
50 (defimplementation local-port (socket)
51 (nth-value 1 (ext::get-socket-host-and-port (socket-fd socket))))
52
53 (defimplementation close-socket (socket)
54 (ext:close-socket (socket-fd socket)))
55
56 (defimplementation accept-connection (socket)
57 #+MP (mp:process-wait-until-fd-usable socket :input)
58 (make-socket-io-stream (ext:accept-tcp-connection socket)))
59
60 (defvar *sigio-handlers* '()
61 "List of (key . (fn . args)) pairs to be called on SIGIO.")
62
63 (defun sigio-handler (signal code scp)
64 (declare (ignore signal code scp))
65 (mapc (lambda (handler) (funcall (cdr handler))) *sigio-handlers*))
66
67 (defun set-sigio-handler ()
68 (sys:enable-interrupt unix:SIGIO (lambda (signal code scp)
69 (sigio-handler signal code scp))))
70
71 (defun fcntl (fd command arg)
72 (multiple-value-bind (ok error) (unix:unix-fcntl fd command arg)
73 (cond (ok)
74 (t (error "fcntl: ~A" (unix:get-unix-error-msg error))))))
75
76 (defimplementation add-sigio-handler (socket fn)
77 (set-sigio-handler)
78 (let ((fd (socket-fd socket)))
79 (format *debug-io* "; Adding input handler: ~S ~%" fd)
80 (fcntl fd unix:f-setown (unix:unix-getpid))
81 (fcntl fd unix:f-setfl unix:FASYNC)
82 (push (cons fd fn) *sigio-handlers*)))
83
84 (defimplementation remove-sigio-handlers (socket)
85 (let ((fd (socket-fd socket)))
86 (setf *sigio-handlers* (delete fd *sigio-handlers* :key #'car))
87 (sys:invalidate-descriptor fd))
88 (close socket))
89
90 (defimplementation add-fd-handler (socket fn)
91 (let ((fd (socket-fd socket)))
92 (format *debug-io* "; Adding fd handler: ~S ~%" fd)
93 (sys:add-fd-handler fd :input (lambda (_)
94 _
95 (funcall fn)))))
96
97 (defimplementation remove-fd-handlers (socket)
98 (sys:invalidate-descriptor (socket-fd socket)))
99
100 (defimplementation make-fn-streams (input-fn output-fn)
101 (let* ((output (make-slime-output-stream output-fn))
102 (input (make-slime-input-stream input-fn output)))
103 (values input output)))
104
105 ;;;;; Socket helpers.
106
107 (defun socket-fd (socket)
108 "Return the filedescriptor for the socket represented by SOCKET."
109 (etypecase socket
110 (fixnum socket)
111 (sys:fd-stream (sys:fd-stream-fd socket))))
112
113 (defun resolve-hostname (hostname)
114 "Return the IP address of HOSTNAME as an integer."
115 (let* ((hostent (ext:lookup-host-entry hostname))
116 (address (car (ext:host-entry-addr-list hostent))))
117 (ext:htonl address)))
118
119 (defun make-socket-io-stream (fd)
120 "Create a new input/output fd-stream for FD."
121 (sys:make-fd-stream fd :input t :output t :element-type 'base-char))
122
123 (defun set-fd-non-blocking (fd)
124 (flet ((fcntl (fd cmd arg)
125 (multiple-value-bind (flags errno) (unix:unix-fcntl fd cmd arg)
126 (or flags
127 (error "fcntl: ~A" (unix:get-unix-error-msg errno))))))
128 (let ((flags (fcntl fd unix:F-GETFL 0)))
129 (fcntl fd unix:F-SETFL (logior flags unix:O_NONBLOCK)))))
130
131
132 ;;;; Unix signals
133
134 (defmethod call-without-interrupts (fn)
135 (sys:without-interrupts (funcall fn)))
136
137 (defimplementation getpid ()
138 (unix:unix-getpid))
139
140 (defimplementation lisp-implementation-type-name ()
141 "cmucl")
142
143
144 ;;;; Stream handling
145
146 (defstruct (slime-output-stream
147 (:include lisp::lisp-stream
148 (lisp::misc #'sos/misc)
149 (lisp::out #'sos/out)
150 (lisp::sout #'sos/sout))
151 (:conc-name sos.)
152 (:print-function %print-slime-output-stream)
153 (:constructor make-slime-output-stream (output-fn)))
154 (output-fn nil :type function)
155 (buffer (make-string 512) :type string)
156 (index 0 :type kernel:index)
157 (column 0 :type kernel:index))
158
159 (defun %print-slime-output-stream (s stream d)
160 (declare (ignore d))
161 (print-unreadable-object (s stream :type t :identity t)))
162
163 (defun sos/out (stream char)
164 (let ((buffer (sos.buffer stream))
165 (index (sos.index stream)))
166 (setf (schar buffer index) char)
167 (setf (sos.index stream) (1+ index))
168 (incf (sos.column stream))
169 (when (char= #\newline char)
170 (setf (sos.column stream) 0))
171 (when (= index (1- (length buffer)))
172 (force-output stream)))
173 char)
174
175 (defun sos/sout (stream string start end)
176 (loop for i from start below end
177 do (sos/out stream (aref string i))))
178
179 (defun sos/misc (stream operation &optional arg1 arg2)
180 (declare (ignore arg1 arg2))
181 (case operation
182 ((:force-output :finish-output)
183 (let ((end (sos.index stream)))
184 (unless (zerop end)
185 (funcall (sos.output-fn stream) (subseq (sos.buffer stream) 0 end))
186 (setf (sos.index stream) 0))))
187 (:charpos (sos.column stream))
188 (:line-length 75)
189 (:file-position nil)
190 (:element-type 'base-char)
191 (:get-command nil)
192 (:close nil)
193 (t (format *terminal-io* "~&~Astream: ~S~%" stream operation))))
194
195 (defstruct (slime-input-stream
196 (:include string-stream
197 (lisp::in #'sis/in)
198 (lisp::misc #'sis/misc))
199 (:conc-name sis.)
200 (:print-function %print-slime-output-stream)
201 (:constructor make-slime-input-stream (input-fn sos)))
202 (input-fn nil :type function)
203 ;; We know our sibling output stream, so that we can force it before
204 ;; requesting input.
205 (sos nil :type slime-output-stream)
206 (buffer "" :type string)
207 (index 0 :type kernel:index))
208
209 (defun sis/in (stream eof-errorp eof-value)
210 (declare (ignore eof-errorp eof-value))
211 (let ((index (sis.index stream))
212 (buffer (sis.buffer stream)))
213 (when (= index (length buffer))
214 (force-output (sis.sos stream))
215 (setf buffer (funcall (sis.input-fn stream)))
216 (setf (sis.buffer stream) buffer)
217 (setf index 0))
218 (prog1 (aref buffer index)
219 (setf (sis.index stream) (1+ index)))))
220
221 (defun sis/misc (stream operation &optional arg1 arg2)
222 (declare (ignore arg2))
223 (ecase operation
224 (:file-position nil)
225 (:file-length nil)
226 (:unread (setf (aref (sis.buffer stream)
227 (decf (sis.index stream)))
228 arg1))
229 (:clear-input
230 (setf (sis.index stream) 0
231 (sis.buffer stream) ""))
232 (:listen (< (sis.index stream) (length (sis.buffer stream))))
233 (:charpos nil)
234 (:line-length nil)
235 (:get-command nil)
236 (:element-type 'base-char)
237 (:close nil)))
238
239
240 ;;;; Compilation Commands
241
242 (defvar *swank-source-info* nil
243 "Bound to a SOURCE-INFO object during compilation.")
244
245 (defvar *previous-compiler-condition* nil
246 "Used to detect duplicates.")
247
248 (defvar *previous-context* nil
249 "Previous compiler error context.")
250
251 (defvar *compiler-notes* '()
252 "List of compiler notes for the last compilation unit.")
253
254 (defvar *buffer-name* nil)
255 (defvar *buffer-start-position* nil)
256 (defvar *buffer-substring* nil)
257 (defvar *compile-filename* nil)
258
259
260 ;;;;; Trapping notes
261
262 (defun handle-notification-condition (condition)
263 "Handle a condition caused by a compiler warning.
264 This traps all compiler conditions at a lower-level than using
265 C:*COMPILER-NOTIFICATION-FUNCTION*. The advantage is that we get to
266 craft our own error messages, which can omit a lot of redundant
267 information."
268 (unless (eq condition *previous-compiler-condition*)
269 (let ((context (c::find-error-context nil)))
270 (setq *previous-compiler-condition* condition)
271 (setq *previous-context* context)
272 (signal-compiler-condition condition context))))
273
274 (defun signal-compiler-condition (condition context)
275 (signal (make-condition
276 'compiler-condition
277 :original-condition condition
278 :severity (severity-for-emacs condition)
279 :short-message (brief-compiler-message-for-emacs condition)
280 :message (long-compiler-message-for-emacs condition context)
281 :location (compiler-note-location context))))
282
283 (defun severity-for-emacs (condition)
284 "Return the severity of CONDITION."
285 (etypecase condition
286 (c::compiler-error :error)
287 (c::style-warning :note)
288 (c::warning :warning)))
289
290 (defun brief-compiler-message-for-emacs (condition)
291 "Briefly describe a compiler error for Emacs.
292 When Emacs presents the message it already has the source popped up
293 and the source form highlighted. This makes much of the information in
294 the error-context redundant."
295 (princ-to-string condition))
296
297 (defun long-compiler-message-for-emacs (condition error-context)
298 "Describe a compiler error for Emacs including context information."
299 (declare (type (or c::compiler-error-context null) error-context))
300 (multiple-value-bind (enclosing source)
301 (if error-context
302 (values (c::compiler-error-context-enclosing-source error-context)
303 (c::compiler-error-context-source error-context)))
304 (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~^~%~}~]~A"
305 enclosing source condition)))
306
307 (defun compiler-note-location (context)
308 (cond (context
309 (resolve-note-location
310 *buffer-name*
311 (c::compiler-error-context-file-name context)
312 (c::compiler-error-context-file-position context)
313 (reverse (c::compiler-error-context-original-source-path context))
314 (c::compiler-error-context-original-source context)))
315 (t
316 (resolve-note-location *buffer-name* nil nil nil nil))))
317
318 (defgeneric resolve-note-location (buffer file-name file-position
319 source-path source))
320
321 (defmethod resolve-note-location ((b (eql nil)) (f pathname) pos path source)
322 (make-location
323 `(:file ,(unix-truename f))
324 `(:position ,(1+ (source-path-file-position path f)))))
325
326 (defmethod resolve-note-location ((b string) (f (eql :stream)) pos path source)
327 (make-location
328 `(:buffer ,b)
329 `(:position ,(+ *buffer-start-position*
330 (source-path-string-position path *buffer-substring*)))))
331
332 (defmethod resolve-note-location (b (f (eql :lisp)) pos path (source string))
333 (make-location
334 `(:source-form ,source)
335 `(:position 1)))
336
337 (defmethod resolve-note-location (buffer
338 (file (eql nil))
339 (pos (eql nil))
340 (path (eql nil))
341 (source (eql nil)))
342 (list :error "No error location available")
343 #+(or)
344 (cond (buffer
345 (make-location (list :buffer buffer)
346 (list :position *buffer-start-position*)))
347 (*compile-file-truename*
348 (make-location (list :file (namestring *compile-file-truename*))
349 (list :source-path '(0) 1)))
350 (*compile-filename*
351 (make-location (list :file *compile-filename*)
352 (list :source-path '(0) 1)))
353 (t
354 (list :error "No error location available"))))
355
356 (defimplementation call-with-compilation-hooks (function)
357 (let ((*previous-compiler-condition* nil)
358 (*previous-context* nil)
359 (*print-readably* nil))
360 (handler-bind ((c::compiler-error #'handle-notification-condition)
361 (c::style-warning #'handle-notification-condition)
362 (c::warning #'handle-notification-condition))
363 (funcall function))))
364
365 (defimplementation compile-file-for-emacs (filename load-p)
366 (clear-xref-info filename)
367 (with-compilation-hooks ()
368 (let ((*buffer-name* nil)
369 (*compile-filename* filename))
370 (compile-file filename :load load-p))))
371
372 (defimplementation compile-string-for-emacs (string &key buffer position)
373 (with-compilation-hooks ()
374 (let ((*package* *buffer-package*)
375 (*compile-filename* nil)
376 (*buffer-name* buffer)
377 (*buffer-start-position* position)
378 (*buffer-substring* string))
379 (with-input-from-string (stream string)
380 (ext:compile-from-stream
381 stream
382 :source-info `(:emacs-buffer ,buffer
383 :emacs-buffer-offset ,position
384 :emacs-buffer-string ,string))))))
385
386
387 ;;;; XREF
388
389 (defun lookup-xrefs (finder name)
390 (xref-results-for-emacs (funcall finder (from-string name))))
391
392 (defimplementation who-calls (function-name)
393 (lookup-xrefs #'xref:who-calls function-name))
394
395 (defimplementation who-references (variable)
396 (lookup-xrefs #'xref:who-references variable))
397
398 (defimplementation who-binds (variable)
399 (lookup-xrefs #'xref:who-binds variable))
400
401 (defimplementation who-sets (variable)
402 (lookup-xrefs #'xref:who-sets variable))
403
404 #+cmu19
405 (progn
406 (defimplementation who-macroexpands (macro)
407 (lookup-xrefs #'xref:who-macroexpands macro))
408
409 (defimplementation who-specializes (class)
410 (let* ((methods (xref::who-specializes (find-class (from-string class))))
411 (locations (mapcar #'method-source-location methods)))
412 (group-xrefs (mapcar (lambda (m l)
413 (cons (let ((*print-pretty* nil))
414 (to-string m))
415 l))
416 methods locations)))))
417
418 (defun resolve-xref-location (xref)
419 (let ((name (xref:xref-context-name xref))
420 (file (xref:xref-context-file xref))
421 (source-path (xref:xref-context-source-path xref)))
422 (cond ((and file source-path)
423 (let ((position (source-path-file-position source-path file)))
424 (make-location (list :file (unix-truename file))
425 (list :position (1+ position)))))
426 (file
427 (make-location (list :file (unix-truename file))
428 (list :function-name (string name))))
429 (t
430 `(:error ,(format nil "Unkown source location: ~S ~S ~S "
431 name file source-path))))))
432
433
434 (defun xref-results-for-emacs (contexts)
435 "Prepare a list of xref contexts for Emacs.
436 The result is a list of xrefs:
437 group ::= (FILENAME . ({reference}+))
438 reference ::= (FUNCTION-SPECIFIER . SOURCE-LOCATION)"
439 (let ((xrefs '()))
440 (dolist (cxt contexts)
441 (let ((name (xref:xref-context-name cxt)))
442 (push (cons (to-string name)
443 (resolve-xref-location cxt))
444 xrefs)))
445 (group-xrefs xrefs)))
446
447 (defun clear-xref-info (namestring)
448 "Clear XREF notes pertaining to NAMESTRING.
449 This is a workaround for a CMUCL bug: XREF records are cumulative."
450 (when c:*record-xref-info*
451 (let ((filename (truename namestring)))
452 (dolist (db (list xref::*who-calls*
453 #+cmu19 xref::*who-is-called*
454 #+cmu19 xref::*who-macroexpands*
455 xref::*who-references*
456 xref::*who-binds*
457 xref::*who-sets*))
458 (maphash (lambda (target contexts)
459 ;; XXX update during traversal?
460 (setf (gethash target db)
461 (delete filename contexts
462 :key #'xref:xref-context-file
463 :test #'equalp)))
464 db)))))
465
466 (defun unix-truename (pathname)
467 (ext:unix-namestring (truename pathname)))
468
469
470 ;;;; Find callers and callees
471
472 ;;; Find callers and callees by looking at the constant pool of
473 ;;; compiled code objects. We assume every fdefn object in the
474 ;;; constant pool corresponds to a call to that function. A better
475 ;;; strategy would be to use the disassembler to find actual
476 ;;; call-sites.
477
478 (declaim (inline map-code-constants))
479 (defun map-code-constants (code fn)
480 "Call FN for each constant in CODE's constant pool."
481 (check-type code kernel:code-component)
482 (loop for i from vm:code-constants-offset below (kernel:get-header-data code)
483 do (funcall fn (kernel:code-header-ref code i))))
484
485 (defun function-callees (function)
486 "Return FUNCTION's callees as a list of functions."
487 (let ((callees '()))
488 (map-code-constants
489 (vm::find-code-object function)
490 (lambda (obj)
491 (when (kernel:fdefn-p obj)
492 (push (kernel:fdefn-function obj) callees))))
493 callees))
494
495 (declaim (ext:maybe-inline map-allocated-code-components))
496 (defun map-allocated-code-components (spaces fn)
497 "Call FN for each allocated code component in one of SPACES. FN
498 receives the object as argument. SPACES should be a list of the
499 symbols :dynamic, :static, or :read-only."
500 (dolist (space spaces)
501 (declare (inline vm::map-allocated-objects))
502 (vm::map-allocated-objects
503 (lambda (obj header size)
504 (declare (type fixnum size) (ignore size))
505 (when (= vm:code-header-type header)
506 (funcall fn obj)))
507 space)))
508
509 (declaim (ext:maybe-inline map-caller-code-components))
510 (defun map-caller-code-components (function spaces fn)
511 "Call FN for each code component with a fdefn for FUNCTION in its
512 constant pool."
513 (let ((function (coerce function 'function)))
514 (declare (inline map-allocated-code-components))
515 (map-allocated-code-components
516 spaces
517 (lambda (obj)
518 (map-code-constants
519 obj
520 (lambda (constant)
521 (when (and (kernel:fdefn-p constant)
522 (eq (kernel:fdefn-function constant)
523 function))
524 (funcall fn obj))))))))
525
526 (defun function-callers (function &optional (spaces '(:read-only :static
527 :dynamic)))
528 "Return FUNCTION's callers. The result is a list of code-objects."
529 (let ((referrers '()))
530 (declare (inline map-caller-code-components))
531 (ext:gc :full t)
532 (map-caller-code-components function spaces
533 (lambda (code) (push code referrers)))
534 referrers))
535
536 (defun debug-info-definitions (debug-info)
537 "Return the defintions for a debug-info. This should only be used
538 for code-object without entry points, i.e., byte compiled
539 code (are theree others?)"
540 ;; This mess has only been tested with #'ext::skip-whitespace, a
541 ;; byte-compiled caller of #'read-char .
542 (check-type debug-info (and (not c::compiled-debug-info) c::debug-info))
543 (let ((name (c::debug-info-name debug-info))
544 (source (c::debug-info-source debug-info)))
545 (destructuring-bind (first) source
546 (ecase (c::debug-source-from first)
547 (:file
548 (list
549 (cons name
550 (make-location
551 (list :file (unix-truename (c::debug-source-name first)))
552 (list :function-name name)))))))))
553
554 (defun code-component-entry-points (code)
555 "Return a list ((NAME . LOCATION) ...) of function definitons for
556 the code omponent CODE."
557 (delete-duplicates
558 (loop for e = (kernel:%code-entry-points code)
559 then (kernel::%function-next e)
560 while e
561 collect (cons (to-string (kernel:%function-name e))
562 (function-source-location e)))
563 :test #'equal))
564
565 (defimplementation list-callers (symbol-name)
566 "Return a list ((FILE . ((NAME . LOCATION) ...)) ...) of callers."
567 (let ((components (function-callers (from-string symbol-name)))
568 (xrefs '()))
569 (dolist (code components)
570 (let* ((entry (kernel:%code-entry-points code))
571 (defs (if entry
572 (code-component-entry-points code)
573 ;; byte compiled stuff
574 (debug-info-definitions
575 (kernel:%code-debug-info code)))))
576 (setq xrefs (nconc defs xrefs))))
577 (group-xrefs xrefs)))
578
579 (defimplementation list-callees (symbol-name)
580 (let ((fns (function-callees (from-string symbol-name))))
581 (group-xrefs (mapcar (lambda (fn)
582 (cons (to-string (kernel:%function-name fn))
583 (function-source-location fn)))
584 fns))))
585
586
587 ;;;; Definitions
588
589 (defvar *debug-definition-finding* nil
590 "When true don't handle errors while looking for definitions.
591 This is useful when debugging the definition-finding code.")
592
593 (defmacro safe-definition-finding (&body body)
594 "Execute BODY ignoring errors. Return the source location returned
595 by BODY or if an error occurs a description of the error. The second
596 return value is the condition or nil."
597 `(flet ((body () ,@body))
598 (if *debug-definition-finding*
599 (body)
600 (handler-case (values (progn ,@body) nil)
601 (error (c) (values (list :error (princ-to-string c)) c))))))
602
603 (defun function-first-code-location (function)
604 (and (function-has-debug-function-p function)
605 (di:debug-function-start-location
606 (di:function-debug-function function))))
607
608 (defun function-has-debug-function-p (function)
609 (di:function-debug-function function))
610
611 (defun function-code-object= (closure function)
612 (and (eq (vm::find-code-object closure)
613 (vm::find-code-object function))
614 (not (eq closure function))))
615
616 (defun struct-closure-p (function)
617 (or (function-code-object= function #'kernel::structure-slot-accessor)
618 (function-code-object= function #'kernel::structure-slot-setter)
619 (function-code-object= function #'kernel::%defstruct)))
620
621 (defun struct-closure-dd (function)
622 (assert (= (kernel:get-type function) vm:closure-header-type))
623 (flet ((find-layout (function)
624 (sys:find-if-in-closure
625 (lambda (x)
626 (let ((value (if (di::indirect-value-cell-p x)
627 (c:value-cell-ref x)
628 x)))
629 (when (kernel::layout-p value)
630 (return-from find-layout value))))
631 function)))
632 (kernel:layout-info (find-layout function))))
633
634 (defun dd-source-location (dd)
635 (let ((constructor (or (kernel:dd-default-constructor dd)
636 (car (kernel::dd-constructors dd)))))
637 (when (or (not constructor) (and (consp constructor)
638 (not (car constructor))))
639 (error "Cannot locate struct without constructor: ~S"
640 (kernel::dd-name dd)))
641 (function-source-location
642 (coerce (if (consp constructor) (car constructor) constructor)
643 'function))))
644
645 (defun genericp (fn)
646 (typep fn 'generic-function))
647
648 (defun gf-definition-location (gf)
649 (flet ((guess-source-file (faslfile)
650 (unix-truename
651 (merge-pathnames (make-pathname :type "lisp")
652 faslfile))))
653 (let ((def-source (pcl::definition-source gf))
654 (name (string (pcl:generic-function-name gf))))
655 (etypecase def-source
656 (pathname (make-location
657 `(:file ,(guess-source-file def-source))
658 `(:function-name ,name)))
659 (cons
660 (destructuring-bind ((dg name) pathname) def-source
661 (declare (ignore dg))
662 (etypecase pathname
663 (pathname
664 (make-location `(:file ,(guess-source-file pathname))
665 `(:function-name ,(string name))))
666 (null `(:error ,(format nil "Cannot resolve: ~S" def-source)))
667 )))))))
668
669 (defun method-source-location (method)
670 (function-source-location (or (pcl::method-fast-function method)
671 (pcl:method-function method))))
672
673 (defun gf-method-locations (gf)
674 (let ((ms (pcl::generic-function-methods gf)))
675 (mapcar #'method-source-location ms)))
676
677 (defun gf-source-locations (gf)
678 (list* (gf-definition-location gf)
679 (gf-method-locations gf)))
680
681 (defun function-source-locations (function)
682 "Return a list of source locations for FUNCTION."
683 ;; First test if FUNCTION is a closure created by defstruct; if so
684 ;; extract the defstruct-description (dd) from the closure and find
685 ;; the constructor for the struct. Defstruct creates a defun for
686 ;; the default constructor and we use that as an approximation to
687 ;; the source location of the defstruct.
688 ;;
689 ;; For an ordinary function we return the source location of the
690 ;; first code-location we find.
691 (cond ((struct-closure-p function)
692 (list
693 (safe-definition-finding
694 (dd-source-location (struct-closure-dd function)))))
695 ((genericp function)
696 (gf-source-locations function))
697 (t
698 (list
699 (multiple-value-bind (code-location error)
700 (safe-definition-finding (function-first-code-location function))
701 (cond (error (list :error (princ-to-string error)))
702 (t (code-location-source-location code-location))))))))
703
704 (defun function-source-location (function)
705 (destructuring-bind (first) (function-source-locations function)
706 first))
707
708 (defimplementation find-function-locations (symbol-name)
709 "Return a list of source-locations for SYMBOL-NAME's functions."
710 (multiple-value-bind (symbol foundp) (find-symbol-designator symbol-name)
711 (cond ((not foundp)
712 (list (list :error (format nil "Unkown symbol: ~A" symbol-name))))
713 ((macro-function symbol)
714 (function-source-locations (macro-function symbol)))
715 ((special-operator-p symbol)
716 (list (list :error (format nil "~A is a special-operator" symbol))))
717 ((fboundp symbol)
718 (function-source-locations (coerce symbol 'function)))
719 (t (list (list :error
720 (format nil "Symbol not fbound: ~A" symbol-name))))
721 )))
722
723
724 ;;;; Documentation.
725
726 (defimplementation describe-symbol-for-emacs (symbol)
727 (let ((result '()))
728 (flet ((doc (kind)
729 (or (documentation symbol kind) :not-documented))
730 (maybe-push (property value)
731 (when value
732 (setf result (list* property value result)))))
733 (maybe-push
734 :variable (multiple-value-bind (kind recorded-p)
735 (ext:info variable kind symbol)
736 (declare (ignore kind))
737 (if (or (boundp symbol) recorded-p)
738 (doc 'variable))))
739 (maybe-push
740 :generic-function
741 (if (and (fboundp symbol)
742 (typep (fdefinition symbol) 'generic-function))
743 (doc 'function)))
744 (maybe-push
745 :function (if (and (fboundp symbol)
746 (not (typep (fdefinition symbol) 'generic-function)))
747 (doc 'function)))
748 (maybe-push
749 :setf (if (or (ext:info setf inverse symbol)
750 (ext:info setf expander symbol))
751 (doc 'setf)))
752 (maybe-push
753 :type (if (ext:info type kind symbol)
754 (doc 'type)))
755 (maybe-push
756 :class (if (find-class symbol nil)
757 (doc 'class)))
758 (maybe-push
759 :alien-type (if (not (eq (ext:info alien-type kind symbol) :unknown))
760 (doc 'alien-type)))
761 (maybe-push
762 :alien-struct (if (ext:info alien-type struct symbol)
763 (doc nil)))
764 (maybe-push
765 :alien-union (if (ext:info alien-type union symbol)
766 (doc nil)))
767 (maybe-push
768 :alien-enum (if (ext:info alien-type enum symbol)
769 (doc nil)))
770 result)))
771
772 (defmacro %describe-alien (symbol-name namespace)
773 `(print-description-to-string
774 (ext:info :alien-type ,namespace (from-string ,symbol-name))))
775
776 (defimplementation describe-definition (symbol-name type)
777 (case type
778 (:variable
779 (describe-symbol symbol-name))
780 ((:function :generic-function)
781 (describe-function symbol-name))
782 (:setf
783 (print-description-to-string
784 (or (ext:info setf inverse (from-string symbol-name))
785 (ext:info setf expander (from-string symbol-name)))))
786 (:type
787 (print-description-to-string
788 (kernel:values-specifier-type (from-string symbol-name))))
789 (:class
790 (print-description-to-string (find-class (from-string symbol-name) nil)))
791 (:alien-type
792 (let ((name (from-string symbol-name)))
793 (ecase (ext:info :alien-type :kind name)
794 (:primitive
795 (print-description-to-string
796 (let ((alien::*values-type-okay* t))
797 (funcall (ext:info :alien-type :translator name) (list name)))))
798 ((:defined)
799 (print-description-to-string (ext:info :alien-type
800 :definition name)))
801 (:unknown
802 (format nil "Unkown alien type: ~A" symbol-name)))))
803 (:alien-struct
804 (%describe-alien symbol-name :struct))
805 (:alien-union
806 (%describe-alien symbol-name :union))
807 (:alien-enum
808 (%describe-alien symbol-name :enum))))
809
810 (defimplementation arglist-string (fname)
811 "Return a string describing the argument list for FNAME.
812 The result has the format \"(...)\"."
813 (declare (type string fname))
814 (multiple-value-bind (function package) (find-symbol-designator fname)
815 (unless package
816 (return-from arglist-string (format nil "(-- Unkown symbol: ~A)" fname)))
817 (let ((arglist
818 (if (not (or (fboundp function)
819 (functionp function)))
820 "(-- <Unknown-Function>)"
821 (let* ((fun (or (macro-function function)
822 (symbol-function function)))
823 (arglist (kernel:%function-arglist
824 (kernel:%function-self fun))))
825 (cond ((eval:interpreted-function-p fun)
826 (eval:interpreted-function-arglist fun))
827 ((pcl::generic-function-p fun)
828 (pcl:generic-function-lambda-list fun))
829 (arglist arglist)
830 ;; this should work both for
831 ;; compiled-debug-function and for
832 ;; interpreted-debug-function
833 (t (let ((df (di::function-debug-function fun)))
834 (if df
835 (di::debug-function-lambda-list df)
836 "(<arglist-unavailable>)"))))))))
837 (etypecase arglist
838 (string arglist)
839 (cons (let ((*print-case* :downcase)
840 (*print-pretty* nil))
841 (princ-to-string arglist)))
842 (null "()")))))
843
844
845 ;;;; Miscellaneous.
846
847 (defimplementation macroexpand-all (form)
848 (walker:macroexpand-all form))
849
850 (in-package :c)
851
852 (defun swank::expand-ir1-top-level (form)
853 "A scaled down version of the first pass of the compiler."
854 (with-compilation-unit ()
855 (let* ((*lexical-environment*
856 (make-lexenv :default (make-null-environment)
857 :cookie *default-cookie*
858 :interface-cookie *default-interface-cookie*))
859 (*source-info* (make-lisp-source-info form))
860 (*block-compile* nil)
861 (*block-compile-default* nil))
862 (with-ir1-namespace
863 (clear-stuff)
864 (find-source-paths form 0)
865 (ir1-top-level form '(0) t)))))
866
867 (in-package :swank)
868
869 (defslimefun print-ir1-converted-blocks (form)
870 (with-output-to-string (*standard-output*)
871 (c::print-all-blocks (expand-ir1-top-level (from-string form)))))
872
873 (defslimefun print-compilation-trace (form)
874 (with-output-to-string (*standard-output*)
875 (with-input-from-string (s form)
876 (let ((*package* *buffer-package*))
877 (ext:compile-from-stream s
878 :verbose t
879 :progress t
880 :trace-stream *standard-output*)))))
881
882 (defslimefun set-default-directory (directory)
883 (setf (ext:default-directory) (namestring directory))
884 ;; Setting *default-pathname-defaults* to an absolute directory
885 ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive.
886 (setf *default-pathname-defaults* (pathname (ext:default-directory)))
887 (namestring (ext:default-directory)))
888
889 ;;; source-path-{stream,file,string,etc}-position moved into
890 ;;; swank-source-path-parser
891
892 (defun code-location-stream-position (code-location stream)
893 "Return the byte offset of CODE-LOCATION in STREAM. Extract the
894 toplevel-form-number and form-number from CODE-LOCATION and use that
895 to find the position of the corresponding form."
896 (let* ((location (debug::maybe-block-start-location code-location))
897 (tlf-offset (di:code-location-top-level-form-offset location))
898 (form-number (di:code-location-form-number location))
899 (*read-suppress* t))
900 (dotimes (i tlf-offset) (read stream))
901 (multiple-value-bind (tlf position-map) (read-and-record-source-map stream)
902 (let* ((path-table (di:form-number-translations tlf 0))
903 (source-path
904 (if (<= (length path-table) form-number) ; source out of sync?
905 (list 0) ; should probably signal a condition
906 (reverse (cdr (aref path-table form-number))))))
907 (source-path-source-position source-path tlf position-map)))))
908
909 (defun code-location-string-offset (code-location string)
910 (with-input-from-string (s string)
911 (code-location-stream-position code-location s)))
912
913 (defun code-location-file-position (code-location filename)
914 (with-open-file (s filename :direction :input)
915 (code-location-stream-position code-location s)))
916
917 (defun debug-source-info-from-emacs-buffer-p (debug-source)
918 (let ((info (c::debug-source-info debug-source)))
919 (and info
920 (consp info)
921 (eq :emacs-buffer (car info)))))
922
923 (defun source-location-from-code-location (code-location)
924 "Return the source location for CODE-LOCATION."
925 (let ((debug-fun (di:code-location-debug-function code-location)))
926 (when (di::bogus-debug-function-p debug-fun)
927 (error "Bogus debug function: ~A" debug-fun)))
928 (let* ((debug-source (di:code-location-debug-source code-location))
929 (from (di:debug-source-from debug-source))
930 (name (di:debug-source-name debug-source)))
931 (ecase from
932 (:file
933 (make-location (list :file (unix-truename name))
934 (list :position (1+ (code-location-file-position
935 code-location name)))))
936 (:stream
937 (assert (debug-source-info-from-emacs-buffer-p debug-source))
938 (let ((info (c::debug-source-info debug-source)))
939 (make-location
940 (list :buffer (getf info :emacs-buffer))
941 (list :position (+ (getf info :emacs-buffer-offset)
942 (code-location-string-offset
943 code-location
944 (getf info :emacs-buffer-string)))))))
945 (:lisp
946 (make-location
947 (list :source-form (with-output-to-string (*standard-output*)
948 (debug::print-code-location-source-form
949 code-location 100 t)))
950 (list :position 1))))))
951
952 (defun code-location-source-location (code-location)
953 "Safe wrapper around `code-location-from-source-location'."
954 (safe-definition-finding
955 (source-location-from-code-location code-location)))
956
957
958 ;;;; Debugging
959
960 (defvar *sldb-stack-top*)
961 (defvar *sldb-restarts*)
962
963 (defimplementation call-with-debugging-environment (debugger-loop-fn)
964 (unix:unix-sigsetmask 0)
965 (let* ((*sldb-stack-top* (or debug:*stack-top-hint* (di:top-frame)))
966 (*sldb-restarts* (compute-restarts *swank-debugger-condition*))
967 (debug:*stack-top-hint* nil))
968 (handler-bind ((di:debug-condition
969 (lambda (condition)
970 (signal (make-condition
971 'sldb-condition
972 :original-condition condition)))))
973 (funcall debugger-loop-fn))))
974
975 (defun format-restarts-for-emacs ()
976 "Return a list of restarts for *swank-debugger-condition* in a
977 format suitable for Emacs."
978 (loop for restart in *sldb-restarts*
979 collect (list (princ-to-string (restart-name restart))
980 (princ-to-string restart))))
981
982 (defun nth-frame (index)
983 (do ((frame *sldb-stack-top* (di:frame-down frame))
984 (i index (1- i)))
985 ((zerop i) frame)))
986
987 (defun nth-restart (index)
988 (nth index *sldb-restarts*))
989
990 (defun format-frame-for-emacs (number frame)
991 (print-with-frame-label
992 number (lambda (*standard-output*)
993 (debug::print-frame-call frame :verbosity 1 :number nil))))
994
995 (defun compute-backtrace (start end)
996 "Return a list of frames starting with frame number START and
997 continuing to frame number END or, if END is nil, the last frame on the
998 stack."
999 (let ((end (or end most-positive-fixnum)))
1000 (loop for f = (nth-frame start) then (di:frame-down f)
1001 for i from start below end
1002 while f
1003 collect (cons i f))))
1004
1005 (defimplementation backtrace (start end)
1006 (loop for (n . frame) in (compute-backtrace start end)
1007 collect (list n (format-frame-for-emacs n frame))))
1008
1009 (defimplementation debugger-info-for-emacs (start end)
1010 (list (debugger-condition-for-emacs)
1011 (format-restarts-for-emacs)
1012 (backtrace start end)))
1013
1014 (defimplementation frame-source-location-for-emacs (index)
1015 (code-location-source-location (di:frame-code-location (nth-frame index))))
1016
1017 (defimplementation eval-in-frame (form index)
1018 (di:eval-in-frame (nth-frame index) form))
1019
1020 (defslimefun pprint-eval-string-in-frame (string index)
1021 (swank-pprint
1022 (multiple-value-list
1023 (di:eval-in-frame (nth-frame index) (from-string string)))))
1024
1025 (defimplementation frame-locals (index)
1026 (let* ((frame (nth-frame index))
1027 (location (di:frame-code-location frame))
1028 (debug-function (di:frame-debug-function frame))
1029 (debug-variables (di::debug-function-debug-variables debug-function)))
1030 (loop for v across debug-variables collect
1031 (list :name (to-string (di:debug-variable-symbol v))
1032 :id (di:debug-variable-id v)
1033 :value (ecase (di:debug-variable-validity v location)
1034 (:valid
1035 (di:debug-variable-value v frame))
1036 ((:invalid :unknown)
1037 "<not-available>"))))))
1038
1039 (defimplementation frame-catch-tags (index)
1040 (loop for (tag . code-location) in (di:frame-catches (nth-frame index))
1041 collect `(,tag . ,(code-location-source-location code-location))))
1042
1043 (defslimefun invoke-nth-restart (index)
1044 (invoke-restart-interactively (nth-restart index)))
1045
1046 (defslimefun sldb-abort ()
1047 (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))
1048
1049 (defun set-step-breakpoints (frame)
1050 (when (di:debug-block-elsewhere-p (di:code-location-debug-block
1051 (di:frame-code-location frame)))
1052 (error "Cannot step, in elsewhere code~%"))
1053 (let* ((code-location (di:frame-code-location frame))
1054 (debug::*bad-code-location-types*
1055 (remove :call-site debug::*bad-code-location-types*))
1056 (next (debug::next-code-locations code-location)))
1057 (cond (next
1058 (let ((steppoints '()))
1059 (flet ((hook (frame breakpoint)
1060 (let ((debug:*stack-top-hint* frame))
1061 (mapc #'di:delete-breakpoint steppoints)
1062 (let ((cl (di::breakpoint-what breakpoint)))
1063 (break "Breakpoint: ~S ~S"
1064 (di:code-location-kind cl)
1065 (di::compiled-code-location-pc cl))))))
1066 (dolist (code-location next)
1067 (let ((bp (di:make-breakpoint #'hook code-location
1068 :kind :code-location)))
1069 (di:activate-breakpoint bp)
1070 (push bp steppoints))))))
1071 (t
1072 (flet ((hook (frame breakpoint values cookie)
1073 (declare (ignore cookie))
1074 (di:delete-breakpoint breakpoint)
1075 (let ((debug:*stack-top-hint* frame))
1076 (break "Function-end: ~A ~A" breakpoint values))))
1077 (let* ((debug-function (di:frame-debug-function frame))
1078 (bp (di:make-breakpoint #'hook debug-function
1079 :kind :function-end)))
1080 (di:activate-breakpoint bp)))))))
1081
1082 (defslimefun sldb-step (frame)
1083 (cond ((find-restart 'continue *swank-debugger-condition*)
1084 (set-step-breakpoints (nth-frame frame))
1085 (continue *swank-debugger-condition*))
1086 (t
1087 (error "Cannot continue in from condition: ~A"
1088 *swank-debugger-condition*))))
1089
1090 (defun frame-cfp (frame)
1091 "Return the Control-Stack-Frame-Pointer for FRAME."
1092 (etypecase frame
1093 (di::compiled-frame (di::frame-pointer frame))
1094 ((or di::interpreted-frame null) -1)))
1095
1096 (defun frame-ip (frame)
1097 "Return the (absolute) instruction pointer and the relative pc of FRAME."
1098 (if (not frame)
1099 -1
1100 (let ((debug-fun (di::frame-debug-function frame)))
1101 (etypecase debug-fun
1102 (di::compiled-debug-function
1103 (let* ((code-loc (di:frame-code-location frame))
1104 (component (di::compiled-debug-function-component debug-fun))
1105 (pc (di::compiled-code-location-pc code-loc))
1106 (ip (sys:without-gcing
1107 (sys:sap-int
1108 (sys:sap+ (kernel:code-instructions component) pc)))))
1109 (values ip pc)))
1110 ((or di::bogus-debug-function di::interpreted-debug-function)
1111 -1)))))
1112
1113 (defun frame-registers (frame)
1114 "Return the lisp registers CSP, CFP, IP, OCFP, LRA for FRAME-NUMBER."
1115 (let* ((cfp (frame-cfp frame))
1116 (csp (frame-cfp (di::frame-up frame)))
1117 (ip (frame-ip frame))
1118 (ocfp (frame-cfp (di::frame-down frame)))
1119 (lra (frame-ip (di::frame-down frame))))
1120 (values csp cfp ip ocfp lra)))
1121
1122 (defun print-frame-registers (frame-number)
1123 (let ((frame (di::frame-real-frame (nth-frame frame-number))))
1124 (flet ((fixnum (p) (etypecase p
1125 (integer p)
1126 (sys:system-area-pointer (sys:sap-int p)))))
1127 (apply #'format t "~
1128 CSP = ~X
1129 CFP = ~X
1130 IP = ~X
1131 OCFP = ~X
1132 LRA = ~X~%" (mapcar #'fixnum
1133 (multiple-value-list (frame-registers frame)))))))
1134
1135 (defslimefun sldb-disassemble (frame-number)
1136 "Return a string with the disassembly of frames code."
1137 (with-output-to-string (*standard-output*)
1138 (print-frame-registers frame-number)
1139 (terpri)
1140 (let* ((frame (di::frame-real-frame (nth-frame frame-number)))
1141 (debug-fun (di::frame-debug-function frame)))
1142 (etypecase debug-fun
1143 (di::compiled-debug-function
1144 (let* ((component (di::compiled-debug-function-component debug-fun))
1145 (fun (di:debug-function-function debug-fun)))
1146 (if fun
1147 (disassemble fun)
1148 (disassem:disassemble-code-component component))))
1149 (di::bogus-debug-function
1150 (format t "~%[Disassembling bogus frames not implemented]"))))))
1151
1152 #+(or)
1153 (defun print-binding-stack ()
1154 (flet ((bsp- (p) (sys:sap+ p (- (* vm:binding-size vm:word-bytes))))
1155 (frob (p offset) (kernel:make-lisp-obj (sys:sap-ref-32 p offset))))
1156 (do ((bsp (bsp- (kernel:binding-stack-pointer-sap)) (bsp- bsp))
1157 (start (sys:int-sap (lisp::binding-stack-start))))
1158 ((sys:sap= bsp start))
1159 (format t "~X: ~S = ~S~%"
1160 (sys:sap-int bsp)
1161 (frob bsp (* vm:binding-symbol-slot vm:word-bytes))
1162 (frob bsp (* vm:binding-value-slot vm:word-bytes))))))
1163
1164 ;; (print-binding-stack)
1165
1166 #+(or)
1167 (defun print-catch-blocks ()
1168 (do ((b (di::descriptor-sap lisp::*current-catch-block*)
1169 (sys:sap-ref-sap b (* vm:catch-block-previous-catch-slot
1170 vm:word-bytes))))
1171 (nil)
1172 (let ((int (sys:sap-int b)))
1173 (when (zerop int) (return))
1174 (flet ((ref (offset) (sys:sap-ref-32 b (* offset vm:word-bytes))))
1175 (let ((uwp (ref vm:catch-block-current-uwp-slot))
1176 (cfp (ref vm:catch-block-current-cont-slot))
1177 (tag (ref vm:catch-block-tag-slot))
1178 )
1179 (format t "~X: uwp = ~8X cfp = ~8X tag = ~X~%"
1180 int uwp cfp (kernel:make-lisp-obj tag)))))))
1181
1182 ;; (print-catch-blocks)
1183
1184 #+(or)
1185 (defun print-unwind-blocks ()
1186 (do ((b (di::descriptor-sap lisp::*current-unwind-protect-block*)
1187 (sys:sap-ref-sap b (* vm:unwind-block-current-uwp-slot
1188 vm:word-bytes))))
1189 (nil)
1190 (let ((int (sys:sap-int b)))
1191 (when (zerop int) (return))
1192 (flet ((ref (offset) (sys:sap-ref-32 b (* offset vm:word-bytes))))
1193 (let ((cfp (ref vm:unwind-block-current-cont-slot)))
1194 (format t "~X: cfp = ~X~%" int cfp))))))
1195
1196 ;; (print-unwind-blocks)
1197
1198
1199 ;;;; Inspecting
1200
1201 (defconstant +lowtag-symbols+
1202 '(vm:even-fixnum-type
1203 vm:function-pointer-type
1204 vm:other-immediate-0-type
1205 vm:list-pointer-type
1206 vm:odd-fixnum-type
1207 vm:instance-pointer-type
1208 vm:other-immediate-1-type
1209 vm:other-pointer-type))
1210
1211 (defconstant +header-type-symbols+
1212 ;; Is there a convinient place for all those constants?
1213 (flet ((tail-comp (string tail)
1214 (and (>= (length string) (length tail))
1215 (string= string tail :start1 (- (length string)
1216 (length tail))))))
1217 (remove-if-not
1218 (lambda (x) (and (tail-comp (symbol-name x) "-TYPE")
1219 (not (member x +lowtag-symbols+))
1220 (boundp x)
1221 (typep (symbol-value x) 'fixnum)))
1222 (append (apropos-list "-TYPE" "VM" t)
1223 (apropos-list "-TYPE" "BIGNUM" t)))))
1224
1225
1226 (defimplementation describe-primitive-type (object)
1227 (with-output-to-string (*standard-output*)
1228 (let* ((lowtag (kernel:get-lowtag object))
1229 (lowtag-symbol (find lowtag +lowtag-symbols+ :key #'symbol-value)))
1230 (format t "lowtag: ~A" lowtag-symbol)
1231 (when (member lowtag (list vm:other-pointer-type
1232 vm:function-pointer-type
1233 vm:other-immediate-0-type
1234 vm:other-immediate-1-type
1235 ))
1236 (let* ((type (kernel:get-type object))
1237 (type-symbol (find type +header-type-symbols+
1238 :key #'symbol-value)))
1239 (format t ", type: ~A" type-symbol))))))
1240
1241 (defimplementation inspected-parts (o)
1242 (cond ((di::indirect-value-cell-p o)
1243 (inspected-parts-of-value-cell o))
1244 (t
1245 (destructuring-bind (text labeledp . parts)
1246 (inspect::describe-parts o)
1247 (let ((parts (if labeledp
1248 (loop for (label . value) in parts
1249 collect (cons (string label) value))
1250 (loop for value in parts
1251 for i from 0
1252 collect (cons (format nil "~D" i) value)))))
1253 (values text parts))))))
1254
1255 (defun inspected-parts-of-value-cell (o)
1256 (values (format nil "~A~% is a value cell." o)
1257 (list (cons "Value" (c:value-cell-ref o)))))
1258
1259 (defmethod inspected-parts ((o function))
1260 (let ((header (kernel:get-type o)))
1261 (cond ((= header vm:function-header-type)
1262 (values
1263 (format nil "~A~% is a function." o)
1264 (list (cons "Self" (kernel:%function-self o))
1265 (cons "Next" (kernel:%function-next o))
1266 (cons "Name" (kernel:%function-name o))
1267 (cons "Arglist" (kernel:%function-arglist o))
1268 (cons "Type" (kernel:%function-type o))
1269 (cons "Code Object" (kernel:function-code-header o)))))
1270 ((= header vm:closure-header-type)
1271 (values (format nil "~A~% is a closure." o)
1272 (list*
1273 (cons "Function" (kernel:%closure-function o))
1274 (loop for i from 0 below (- (kernel:get-closure-length o)
1275 (1- vm:closure-info-offset))
1276 collect (cons (format nil "~D" i)
1277 (kernel:%closure-index-ref o i))))))
1278 (t (call-next-method o)))))
1279
1280 (defmethod inspected-parts ((o kernel:code-component))
1281 (values (format nil "~A~% is a code data-block." o)
1282 `(("First entry point" . ,(kernel:%code-entry-points o))
1283 ,@(loop for i from vm:code-constants-offset
1284 below (kernel:get-header-data o)
1285 collect (cons (format nil "Constant#~D" i)
1286 (kernel:code-header-ref o i)))
1287 ("Debug info" . ,(kernel:%code-debug-info o))
1288 ("Instructions" . ,(kernel:code-instructions o)))))
1289
1290 (defmethod inspected-parts ((o kernel:fdefn))
1291 (values (format nil "~A~% is a fdefn object." o)
1292 `(("Name" . ,(kernel:fdefn-name o))
1293 ("Function" . ,(kernel:fdefn-function o)))))
1294
1295
1296 ;;;; Profiling
1297 (defimplementation profile (fname)
1298 (eval `(profile:profile ,fname)))
1299
1300 (defimplementation unprofile (fname)
1301 (eval `(profile:unprofile ,fname)))
1302
1303 (defimplementation unprofile-all ()
1304 (profile:unprofile)
1305 "All functions unprofiled.")
1306
1307 (defimplementation profile-report ()
1308 (profile:report-time))
1309
1310 (defimplementation profile-reset ()
1311 (profile:reset-time)
1312 "Reset profiling counters.")
1313
1314 (defimplementation profiled-functions ()
1315 profile:*timed-functions*)
1316
1317 (defimplementation profile-package (package callers methods)
1318 (profile:profile-all :package package
1319 :callers-p callers
1320 :methods methods))
1321
1322
1323 ;;;; Multiprocessing
1324
1325 #+MP
1326 (progn
1327 (defimplementation startup-multiprocessing ()
1328 (setq *swank-in-background* :spawn)
1329 ;; Threads magic: this never returns! But top-level becomes
1330 ;; available again.
1331 (mp::startup-idle-and-top-level-loops))
1332
1333 (defimplementation spawn (fn &key (name "Anonymous"))
1334 (mp:make-process fn :name name))
1335
1336 (defimplementation thread-name (thread)
1337 (mp:process-name thread))
1338
1339 (defimplementation thread-status (thread)
1340 (mp:process-whostate thread))
1341
1342 (defimplementation current-thread ()
1343 mp:*current-process*)
1344
1345 (defimplementation all-threads ()
1346 (copy-list mp:*all-processes*))
1347
1348 (defimplementation interrupt-thread (thread fn)
1349 (mp:process-interrupt thread fn))
1350
1351 (defimplementation kill-thread (thread)
1352 (mp:destroy-process thread))
1353
1354 (defvar *mailbox-lock* (mp:make-lock "mailbox lock"))
1355
1356 (defstruct (mailbox (:conc-name mailbox.))
1357 (mutex (mp:make-lock "process mailbox"))
1358 (queue '() :type list))
1359
1360 (defun mailbox (thread)
1361 "Return THREAD's mailbox."
1362 (mp:with-lock-held (*mailbox-lock*)
1363 (or (getf (mp:process-property-list thread) 'mailbox)
1364 (setf (getf (mp:process-property-list thread) 'mailbox)
1365 (make-mailbox)))))
1366
1367 (defimplementation send (thread message)
1368 (let* ((mbox (mailbox thread))
1369 (mutex (mailbox.mutex mbox)))
1370 (mp:with-lock-held (mutex)
1371 (setf (mailbox.queue mbox)
1372 (nconc (mailbox.queue mbox) (list message))))))
1373
1374 (defimplementation receive ()
1375 (let* ((mbox (mailbox mp:*current-process*))
1376 (mutex (mailbox.mutex mbox)))
1377 (mp:process-wait "receive" #'mailbox.queue mbox)
1378 (mp:with-lock-held (mutex)
1379 (pop (mailbox.queue mbox)))))
1380
1381 )
1382
1383
1384 ;;;; Epilogue
1385 ;;; Local Variables:
1386 ;;; eval: (font-lock-add-keywords 'lisp-mode '(("(\\(defslimefun\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)" (1 font-lock-keyword-face) (2 font-lock-function-name-face))))
1387 ;;; End:

  ViewVC Help
Powered by ViewVC 1.1.5