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

Contents of /slime/swank-ecl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.69 - (hide 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 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 jgarcia 1.69 #-ecl-bytecmp
209 trittweiler 1.52 (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 trittweiler 1.53 :message (princ-to-string condition)
216 trittweiler 1.52 :severity (etypecase condition
217     (c:compiler-fatal-error :error)
218 trittweiler 1.53 (c:compiler-error :error)
219     (error :error)
220     (style-warning :style-warning)
221     (warning :warning))
222 trittweiler 1.52 :location (condition-location condition))))
223    
224 jgarcia 1.69 #-ecl-bytecmp
225 trittweiler 1.52 (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 trittweiler 1.56 (make-buffer-location *buffer-name*
231     *buffer-start-position*
232     position)
233 trittweiler 1.53 (make-file-location file position))
234 trittweiler 1.52 (make-error-location "No location found."))))
235 jgarcia 1.1
236     (defimplementation call-with-compilation-hooks (function)
237 jgarcia 1.69 #-ecl-bytecmp
238     (funcall function)
239     #-ecl-bytecmp
240 trittweiler 1.52 (handler-bind ((c:compiler-message #'handle-compiler-message))
241 jgarcia 1.1 (funcall function)))
242    
243 heller 1.38 (defimplementation swank-compile-file (input-file output-file
244 sboukarev 1.58 load-p external-format
245     &key policy)
246     (declare (ignore policy))
247 jgarcia 1.1 (with-compilation-hooks ()
248 trittweiler 1.53 (compile-file input-file :output-file output-file
249     :load load-p
250     :external-format external-format)))
251 jgarcia 1.1
252 trittweiler 1.59 (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 trittweiler 1.63 (setf (gethash tmp-namestring *tmpfile-map*) buffer-name)
258     tmp-namestring))
259 trittweiler 1.59
260     (defun tmpfile-to-buffer (tmp-file)
261     (gethash tmp-file *tmpfile-map*))
262    
263 heller 1.37 (defimplementation swank-compile-string (string &key buffer position filename
264 trittweiler 1.53 policy)
265 trittweiler 1.59 (declare (ignore policy))
266 jgarcia 1.1 (with-compilation-hooks ()
267 trittweiler 1.53 (let ((*buffer-name* buffer) ; for compilation hooks
268 trittweiler 1.52 (*buffer-start-position* position))
269 trittweiler 1.59 (let ((tmp-file (si:mkstemp "TMP:ecl-swank-tmpfile-"))
270 trittweiler 1.54 (fasl-file)
271     (warnings-p)
272     (failure-p))
273 trittweiler 1.53 (unwind-protect
274 trittweiler 1.59 (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 trittweiler 1.54 (multiple-value-setq (fasl-file warnings-p failure-p)
279 trittweiler 1.59 (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 trittweiler 1.54 (when fasl-file
287     (delete-file fasl-file)))
288     (not failure-p)))))
289 jgarcia 1.1
290     ;;;; Documentation
291    
292     (defimplementation arglist (name)
293 trittweiler 1.56 (multiple-value-bind (arglist foundp)
294 trittweiler 1.57 (ext:function-lambda-list name)
295 trittweiler 1.56 (if foundp arglist :not-available)))
296 jgarcia 1.1
297 heller 1.6 (defimplementation function-name (f)
298 sboukarev 1.48 (typecase f
299     (generic-function (clos:generic-function-name f))
300     (function (si:compiled-function-name f))))
301 jgarcia 1.1
302 trittweiler 1.52 ;; FIXME
303     ;; (defimplementation macroexpand-all (form))
304 jgarcia 1.1
305     (defimplementation describe-symbol-for-emacs (symbol)
306     (let ((result '()))
307     (dolist (type '(:VARIABLE :FUNCTION :CLASS))
308 trittweiler 1.57 (when-let (doc (describe-definition symbol type))
309     (setf result (list* type doc result))))
310 jgarcia 1.1 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 trittweiler 1.56
320 jgarcia 1.1 ;;; Debugging
321    
322 heller 1.29 (eval-when (:compile-toplevel :load-toplevel :execute)
323 heller 1.28 (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 jgarcia 1.1
341 trittweiler 1.52 (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 trittweiler 1.53 (ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
356 trittweiler 1.52 (funcall fun)))
357    
358 gcarncross 1.20 (defvar *backtrace* '())
359    
360 trittweiler 1.53 ;;; 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 gcarncross 1.21
392 jgarcia 1.1 (defimplementation call-with-debugging-environment (debugger-loop-fn)
393     (declare (type function debugger-loop-fn))
394 trittweiler 1.57 (let* ((*ihs-top* (ihs-top))
395 trittweiler 1.31 (*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 gcarncross 1.40 (*backtrace* (loop for ihs from 0 below *ihs-top*
400 gcarncross 1.21 collect (list (si::ihs-fun ihs)
401 gcarncross 1.20 (si::ihs-env ihs)
402     nil))))
403 gcarncross 1.40 (declare (special *ihs-current*))
404 gcarncross 1.20 (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 gcarncross 1.23 (unless (si::fixnump name)
410 gcarncross 1.20 (push name (third x)))))))
411 trittweiler 1.53 (setf *backtrace* (nreverse *backtrace*))
412 jgarcia 1.1 (set-break-env)
413     (set-current-ihs)
414 gcarncross 1.20 (let ((*ihs-base* *ihs-top*))
415     (funcall debugger-loop-fn))))
416    
417 jgarcia 1.1 (defimplementation compute-backtrace (start end)
418 gcarncross 1.20 (when (numberp end)
419     (setf end (min end (length *backtrace*))))
420 trittweiler 1.31 (loop for f in (subseq *backtrace* start end)
421 heller 1.35 collect f))
422 gcarncross 1.20
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 trittweiler 1.53 (when file
433     (make-file-location file position))))
434 gcarncross 1.20
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 trittweiler 1.52 (setf frame (si::decode-ihs-env (second frame)))
450 jgarcia 1.67 (dolist (record (remove-if-not #'consp frame))
451 gcarncross 1.20 (let* ((record0 (car record))
452     (record1 (cdr record)))
453 gcarncross 1.40 (cond ((or (symbolp record0) (stringp record0))
454 gcarncross 1.20 (setq variables (acons record0 record1 variables)))
455 gcarncross 1.23 ((not (si::fixnump record0))
456 gcarncross 1.20 (push record1 functions))
457     ((symbolp record1)
458     (push record1 blocks))
459     (t
460     ))))
461     (values functions blocks variables)))
462 jgarcia 1.1
463 heller 1.35 (defimplementation print-frame (frame stream)
464     (format stream "~A" (first frame)))
465 gcarncross 1.20
466 heller 1.41 (defimplementation frame-source-location (frame-number)
467 gcarncross 1.20 (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 trittweiler 1.56 (let ((fun (frame-function (elt *backtrace* frame-number))))
483 gcarncross 1.20 (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 jgarcia 1.1
489 trittweiler 1.65 (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 trittweiler 1.66 (defimplementation command-line-args ()
495     (loop for n from 0 below (si:argc) collect (si:argv n)))
496    
497 trittweiler 1.56
498 jgarcia 1.1 ;;;; Inspector
499    
500 trittweiler 1.56 ;;; FIXME: Would be nice if it was possible to inspect objects
501     ;;; implemented in C.
502 gcarncross 1.11
503 trittweiler 1.56
504 jgarcia 1.1 ;;;; Definitions
505    
506 sboukarev 1.68 (defvar +TAGS+ (namestring
507     (merge-pathnames "TAGS" (translate-logical-pathname "SYS:"))))
508 trittweiler 1.55
509 trittweiler 1.59 (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 trittweiler 1.63 (make-location `(:file ,(namestring (translate-logical-pathname file)))
515 trittweiler 1.59 `(:position ,(1+ file-position))
516     `(:align t)))
517 trittweiler 1.55
518 trittweiler 1.59 (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 trittweiler 1.55
523 trittweiler 1.59 (defun make-TAGS-location (&rest tags)
524     (make-location `(:etags-file ,+TAGS+)
525     `(:tag ,@tags)))
526 trittweiler 1.55
527 trittweiler 1.59 (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 trittweiler 1.54
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 trittweiler 1.57 (when (boundp name)
551     (cond ((constantp name)
552     (push :constant types))
553     (t
554     (push :global-variable types))))
555 trittweiler 1.54 types))
556    
557 trittweiler 1.57 (defun find-definitions-by-type (name type)
558 trittweiler 1.54 (ecase type
559     (:lisp-function
560 trittweiler 1.57 (when-let (loc (source-location (fdefinition name)))
561     (list `((defun ,name) ,loc))))
562 trittweiler 1.54 (:c-function
563 trittweiler 1.57 (when-let (loc (source-location (fdefinition name)))
564     (list `((c-source ,name) ,loc))))
565 trittweiler 1.54 (: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 trittweiler 1.57 (when-let (loc (source-location (macro-function name)))
573     (list `((defmacro ,name) ,loc))))
574 trittweiler 1.59 (: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 trittweiler 1.54
582 trittweiler 1.59 ;;; 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 trittweiler 1.55
606 trittweiler 1.64 (defun package-names (package)
607     (cons (package-name package) (package-nicknames package)))
608    
609 trittweiler 1.54 (defun source-location (object)
610 trittweiler 1.55 (converting-errors-to-error-location
611 trittweiler 1.59 (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 trittweiler 1.64 ;; 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 trittweiler 1.59 (function
630     (multiple-value-bind (file pos) (ext:compiled-function-file object)
631     (cond ((not file)
632     (return-from source-location nil))
633 sboukarev 1.61 ((tmpfile-to-buffer file)
634     (make-buffer-location (tmpfile-to-buffer file) pos))
635 trittweiler 1.59 (t
636     (assert (probe-file file))
637     (assert (not (minusp pos)))
638 trittweiler 1.63 (make-file-location file pos)))))
639 trittweiler 1.59 (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 trittweiler 1.54
648     (defimplementation find-source-location (object)
649     (or (source-location object)
650 trittweiler 1.59 (make-error-location "Source definition of ~S not found." object)))
651 gcarncross 1.17
652 trittweiler 1.56
653 gcarncross 1.42 ;;;; Profiling
654    
655 trittweiler 1.52 #+profile
656     (progn
657    
658 gcarncross 1.42 (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 gcarncross 1.43 (defimplementation profile-package (package callers methods)
679     (declare (ignore callers methods))
680     (eval `(profile:profile ,(package-name (find-package package)))))
681 trittweiler 1.53 ) ; #+profile (progn ...
682 gcarncross 1.43
683 trittweiler 1.56
684 trittweiler 1.52 ;;;; Threads
685 gcarncross 1.9
686     #+threads
687     (progn
688 trittweiler 1.52 (defvar *thread-id-counter* 0)
689 trittweiler 1.51
690 trittweiler 1.52 (defparameter *thread-id-map* (make-hash-table))
691 gcarncross 1.9
692 trittweiler 1.52 (defvar *thread-id-map-lock*
693     (mp:make-lock :name "thread id map lock"))
694 gcarncross 1.9
695     (defimplementation spawn (fn &key name)
696 trittweiler 1.52 (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 gcarncross 1.9
715     (defimplementation find-thread (id)
716 trittweiler 1.52 (mp:with-lock (*thread-id-map-lock*)
717 trittweiler 1.53 (let* ((thread-ptr (gethash id *thread-id-map*))
718     (thread (and thread-ptr (si:weak-pointer-value thread-ptr))))
719 trittweiler 1.52 (unless thread
720     (remhash id *thread-id-map*))
721     thread)))
722 gcarncross 1.9
723     (defimplementation thread-name (thread)
724     (mp:process-name thread))
725    
726     (defimplementation thread-status (thread)
727 trittweiler 1.52 (if (mp:process-active-p thread)
728     "RUNNING"
729     "STOPPED"))
730 gcarncross 1.9
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 trittweiler 1.52 (defvar *mailbox-lock* (mp:make-lock :name "mailbox lock"))
754     (defvar *mailboxes* (list))
755     (declaim (type list *mailboxes*))
756    
757 gcarncross 1.9 (defstruct (mailbox (:conc-name mailbox.))
758 trittweiler 1.52 thread
759     (mutex (mp:make-lock))
760     (cvar (mp:make-condition-variable))
761 gcarncross 1.9 (queue '() :type list))
762    
763     (defun mailbox (thread)
764     "Return THREAD's mailbox."
765 trittweiler 1.52 (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 gcarncross 1.9
771     (defimplementation send (thread message)
772 trittweiler 1.52 (let* ((mbox (mailbox thread))
773     (mutex (mailbox.mutex mbox)))
774     (mp:with-lock (mutex)
775 trittweiler 1.51 (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 trittweiler 1.52 (let* ((mbox (mailbox (current-thread)))
781     (mutex (mailbox.mutex mbox)))
782 trittweiler 1.51 (assert (or (not timeout) (eq timeout t)))
783     (loop
784 trittweiler 1.52 (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 gcarncross 1.9
796 trittweiler 1.52 ) ; #+threads (progn ...

  ViewVC Help
Powered by ViewVC 1.1.5