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

Contents of /slime/swank-ecl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5