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

Contents of /slime/swank-ecl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5