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

Contents of /slime/swank-ecl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5