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

Contents of /slime/swank-ecl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.83 - (show annotations)
Sat Feb 2 10:11:16 2013 UTC (14 months, 2 weeks ago) by sboukarev
Branch: MAIN
CVS Tags: HEAD
Changes since 1.82: +4 -0 lines
* swank-backend.lisp (type-specifier-p): New.
Implement it for ACL, ECL, CCL, Clisp, SBCL, LW.

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

  ViewVC Help
Powered by ViewVC 1.1.5