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

Contents of /slime/swank-ecl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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