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

Contents of /slime/swank-cmucl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.81 - (show annotations)
Tue Mar 9 19:35:36 2004 UTC (10 years, 1 month ago) by heller
Branch: MAIN
Changes since 1.80: +46 -0 lines
Minor modifications.
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 <<<<<<< swank-cmucl.lisp
376 (defmacro defxref (name function)
377 `(defimplementation ,name (name)
378 (xref-results (,function ,name))))
379
380 (defxref who-calls xref:who-calls)
381 (defxref who-references xref:who-references)
382 (defxref who-binds xref:who-binds)
383 (defxref who-sets xref:who-sets)
384 =======
385 (defimplementation who-calls (symbol)
386 (xrefs (xref:who-calls symbol)))
387
388 (defimplementation who-references (symbol)
389 (xrefs (xref:who-references symbol)))
390
391 (defimplementation who-binds (symbol)
392 (xrefs (xref:who-binds symbol)))
393
394 (defimplementation who-sets (symbol)
395 (xrefs (xref:who-sets symbol)))
396 >>>>>>> 1.80
397
398 #+cmu19
399 (progn
400 <<<<<<< swank-cmucl.lisp
401 (defxref who-macroexpands xref:who-macroexpands)
402 ;; XXX
403 (defimplementation who-specializes (symbol)
404 (let* ((methods (xref::who-specializes (find-class symbol)))
405 =======
406 (defimplementation who-macroexpands (macro)
407 (xrefs (xref:who-macroexpands macro)))
408 ;; XXX
409 (defimplementation who-specializes (symbol)
410 (let* ((methods (xref::who-specializes (find-class symbol)))
411 >>>>>>> 1.80
412 (locations (mapcar #'method-source-location methods)))
413 <<<<<<< swank-cmucl.lisp
414 (mapcar #'list methods locations))))
415
416 (defun xref-results (contexts)
417 (mapcar (lambda (xref)
418 (list (xref:xref-context-name xref)
419 (resolve-xref-location xref)))
420 contexts))
421 =======
422 (mapcar #'list methods locations))))
423
424 (defun xrefs (contexts)
425 (mapcar (lambda (xref)
426 (list (xref:xref-context-name xref)
427 (resolve-xref-location xref)))
428 contexts))
429 >>>>>>> 1.80
430
431 (defun resolve-xref-location (xref)
432 (let ((name (xref:xref-context-name xref))
433 (file (xref:xref-context-file xref))
434 (source-path (xref:xref-context-source-path xref)))
435 (cond ((and file source-path)
436 (let ((position (source-path-file-position source-path file)))
437 (make-location (list :file (unix-truename file))
438 (list :position (1+ position)))))
439 (file
440 (make-location (list :file (unix-truename file))
441 (list :function-name (string name))))
442 (t
443 `(:error ,(format nil "Unkown source location: ~S ~S ~S "
444 name file source-path))))))
445
446 (defun clear-xref-info (namestring)
447 "Clear XREF notes pertaining to NAMESTRING.
448 This is a workaround for a CMUCL bug: XREF records are cumulative."
449 (when c:*record-xref-info*
450 (let ((filename (truename namestring)))
451 (dolist (db (list xref::*who-calls*
452 #+cmu19 xref::*who-is-called*
453 #+cmu19 xref::*who-macroexpands*
454 xref::*who-references*
455 xref::*who-binds*
456 xref::*who-sets*))
457 (maphash (lambda (target contexts)
458 ;; XXX update during traversal?
459 (setf (gethash target db)
460 (delete filename contexts
461 :key #'xref:xref-context-file
462 :test #'equalp)))
463 db)))))
464
465 (defun unix-truename (pathname)
466 (ext:unix-namestring (truename pathname)))
467
468
469 ;;;; Find callers and callees
470
471 ;;; Find callers and callees by looking at the constant pool of
472 ;;; compiled code objects. We assume every fdefn object in the
473 ;;; constant pool corresponds to a call to that function. A better
474 ;;; strategy would be to use the disassembler to find actual
475 ;;; call-sites.
476
477 (declaim (inline map-code-constants))
478 (defun map-code-constants (code fn)
479 "Call FN for each constant in CODE's constant pool."
480 (check-type code kernel:code-component)
481 (loop for i from vm:code-constants-offset below (kernel:get-header-data code)
482 do (funcall fn (kernel:code-header-ref code i))))
483
484 (defun function-callees (function)
485 "Return FUNCTION's callees as a list of functions."
486 (let ((callees '()))
487 (map-code-constants
488 (vm::find-code-object function)
489 (lambda (obj)
490 (when (kernel:fdefn-p obj)
491 (push (kernel:fdefn-function obj) callees))))
492 callees))
493
494 (declaim (ext:maybe-inline map-allocated-code-components))
495 (defun map-allocated-code-components (spaces fn)
496 "Call FN for each allocated code component in one of SPACES. FN
497 receives the object as argument. SPACES should be a list of the
498 symbols :dynamic, :static, or :read-only."
499 (dolist (space spaces)
500 (declare (inline vm::map-allocated-objects))
501 (vm::map-allocated-objects
502 (lambda (obj header size)
503 (declare (type fixnum size) (ignore size))
504 (when (= vm:code-header-type header)
505 (funcall fn obj)))
506 space)))
507
508 (declaim (ext:maybe-inline map-caller-code-components))
509 (defun map-caller-code-components (function spaces fn)
510 "Call FN for each code component with a fdefn for FUNCTION in its
511 constant pool."
512 (let ((function (coerce function 'function)))
513 (declare (inline map-allocated-code-components))
514 (map-allocated-code-components
515 spaces
516 (lambda (obj)
517 (map-code-constants
518 obj
519 (lambda (constant)
520 (when (and (kernel:fdefn-p constant)
521 (eq (kernel:fdefn-function constant)
522 function))
523 (funcall fn obj))))))))
524
525 (defun function-callers (function &optional (spaces '(:read-only :static
526 :dynamic)))
527 "Return FUNCTION's callers. The result is a list of code-objects."
528 (let ((referrers '()))
529 (declare (inline map-caller-code-components))
530 (ext:gc :full t)
531 (map-caller-code-components function spaces
532 (lambda (code) (push code referrers)))
533 referrers))
534
535 (defun debug-info-definitions (debug-info)
536 "Return the defintions for a debug-info. This should only be used
537 for code-object without entry points, i.e., byte compiled
538 code (are theree others?)"
539 ;; This mess has only been tested with #'ext::skip-whitespace, a
540 ;; byte-compiled caller of #'read-char .
541 (check-type debug-info (and (not c::compiled-debug-info) c::debug-info))
542 (let ((name (c::debug-info-name debug-info))
543 (source (c::debug-info-source debug-info)))
544 (destructuring-bind (first) source
545 (ecase (c::debug-source-from first)
546 (:file
547 (list (list name
548 (make-location
549 (list :file (unix-truename (c::debug-source-name first)))
550 (list :function-name name)))))))))
551
552 (defun code-component-entry-points (code)
553 "Return a list ((NAME LOCATION) ...) of function definitons for
554 the code omponent CODE."
555 (delete-duplicates
556 (loop for e = (kernel:%code-entry-points code)
557 then (kernel::%function-next e)
558 while e
559 collect (list (kernel:%function-name e)
560 (function-source-location e)))
561 :test #'equal))
562
563 (defimplementation list-callers (symbol)
564 "Return a list ((NAME LOCATION) ...) of callers."
565 (let ((components (function-callers symbol))
566 (xrefs '()))
567 (dolist (code components)
568 (let* ((entry (kernel:%code-entry-points code))
569 (defs (if entry
570 (code-component-entry-points code)
571 ;; byte compiled stuff
572 (debug-info-definitions
573 (kernel:%code-debug-info code)))))
574 (setq xrefs (nconc defs xrefs))))
575 xrefs))
576
577 (defimplementation list-callees (symbol)
578 (let ((fns (function-callees symbol)))
579 (mapcar (lambda (fn)
580 (list (kernel:%function-name fn)
581 (function-source-location fn)))
582 fns)))
583
584
585 ;;;; Definitions
586
587 (defvar *debug-definition-finding* nil
588 "When true don't handle errors while looking for definitions.
589 This is useful when debugging the definition-finding code.")
590
591 (defmacro safe-definition-finding (&body body)
592 "Execute BODY ignoring errors. Return the source location returned
593 by BODY or if an error occurs a description of the error. The second
594 return value is the condition or nil."
595 `(flet ((body () ,@body))
596 (if *debug-definition-finding*
597 (body)
598 (handler-case (values (progn ,@body) nil)
599 (error (c) (values (list :error (princ-to-string c)) c))))))
600
601 (defun function-first-code-location (function)
602 (and (function-has-debug-function-p function)
603 (di:debug-function-start-location
604 (di:function-debug-function function))))
605
606 (defun function-has-debug-function-p (function)
607 (di:function-debug-function function))
608
609 (defun function-code-object= (closure function)
610 (and (eq (vm::find-code-object closure)
611 (vm::find-code-object function))
612 (not (eq closure function))))
613
614 (defun struct-closure-p (function)
615 (or (function-code-object= function #'kernel::structure-slot-accessor)
616 (function-code-object= function #'kernel::structure-slot-setter)
617 (function-code-object= function #'kernel::%defstruct)))
618
619 (defun struct-closure-dd (function)
620 (assert (= (kernel:get-type function) vm:closure-header-type))
621 (flet ((find-layout (function)
622 (sys:find-if-in-closure
623 (lambda (x)
624 (let ((value (if (di::indirect-value-cell-p x)
625 (c:value-cell-ref x)
626 x)))
627 (when (kernel::layout-p value)
628 (return-from find-layout value))))
629 function)))
630 (kernel:layout-info (find-layout function))))
631
632 (defun dd-source-location (dd)
633 (let ((constructor (or (kernel:dd-default-constructor dd)
634 (car (kernel::dd-constructors dd)))))
635 (when (or (not constructor) (and (consp constructor)
636 (not (car constructor))))
637 (error "Cannot locate struct without constructor: ~S"
638 (kernel::dd-name dd)))
639 (function-source-location
640 (coerce (if (consp constructor) (car constructor) constructor)
641 'function))))
642
643 (defun genericp (fn)
644 (typep fn 'generic-function))
645
646 (defun gf-definition-location (gf)
647 (flet ((guess-source-file (faslfile)
648 (unix-truename
649 (merge-pathnames (make-pathname :type "lisp")
650 faslfile))))
651 (let ((def-source (pcl::definition-source gf))
652 (name (string (pcl:generic-function-name gf))))
653 (etypecase def-source
654 (pathname (make-location
655 `(:file ,(guess-source-file def-source))
656 `(:function-name ,name)))
657 (cons
658 (destructuring-bind ((dg name) pathname) def-source
659 (declare (ignore dg))
660 (etypecase pathname
661 (pathname
662 (make-location `(:file ,(guess-source-file pathname))
663 `(:function-name ,(string name))))
664 (null `(:error ,(format nil "Cannot resolve: ~S" def-source)))
665 )))))))
666
667 (defun method-source-location (method)
668 (function-source-location (or (pcl::method-fast-function method)
669 (pcl:method-function method))))
670
671 (defun gf-method-locations (gf)
672 (let ((ms (pcl::generic-function-methods gf)))
673 (mapcar #'method-source-location ms)))
674
675 (defun gf-source-locations (gf)
676 (list* (gf-definition-location gf)
677 (gf-method-locations gf)))
678
679 (defun function-source-locations (function)
680 "Return a list of source locations for FUNCTION."
681 ;; First test if FUNCTION is a closure created by defstruct; if so
682 ;; extract the defstruct-description (dd) from the closure and find
683 ;; the constructor for the struct. Defstruct creates a defun for
684 ;; the default constructor and we use that as an approximation to
685 ;; the source location of the defstruct.
686 ;;
687 ;; For an ordinary function we return the source location of the
688 ;; first code-location we find.
689 (cond ((struct-closure-p function)
690 (list
691 (safe-definition-finding
692 (dd-source-location (struct-closure-dd function)))))
693 ((genericp function)
694 (gf-source-locations function))
695 (t
696 (list
697 (multiple-value-bind (code-location error)
698 (safe-definition-finding (function-first-code-location function))
699 (cond (error (list :error (princ-to-string error)))
700 (t (code-location-source-location code-location))))))))
701
702 (defun function-source-location (function)
703 (destructuring-bind (first) (function-source-locations function)
704 first))
705
706 (defimplementation find-definitions (symbol)
707 (cond ((macro-function symbol)
708 (mapcar (lambda (loc) `((macro ,symbol) ,loc))
709 (function-source-locations (macro-function symbol))))
710 ((fboundp symbol)
711 ;; XXX fixme
712 (mapcar (lambda (loc) `((function ,symbol) ,loc))
713 (function-source-locations (coerce symbol 'function))))))
714
715 ;;;; Documentation.
716
717 (defimplementation describe-symbol-for-emacs (symbol)
718 (let ((result '()))
719 (flet ((doc (kind)
720 (or (documentation symbol kind) :not-documented))
721 (maybe-push (property value)
722 (when value
723 (setf result (list* property value result)))))
724 (maybe-push
725 :variable (multiple-value-bind (kind recorded-p)
726 (ext:info variable kind symbol)
727 (declare (ignore kind))
728 (if (or (boundp symbol) recorded-p)
729 (doc 'variable))))
730 (maybe-push
731 :generic-function
732 (if (and (fboundp symbol)
733 (typep (fdefinition symbol) 'generic-function))
734 (doc 'function)))
735 (maybe-push
736 :function (if (and (fboundp symbol)
737 (not (typep (fdefinition symbol) 'generic-function)))
738 (doc 'function)))
739 (maybe-push
740 :setf (if (or (ext:info setf inverse symbol)
741 (ext:info setf expander symbol))
742 (doc 'setf)))
743 (maybe-push
744 :type (if (ext:info type kind symbol)
745 (doc 'type)))
746 (maybe-push
747 :class (if (find-class symbol nil)
748 (doc 'class)))
749 (maybe-push
750 :alien-type (if (not (eq (ext:info alien-type kind symbol) :unknown))
751 (doc 'alien-type)))
752 (maybe-push
753 :alien-struct (if (ext:info alien-type struct symbol)
754 (doc nil)))
755 (maybe-push
756 :alien-union (if (ext:info alien-type union symbol)
757 (doc nil)))
758 (maybe-push
759 :alien-enum (if (ext:info alien-type enum symbol)
760 (doc nil)))
761 result)))
762
763 (defimplementation describe-definition (symbol namespace)
764 (ecase namespace
765 (:variable
766 (describe symbol))
767 ((:function :generic-function)
768 (describe (symbol-function symbol)))
769 (:setf
770 (describe (or (ext:info setf inverse symbol))
771 (ext:info setf expander symbol)))
772 (:type
773 (describe (kernel:values-specifier-type symbol)))
774 (:class
775 (describe (find-class symbol)))
776 (:alien-type
777 (ecase (ext:info :alien-type :kind symbol)
778 (:primitive
779 (describe (let ((alien::*values-type-okay* t))
780 (funcall (ext:info :alien-type :translator symbol)
781 (list symbol)))))
782 ((:defined)
783 (describe (ext:info :alien-type :definition symbol)))
784 (:unknown
785 (format nil "Unkown alien type: ~S" symbol))))
786 (:alien-struct
787 (describe (ext:info :alien-type :struct symbol)))
788 (:alien-union
789 (describe (ext:info :alien-type :union symbol)))
790 (:alien-enum
791 (describe (ext:info :alien-type :enum symbol)))))
792
793 (defimplementation arglist (symbol)
794 (let* ((fun (or (macro-function symbol)
795 (symbol-function symbol)))
796 (arglist
797 (cond ((eval:interpreted-function-p fun)
798 (eval:interpreted-function-arglist fun))
799 ((pcl::generic-function-p fun)
800 (pcl:generic-function-lambda-list fun))
801 ((kernel:%function-arglist (kernel:%function-self fun)))
802 ;; this should work both for
803 ;; compiled-debug-function and for
804 ;; interpreted-debug-function
805 (t (let ((df (di::function-debug-function fun)))
806 (if df
807 (di::debug-function-lambda-list df)
808 "(<arglist-unavailable>)"))))))
809 (check-type arglist (or list string))
810 arglist))
811
812
813 ;;;; Miscellaneous.
814
815 (defimplementation macroexpand-all (form)
816 (walker:macroexpand-all form))
817
818 ;; (in-package :c)
819 ;;
820 ;; (defun swank-backend::expand-ir1-top-level (form)
821 ;; "A scaled down version of the first pass of the compiler."
822 ;; (with-compilation-unit ()
823 ;; (let* ((*lexical-environment*
824 ;; (make-lexenv :default (make-null-environment)
825 ;; :cookie *default-cookie*
826 ;; :interface-cookie *default-interface-cookie*))
827 ;; (*source-info* (make-lisp-source-info form))
828 ;; (*block-compile* nil)
829 ;; (*block-compile-default* nil))
830 ;; (with-ir1-namespace
831 ;; (clear-stuff)
832 ;; (find-source-paths form 0)
833 ;; (ir1-top-level form '(0) t)))))
834 ;;
835 ;; (in-package :swank-backend)
836 ;;
837 ;; (defun print-ir1-converted-blocks (form)
838 ;; (with-output-to-string (*standard-output*)
839 ;; (c::print-all-blocks (expand-ir1-top-level (from-string form)))))
840 ;;
841 ;; (defun print-compilation-trace (form)
842 ;; (with-output-to-string (*standard-output*)
843 ;; (with-input-from-string (s form)
844 ;; (ext:compile-from-stream s
845 ;; :verbose t
846 ;; :progress t
847 ;; :trace-stream *standard-output*))))
848
849 (defun set-default-directory (directory)
850 (setf (ext:default-directory) (namestring directory))
851 ;; Setting *default-pathname-defaults* to an absolute directory
852 ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive.
853 (setf *default-pathname-defaults* (pathname (ext:default-directory)))
854 (namestring (ext:default-directory)))
855
856 ;;; source-path-{stream,file,string,etc}-position moved into
857 ;;; swank-source-path-parser
858
859 (defun code-location-stream-position (code-location stream)
860 "Return the byte offset of CODE-LOCATION in STREAM. Extract the
861 toplevel-form-number and form-number from CODE-LOCATION and use that
862 to find the position of the corresponding form."
863 (let* ((location (debug::maybe-block-start-location code-location))
864 (tlf-offset (di:code-location-top-level-form-offset location))
865 (form-number (di:code-location-form-number location))
866 (*read-suppress* t))
867 (dotimes (i tlf-offset) (read stream))
868 (multiple-value-bind (tlf position-map) (read-and-record-source-map stream)
869 (let* ((path-table (di:form-number-translations tlf 0))
870 (source-path
871 (if (<= (length path-table) form-number) ; source out of sync?
872 (list 0) ; should probably signal a condition
873 (reverse (cdr (aref path-table form-number))))))
874 (source-path-source-position source-path tlf position-map)))))
875
876 (defun code-location-string-offset (code-location string)
877 (with-input-from-string (s string)
878 (code-location-stream-position code-location s)))
879
880 (defun code-location-file-position (code-location filename)
881 (with-open-file (s filename :direction :input)
882 (code-location-stream-position code-location s)))
883
884 (defun debug-source-info-from-emacs-buffer-p (debug-source)
885 (let ((info (c::debug-source-info debug-source)))
886 (and info
887 (consp info)
888 (eq :emacs-buffer (car info)))))
889
890 (defun source-location-from-code-location (code-location)
891 "Return the source location for CODE-LOCATION."
892 (let ((debug-fun (di:code-location-debug-function code-location)))
893 (when (di::bogus-debug-function-p debug-fun)
894 (error "Bogus debug function: ~A" debug-fun)))
895 (let* ((debug-source (di:code-location-debug-source code-location))
896 (from (di:debug-source-from debug-source))
897 (name (di:debug-source-name debug-source)))
898 (ecase from
899 (:file
900 (make-location (list :file (unix-truename name))
901 (list :position (1+ (code-location-file-position
902 code-location name)))))
903 (:stream
904 (assert (debug-source-info-from-emacs-buffer-p debug-source))
905 (let ((info (c::debug-source-info debug-source)))
906 (make-location
907 (list :buffer (getf info :emacs-buffer))
908 (list :position (+ (getf info :emacs-buffer-offset)
909 (code-location-string-offset
910 code-location
911 (getf info :emacs-buffer-string)))))))
912 (:lisp
913 (make-location
914 (list :source-form (with-output-to-string (*standard-output*)
915 (debug::print-code-location-source-form
916 code-location 100 t)))
917 (list :position 1))))))
918
919 (defun code-location-source-location (code-location)
920 "Safe wrapper around `code-location-from-source-location'."
921 (safe-definition-finding
922 (source-location-from-code-location code-location)))
923
924
925 ;;;; Debugging
926
927 (defvar *sldb-stack-top*)
928
929 (defimplementation call-with-debugging-environment (debugger-loop-fn)
930 (unix:unix-sigsetmask 0)
931 (let* ((*sldb-stack-top* (or debug:*stack-top-hint* (di:top-frame)))
932 (debug:*stack-top-hint* nil))
933 (handler-bind ((di:debug-condition
934 (lambda (condition)
935 (signal (make-condition
936 'sldb-condition
937 :original-condition condition)))))
938 (funcall debugger-loop-fn))))
939
940 (defun nth-frame (index)
941 (do ((frame *sldb-stack-top* (di:frame-down frame))
942 (i index (1- i)))
943 ((zerop i) frame)))
944
945 (defimplementation compute-backtrace (start end)
946 (let ((end (or end most-positive-fixnum)))
947 (loop for f = (nth-frame start) then (di:frame-down f)
948 for i from start below end
949 while f
950 collect f)))
951
952 (defimplementation print-frame (frame stream)
953 (let ((*standard-output* stream))
954 (debug::print-frame-call frame :verbosity 1 :number nil)))
955
956 (defimplementation frame-source-location-for-emacs (index)
957 (code-location-source-location (di:frame-code-location (nth-frame index))))
958
959 (defimplementation eval-in-frame (form index)
960 (di:eval-in-frame (nth-frame index) form))
961
962 (defimplementation frame-locals (index)
963 (let* ((frame (nth-frame index))
964 (location (di:frame-code-location frame))
965 (debug-function (di:frame-debug-function frame))
966 (debug-variables (di::debug-function-debug-variables debug-function)))
967 (loop for v across debug-variables collect
968 (list :name (di:debug-variable-symbol v)
969 :id (di:debug-variable-id v)
970 :value (ecase (di:debug-variable-validity v location)
971 (:valid
972 (di:debug-variable-value v frame))
973 ((:invalid :unknown)
974 ':not-available))))))
975
976 (defimplementation frame-catch-tags (index)
977 (mapcar #'car (di:frame-catches (nth-frame index))))
978
979 (defun set-step-breakpoints (frame)
980 (when (di:debug-block-elsewhere-p (di:code-location-debug-block
981 (di:frame-code-location frame)))
982 (error "Cannot step, in elsewhere code~%"))
983 (let* ((code-location (di:frame-code-location frame))
984 (debug::*bad-code-location-types*
985 (remove :call-site debug::*bad-code-location-types*))
986 (next (debug::next-code-locations code-location)))
987 (cond (next
988 (let ((steppoints '()))
989 (flet ((hook (frame breakpoint)
990 (let ((debug:*stack-top-hint* frame))
991 (mapc #'di:delete-breakpoint steppoints)
992 (let ((cl (di::breakpoint-what breakpoint)))
993 (break "Breakpoint: ~S ~S"
994 (di:code-location-kind cl)
995 (di::compiled-code-location-pc cl))))))
996 (dolist (code-location next)
997 (let ((bp (di:make-breakpoint #'hook code-location
998 :kind :code-location)))
999 (di:activate-breakpoint bp)
1000 (push bp steppoints))))))
1001 (t
1002 (flet ((hook (frame breakpoint values cookie)
1003 (declare (ignore cookie))
1004 (di:delete-breakpoint breakpoint)
1005 (let ((debug:*stack-top-hint* frame))
1006 (break "Function-end: ~A ~A" breakpoint values))))
1007 (let* ((debug-function (di:frame-debug-function frame))
1008 (bp (di:make-breakpoint #'hook debug-function
1009 :kind :function-end)))
1010 (di:activate-breakpoint bp)))))))
1011
1012 ;; (defslimefun sldb-step (frame)
1013 ;; (cond ((find-restart 'continue *swank-debugger-condition*)
1014 ;; (set-step-breakpoints (nth-frame frame))
1015 ;; (continue *swank-debugger-condition*))
1016 ;; (t
1017 ;; (error "Cannot continue in from condition: ~A"
1018 ;; *swank-debugger-condition*))))
1019
1020 (defun frame-cfp (frame)
1021 "Return the Control-Stack-Frame-Pointer for FRAME."
1022 (etypecase frame
1023 (di::compiled-frame (di::frame-pointer frame))
1024 ((or di::interpreted-frame null) -1)))
1025
1026 (defun frame-ip (frame)
1027 "Return the (absolute) instruction pointer and the relative pc of FRAME."
1028 (if (not frame)
1029 -1
1030 (let ((debug-fun (di::frame-debug-function frame)))
1031 (etypecase debug-fun
1032 (di::compiled-debug-function
1033 (let* ((code-loc (di:frame-code-location frame))
1034 (component (di::compiled-debug-function-component debug-fun))
1035 (pc (di::compiled-code-location-pc code-loc))
1036 (ip (sys:without-gcing
1037 (sys:sap-int
1038 (sys:sap+ (kernel:code-instructions component) pc)))))
1039 (values ip pc)))
1040 ((or di::bogus-debug-function di::interpreted-debug-function)
1041 -1)))))
1042
1043 (defun frame-registers (frame)
1044 "Return the lisp registers CSP, CFP, IP, OCFP, LRA for FRAME-NUMBER."
1045 (let* ((cfp (frame-cfp frame))
1046 (csp (frame-cfp (di::frame-up frame)))
1047 (ip (frame-ip frame))
1048 (ocfp (frame-cfp (di::frame-down frame)))
1049 (lra (frame-ip (di::frame-down frame))))
1050 (values csp cfp ip ocfp lra)))
1051
1052 (defun print-frame-registers (frame-number)
1053 (let ((frame (di::frame-real-frame (nth-frame frame-number))))
1054 (flet ((fixnum (p) (etypecase p
1055 (integer p)
1056 (sys:system-area-pointer (sys:sap-int p)))))
1057 (apply #'format t "~
1058 CSP = ~X
1059 CFP = ~X
1060 IP = ~X
1061 OCFP = ~X
1062 LRA = ~X~%" (mapcar #'fixnum
1063 (multiple-value-list (frame-registers frame)))))))
1064
1065 <<<<<<< swank-cmucl.lisp
1066 (defimplementation disassemble-frame (frame-number)
1067 "Return a string with the disassembly of frames code."
1068 (print-frame-registers frame-number)
1069 (terpri)
1070 (let* ((frame (di::frame-real-frame (nth-frame frame-number)))
1071 (debug-fun (di::frame-debug-function frame)))
1072 (etypecase debug-fun
1073 (di::compiled-debug-function
1074 (let* ((component (di::compiled-debug-function-component debug-fun))
1075 (fun (di:debug-function-function debug-fun)))
1076 (if fun
1077 (disassemble fun)
1078 (disassem:disassemble-code-component component))))
1079 (di::bogus-debug-function
1080 (format t "~%[Disassembling bogus frames not implemented]")))))
1081 =======
1082 ;; (defslimefun sldb-disassemble (frame-number)
1083 ;; "Return a string with the disassembly of frames code."
1084 ;; (with-output-to-string (*standard-output*)
1085 ;; (print-frame-registers frame-number)
1086 ;; (terpri)
1087 ;; (let* ((frame (di::frame-real-frame (nth-frame frame-number)))
1088 ;; (debug-fun (di::frame-debug-function frame)))
1089 ;; (etypecase debug-fun
1090 ;; (di::compiled-debug-function
1091 ;; (let* ((component (di::compiled-debug-function-component debug-fun))
1092 ;; (fun (di:debug-function-function debug-fun)))
1093 ;; (if fun
1094 ;; (disassemble fun)
1095 ;; (disassem:disassemble-code-component component))))
1096 ;; (di::bogus-debug-function
1097 ;; (format t "~%[Disassembling bogus frames not implemented]"))))))
1098 >>>>>>> 1.80
1099
1100 #+(or)
1101 (defun print-binding-stack ()
1102 (flet ((bsp- (p) (sys:sap+ p (- (* vm:binding-size vm:word-bytes))))
1103 (frob (p offset) (kernel:make-lisp-obj (sys:sap-ref-32 p offset))))
1104 (do ((bsp (bsp- (kernel:binding-stack-pointer-sap)) (bsp- bsp))
1105 (start (sys:int-sap (lisp::binding-stack-start))))
1106 ((sys:sap= bsp start))
1107 (format t "~X: ~S = ~S~%"
1108 (sys:sap-int bsp)
1109 (frob bsp (* vm:binding-symbol-slot vm:word-bytes))
1110 (frob bsp (* vm:binding-value-slot vm:word-bytes))))))
1111
1112 ;; (print-binding-stack)
1113
1114 #+(or)
1115 (defun print-catch-blocks ()
1116 (do ((b (di::descriptor-sap lisp::*current-catch-block*)
1117 (sys:sap-ref-sap b (* vm:catch-block-previous-catch-slot
1118 vm:word-bytes))))
1119 (nil)
1120 (let ((int (sys:sap-int b)))
1121 (when (zerop int) (return))
1122 (flet ((ref (offset) (sys:sap-ref-32 b (* offset vm:word-bytes))))
1123 (let ((uwp (ref vm:catch-block-current-uwp-slot))
1124 (cfp (ref vm:catch-block-current-cont-slot))
1125 (tag (ref vm:catch-block-tag-slot))
1126 )
1127 (format t "~X: uwp = ~8X cfp = ~8X tag = ~X~%"
1128 int uwp cfp (kernel:make-lisp-obj tag)))))))
1129
1130 ;; (print-catch-blocks)
1131
1132 #+(or)
1133 (defun print-unwind-blocks ()
1134 (do ((b (di::descriptor-sap lisp::*current-unwind-protect-block*)
1135 (sys:sap-ref-sap b (* vm:unwind-block-current-uwp-slot
1136 vm:word-bytes))))
1137 (nil)
1138 (let ((int (sys:sap-int b)))
1139 (when (zerop int) (return))
1140 (flet ((ref (offset) (sys:sap-ref-32 b (* offset vm:word-bytes))))
1141 (let ((cfp (ref vm:unwind-block-current-cont-slot)))
1142 (format t "~X: cfp = ~X~%" int cfp))))))
1143
1144 ;; (print-unwind-blocks)
1145
1146
1147 ;;;; Inspecting
1148
1149 (defconstant +lowtag-symbols+
1150 '(vm:even-fixnum-type
1151 vm:function-pointer-type
1152 vm:other-immediate-0-type
1153 vm:list-pointer-type
1154 vm:odd-fixnum-type
1155 vm:instance-pointer-type
1156 vm:other-immediate-1-type
1157 vm:other-pointer-type))
1158
1159 (defconstant +header-type-symbols+
1160 ;; Is there a convinient place for all those constants?
1161 (flet ((tail-comp (string tail)
1162 (and (>= (length string) (length tail))
1163 (string= string tail :start1 (- (length string)
1164 (length tail))))))
1165 (remove-if-not
1166 (lambda (x) (and (tail-comp (symbol-name x) "-TYPE")
1167 (not (member x +lowtag-symbols+))
1168 (boundp x)
1169 (typep (symbol-value x) 'fixnum)))
1170 (append (apropos-list "-TYPE" "VM" t)
1171 (apropos-list "-TYPE" "BIGNUM" t)))))
1172
1173
1174 (defimplementation describe-primitive-type (object)
1175 (with-output-to-string (*standard-output*)
1176 (let* ((lowtag (kernel:get-lowtag object))
1177 (lowtag-symbol (find lowtag +lowtag-symbols+ :key #'symbol-value)))
1178 (format t "lowtag: ~A" lowtag-symbol)
1179 (when (member lowtag (list vm:other-pointer-type
1180 vm:function-pointer-type
1181 vm:other-immediate-0-type
1182 vm:other-immediate-1-type
1183 ))
1184 (let* ((type (kernel:get-type object))
1185 (type-symbol (find type +header-type-symbols+
1186 :key #'symbol-value)))
1187 (format t ", type: ~A" type-symbol))))))
1188
1189 (defimplementation inspected-parts (o)
1190 (cond ((di::indirect-value-cell-p o)
1191 (inspected-parts-of-value-cell o))
1192 (t
1193 (destructuring-bind (text labeledp . parts)
1194 (inspect::describe-parts o)
1195 (let ((parts (if labeledp
1196 (loop for (label . value) in parts
1197 collect (cons (string label) value))
1198 (loop for value in parts
1199 for i from 0
1200 collect (cons (format nil "~D" i) value)))))
1201 (values text parts))))))
1202
1203 (defun inspected-parts-of-value-cell (o)
1204 (values (format nil "~A~% is a value cell." o)
1205 (list (cons "Value" (c:value-cell-ref o)))))
1206
1207 (defmethod inspected-parts ((o function))
1208 (let ((header (kernel:get-type o)))
1209 (cond ((= header vm:function-header-type)
1210 (values
1211 (format nil "~A~% is a function." o)
1212 (list (cons "Self" (kernel:%function-self o))
1213 (cons "Next" (kernel:%function-next o))
1214 (cons "Name" (kernel:%function-name o))
1215 (cons "Arglist" (kernel:%function-arglist o))
1216 (cons "Type" (kernel:%function-type o))
1217 (cons "Code Object" (kernel:function-code-header o)))))
1218 ((= header vm:closure-header-type)
1219 (values (format nil "~A~% is a closure." o)
1220 (list*
1221 (cons "Function" (kernel:%closure-function o))
1222 (loop for i from 0 below (- (kernel:get-closure-length o)
1223 (1- vm:closure-info-offset))
1224 collect (cons (format nil "~D" i)
1225 (kernel:%closure-index-ref o i))))))
1226 (t (call-next-method o)))))
1227
1228 (defmethod inspected-parts ((o kernel:code-component))
1229 (values (format nil "~A~% is a code data-block." o)
1230 `(("First entry point" . ,(kernel:%code-entry-points o))
1231 ,@(loop for i from vm:code-constants-offset
1232 below (kernel:get-header-data o)
1233 collect (cons (format nil "Constant#~D" i)
1234 (kernel:code-header-ref o i)))
1235 ("Debug info" . ,(kernel:%code-debug-info o))
1236 ("Instructions" . ,(kernel:code-instructions o)))))
1237
1238 (defmethod inspected-parts ((o kernel:fdefn))
1239 (values (format nil "~A~% is a fdefn object." o)
1240 `(("Name" . ,(kernel:fdefn-name o))
1241 ("Function" . ,(kernel:fdefn-function o)))))
1242
1243
1244 ;;;; Profiling
1245 (defimplementation profile (fname)
1246 (eval `(profile:profile ,fname)))
1247
1248 (defimplementation unprofile (fname)
1249 (eval `(profile:unprofile ,fname)))
1250
1251 (defimplementation unprofile-all ()
1252 (profile:unprofile)
1253 "All functions unprofiled.")
1254
1255 (defimplementation profile-report ()
1256 (profile:report-time))
1257
1258 (defimplementation profile-reset ()
1259 (profile:reset-time)
1260 "Reset profiling counters.")
1261
1262 (defimplementation profiled-functions ()
1263 profile:*timed-functions*)
1264
1265 (defimplementation profile-package (package callers methods)
1266 (profile:profile-all :package package
1267 :callers-p callers
1268 :methods methods))
1269
1270
1271 ;;;; Multiprocessing
1272
1273 #+MP
1274 (progn
1275 (defimplementation startup-multiprocessing ()
1276 ;; Threads magic: this never returns! But top-level becomes
1277 ;; available again.
1278 (mp::startup-idle-and-top-level-loops))
1279
1280 (defimplementation spawn (fn &key (name "Anonymous"))
1281 (mp:make-process fn :name name))
1282
1283 (defimplementation thread-name (thread)
1284 (mp:process-name thread))
1285
1286 (defimplementation thread-status (thread)
1287 (mp:process-whostate thread))
1288
1289 (defimplementation current-thread ()
1290 mp:*current-process*)
1291
1292 (defimplementation all-threads ()
1293 (copy-list mp:*all-processes*))
1294
1295 (defimplementation interrupt-thread (thread fn)
1296 (mp:process-interrupt thread fn))
1297
1298 (defimplementation kill-thread (thread)
1299 (mp:destroy-process thread))
1300
1301 (defvar *mailbox-lock* (mp:make-lock "mailbox lock"))
1302
1303 (defstruct (mailbox (:conc-name mailbox.))
1304 (mutex (mp:make-lock "process mailbox"))
1305 (queue '() :type list))
1306
1307 (defun mailbox (thread)
1308 "Return THREAD's mailbox."
1309 (mp:with-lock-held (*mailbox-lock*)
1310 (or (getf (mp:process-property-list thread) 'mailbox)
1311 (setf (getf (mp:process-property-list thread) 'mailbox)
1312 (make-mailbox)))))
1313
1314 (defimplementation send (thread message)
1315 (let* ((mbox (mailbox thread))
1316 (mutex (mailbox.mutex mbox)))
1317 (mp:with-lock-held (mutex)
1318 (setf (mailbox.queue mbox)
1319 (nconc (mailbox.queue mbox) (list message))))))
1320
1321 (defimplementation receive ()
1322 (let* ((mbox (mailbox mp:*current-process*))
1323 (mutex (mailbox.mutex mbox)))
1324 (mp:process-wait "receive" #'mailbox.queue mbox)
1325 (mp:with-lock-held (mutex)
1326 (pop (mailbox.queue mbox)))))
1327
1328 )

  ViewVC Help
Powered by ViewVC 1.1.5