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

Contents of /slime/swank-ecl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.71 - (hide annotations)
Sun Nov 27 21:47:15 2011 UTC (2 years, 4 months ago) by heller
Branch: MAIN
Changes since 1.70: +2 -2 lines
* swank.lisp (create-server): Add a :backlog argument.
(setup-server): Pass it along.

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

  ViewVC Help
Powered by ViewVC 1.1.5