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

Contents of /slime/swank-ecl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5