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

Contents of /slime/swank-ecl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.53 - (hide annotations)
Sat Feb 20 19:15:59 2010 UTC (4 years, 1 month ago) by trittweiler
Branch: MAIN
Changes since 1.52: +108 -82 lines
	More work on ECL's swank-backend.

	* swank-ecl.lisp (accept-connection): Handle :buffering, and
	:external-format.
	(external-format): New helper.
	(find-external-format): Make sure to only return :default in case
	ECL was built with --disable-unicode; it'll barf on anything else.
	(socket-fd): Add two-way-stream case due to recent changes in ECL.
	(make-file-location, make-buffer-location): New helpers.
	(condition-location): Use them.
	(swank-compile-file): Handle :external-format.
	(compile-from-stream): Deleted. Slurped into swank-compile-string.
	(swank-compile-string): Call SI:MKSTEMP correctly. Make sure to
	also remove fasl file, not just source file.
	(grovel-docstring-for-arglist): Do not look at "Syntax:" entry in
	docstring because that was a kludge. Upstream ECL should be
	modified instead.
	(in-swank-package-p, is-swank-source-p, is-ignorable-fun-p):
	Commented out. They make debugging ECL's swank-backend harder.
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     (when (or (not version) (< (symbol-value version) 100201))
16     (error "~&IMPORTANT:~% ~
17     The version of ECL you're using (~A) is too old.~% ~
18     Please upgrade to at least 10.2.1.~% ~
19     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     (defun resolve-hostname (name)
53     (car (sb-bsd-sockets:host-ent-addresses
54     (sb-bsd-sockets:get-host-by-name name))))
55    
56     (defimplementation create-socket (host port)
57     (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
58     :type :stream
59     :protocol :tcp)))
60     (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
61     (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port)
62     (sb-bsd-sockets:socket-listen socket 5)
63     socket))
64    
65     (defimplementation local-port (socket)
66     (nth-value 1 (sb-bsd-sockets:socket-name socket)))
67    
68     (defimplementation close-socket (socket)
69 trittweiler 1.52 (when (eq (preferred-communication-style) :fd-handler)
70     (remove-fd-handlers socket))
71 jgarcia 1.1 (sb-bsd-sockets:socket-close socket))
72    
73     (defimplementation accept-connection (socket
74 heller 1.6 &key external-format
75 dcrosher 1.5 buffering timeout)
76 trittweiler 1.53 (declare (ignore timeout))
77 trittweiler 1.52 (sb-bsd-sockets:socket-make-stream (accept socket)
78 jgarcia 1.1 :output t
79     :input t
80 trittweiler 1.53 :buffering buffering
81     :external-format external-format))
82 jgarcia 1.1 (defun accept (socket)
83     "Like socket-accept, but retry on EAGAIN."
84     (loop (handler-case
85     (return (sb-bsd-sockets:socket-accept socket))
86     (sb-bsd-sockets:interrupted-error ()))))
87    
88     (defimplementation preferred-communication-style ()
89 trittweiler 1.52 ;; ECL on Windows does not provide condition-variables
90 trittweiler 1.53 (or #+(and threads (not windows)) :spawn
91 trittweiler 1.52 #+serve-event :fd-handler
92     nil))
93 jgarcia 1.1
94 trittweiler 1.44 (defvar *external-format-to-coding-system*
95 trittweiler 1.53 '((:latin-1
96 trittweiler 1.44 "latin-1" "latin-1-unix" "iso-latin-1-unix"
97     "iso-8859-1" "iso-8859-1-unix")
98     (:utf-8 "utf-8" "utf-8-unix")))
99    
100 trittweiler 1.53 (defun external-format (coding-system)
101     (or (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
102     *external-format-to-coding-system*))
103     (find coding-system (ext:all-encodings) :test #'string-equal)))
104    
105 trittweiler 1.44 (defimplementation find-external-format (coding-system)
106 trittweiler 1.53 #+unicode (external-format coding-system)
107     ;; Without unicode support, ECL uses the one-byte encoding of the
108     ;; underlying OS, and will barf on anything except :DEFAULT. We
109     ;; return NIL here for known multibyte encodings, so
110     ;; SWANK:CREATE-SERVER will barf.
111     #-unicode (let ((xf (external-format coding-system)))
112     (if (member xf '(:utf-8))
113     nil
114     :default)))
115 trittweiler 1.44
116 jgarcia 1.1
117 trittweiler 1.53 ;;;; Unix Integration
118 jgarcia 1.1
119 trittweiler 1.52 (defvar *original-sigint-handler* #'si:terminal-interrupt)
120    
121 heller 1.27 (defimplementation install-sigint-handler (handler)
122 trittweiler 1.52 (declare (function handler))
123 heller 1.27 (let ((old-handler (symbol-function 'si:terminal-interrupt)))
124     (setf (symbol-function 'si:terminal-interrupt)
125 trittweiler 1.52 (if (eq handler *original-sigint-handler*)
126     handler
127 heller 1.27 (lambda (&rest args)
128     (declare (ignore args))
129     (funcall handler)
130     (continue))))
131 trittweiler 1.52 old-handler))
132 heller 1.27
133 jgarcia 1.1 (defimplementation getpid ()
134     (si:getpid))
135    
136     (defimplementation set-default-directory (directory)
137 trittweiler 1.52 (ext:chdir (namestring directory)) ; adapts *DEFAULT-PATHNAME-DEFAULTS*.
138 jgarcia 1.1 (default-directory))
139    
140     (defimplementation default-directory ()
141     (namestring (ext:getcwd)))
142    
143     (defimplementation quit-lisp ()
144     (ext:quit))
145    
146    
147 trittweiler 1.52 ;;;; Serve Event Handlers
148    
149     ;;; FIXME: verify this is correct implementation
150    
151     #+serve-event
152     (progn
153    
154     (defun socket-fd (socket)
155     (etypecase socket
156     (fixnum socket)
157 trittweiler 1.53 (two-way-stream (socket-fd (two-way-stream-input-stream socket)))
158 trittweiler 1.52 (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket))
159     (file-stream (si:file-stream-fd socket))))
160    
161     (defvar *descriptor-handlers* (make-hash-table :test 'eql))
162    
163     (defimplementation add-fd-handler (socket fun)
164     (let* ((fd (socket-fd socket))
165     (handler (gethash fd *descriptor-handlers*)))
166     (when handler
167     (serve-event:remove-fd-handler handler))
168     (setf (gethash fd *descriptor-handlers*)
169     (serve-event:add-fd-handler fd :input #'(lambda (x)
170     (declare (ignore x))
171     (funcall fun))))
172     (serve-event:serve-event)))
173    
174     (defimplementation remove-fd-handlers (socket)
175     (let ((handler (gethash (socket-fd socket) *descriptor-handlers*)))
176     (when handler
177     (serve-event:remove-fd-handler handler))))
178    
179     (defimplementation wait-for-input (streams &optional timeout)
180     (assert (member timeout '(nil t)))
181     (loop
182     (let ((ready (remove-if-not #'listen streams)))
183     (when ready (return ready)))
184     ;; (when timeout (return nil))
185     (when (check-slime-interrupts) (return :interrupt))
186     (serve-event:serve-event)))
187    
188     ) ; #+serve-event (progn ...
189    
190    
191 jgarcia 1.1 ;;;; Compilation
192    
193     (defvar *buffer-name* nil)
194     (defvar *buffer-start-position*)
195    
196     (defun signal-compiler-condition (&rest args)
197     (signal (apply #'make-condition 'compiler-condition args)))
198    
199 trittweiler 1.52 (defun handle-compiler-message (condition)
200     ;; ECL emits lots of noise in compiler-notes, like "Invoking
201     ;; external command".
202     (unless (typep condition 'c::compiler-note)
203     (signal-compiler-condition
204     :original-condition condition
205 trittweiler 1.53 :message (princ-to-string condition)
206 trittweiler 1.52 :severity (etypecase condition
207     (c:compiler-fatal-error :error)
208 trittweiler 1.53 (c:compiler-error :error)
209     (error :error)
210     (style-warning :style-warning)
211     (warning :warning))
212 trittweiler 1.52 :location (condition-location condition))))
213    
214 trittweiler 1.53 (defun make-file-location (file file-position)
215     ;; File positions in CL start at 0, but Emacs' buffer positions
216     ;; start at 1.
217     (make-location `(:file ,(namestring file))
218     `(:position ,(1+ file-position))
219     `(:align t)))
220    
221     (defun make-buffer-location (buffer-name start-position offset)
222     (make-location `(:buffer ,buffer-name)
223     `(:offset ,start-position ,offset)
224     `(:align t)))
225    
226 trittweiler 1.52 (defun condition-location (condition)
227     (let ((file (c:compiler-message-file condition))
228     (position (c:compiler-message-file-position condition)))
229     (if (and position (not (minusp position)))
230     (if *buffer-name*
231 trittweiler 1.53 (make-buffer-location *buffer-name* *buffer-start-position* position)
232     (make-file-location file position))
233 trittweiler 1.52 (make-error-location "No location found."))))
234 jgarcia 1.1
235     (defimplementation call-with-compilation-hooks (function)
236 trittweiler 1.52 (handler-bind ((c:compiler-message #'handle-compiler-message))
237 jgarcia 1.1 (funcall function)))
238    
239 heller 1.38 (defimplementation swank-compile-file (input-file output-file
240     load-p external-format)
241 jgarcia 1.1 (with-compilation-hooks ()
242 trittweiler 1.53 (compile-file input-file :output-file output-file
243     :load load-p
244     :external-format external-format)))
245 jgarcia 1.1
246 heller 1.37 (defimplementation swank-compile-string (string &key buffer position filename
247 trittweiler 1.53 policy)
248 heller 1.37 (declare (ignore filename policy))
249 jgarcia 1.1 (with-compilation-hooks ()
250 trittweiler 1.53 (let ((*buffer-name* buffer) ; for compilation hooks
251 trittweiler 1.52 (*buffer-start-position* position))
252 trittweiler 1.53 (let ((file (si:mkstemp "TMP:ECL-SWANK-")))
253     (unwind-protect
254     (with-open-file (file-stream file :direction :output
255     :if-exists :supersede)
256     (write-string string file-stream)
257     (finish-output file-stream)
258     (not (nth-value 2 (compile-file file :load t))))
259     (delete-file file)
260     (delete-file (compile-file-pathname file)))))))
261 jgarcia 1.1
262     ;;;; Documentation
263    
264 trittweiler 1.32 (defun grovel-docstring-for-arglist (name type)
265     (flet ((compute-arglist-offset (docstring)
266     (when docstring
267     (let ((pos1 (search "Args: " docstring)))
268 trittweiler 1.53 (and pos1 (+ pos1 6))))))
269 trittweiler 1.32 (let* ((docstring (si::get-documentation name type))
270     (pos (compute-arglist-offset docstring)))
271     (if pos
272     (multiple-value-bind (arglist errorp)
273     (ignore-errors
274     (values (read-from-string docstring t nil :start pos)))
275 gcarncross 1.39 (if (or errorp (not (listp arglist)))
276     :not-available
277 sboukarev 1.46 ; ECL for some reason includes macro name at the first place
278     (if (or (macro-function name)
279     (special-operator-p name))
280     (cdr arglist)
281     arglist)))
282 trittweiler 1.32 :not-available ))))
283    
284 jgarcia 1.1 (defimplementation arglist (name)
285 sboukarev 1.48 (cond ((and (symbolp name) (special-operator-p name))
286 trittweiler 1.32 (grovel-docstring-for-arglist name 'function))
287 sboukarev 1.48 ((and (symbolp name) (macro-function name))
288 trittweiler 1.32 (grovel-docstring-for-arglist name 'function))
289     ((or (functionp name) (fboundp name))
290     (multiple-value-bind (name fndef)
291     (if (functionp name)
292     (values (function-name name) name)
293     (values name (fdefinition name)))
294     (typecase fndef
295     (generic-function
296     (clos::generic-function-lambda-list fndef))
297     (compiled-function
298     (grovel-docstring-for-arglist name 'function))
299     (function
300     (let ((fle (function-lambda-expression fndef)))
301     (case (car fle)
302     (si:lambda-block (caddr fle))
303     (t :not-available)))))))
304     (t :not-available)))
305 jgarcia 1.1
306 heller 1.6 (defimplementation function-name (f)
307 sboukarev 1.48 (typecase f
308     (generic-function (clos:generic-function-name f))
309     (function (si:compiled-function-name f))))
310 jgarcia 1.1
311 trittweiler 1.52 ;; FIXME
312     ;; (defimplementation macroexpand-all (form))
313 jgarcia 1.1
314     (defimplementation describe-symbol-for-emacs (symbol)
315     (let ((result '()))
316     (dolist (type '(:VARIABLE :FUNCTION :CLASS))
317     (let ((doc (describe-definition symbol type)))
318     (when doc
319     (setf result (list* type doc result)))))
320     result))
321    
322     (defimplementation describe-definition (name type)
323     (case type
324     (:variable (documentation name 'variable))
325     (:function (documentation name 'function))
326     (:class (documentation name 'class))
327     (t nil)))
328    
329     ;;; Debugging
330    
331 heller 1.29 (eval-when (:compile-toplevel :load-toplevel :execute)
332 heller 1.28 (import
333     '(si::*break-env*
334     si::*ihs-top*
335     si::*ihs-current*
336     si::*ihs-base*
337     si::*frs-base*
338     si::*frs-top*
339     si::*tpl-commands*
340     si::*tpl-level*
341     si::frs-top
342     si::ihs-top
343     si::ihs-fun
344     si::ihs-env
345     si::sch-frs-base
346     si::set-break-env
347     si::set-current-ihs
348     si::tpl-commands)))
349 jgarcia 1.1
350 trittweiler 1.52 (defun make-invoke-debugger-hook (hook)
351     (when hook
352     #'(lambda (condition old-hook)
353     ;; Regard *debugger-hook* if set by user.
354     (if *debugger-hook*
355     nil ; decline, *DEBUGGER-HOOK* will be tried next.
356     (funcall hook condition old-hook)))))
357    
358     (defimplementation install-debugger-globally (function)
359     (setq *debugger-hook* function)
360     (setq ext:*invoke-debugger-hook* (make-invoke-debugger-hook function)))
361    
362     (defimplementation call-with-debugger-hook (hook fun)
363     (let ((*debugger-hook* hook)
364 trittweiler 1.53 (ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
365 trittweiler 1.52 (funcall fun)))
366    
367 gcarncross 1.20 (defvar *backtrace* '())
368    
369 trittweiler 1.53 ;;; Commented out; it's not clear this is a good way of doing it. In
370     ;;; particular because it makes errors stemming from this file harder
371     ;;; to debug, and given the "young" age of ECL's swank backend, that's
372     ;;; a bad idea.
373    
374     ;; (defun in-swank-package-p (x)
375     ;; (and
376     ;; (symbolp x)
377     ;; (member (symbol-package x)
378     ;; (list #.(find-package :swank)
379     ;; #.(find-package :swank-backend)
380     ;; #.(ignore-errors (find-package :swank-mop))
381     ;; #.(ignore-errors (find-package :swank-loader))))
382     ;; t))
383    
384     ;; (defun is-swank-source-p (name)
385     ;; (setf name (pathname name))
386     ;; (pathname-match-p
387     ;; name
388     ;; (make-pathname :defaults swank-loader::*source-directory*
389     ;; :name (pathname-name name)
390     ;; :type (pathname-type name)
391     ;; :version (pathname-version name))))
392    
393     ;; (defun is-ignorable-fun-p (x)
394     ;; (or
395     ;; (in-swank-package-p (frame-name x))
396     ;; (multiple-value-bind (file position)
397     ;; (ignore-errors (si::bc-file (car x)))
398     ;; (declare (ignore position))
399     ;; (if file (is-swank-source-p file)))))
400 gcarncross 1.21
401 jgarcia 1.1 (defimplementation call-with-debugging-environment (debugger-loop-fn)
402     (declare (type function debugger-loop-fn))
403     (let* ((*tpl-commands* si::tpl-commands)
404 trittweiler 1.52 (*ihs-top* (ihs-top))
405 trittweiler 1.31 (*ihs-current* *ihs-top*)
406     (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top))))
407     (*frs-top* (frs-top))
408     (*read-suppress* nil)
409     (*tpl-level* (1+ *tpl-level*))
410 gcarncross 1.40 (*backtrace* (loop for ihs from 0 below *ihs-top*
411 gcarncross 1.21 collect (list (si::ihs-fun ihs)
412 gcarncross 1.20 (si::ihs-env ihs)
413     nil))))
414 gcarncross 1.40 (declare (special *ihs-current*))
415 gcarncross 1.20 (loop for f from *frs-base* until *frs-top*
416     do (let ((i (- (si::frs-ihs f) *ihs-base* 1)))
417     (when (plusp i)
418     (let* ((x (elt *backtrace* i))
419     (name (si::frs-tag f)))
420 gcarncross 1.23 (unless (si::fixnump name)
421 gcarncross 1.20 (push name (third x)))))))
422 trittweiler 1.53 (setf *backtrace* (nreverse *backtrace*))
423 jgarcia 1.1 (set-break-env)
424     (set-current-ihs)
425 gcarncross 1.20 (let ((*ihs-base* *ihs-top*))
426     (funcall debugger-loop-fn))))
427    
428 jgarcia 1.1 (defimplementation compute-backtrace (start end)
429 gcarncross 1.20 (when (numberp end)
430     (setf end (min end (length *backtrace*))))
431 trittweiler 1.31 (loop for f in (subseq *backtrace* start end)
432 heller 1.35 collect f))
433 gcarncross 1.20
434     (defun frame-name (frame)
435     (let ((x (first frame)))
436     (if (symbolp x)
437     x
438     (function-name x))))
439    
440     (defun function-position (fun)
441     (multiple-value-bind (file position)
442     (si::bc-file fun)
443 trittweiler 1.53 (when file
444     (make-file-location file position))))
445 gcarncross 1.20
446     (defun frame-function (frame)
447     (let* ((x (first frame))
448     fun position)
449     (etypecase x
450     (symbol (and (fboundp x)
451     (setf fun (fdefinition x)
452     position (function-position fun))))
453     (function (setf fun x position (function-position x))))
454     (values fun position)))
455    
456     (defun frame-decode-env (frame)
457     (let ((functions '())
458     (blocks '())
459     (variables '()))
460 trittweiler 1.52 (setf frame (si::decode-ihs-env (second frame)))
461 gcarncross 1.40 (dolist (record frame)
462 gcarncross 1.20 (let* ((record0 (car record))
463     (record1 (cdr record)))
464 gcarncross 1.40 (cond ((or (symbolp record0) (stringp record0))
465 gcarncross 1.20 (setq variables (acons record0 record1 variables)))
466 gcarncross 1.23 ((not (si::fixnump record0))
467 gcarncross 1.20 (push record1 functions))
468     ((symbolp record1)
469     (push record1 blocks))
470     (t
471     ))))
472     (values functions blocks variables)))
473 jgarcia 1.1
474 heller 1.35 (defimplementation print-frame (frame stream)
475     (format stream "~A" (first frame)))
476 gcarncross 1.20
477 heller 1.41 (defimplementation frame-source-location (frame-number)
478 gcarncross 1.20 (nth-value 1 (frame-function (elt *backtrace* frame-number))))
479    
480     (defimplementation frame-catch-tags (frame-number)
481     (third (elt *backtrace* frame-number)))
482    
483     (defimplementation frame-locals (frame-number)
484     (loop for (name . value) in (nth-value 2 (frame-decode-env (elt *backtrace* frame-number)))
485     with i = 0
486     collect (list :name name :id (prog1 i (incf i)) :value value)))
487    
488     (defimplementation frame-var-value (frame-number var-id)
489     (elt (nth-value 2 (frame-decode-env (elt *backtrace* frame-number)))
490     var-id))
491    
492     (defimplementation disassemble-frame (frame-number)
493     (let ((fun (frame-fun (elt *backtrace* frame-number))))
494     (disassemble fun)))
495    
496     (defimplementation eval-in-frame (form frame-number)
497     (let ((env (second (elt *backtrace* frame-number))))
498     (si:eval-with-env form env)))
499 jgarcia 1.1
500     ;;;; Inspector
501    
502 heller 1.13 (defmethod emacs-inspect ((o t))
503 gcarncross 1.11 ; ecl clos support leaves some to be desired
504     (cond
505     ((streamp o)
506 heller 1.14 (list*
507     (format nil "~S is an ordinary stream~%" o)
508 gcarncross 1.11 (append
509     (list
510     "Open for "
511     (cond
512     ((ignore-errors (interactive-stream-p o)) "Interactive")
513     ((and (input-stream-p o) (output-stream-p o)) "Input and output")
514     ((input-stream-p o) "Input")
515     ((output-stream-p o) "Output"))
516     `(:newline) `(:newline))
517     (label-value-line*
518     ("Element type" (stream-element-type o))
519     ("External format" (stream-external-format o)))
520     (ignore-errors (label-value-line*
521     ("Broadcast streams" (broadcast-stream-streams o))))
522     (ignore-errors (label-value-line*
523     ("Concatenated streams" (concatenated-stream-streams o))))
524     (ignore-errors (label-value-line*
525     ("Echo input stream" (echo-stream-input-stream o))))
526     (ignore-errors (label-value-line*
527     ("Echo output stream" (echo-stream-output-stream o))))
528     (ignore-errors (label-value-line*
529     ("Output String" (get-output-stream-string o))))
530     (ignore-errors (label-value-line*
531     ("Synonym symbol" (synonym-stream-symbol o))))
532     (ignore-errors (label-value-line*
533     ("Input stream" (two-way-stream-input-stream o))))
534     (ignore-errors (label-value-line*
535     ("Output stream" (two-way-stream-output-stream o)))))))
536 trittweiler 1.52 ((si:instancep o)
537 gcarncross 1.11 (let* ((cl (si:instance-class o))
538     (slots (clos:class-slots cl)))
539 heller 1.14 (list* (format nil "~S is an instance of class ~A~%"
540 trittweiler 1.52 o (clos::class-name cl))
541 gcarncross 1.11 (loop for x in slots append
542     (let* ((name (clos:slot-definition-name x))
543     (value (clos::slot-value o name)))
544     (list
545     (format nil "~S: " name)
546     `(:value ,value)
547     `(:newline)))))))))
548    
549 jgarcia 1.1 ;;;; Definitions
550    
551 gcarncross 1.19 (defimplementation find-definitions (name)
552     (if (fboundp name)
553     (let ((tmp (find-source-location (symbol-function name))))
554     `(((defun ,name) ,tmp)))))
555 gcarncross 1.9
556 trittweiler 1.53 ;;; FIXME: BC-FILE may return "/tmp/ECLXXXXXXKMOXtm" which are the
557     ;;; temporary files comming from C-c C-c.
558 gcarncross 1.17 (defimplementation find-source-location (obj)
559     (or
560     (typecase obj
561     (function
562 gcarncross 1.20 (multiple-value-bind (file pos) (ignore-errors (si::bc-file obj))
563 gcarncross 1.17 (if (and file pos)
564 gcarncross 1.18 (make-location
565 gcarncross 1.19 `(:file ,(namestring file))
566 gcarncross 1.18 `(:position ,pos)
567     `(:snippet
568     ,(with-open-file (s file)
569 trittweiler 1.52 (file-position s pos)
570     (skip-comments-and-whitespace s)
571     (read-snippet s))))))))
572 sboukarev 1.47 `(:error ,(format nil "Source definition of ~S not found" obj))))
573 gcarncross 1.17
574 gcarncross 1.42 ;;;; Profiling
575    
576 trittweiler 1.52 #+profile
577     (progn
578    
579 gcarncross 1.42 (eval-when (:compile-toplevel :load-toplevel :execute)
580     (require 'profile))
581    
582     (defimplementation profile (fname)
583     (when fname (eval `(profile:profile ,fname))))
584    
585     (defimplementation unprofile (fname)
586     (when fname (eval `(profile:unprofile ,fname))))
587    
588     (defimplementation unprofile-all ()
589     (profile:unprofile-all)
590     "All functions unprofiled.")
591    
592     (defimplementation profile-report ()
593     (profile:report))
594    
595     (defimplementation profile-reset ()
596     (profile:reset)
597     "Reset profiling counters.")
598    
599     (defimplementation profiled-functions ()
600     (profile:profile))
601    
602 gcarncross 1.43 (defimplementation profile-package (package callers methods)
603     (declare (ignore callers methods))
604     (eval `(profile:profile ,(package-name (find-package package)))))
605 trittweiler 1.53 ) ; #+profile (progn ...
606 gcarncross 1.43
607 trittweiler 1.52 ;;;; Threads
608 gcarncross 1.9
609     #+threads
610     (progn
611 trittweiler 1.52 (defvar *thread-id-counter* 0)
612 trittweiler 1.51
613 trittweiler 1.52 (defparameter *thread-id-map* (make-hash-table))
614 gcarncross 1.9
615 trittweiler 1.52 (defvar *thread-id-map-lock*
616     (mp:make-lock :name "thread id map lock"))
617 gcarncross 1.9
618     (defimplementation spawn (fn &key name)
619 trittweiler 1.52 (mp:process-run-function name fn))
620    
621     (defimplementation thread-id (target-thread)
622     (block thread-id
623     (mp:with-lock (*thread-id-map-lock*)
624     ;; Does TARGET-THREAD have an id already?
625     (maphash (lambda (id thread-pointer)
626     (let ((thread (si:weak-pointer-value thread-pointer)))
627     (cond ((not thread)
628     (remhash id *thread-id-map*))
629     ((eq thread target-thread)
630     (return-from thread-id id)))))
631     *thread-id-map*)
632     ;; TARGET-THREAD not found in *THREAD-ID-MAP*
633     (let ((id (incf *thread-id-counter*))
634     (thread-pointer (si:make-weak-pointer target-thread)))
635     (setf (gethash id *thread-id-map*) thread-pointer)
636     id))))
637 gcarncross 1.9
638     (defimplementation find-thread (id)
639 trittweiler 1.52 (mp:with-lock (*thread-id-map-lock*)
640 trittweiler 1.53 (let* ((thread-ptr (gethash id *thread-id-map*))
641     (thread (and thread-ptr (si:weak-pointer-value thread-ptr))))
642 trittweiler 1.52 (unless thread
643     (remhash id *thread-id-map*))
644     thread)))
645 gcarncross 1.9
646     (defimplementation thread-name (thread)
647     (mp:process-name thread))
648    
649     (defimplementation thread-status (thread)
650 trittweiler 1.52 (if (mp:process-active-p thread)
651     "RUNNING"
652     "STOPPED"))
653 gcarncross 1.9
654     (defimplementation make-lock (&key name)
655     (mp:make-lock :name name))
656    
657     (defimplementation call-with-lock-held (lock function)
658     (declare (type function function))
659     (mp:with-lock (lock) (funcall function)))
660    
661     (defimplementation current-thread ()
662     mp:*current-process*)
663    
664     (defimplementation all-threads ()
665     (mp:all-processes))
666    
667     (defimplementation interrupt-thread (thread fn)
668     (mp:interrupt-process thread fn))
669    
670     (defimplementation kill-thread (thread)
671     (mp:process-kill thread))
672    
673     (defimplementation thread-alive-p (thread)
674     (mp:process-active-p thread))
675    
676 trittweiler 1.52 (defvar *mailbox-lock* (mp:make-lock :name "mailbox lock"))
677     (defvar *mailboxes* (list))
678     (declaim (type list *mailboxes*))
679    
680 gcarncross 1.9 (defstruct (mailbox (:conc-name mailbox.))
681 trittweiler 1.52 thread
682     (mutex (mp:make-lock))
683     (cvar (mp:make-condition-variable))
684 gcarncross 1.9 (queue '() :type list))
685    
686     (defun mailbox (thread)
687     "Return THREAD's mailbox."
688 trittweiler 1.52 (mp:with-lock (*mailbox-lock*)
689     (or (find thread *mailboxes* :key #'mailbox.thread)
690     (let ((mb (make-mailbox :thread thread)))
691     (push mb *mailboxes*)
692     mb))))
693 gcarncross 1.9
694     (defimplementation send (thread message)
695 trittweiler 1.52 (let* ((mbox (mailbox thread))
696     (mutex (mailbox.mutex mbox)))
697     (mp:with-lock (mutex)
698 trittweiler 1.51 (setf (mailbox.queue mbox)
699     (nconc (mailbox.queue mbox) (list message)))
700     (mp:condition-variable-broadcast (mailbox.cvar mbox)))))
701    
702     (defimplementation receive-if (test &optional timeout)
703 trittweiler 1.52 (let* ((mbox (mailbox (current-thread)))
704     (mutex (mailbox.mutex mbox)))
705 trittweiler 1.51 (assert (or (not timeout) (eq timeout t)))
706     (loop
707 trittweiler 1.52 (check-slime-interrupts)
708     (mp:with-lock (mutex)
709     (let* ((q (mailbox.queue mbox))
710     (tail (member-if test q)))
711     (when tail
712     (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
713     (return (car tail))))
714     (when (eq timeout t) (return (values nil t)))
715     (mp:condition-variable-timedwait (mailbox.cvar mbox)
716     mutex
717     0.2)))))
718 gcarncross 1.9
719 trittweiler 1.52 ) ; #+threads (progn ...

  ViewVC Help
Powered by ViewVC 1.1.5