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

Contents of /slime/swank-ecl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.66 - (hide annotations)
Fri Mar 19 12:32:30 2010 UTC (4 years, 1 month ago) by trittweiler
Branch: MAIN
Changes since 1.65: +3 -0 lines
	* slime.el (slime-lisp-implementation-program): New connection
	variable.
	(slime-set-connection-info): Adapted to set it.
	(slime-attach-gdb): Use it to invoke gdb so gdb is able to find
	debugging symbols on non-Linux platforms.

	* swank.lisp (connection-info): Include lisp-implementation-program.

	* swank-backend.lisp (lisp-implementation-program): New interface.
	Default implementation based on command-line-args.

	* swank-ecl.lisp (command-line-args): Implement.
1 heller 1.7 ;;;; -*- indent-tabs-mode: nil -*-
2 jgarcia 1.1 ;;;
3     ;;; swank-ecl.lisp --- SLIME backend for ECL.
4 heller 1.7 ;;;
5     ;;; This code has been placed in the Public Domain. All warranties
6     ;;; are disclaimed.
7     ;;;
8 jgarcia 1.1
9     ;;; Administrivia
10    
11     (in-package :swank-backend)
12    
13 trittweiler 1.52 (eval-when (:compile-toplevel :load-toplevel :execute)
14     (let ((version (find-symbol "+ECL-VERSION-NUMBER+" :EXT)))
15 trittweiler 1.60 (when (or (not version) (< (symbol-value version) 100301))
16 trittweiler 1.52 (error "~&IMPORTANT:~% ~
17     The version of ECL you're using (~A) is too old.~% ~
18 trittweiler 1.60 Please upgrade to at least 10.3.1.~% ~
19 trittweiler 1.52 Sorry for the inconvenience.~%~%"
20     (lisp-implementation-version)))))
21    
22 trittweiler 1.53 ;; 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 gcarncross 1.40 (declaim (optimize (debug 3)))
36    
37 trittweiler 1.52 ;;; Swank-mop
38 gcarncross 1.19
39 heller 1.29 (eval-when (:compile-toplevel :load-toplevel :execute)
40 trittweiler 1.52 (import-from :gray *gray-stream-symbols* :swank-backend)
41 sboukarev 1.49
42 trittweiler 1.52 (import-swank-mop-symbols :clos
43 sboukarev 1.49 '(:eql-specializer
44     :eql-specializer-object
45     :generic-function-declarations
46     :specializer-direct-methods
47     :compute-applicable-methods-using-classes)))
48    
49 jgarcia 1.1
50     ;;;; TCP Server
51    
52 trittweiler 1.56 (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 jgarcia 1.1 (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 heller 1.6 &key external-format
82 dcrosher 1.5 buffering timeout)
83 trittweiler 1.53 (declare (ignore timeout))
84 trittweiler 1.52 (sb-bsd-sockets:socket-make-stream (accept socket)
85 jgarcia 1.1 :output t
86     :input t
87 trittweiler 1.53 :buffering buffering
88     :external-format external-format))
89 jgarcia 1.1 (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 trittweiler 1.56 (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 jgarcia 1.1
102 trittweiler 1.44 (defvar *external-format-to-coding-system*
103 trittweiler 1.53 '((:latin-1
104 trittweiler 1.44 "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 trittweiler 1.53 (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 trittweiler 1.44 (defimplementation find-external-format (coding-system)
114 trittweiler 1.53 #+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 trittweiler 1.44
124 jgarcia 1.1
125 trittweiler 1.53 ;;;; Unix Integration
126 jgarcia 1.1
127 trittweiler 1.62 ;;; 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 trittweiler 1.52
133 trittweiler 1.62 (defimplementation call-with-user-break-handler (real-handler function)
134     (let ((old-handler #'si:terminal-interrupt))
135 heller 1.27 (setf (symbol-function 'si:terminal-interrupt)
136 trittweiler 1.62 (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 heller 1.27
155 jgarcia 1.1 (defimplementation getpid ()
156     (si:getpid))
157    
158     (defimplementation set-default-directory (directory)
159 trittweiler 1.52 (ext:chdir (namestring directory)) ; adapts *DEFAULT-PATHNAME-DEFAULTS*.
160 jgarcia 1.1 (default-directory))
161    
162     (defimplementation default-directory ()
163     (namestring (ext:getcwd)))
164    
165     (defimplementation quit-lisp ()
166     (ext:quit))
167    
168    
169 trittweiler 1.52
170 trittweiler 1.56 ;;; Instead of busy waiting with communication-style NIL, use select()
171     ;;; on the sockets' streams.
172 trittweiler 1.52 #+serve-event
173     (progn
174 trittweiler 1.56 (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 trittweiler 1.64 collect (cons fd s)
182 trittweiler 1.56 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 trittweiler 1.57 (when-let (ready (poll-streams streams 0.2))
195     (return ready))))))
196 trittweiler 1.52
197     ) ; #+serve-event (progn ...
198    
199    
200 jgarcia 1.1 ;;;; 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 trittweiler 1.52 (defun handle-compiler-message (condition)
209     ;; ECL emits lots of noise in compiler-notes, like "Invoking
210     ;; external command".
211     (unless (typep condition 'c::compiler-note)
212     (signal-compiler-condition
213     :original-condition condition
214 trittweiler 1.53 :message (princ-to-string condition)
215 trittweiler 1.52 :severity (etypecase condition
216     (c:compiler-fatal-error :error)
217 trittweiler 1.53 (c:compiler-error :error)
218     (error :error)
219     (style-warning :style-warning)
220     (warning :warning))
221 trittweiler 1.52 :location (condition-location condition))))
222    
223     (defun condition-location (condition)
224     (let ((file (c:compiler-message-file condition))
225     (position (c:compiler-message-file-position condition)))
226     (if (and position (not (minusp position)))
227     (if *buffer-name*
228 trittweiler 1.56 (make-buffer-location *buffer-name*
229     *buffer-start-position*
230     position)
231 trittweiler 1.53 (make-file-location file position))
232 trittweiler 1.52 (make-error-location "No location found."))))
233 jgarcia 1.1
234     (defimplementation call-with-compilation-hooks (function)
235 trittweiler 1.52 (handler-bind ((c:compiler-message #'handle-compiler-message))
236 jgarcia 1.1 (funcall function)))
237    
238 heller 1.38 (defimplementation swank-compile-file (input-file output-file
239 sboukarev 1.58 load-p external-format
240     &key policy)
241     (declare (ignore policy))
242 jgarcia 1.1 (with-compilation-hooks ()
243 trittweiler 1.53 (compile-file input-file :output-file output-file
244     :load load-p
245     :external-format external-format)))
246 jgarcia 1.1
247 trittweiler 1.59 (defvar *tmpfile-map* (make-hash-table :test #'equal))
248    
249     (defun note-buffer-tmpfile (tmp-file buffer-name)
250     ;; EXT:COMPILED-FUNCTION-FILE below will return a namestring.
251     (let ((tmp-namestring (namestring (truename tmp-file))))
252 trittweiler 1.63 (setf (gethash tmp-namestring *tmpfile-map*) buffer-name)
253     tmp-namestring))
254 trittweiler 1.59
255     (defun tmpfile-to-buffer (tmp-file)
256     (gethash tmp-file *tmpfile-map*))
257    
258 heller 1.37 (defimplementation swank-compile-string (string &key buffer position filename
259 trittweiler 1.53 policy)
260 trittweiler 1.59 (declare (ignore policy))
261 jgarcia 1.1 (with-compilation-hooks ()
262 trittweiler 1.53 (let ((*buffer-name* buffer) ; for compilation hooks
263 trittweiler 1.52 (*buffer-start-position* position))
264 trittweiler 1.59 (let ((tmp-file (si:mkstemp "TMP:ecl-swank-tmpfile-"))
265 trittweiler 1.54 (fasl-file)
266     (warnings-p)
267     (failure-p))
268 trittweiler 1.53 (unwind-protect
269 trittweiler 1.59 (with-open-file (tmp-stream tmp-file :direction :output
270     :if-exists :supersede)
271     (write-string string tmp-stream)
272     (finish-output tmp-stream)
273 trittweiler 1.54 (multiple-value-setq (fasl-file warnings-p failure-p)
274 trittweiler 1.59 (compile-file tmp-file
275     :load t
276     :source-truename (or filename
277     (note-buffer-tmpfile tmp-file buffer))
278     :source-offset (1- position))))
279     (when (probe-file tmp-file)
280     (delete-file tmp-file))
281 trittweiler 1.54 (when fasl-file
282     (delete-file fasl-file)))
283     (not failure-p)))))
284 jgarcia 1.1
285     ;;;; Documentation
286    
287     (defimplementation arglist (name)
288 trittweiler 1.56 (multiple-value-bind (arglist foundp)
289 trittweiler 1.57 (ext:function-lambda-list name)
290 trittweiler 1.56 (if foundp arglist :not-available)))
291 jgarcia 1.1
292 heller 1.6 (defimplementation function-name (f)
293 sboukarev 1.48 (typecase f
294     (generic-function (clos:generic-function-name f))
295     (function (si:compiled-function-name f))))
296 jgarcia 1.1
297 trittweiler 1.52 ;; FIXME
298     ;; (defimplementation macroexpand-all (form))
299 jgarcia 1.1
300     (defimplementation describe-symbol-for-emacs (symbol)
301     (let ((result '()))
302     (dolist (type '(:VARIABLE :FUNCTION :CLASS))
303 trittweiler 1.57 (when-let (doc (describe-definition symbol type))
304     (setf result (list* type doc result))))
305 jgarcia 1.1 result))
306    
307     (defimplementation describe-definition (name type)
308     (case type
309     (:variable (documentation name 'variable))
310     (:function (documentation name 'function))
311     (:class (documentation name 'class))
312     (t nil)))
313    
314 trittweiler 1.56
315 jgarcia 1.1 ;;; Debugging
316    
317 heller 1.29 (eval-when (:compile-toplevel :load-toplevel :execute)
318 heller 1.28 (import
319     '(si::*break-env*
320     si::*ihs-top*
321     si::*ihs-current*
322     si::*ihs-base*
323     si::*frs-base*
324     si::*frs-top*
325     si::*tpl-commands*
326     si::*tpl-level*
327     si::frs-top
328     si::ihs-top
329     si::ihs-fun
330     si::ihs-env
331     si::sch-frs-base
332     si::set-break-env
333     si::set-current-ihs
334     si::tpl-commands)))
335 jgarcia 1.1
336 trittweiler 1.52 (defun make-invoke-debugger-hook (hook)
337     (when hook
338     #'(lambda (condition old-hook)
339     ;; Regard *debugger-hook* if set by user.
340     (if *debugger-hook*
341     nil ; decline, *DEBUGGER-HOOK* will be tried next.
342     (funcall hook condition old-hook)))))
343    
344     (defimplementation install-debugger-globally (function)
345     (setq *debugger-hook* function)
346     (setq ext:*invoke-debugger-hook* (make-invoke-debugger-hook function)))
347    
348     (defimplementation call-with-debugger-hook (hook fun)
349     (let ((*debugger-hook* hook)
350 trittweiler 1.53 (ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
351 trittweiler 1.52 (funcall fun)))
352    
353 gcarncross 1.20 (defvar *backtrace* '())
354    
355 trittweiler 1.53 ;;; Commented out; it's not clear this is a good way of doing it. In
356     ;;; particular because it makes errors stemming from this file harder
357     ;;; to debug, and given the "young" age of ECL's swank backend, that's
358     ;;; a bad idea.
359    
360     ;; (defun in-swank-package-p (x)
361     ;; (and
362     ;; (symbolp x)
363     ;; (member (symbol-package x)
364     ;; (list #.(find-package :swank)
365     ;; #.(find-package :swank-backend)
366     ;; #.(ignore-errors (find-package :swank-mop))
367     ;; #.(ignore-errors (find-package :swank-loader))))
368     ;; t))
369    
370     ;; (defun is-swank-source-p (name)
371     ;; (setf name (pathname name))
372     ;; (pathname-match-p
373     ;; name
374     ;; (make-pathname :defaults swank-loader::*source-directory*
375     ;; :name (pathname-name name)
376     ;; :type (pathname-type name)
377     ;; :version (pathname-version name))))
378    
379     ;; (defun is-ignorable-fun-p (x)
380     ;; (or
381     ;; (in-swank-package-p (frame-name x))
382     ;; (multiple-value-bind (file position)
383     ;; (ignore-errors (si::bc-file (car x)))
384     ;; (declare (ignore position))
385     ;; (if file (is-swank-source-p file)))))
386 gcarncross 1.21
387 jgarcia 1.1 (defimplementation call-with-debugging-environment (debugger-loop-fn)
388     (declare (type function debugger-loop-fn))
389 trittweiler 1.57 (let* ((*ihs-top* (ihs-top))
390 trittweiler 1.31 (*ihs-current* *ihs-top*)
391     (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top))))
392     (*frs-top* (frs-top))
393     (*tpl-level* (1+ *tpl-level*))
394 gcarncross 1.40 (*backtrace* (loop for ihs from 0 below *ihs-top*
395 gcarncross 1.21 collect (list (si::ihs-fun ihs)
396 gcarncross 1.20 (si::ihs-env ihs)
397     nil))))
398 gcarncross 1.40 (declare (special *ihs-current*))
399 gcarncross 1.20 (loop for f from *frs-base* until *frs-top*
400     do (let ((i (- (si::frs-ihs f) *ihs-base* 1)))
401     (when (plusp i)
402     (let* ((x (elt *backtrace* i))
403     (name (si::frs-tag f)))
404 gcarncross 1.23 (unless (si::fixnump name)
405 gcarncross 1.20 (push name (third x)))))))
406 trittweiler 1.53 (setf *backtrace* (nreverse *backtrace*))
407 jgarcia 1.1 (set-break-env)
408     (set-current-ihs)
409 gcarncross 1.20 (let ((*ihs-base* *ihs-top*))
410     (funcall debugger-loop-fn))))
411    
412 jgarcia 1.1 (defimplementation compute-backtrace (start end)
413 gcarncross 1.20 (when (numberp end)
414     (setf end (min end (length *backtrace*))))
415 trittweiler 1.31 (loop for f in (subseq *backtrace* start end)
416 heller 1.35 collect f))
417 gcarncross 1.20
418     (defun frame-name (frame)
419     (let ((x (first frame)))
420     (if (symbolp x)
421     x
422     (function-name x))))
423    
424     (defun function-position (fun)
425     (multiple-value-bind (file position)
426     (si::bc-file fun)
427 trittweiler 1.53 (when file
428     (make-file-location file position))))
429 gcarncross 1.20
430     (defun frame-function (frame)
431     (let* ((x (first frame))
432     fun position)
433     (etypecase x
434     (symbol (and (fboundp x)
435     (setf fun (fdefinition x)
436     position (function-position fun))))
437     (function (setf fun x position (function-position x))))
438     (values fun position)))
439    
440     (defun frame-decode-env (frame)
441     (let ((functions '())
442     (blocks '())
443     (variables '()))
444 trittweiler 1.52 (setf frame (si::decode-ihs-env (second frame)))
445 gcarncross 1.40 (dolist (record frame)
446 gcarncross 1.20 (let* ((record0 (car record))
447     (record1 (cdr record)))
448 gcarncross 1.40 (cond ((or (symbolp record0) (stringp record0))
449 gcarncross 1.20 (setq variables (acons record0 record1 variables)))
450 gcarncross 1.23 ((not (si::fixnump record0))
451 gcarncross 1.20 (push record1 functions))
452     ((symbolp record1)
453     (push record1 blocks))
454     (t
455     ))))
456     (values functions blocks variables)))
457 jgarcia 1.1
458 heller 1.35 (defimplementation print-frame (frame stream)
459     (format stream "~A" (first frame)))
460 gcarncross 1.20
461 heller 1.41 (defimplementation frame-source-location (frame-number)
462 gcarncross 1.20 (nth-value 1 (frame-function (elt *backtrace* frame-number))))
463    
464     (defimplementation frame-catch-tags (frame-number)
465     (third (elt *backtrace* frame-number)))
466    
467     (defimplementation frame-locals (frame-number)
468     (loop for (name . value) in (nth-value 2 (frame-decode-env (elt *backtrace* frame-number)))
469     with i = 0
470     collect (list :name name :id (prog1 i (incf i)) :value value)))
471    
472     (defimplementation frame-var-value (frame-number var-id)
473     (elt (nth-value 2 (frame-decode-env (elt *backtrace* frame-number)))
474     var-id))
475    
476     (defimplementation disassemble-frame (frame-number)
477 trittweiler 1.56 (let ((fun (frame-function (elt *backtrace* frame-number))))
478 gcarncross 1.20 (disassemble fun)))
479    
480     (defimplementation eval-in-frame (form frame-number)
481     (let ((env (second (elt *backtrace* frame-number))))
482     (si:eval-with-env form env)))
483 jgarcia 1.1
484 trittweiler 1.65 (defimplementation gdb-initial-commands ()
485     ;; These signals are used by the GC.
486     #+linux '("handle SIGPWR noprint nostop"
487     "handle SIGXCPU noprint nostop"))
488    
489 trittweiler 1.66 (defimplementation command-line-args ()
490     (loop for n from 0 below (si:argc) collect (si:argv n)))
491    
492 trittweiler 1.56
493 jgarcia 1.1 ;;;; Inspector
494    
495 trittweiler 1.56 ;;; FIXME: Would be nice if it was possible to inspect objects
496     ;;; implemented in C.
497 gcarncross 1.11
498 trittweiler 1.56
499 jgarcia 1.1 ;;;; Definitions
500    
501 trittweiler 1.59 (defvar +TAGS+ (namestring (translate-logical-pathname #P"SYS:TAGS")))
502 trittweiler 1.55
503 trittweiler 1.59 (defun make-file-location (file file-position)
504     ;; File positions in CL start at 0, but Emacs' buffer positions
505     ;; start at 1. We specify (:ALIGN T) because the positions comming
506     ;; from ECL point at right after the toplevel form appearing before
507     ;; the actual target toplevel form; (:ALIGN T) will DTRT in that case.
508 trittweiler 1.63 (make-location `(:file ,(namestring (translate-logical-pathname file)))
509 trittweiler 1.59 `(:position ,(1+ file-position))
510     `(:align t)))
511 trittweiler 1.55
512 trittweiler 1.59 (defun make-buffer-location (buffer-name start-position &optional (offset 0))
513     (make-location `(:buffer ,buffer-name)
514     `(:offset ,start-position ,offset)
515     `(:align t)))
516 trittweiler 1.55
517 trittweiler 1.59 (defun make-TAGS-location (&rest tags)
518     (make-location `(:etags-file ,+TAGS+)
519     `(:tag ,@tags)))
520 trittweiler 1.55
521 trittweiler 1.59 (defimplementation find-definitions (name)
522     (let ((annotations (ext:get-annotation name 'si::location :all)))
523     (cond (annotations
524     (loop for annotation in annotations
525     collect (destructuring-bind (dspec file . pos) annotation
526     `(,dspec ,(make-file-location file pos)))))
527     (t
528     (mapcan #'(lambda (type) (find-definitions-by-type name type))
529     (classify-definition-name name))))))
530 trittweiler 1.54
531     (defun classify-definition-name (name)
532     (let ((types '()))
533     (when (fboundp name)
534     (cond ((special-operator-p name)
535     (push :special-operator types))
536     ((macro-function name)
537     (push :macro types))
538     ((typep (fdefinition name) 'generic-function)
539     (push :generic-function types))
540     ((si:mangle-name name t)
541     (push :c-function types))
542     (t
543     (push :lisp-function types))))
544 trittweiler 1.57 (when (boundp name)
545     (cond ((constantp name)
546     (push :constant types))
547     (t
548     (push :global-variable types))))
549 trittweiler 1.54 types))
550    
551 trittweiler 1.57 (defun find-definitions-by-type (name type)
552 trittweiler 1.54 (ecase type
553     (:lisp-function
554 trittweiler 1.57 (when-let (loc (source-location (fdefinition name)))
555     (list `((defun ,name) ,loc))))
556 trittweiler 1.54 (:c-function
557 trittweiler 1.57 (when-let (loc (source-location (fdefinition name)))
558     (list `((c-source ,name) ,loc))))
559 trittweiler 1.54 (:generic-function
560     (loop for method in (clos:generic-function-methods (fdefinition name))
561     for specs = (clos:method-specializers method)
562     for loc = (source-location method)
563     when loc
564     collect `((defmethod ,name ,specs) ,loc)))
565     (:macro
566 trittweiler 1.57 (when-let (loc (source-location (macro-function name)))
567     (list `((defmacro ,name) ,loc))))
568 trittweiler 1.59 (:constant
569     (when-let (loc (source-location name))
570     (list `((defconstant ,name) ,loc))))
571     (:global-variable
572     (when-let (loc (source-location name))
573     (list `((defvar ,name) ,loc))))
574     (:special-operator)))
575 trittweiler 1.54
576 trittweiler 1.59 ;;; FIXME: There ought to be a better way.
577     (eval-when (:compile-toplevel :load-toplevel :execute)
578     (defun c-function-name-p (name)
579     (and (symbolp name) (si:mangle-name name t) t))
580     (defun c-function-p (object)
581     (and (functionp object)
582     (let ((fn-name (function-name object)))
583     (and fn-name (c-function-name-p fn-name))))))
584    
585     (deftype c-function ()
586     `(satisfies c-function-p))
587    
588     (defun assert-source-directory ()
589     (unless (probe-file #P"SRC:")
590     (error "ECL's source directory ~A does not exist. ~
591     You can specify a different location via the environment ~
592     variable `ECLSRCDIR'."
593     (namestring (translate-logical-pathname #P"SYS:")))))
594    
595     (defun assert-TAGS-file ()
596     (unless (probe-file +TAGS+)
597     (error "No TAGS file ~A found. It should have been installed with ECL."
598     +TAGS+)))
599 trittweiler 1.55
600 trittweiler 1.64 (defun package-names (package)
601     (cons (package-name package) (package-nicknames package)))
602    
603 trittweiler 1.54 (defun source-location (object)
604 trittweiler 1.55 (converting-errors-to-error-location
605 trittweiler 1.59 (typecase object
606     (c-function
607     (assert-source-directory)
608     (assert-TAGS-file)
609     (let ((lisp-name (function-name object)))
610     (assert lisp-name)
611     (multiple-value-bind (flag c-name) (si:mangle-name lisp-name t)
612     (assert flag)
613     ;; In ECL's code base sometimes the mangled name is used
614 trittweiler 1.64 ;; directly, sometimes ECL's DPP magic of @SI::SYMBOL or
615     ;; @EXT::SYMBOL is used. We cannot predict here, so we just
616     ;; provide several candidates.
617     (apply #'make-TAGS-location
618     c-name
619     (loop with s = (symbol-name lisp-name)
620     for p in (package-names (symbol-package lisp-name))
621     collect (format nil "~A::~A" p s)
622     collect (format nil "~(~A::~A~)" p s))))))
623 trittweiler 1.59 (function
624     (multiple-value-bind (file pos) (ext:compiled-function-file object)
625     (cond ((not file)
626     (return-from source-location nil))
627 sboukarev 1.61 ((tmpfile-to-buffer file)
628     (make-buffer-location (tmpfile-to-buffer file) pos))
629 trittweiler 1.59 (t
630     (assert (probe-file file))
631     (assert (not (minusp pos)))
632 trittweiler 1.63 (make-file-location file pos)))))
633 trittweiler 1.59 (method
634     ;; FIXME: This will always return NIL at the moment; ECL does not
635     ;; store debug information for methods yet.
636     (source-location (clos:method-function object)))
637     ((member nil t)
638     (multiple-value-bind (flag c-name) (si:mangle-name object)
639     (assert flag)
640     (make-TAGS-location c-name))))))
641 trittweiler 1.54
642     (defimplementation find-source-location (object)
643     (or (source-location object)
644 trittweiler 1.59 (make-error-location "Source definition of ~S not found." object)))
645 gcarncross 1.17
646 trittweiler 1.56
647 gcarncross 1.42 ;;;; Profiling
648    
649 trittweiler 1.52 #+profile
650     (progn
651    
652 gcarncross 1.42 (defimplementation profile (fname)
653     (when fname (eval `(profile:profile ,fname))))
654    
655     (defimplementation unprofile (fname)
656     (when fname (eval `(profile:unprofile ,fname))))
657    
658     (defimplementation unprofile-all ()
659     (profile:unprofile-all)
660     "All functions unprofiled.")
661    
662     (defimplementation profile-report ()
663     (profile:report))
664    
665     (defimplementation profile-reset ()
666     (profile:reset)
667     "Reset profiling counters.")
668    
669     (defimplementation profiled-functions ()
670     (profile:profile))
671    
672 gcarncross 1.43 (defimplementation profile-package (package callers methods)
673     (declare (ignore callers methods))
674     (eval `(profile:profile ,(package-name (find-package package)))))
675 trittweiler 1.53 ) ; #+profile (progn ...
676 gcarncross 1.43
677 trittweiler 1.56
678 trittweiler 1.52 ;;;; Threads
679 gcarncross 1.9
680     #+threads
681     (progn
682 trittweiler 1.52 (defvar *thread-id-counter* 0)
683 trittweiler 1.51
684 trittweiler 1.52 (defparameter *thread-id-map* (make-hash-table))
685 gcarncross 1.9
686 trittweiler 1.52 (defvar *thread-id-map-lock*
687     (mp:make-lock :name "thread id map lock"))
688 gcarncross 1.9
689     (defimplementation spawn (fn &key name)
690 trittweiler 1.52 (mp:process-run-function name fn))
691    
692     (defimplementation thread-id (target-thread)
693     (block thread-id
694     (mp:with-lock (*thread-id-map-lock*)
695     ;; Does TARGET-THREAD have an id already?
696     (maphash (lambda (id thread-pointer)
697     (let ((thread (si:weak-pointer-value thread-pointer)))
698     (cond ((not thread)
699     (remhash id *thread-id-map*))
700     ((eq thread target-thread)
701     (return-from thread-id id)))))
702     *thread-id-map*)
703     ;; TARGET-THREAD not found in *THREAD-ID-MAP*
704     (let ((id (incf *thread-id-counter*))
705     (thread-pointer (si:make-weak-pointer target-thread)))
706     (setf (gethash id *thread-id-map*) thread-pointer)
707     id))))
708 gcarncross 1.9
709     (defimplementation find-thread (id)
710 trittweiler 1.52 (mp:with-lock (*thread-id-map-lock*)
711 trittweiler 1.53 (let* ((thread-ptr (gethash id *thread-id-map*))
712     (thread (and thread-ptr (si:weak-pointer-value thread-ptr))))
713 trittweiler 1.52 (unless thread
714     (remhash id *thread-id-map*))
715     thread)))
716 gcarncross 1.9
717     (defimplementation thread-name (thread)
718     (mp:process-name thread))
719    
720     (defimplementation thread-status (thread)
721 trittweiler 1.52 (if (mp:process-active-p thread)
722     "RUNNING"
723     "STOPPED"))
724 gcarncross 1.9
725     (defimplementation make-lock (&key name)
726     (mp:make-lock :name name))
727    
728     (defimplementation call-with-lock-held (lock function)
729     (declare (type function function))
730     (mp:with-lock (lock) (funcall function)))
731    
732     (defimplementation current-thread ()
733     mp:*current-process*)
734    
735     (defimplementation all-threads ()
736     (mp:all-processes))
737    
738     (defimplementation interrupt-thread (thread fn)
739     (mp:interrupt-process thread fn))
740    
741     (defimplementation kill-thread (thread)
742     (mp:process-kill thread))
743    
744     (defimplementation thread-alive-p (thread)
745     (mp:process-active-p thread))
746    
747 trittweiler 1.52 (defvar *mailbox-lock* (mp:make-lock :name "mailbox lock"))
748     (defvar *mailboxes* (list))
749     (declaim (type list *mailboxes*))
750    
751 gcarncross 1.9 (defstruct (mailbox (:conc-name mailbox.))
752 trittweiler 1.52 thread
753     (mutex (mp:make-lock))
754     (cvar (mp:make-condition-variable))
755 gcarncross 1.9 (queue '() :type list))
756    
757     (defun mailbox (thread)
758     "Return THREAD's mailbox."
759 trittweiler 1.52 (mp:with-lock (*mailbox-lock*)
760     (or (find thread *mailboxes* :key #'mailbox.thread)
761     (let ((mb (make-mailbox :thread thread)))
762     (push mb *mailboxes*)
763     mb))))
764 gcarncross 1.9
765     (defimplementation send (thread message)
766 trittweiler 1.52 (let* ((mbox (mailbox thread))
767     (mutex (mailbox.mutex mbox)))
768     (mp:with-lock (mutex)
769 trittweiler 1.51 (setf (mailbox.queue mbox)
770     (nconc (mailbox.queue mbox) (list message)))
771     (mp:condition-variable-broadcast (mailbox.cvar mbox)))))
772    
773     (defimplementation receive-if (test &optional timeout)
774 trittweiler 1.52 (let* ((mbox (mailbox (current-thread)))
775     (mutex (mailbox.mutex mbox)))
776 trittweiler 1.51 (assert (or (not timeout) (eq timeout t)))
777     (loop
778 trittweiler 1.52 (check-slime-interrupts)
779     (mp:with-lock (mutex)
780     (let* ((q (mailbox.queue mbox))
781     (tail (member-if test q)))
782     (when tail
783     (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
784     (return (car tail))))
785     (when (eq timeout t) (return (values nil t)))
786     (mp:condition-variable-timedwait (mailbox.cvar mbox)
787     mutex
788     0.2)))))
789 gcarncross 1.9
790 trittweiler 1.52 ) ; #+threads (progn ...

  ViewVC Help
Powered by ViewVC 1.1.5