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

Contents of /slime/swank-cmucl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5