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

Contents of /slime/swank-ecl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.54 - (show annotations)
Mon Feb 22 12:56:36 2010 UTC (4 years, 1 month ago) by trittweiler
Branch: MAIN
Changes since 1.53: +103 -26 lines
	Make M-. be able to jump right into the C source for ECL.

	Because it's based on TAGS files, M-. and M-* will DTRT once in a
	.c file.

	* swank-ecl.lisp (assert-TAGS-file): New helper.
	(classify-definition-name): Ditto.
	(find-definitions-for-type): Ditto. Understands Lisp and C
	functions.
	(find-definitions): Use them.
	(source-location): New helper. Extracted from FIND-SOURCE-LOCATION.
	(find-source-location): Use it.
	(swank-compile-string): Only try to delete temporary files if they
	exist.
1 ;;;; -*- indent-tabs-mode: nil -*-
2 ;;;
3 ;;; swank-ecl.lisp --- SLIME backend for ECL.
4 ;;;
5 ;;; This code has been placed in the Public Domain. All warranties
6 ;;; are disclaimed.
7 ;;;
8
9 ;;; Administrivia
10
11 (in-package :swank-backend)
12
13 (eval-when (:compile-toplevel :load-toplevel :execute)
14 (let ((version (find-symbol "+ECL-VERSION-NUMBER+" :EXT)))
15 (when (or (not version) (< (symbol-value version) 100201))
16 (error "~&IMPORTANT:~% ~
17 The version of ECL you're using (~A) is too old.~% ~
18 Please upgrade to at least 10.2.1.~% ~
19 Sorry for the inconvenience.~%~%"
20 (lisp-implementation-version)))))
21
22 ;; Hard dependencies.
23 (eval-when (:compile-toplevel :load-toplevel :execute)
24 (require 'sockets))
25
26 ;; Soft dependencies.
27 (eval-when (:compile-toplevel :load-toplevel :execute)
28 (when (probe-file "sys:profile.fas")
29 (require :profile)
30 (pushnew :profile *features*))
31 (when (probe-file "sys:serve-event.fas")
32 (require :serve-event)
33 (pushnew :serve-event *features*)))
34
35 (declaim (optimize (debug 3)))
36
37 ;;; Swank-mop
38
39 (eval-when (:compile-toplevel :load-toplevel :execute)
40 (import-from :gray *gray-stream-symbols* :swank-backend)
41
42 (import-swank-mop-symbols :clos
43 '(:eql-specializer
44 :eql-specializer-object
45 :generic-function-declarations
46 :specializer-direct-methods
47 :compute-applicable-methods-using-classes)))
48
49
50 ;;;; TCP Server
51
52 (defun resolve-hostname (name)
53 (car (sb-bsd-sockets:host-ent-addresses
54 (sb-bsd-sockets:get-host-by-name name))))
55
56 (defimplementation create-socket (host port)
57 (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
58 :type :stream
59 :protocol :tcp)))
60 (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
61 (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port)
62 (sb-bsd-sockets:socket-listen socket 5)
63 socket))
64
65 (defimplementation local-port (socket)
66 (nth-value 1 (sb-bsd-sockets:socket-name socket)))
67
68 (defimplementation close-socket (socket)
69 (when (eq (preferred-communication-style) :fd-handler)
70 (remove-fd-handlers socket))
71 (sb-bsd-sockets:socket-close socket))
72
73 (defimplementation accept-connection (socket
74 &key external-format
75 buffering timeout)
76 (declare (ignore timeout))
77 (sb-bsd-sockets:socket-make-stream (accept socket)
78 :output t
79 :input t
80 :buffering buffering
81 :external-format external-format))
82 (defun accept (socket)
83 "Like socket-accept, but retry on EAGAIN."
84 (loop (handler-case
85 (return (sb-bsd-sockets:socket-accept socket))
86 (sb-bsd-sockets:interrupted-error ()))))
87
88 (defimplementation preferred-communication-style ()
89 ;; ECL on Windows does not provide condition-variables
90 (or #+(and threads (not windows)) :spawn
91 #+serve-event :fd-handler
92 nil))
93
94 (defvar *external-format-to-coding-system*
95 '((:latin-1
96 "latin-1" "latin-1-unix" "iso-latin-1-unix"
97 "iso-8859-1" "iso-8859-1-unix")
98 (:utf-8 "utf-8" "utf-8-unix")))
99
100 (defun external-format (coding-system)
101 (or (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
102 *external-format-to-coding-system*))
103 (find coding-system (ext:all-encodings) :test #'string-equal)))
104
105 (defimplementation find-external-format (coding-system)
106 #+unicode (external-format coding-system)
107 ;; Without unicode support, ECL uses the one-byte encoding of the
108 ;; underlying OS, and will barf on anything except :DEFAULT. We
109 ;; return NIL here for known multibyte encodings, so
110 ;; SWANK:CREATE-SERVER will barf.
111 #-unicode (let ((xf (external-format coding-system)))
112 (if (member xf '(:utf-8))
113 nil
114 :default)))
115
116
117 ;;;; Unix Integration
118
119 (defvar *original-sigint-handler* #'si:terminal-interrupt)
120
121 (defimplementation install-sigint-handler (handler)
122 (declare (function handler))
123 (let ((old-handler (symbol-function 'si:terminal-interrupt)))
124 (setf (symbol-function 'si:terminal-interrupt)
125 (if (eq handler *original-sigint-handler*)
126 handler
127 (lambda (&rest args)
128 (declare (ignore args))
129 (funcall handler)
130 (continue))))
131 old-handler))
132
133 (defimplementation getpid ()
134 (si:getpid))
135
136 (defimplementation set-default-directory (directory)
137 (ext:chdir (namestring directory)) ; adapts *DEFAULT-PATHNAME-DEFAULTS*.
138 (default-directory))
139
140 (defimplementation default-directory ()
141 (namestring (ext:getcwd)))
142
143 (defimplementation quit-lisp ()
144 (ext:quit))
145
146
147 ;;;; Serve Event Handlers
148
149 ;;; FIXME: verify this is correct implementation
150
151 #+serve-event
152 (progn
153
154 (defun socket-fd (socket)
155 (etypecase socket
156 (fixnum socket)
157 (two-way-stream (socket-fd (two-way-stream-input-stream socket)))
158 (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket))
159 (file-stream (si:file-stream-fd socket))))
160
161 (defvar *descriptor-handlers* (make-hash-table :test 'eql))
162
163 (defimplementation add-fd-handler (socket fun)
164 (let* ((fd (socket-fd socket))
165 (handler (gethash fd *descriptor-handlers*)))
166 (when handler
167 (serve-event:remove-fd-handler handler))
168 (setf (gethash fd *descriptor-handlers*)
169 (serve-event:add-fd-handler fd :input #'(lambda (x)
170 (declare (ignore x))
171 (funcall fun))))
172 (serve-event:serve-event)))
173
174 (defimplementation remove-fd-handlers (socket)
175 (let ((handler (gethash (socket-fd socket) *descriptor-handlers*)))
176 (when handler
177 (serve-event:remove-fd-handler handler))))
178
179 (defimplementation wait-for-input (streams &optional timeout)
180 (assert (member timeout '(nil t)))
181 (loop
182 (let ((ready (remove-if-not #'listen streams)))
183 (when ready (return ready)))
184 ;; (when timeout (return nil))
185 (when (check-slime-interrupts) (return :interrupt))
186 (serve-event:serve-event)))
187
188 ) ; #+serve-event (progn ...
189
190
191 ;;;; Compilation
192
193 (defvar *buffer-name* nil)
194 (defvar *buffer-start-position*)
195
196 (defun signal-compiler-condition (&rest args)
197 (signal (apply #'make-condition 'compiler-condition args)))
198
199 (defun handle-compiler-message (condition)
200 ;; ECL emits lots of noise in compiler-notes, like "Invoking
201 ;; external command".
202 (unless (typep condition 'c::compiler-note)
203 (signal-compiler-condition
204 :original-condition condition
205 :message (princ-to-string condition)
206 :severity (etypecase condition
207 (c:compiler-fatal-error :error)
208 (c:compiler-error :error)
209 (error :error)
210 (style-warning :style-warning)
211 (warning :warning))
212 :location (condition-location condition))))
213
214 (defun make-file-location (file file-position)
215 ;; File positions in CL start at 0, but Emacs' buffer positions
216 ;; start at 1. We specify (:ALIGN T) because the positions comming
217 ;; from ECL point at right after the toplevel form appearing before
218 ;; the actual target toplevel form; (:ALIGN T) will DTRT in that case.
219 (make-location `(:file ,(namestring file))
220 `(:position ,(1+ file-position))
221 `(:align t)))
222
223 (defun make-buffer-location (buffer-name start-position offset)
224 (make-location `(:buffer ,buffer-name)
225 `(:offset ,start-position ,offset)
226 `(:align t)))
227
228 (defun condition-location (condition)
229 (let ((file (c:compiler-message-file condition))
230 (position (c:compiler-message-file-position condition)))
231 (if (and position (not (minusp position)))
232 (if *buffer-name*
233 (make-buffer-location *buffer-name* *buffer-start-position* position)
234 (make-file-location file position))
235 (make-error-location "No location found."))))
236
237 (defimplementation call-with-compilation-hooks (function)
238 (handler-bind ((c:compiler-message #'handle-compiler-message))
239 (funcall function)))
240
241 (defimplementation swank-compile-file (input-file output-file
242 load-p external-format)
243 (with-compilation-hooks ()
244 (compile-file input-file :output-file output-file
245 :load load-p
246 :external-format external-format)))
247
248 (defimplementation swank-compile-string (string &key buffer position filename
249 policy)
250 (declare (ignore filename policy))
251 (with-compilation-hooks ()
252 (let ((*buffer-name* buffer) ; for compilation hooks
253 (*buffer-start-position* position))
254 (let ((file (si:mkstemp "TMP:ECL-SWANK-"))
255 (fasl-file)
256 (warnings-p)
257 (failure-p))
258 (unwind-protect
259 (with-open-file (file-stream file :direction :output
260 :if-exists :supersede)
261 (write-string string file-stream)
262 (finish-output file-stream)
263 (multiple-value-setq (fasl-file warnings-p failure-p)
264 (compile-file file :load t)))
265 (when (probe-file file)
266 (delete-file file))
267 (when fasl-file
268 (delete-file fasl-file)))
269 (not failure-p)))))
270
271 ;;;; Documentation
272
273 (defun grovel-docstring-for-arglist (name type)
274 (flet ((compute-arglist-offset (docstring)
275 (when docstring
276 (let ((pos1 (search "Args: " docstring)))
277 (and pos1 (+ pos1 6))))))
278 (let* ((docstring (si::get-documentation name type))
279 (pos (compute-arglist-offset docstring)))
280 (if pos
281 (multiple-value-bind (arglist errorp)
282 (ignore-errors
283 (values (read-from-string docstring t nil :start pos)))
284 (if (or errorp (not (listp arglist)))
285 :not-available
286 ; ECL for some reason includes macro name at the first place
287 (if (or (macro-function name)
288 (special-operator-p name))
289 (cdr arglist)
290 arglist)))
291 :not-available ))))
292
293 (defimplementation arglist (name)
294 (cond ((and (symbolp name) (special-operator-p name))
295 (grovel-docstring-for-arglist name 'function))
296 ((and (symbolp name) (macro-function name))
297 (grovel-docstring-for-arglist name 'function))
298 ((or (functionp name) (fboundp name))
299 (multiple-value-bind (name fndef)
300 (if (functionp name)
301 (values (function-name name) name)
302 (values name (fdefinition name)))
303 (typecase fndef
304 (generic-function
305 (clos::generic-function-lambda-list fndef))
306 (compiled-function
307 (grovel-docstring-for-arglist name 'function))
308 (function
309 (let ((fle (function-lambda-expression fndef)))
310 (case (car fle)
311 (si:lambda-block (caddr fle))
312 (t :not-available)))))))
313 (t :not-available)))
314
315 (defimplementation function-name (f)
316 (typecase f
317 (generic-function (clos:generic-function-name f))
318 (function (si:compiled-function-name f))))
319
320 ;; FIXME
321 ;; (defimplementation macroexpand-all (form))
322
323 (defimplementation describe-symbol-for-emacs (symbol)
324 (let ((result '()))
325 (dolist (type '(:VARIABLE :FUNCTION :CLASS))
326 (let ((doc (describe-definition symbol type)))
327 (when doc
328 (setf result (list* type doc result)))))
329 result))
330
331 (defimplementation describe-definition (name type)
332 (case type
333 (:variable (documentation name 'variable))
334 (:function (documentation name 'function))
335 (:class (documentation name 'class))
336 (t nil)))
337
338 ;;; Debugging
339
340 (eval-when (:compile-toplevel :load-toplevel :execute)
341 (import
342 '(si::*break-env*
343 si::*ihs-top*
344 si::*ihs-current*
345 si::*ihs-base*
346 si::*frs-base*
347 si::*frs-top*
348 si::*tpl-commands*
349 si::*tpl-level*
350 si::frs-top
351 si::ihs-top
352 si::ihs-fun
353 si::ihs-env
354 si::sch-frs-base
355 si::set-break-env
356 si::set-current-ihs
357 si::tpl-commands)))
358
359 (defun make-invoke-debugger-hook (hook)
360 (when hook
361 #'(lambda (condition old-hook)
362 ;; Regard *debugger-hook* if set by user.
363 (if *debugger-hook*
364 nil ; decline, *DEBUGGER-HOOK* will be tried next.
365 (funcall hook condition old-hook)))))
366
367 (defimplementation install-debugger-globally (function)
368 (setq *debugger-hook* function)
369 (setq ext:*invoke-debugger-hook* (make-invoke-debugger-hook function)))
370
371 (defimplementation call-with-debugger-hook (hook fun)
372 (let ((*debugger-hook* hook)
373 (ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
374 (funcall fun)))
375
376 (defvar *backtrace* '())
377
378 ;;; Commented out; it's not clear this is a good way of doing it. In
379 ;;; particular because it makes errors stemming from this file harder
380 ;;; to debug, and given the "young" age of ECL's swank backend, that's
381 ;;; a bad idea.
382
383 ;; (defun in-swank-package-p (x)
384 ;; (and
385 ;; (symbolp x)
386 ;; (member (symbol-package x)
387 ;; (list #.(find-package :swank)
388 ;; #.(find-package :swank-backend)
389 ;; #.(ignore-errors (find-package :swank-mop))
390 ;; #.(ignore-errors (find-package :swank-loader))))
391 ;; t))
392
393 ;; (defun is-swank-source-p (name)
394 ;; (setf name (pathname name))
395 ;; (pathname-match-p
396 ;; name
397 ;; (make-pathname :defaults swank-loader::*source-directory*
398 ;; :name (pathname-name name)
399 ;; :type (pathname-type name)
400 ;; :version (pathname-version name))))
401
402 ;; (defun is-ignorable-fun-p (x)
403 ;; (or
404 ;; (in-swank-package-p (frame-name x))
405 ;; (multiple-value-bind (file position)
406 ;; (ignore-errors (si::bc-file (car x)))
407 ;; (declare (ignore position))
408 ;; (if file (is-swank-source-p file)))))
409
410 (defimplementation call-with-debugging-environment (debugger-loop-fn)
411 (declare (type function debugger-loop-fn))
412 (let* ((*tpl-commands* si::tpl-commands)
413 (*ihs-top* (ihs-top))
414 (*ihs-current* *ihs-top*)
415 (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top))))
416 (*frs-top* (frs-top))
417 (*read-suppress* nil)
418 (*tpl-level* (1+ *tpl-level*))
419 (*backtrace* (loop for ihs from 0 below *ihs-top*
420 collect (list (si::ihs-fun ihs)
421 (si::ihs-env ihs)
422 nil))))
423 (declare (special *ihs-current*))
424 (loop for f from *frs-base* until *frs-top*
425 do (let ((i (- (si::frs-ihs f) *ihs-base* 1)))
426 (when (plusp i)
427 (let* ((x (elt *backtrace* i))
428 (name (si::frs-tag f)))
429 (unless (si::fixnump name)
430 (push name (third x)))))))
431 (setf *backtrace* (nreverse *backtrace*))
432 (set-break-env)
433 (set-current-ihs)
434 (let ((*ihs-base* *ihs-top*))
435 (funcall debugger-loop-fn))))
436
437 (defimplementation compute-backtrace (start end)
438 (when (numberp end)
439 (setf end (min end (length *backtrace*))))
440 (loop for f in (subseq *backtrace* start end)
441 collect f))
442
443 (defun frame-name (frame)
444 (let ((x (first frame)))
445 (if (symbolp x)
446 x
447 (function-name x))))
448
449 (defun function-position (fun)
450 (multiple-value-bind (file position)
451 (si::bc-file fun)
452 (when file
453 (make-file-location file position))))
454
455 (defun frame-function (frame)
456 (let* ((x (first frame))
457 fun position)
458 (etypecase x
459 (symbol (and (fboundp x)
460 (setf fun (fdefinition x)
461 position (function-position fun))))
462 (function (setf fun x position (function-position x))))
463 (values fun position)))
464
465 (defun frame-decode-env (frame)
466 (let ((functions '())
467 (blocks '())
468 (variables '()))
469 (setf frame (si::decode-ihs-env (second frame)))
470 (dolist (record frame)
471 (let* ((record0 (car record))
472 (record1 (cdr record)))
473 (cond ((or (symbolp record0) (stringp record0))
474 (setq variables (acons record0 record1 variables)))
475 ((not (si::fixnump record0))
476 (push record1 functions))
477 ((symbolp record1)
478 (push record1 blocks))
479 (t
480 ))))
481 (values functions blocks variables)))
482
483 (defimplementation print-frame (frame stream)
484 (format stream "~A" (first frame)))
485
486 (defimplementation frame-source-location (frame-number)
487 (nth-value 1 (frame-function (elt *backtrace* frame-number))))
488
489 (defimplementation frame-catch-tags (frame-number)
490 (third (elt *backtrace* frame-number)))
491
492 (defimplementation frame-locals (frame-number)
493 (loop for (name . value) in (nth-value 2 (frame-decode-env (elt *backtrace* frame-number)))
494 with i = 0
495 collect (list :name name :id (prog1 i (incf i)) :value value)))
496
497 (defimplementation frame-var-value (frame-number var-id)
498 (elt (nth-value 2 (frame-decode-env (elt *backtrace* frame-number)))
499 var-id))
500
501 (defimplementation disassemble-frame (frame-number)
502 (let ((fun (frame-fun (elt *backtrace* frame-number))))
503 (disassemble fun)))
504
505 (defimplementation eval-in-frame (form frame-number)
506 (let ((env (second (elt *backtrace* frame-number))))
507 (si:eval-with-env form env)))
508
509 ;;;; Inspector
510
511 (defmethod emacs-inspect ((o t))
512 ; ecl clos support leaves some to be desired
513 (cond
514 ((streamp o)
515 (list*
516 (format nil "~S is an ordinary stream~%" o)
517 (append
518 (list
519 "Open for "
520 (cond
521 ((ignore-errors (interactive-stream-p o)) "Interactive")
522 ((and (input-stream-p o) (output-stream-p o)) "Input and output")
523 ((input-stream-p o) "Input")
524 ((output-stream-p o) "Output"))
525 `(:newline) `(:newline))
526 (label-value-line*
527 ("Element type" (stream-element-type o))
528 ("External format" (stream-external-format o)))
529 (ignore-errors (label-value-line*
530 ("Broadcast streams" (broadcast-stream-streams o))))
531 (ignore-errors (label-value-line*
532 ("Concatenated streams" (concatenated-stream-streams o))))
533 (ignore-errors (label-value-line*
534 ("Echo input stream" (echo-stream-input-stream o))))
535 (ignore-errors (label-value-line*
536 ("Echo output stream" (echo-stream-output-stream o))))
537 (ignore-errors (label-value-line*
538 ("Output String" (get-output-stream-string o))))
539 (ignore-errors (label-value-line*
540 ("Synonym symbol" (synonym-stream-symbol o))))
541 (ignore-errors (label-value-line*
542 ("Input stream" (two-way-stream-input-stream o))))
543 (ignore-errors (label-value-line*
544 ("Output stream" (two-way-stream-output-stream o)))))))
545 ((si:instancep o)
546 (let* ((cl (si:instance-class o))
547 (slots (clos:class-slots cl)))
548 (list* (format nil "~S is an instance of class ~A~%"
549 o (clos::class-name cl))
550 (loop for x in slots append
551 (let* ((name (clos:slot-definition-name x))
552 (value (clos::slot-value o name)))
553 (list
554 (format nil "~S: " name)
555 `(:value ,value)
556 `(:newline)))))))))
557
558 ;;;; Definitions
559
560 (defconstant +TAGS+ #P"SYS:TAGS")
561
562 ;;; FIXME: this depends on a patch not yet merged into ECL upstream.
563 ;;; When it's in, remove this.
564
565 (defun get-source-pathname ()
566 #+#. (swank-backend::with-symbol 'get-source-pathname 'si)
567 (si:get-source-pathname))
568
569 (defun assert-TAGS-file (fail)
570 (flet ((fail (x)
571 (funcall fail x)))
572 (let ((ecl-src-dir (get-source-pathname)))
573 (unless ecl-src-dir
574 (fail (make-error-location "Do not know where ECL's source directory ~
575 is. You can set the environment variable ~
576 `ECLSRCDIR' for that purpose.")))
577 (unless (probe-file ecl-src-dir)
578 (fail (make-error-location "ECL's source directory ~S does not ~
579 seem to exist." ecl-src-dir)))
580 (unless (probe-file +TAGS+)
581 (fail (make-error-location "No TAGS file ~A. You can create it by ~
582 the command `make TAGS'"
583 (truename +TAGS+)))))))
584
585 (defun classify-definition-name (name)
586 (let ((types '()))
587 (when (fboundp name)
588 (cond ((special-operator-p name)
589 (push :special-operator types))
590 ((macro-function name)
591 (push :macro types))
592 ((typep (fdefinition name) 'generic-function)
593 (push :generic-function types))
594 ((si:mangle-name name t)
595 (push :c-function types))
596 (t
597 (push :lisp-function types))))
598 types))
599
600 (defun find-definitions-for-type (name type)
601 (ecase type
602 (:lisp-function
603 (list `((defun ,name) ,(source-location (symbol-function name)))))
604 (:c-function
605 (assert-TAGS-file #'(lambda (x) (return-from find-definitions-for-type x)))
606 (multiple-value-bind (flag c-name) (si:mangle-name name t)
607 (assert flag)
608 ;; In ECL's code base sometimes the mangled name is used
609 ;; directly, sometimes ECL's DPP magic of @LISP:SYMBOL is used.
610 ;; We cannot predict here, so we just provide two candidates.
611 (let* ((candidate1 c-name)
612 (candidate2 (format nil "~A::~A"
613 (package-name (symbol-package name))
614 (symbol-name name)))
615 (loc (make-location `(:etags-file ,(namestring (truename +TAGS+)))
616 `(:tag ,candidate1 ,candidate2))))
617 (list `((c-function ,name) ,loc)))))
618 (:generic-function
619 (loop for method in (clos:generic-function-methods (fdefinition name))
620 for specs = (clos:method-specializers method)
621 for loc = (source-location method)
622 when loc
623 collect `((defmethod ,name ,specs) ,loc)))
624 (:macro
625 (values 'defmacro (source-location (macro-function name))))
626 (:special-operator)))
627
628 (defimplementation find-definitions (name)
629 (mapcan #'(lambda (type) (find-definitions-for-type name type))
630 (classify-definition-name name)))
631
632 (defun source-location (object)
633 (typecase object
634 (function
635 ;; FIXME: EXT:C-F-FILE may return "/tmp/ECL_SWANK_KMOXtm" which
636 ;; are the temporary files stemming from C-c C-c.
637 (multiple-value-bind (file pos) (ext:compiled-function-file object)
638 (when file
639 (assert (probe-file file))
640 (assert (not (minusp pos)))
641 (make-file-location file pos))))
642 (method
643 ;; FIXME: This will always return NIL at the moment; ECL does not
644 ;; store debug information for methods yet.
645 (source-location (clos:method-function object)))))
646
647 (defimplementation find-source-location (object)
648 (or (source-location object)
649 (make-error-location "Source definition of ~S not found" object)))
650
651 ;;;; Profiling
652
653 #+profile
654 (progn
655
656 (eval-when (:compile-toplevel :load-toplevel :execute)
657 (require 'profile))
658
659 (defimplementation profile (fname)
660 (when fname (eval `(profile:profile ,fname))))
661
662 (defimplementation unprofile (fname)
663 (when fname (eval `(profile:unprofile ,fname))))
664
665 (defimplementation unprofile-all ()
666 (profile:unprofile-all)
667 "All functions unprofiled.")
668
669 (defimplementation profile-report ()
670 (profile:report))
671
672 (defimplementation profile-reset ()
673 (profile:reset)
674 "Reset profiling counters.")
675
676 (defimplementation profiled-functions ()
677 (profile:profile))
678
679 (defimplementation profile-package (package callers methods)
680 (declare (ignore callers methods))
681 (eval `(profile:profile ,(package-name (find-package package)))))
682 ) ; #+profile (progn ...
683
684 ;;;; Threads
685
686 #+threads
687 (progn
688 (defvar *thread-id-counter* 0)
689
690 (defparameter *thread-id-map* (make-hash-table))
691
692 (defvar *thread-id-map-lock*
693 (mp:make-lock :name "thread id map lock"))
694
695 (defimplementation spawn (fn &key name)
696 (mp:process-run-function name fn))
697
698 (defimplementation thread-id (target-thread)
699 (block thread-id
700 (mp:with-lock (*thread-id-map-lock*)
701 ;; Does TARGET-THREAD have an id already?
702 (maphash (lambda (id thread-pointer)
703 (let ((thread (si:weak-pointer-value thread-pointer)))
704 (cond ((not thread)
705 (remhash id *thread-id-map*))
706 ((eq thread target-thread)
707 (return-from thread-id id)))))
708 *thread-id-map*)
709 ;; TARGET-THREAD not found in *THREAD-ID-MAP*
710 (let ((id (incf *thread-id-counter*))
711 (thread-pointer (si:make-weak-pointer target-thread)))
712 (setf (gethash id *thread-id-map*) thread-pointer)
713 id))))
714
715 (defimplementation find-thread (id)
716 (mp:with-lock (*thread-id-map-lock*)
717 (let* ((thread-ptr (gethash id *thread-id-map*))
718 (thread (and thread-ptr (si:weak-pointer-value thread-ptr))))
719 (unless thread
720 (remhash id *thread-id-map*))
721 thread)))
722
723 (defimplementation thread-name (thread)
724 (mp:process-name thread))
725
726 (defimplementation thread-status (thread)
727 (if (mp:process-active-p thread)
728 "RUNNING"
729 "STOPPED"))
730
731 (defimplementation make-lock (&key name)
732 (mp:make-lock :name name))
733
734 (defimplementation call-with-lock-held (lock function)
735 (declare (type function function))
736 (mp:with-lock (lock) (funcall function)))
737
738 (defimplementation current-thread ()
739 mp:*current-process*)
740
741 (defimplementation all-threads ()
742 (mp:all-processes))
743
744 (defimplementation interrupt-thread (thread fn)
745 (mp:interrupt-process thread fn))
746
747 (defimplementation kill-thread (thread)
748 (mp:process-kill thread))
749
750 (defimplementation thread-alive-p (thread)
751 (mp:process-active-p thread))
752
753 (defvar *mailbox-lock* (mp:make-lock :name "mailbox lock"))
754 (defvar *mailboxes* (list))
755 (declaim (type list *mailboxes*))
756
757 (defstruct (mailbox (:conc-name mailbox.))
758 thread
759 (mutex (mp:make-lock))
760 (cvar (mp:make-condition-variable))
761 (queue '() :type list))
762
763 (defun mailbox (thread)
764 "Return THREAD's mailbox."
765 (mp:with-lock (*mailbox-lock*)
766 (or (find thread *mailboxes* :key #'mailbox.thread)
767 (let ((mb (make-mailbox :thread thread)))
768 (push mb *mailboxes*)
769 mb))))
770
771 (defimplementation send (thread message)
772 (let* ((mbox (mailbox thread))
773 (mutex (mailbox.mutex mbox)))
774 (mp:with-lock (mutex)
775 (setf (mailbox.queue mbox)
776 (nconc (mailbox.queue mbox) (list message)))
777 (mp:condition-variable-broadcast (mailbox.cvar mbox)))))
778
779 (defimplementation receive-if (test &optional timeout)
780 (let* ((mbox (mailbox (current-thread)))
781 (mutex (mailbox.mutex mbox)))
782 (assert (or (not timeout) (eq timeout t)))
783 (loop
784 (check-slime-interrupts)
785 (mp:with-lock (mutex)
786 (let* ((q (mailbox.queue mbox))
787 (tail (member-if test q)))
788 (when tail
789 (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
790 (return (car tail))))
791 (when (eq timeout t) (return (values nil t)))
792 (mp:condition-variable-timedwait (mailbox.cvar mbox)
793 mutex
794 0.2)))))
795
796 ) ; #+threads (progn ...

  ViewVC Help
Powered by ViewVC 1.1.5