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

Contents of /slime/swank-cmucl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5