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

Contents of /slime/swank-ecl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.43 - (hide annotations)
Wed Jul 1 03:38:54 2009 UTC (4 years, 9 months ago) by gcarncross
Branch: MAIN
Changes since 1.42: +5 -0 lines
swank-ecl.lisp: Package profiling support
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 gcarncross 1.40 (declaim (optimize (debug 3)))
14    
15 gcarncross 1.19 (defvar *tmp*)
16    
17 heller 1.29 (eval-when (:compile-toplevel :load-toplevel :execute)
18 gcarncross 1.15 (if (find-package :gray)
19     (import-from :gray *gray-stream-symbols* :swank-backend)
20     (import-from :ext *gray-stream-symbols* :swank-backend))
21 jgarcia 1.1
22     (swank-backend::import-swank-mop-symbols :clos
23     '(:eql-specializer
24     :eql-specializer-object
25     :generic-function-declarations
26     :specializer-direct-methods
27 heller 1.28 :compute-applicable-methods-using-classes)))
28 jgarcia 1.1
29    
30     ;;;; TCP Server
31    
32 heller 1.28 (eval-when (:compile-toplevel :load-toplevel :execute)
33     (require 'sockets))
34 jgarcia 1.1
35     (defun resolve-hostname (name)
36     (car (sb-bsd-sockets:host-ent-addresses
37     (sb-bsd-sockets:get-host-by-name name))))
38    
39     (defimplementation create-socket (host port)
40     (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
41     :type :stream
42     :protocol :tcp)))
43     (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
44     (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port)
45     (sb-bsd-sockets:socket-listen socket 5)
46     socket))
47    
48     (defimplementation local-port (socket)
49     (nth-value 1 (sb-bsd-sockets:socket-name socket)))
50    
51     (defimplementation close-socket (socket)
52     (sb-bsd-sockets:socket-close socket))
53    
54     (defimplementation accept-connection (socket
55 heller 1.6 &key external-format
56 dcrosher 1.5 buffering timeout)
57 heller 1.7 (declare (ignore buffering timeout external-format))
58     (make-socket-io-stream (accept socket)))
59 jgarcia 1.1
60 heller 1.7 (defun make-socket-io-stream (socket)
61 jgarcia 1.1 (sb-bsd-sockets:socket-make-stream socket
62     :output t
63     :input t
64     :element-type 'base-char))
65    
66     (defun accept (socket)
67     "Like socket-accept, but retry on EAGAIN."
68     (loop (handler-case
69     (return (sb-bsd-sockets:socket-accept socket))
70     (sb-bsd-sockets:interrupted-error ()))))
71    
72     (defimplementation preferred-communication-style ()
73     (values nil))
74    
75    
76     ;;;; Unix signals
77    
78 heller 1.27 (defimplementation install-sigint-handler (handler)
79     (let ((old-handler (symbol-function 'si:terminal-interrupt)))
80     (setf (symbol-function 'si:terminal-interrupt)
81     (if (consp handler)
82     (car handler)
83     (lambda (&rest args)
84     (declare (ignore args))
85     (funcall handler)
86     (continue))))
87     (list old-handler)))
88    
89    
90 jgarcia 1.1 (defimplementation getpid ()
91     (si:getpid))
92    
93     #+nil
94     (defimplementation set-default-directory (directory)
95     (ext::chdir (namestring directory))
96     ;; Setting *default-pathname-defaults* to an absolute directory
97     ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive.
98     (setf *default-pathname-defaults* (ext::getcwd))
99     (default-directory))
100    
101     #+nil
102     (defimplementation default-directory ()
103     (namestring (ext:getcwd)))
104    
105     (defimplementation quit-lisp ()
106     (ext:quit))
107    
108    
109     ;;;; Compilation
110    
111     (defvar *buffer-name* nil)
112     (defvar *buffer-start-position*)
113     (defvar *buffer-string*)
114     (defvar *compile-filename*)
115    
116     (defun signal-compiler-condition (&rest args)
117     (signal (apply #'make-condition 'compiler-condition args)))
118    
119     (defun handle-compiler-warning (condition)
120     (signal-compiler-condition
121     :original-condition condition
122     :message (format nil "~A" condition)
123     :severity :warning
124     :location
125     (if *buffer-name*
126     (make-location (list :buffer *buffer-name*)
127 heller 1.30 (list :offset *buffer-start-position* 0))
128 jgarcia 1.1 ;; ;; compiler::*current-form*
129     ;; (if compiler::*current-function*
130     ;; (make-location (list :file *compile-filename*)
131     ;; (list :function-name
132     ;; (symbol-name
133     ;; (slot-value compiler::*current-function*
134     ;; 'compiler::name))))
135     (list :error "No location found.")
136     ;; )
137     )))
138    
139     (defimplementation call-with-compilation-hooks (function)
140     (handler-bind ((warning #'handle-compiler-warning))
141     (funcall function)))
142    
143 heller 1.38 (defimplementation swank-compile-file (input-file output-file
144     load-p external-format)
145 jgarcia 1.1 (declare (ignore external-format))
146     (with-compilation-hooks ()
147 heller 1.38 (let ((*buffer-name* nil)
148     (*compile-filename* input-file))
149     (compile-file input-file :output-file output-file :load t))))
150 jgarcia 1.1
151 heller 1.37 (defimplementation swank-compile-string (string &key buffer position filename
152     policy)
153     (declare (ignore filename policy))
154 jgarcia 1.1 (with-compilation-hooks ()
155     (let ((*buffer-name* buffer)
156     (*buffer-start-position* position)
157     (*buffer-string* string))
158     (with-input-from-string (s string)
159 heller 1.34 (not (nth-value 2 (compile-from-stream s :load t)))))))
160 jgarcia 1.1
161     (defun compile-from-stream (stream &rest args)
162     (let ((file (si::mkstemp "TMP:ECLXXXXXX")))
163     (with-open-file (s file :direction :output :if-exists :overwrite)
164     (do ((line (read-line stream nil) (read-line stream nil)))
165 trittweiler 1.8 ((not line))
166 jgarcia 1.1 (write-line line s)))
167     (unwind-protect
168     (apply #'compile-file file args)
169     (delete-file file))))
170    
171    
172     ;;;; Documentation
173    
174 trittweiler 1.32 (defun grovel-docstring-for-arglist (name type)
175     (flet ((compute-arglist-offset (docstring)
176     (when docstring
177     (let ((pos1 (search "Args: " docstring)))
178     (if pos1
179     (+ pos1 6)
180     (let ((pos2 (search "Syntax: " docstring)))
181     (when pos2
182     (+ pos2 8))))))))
183     (let* ((docstring (si::get-documentation name type))
184     (pos (compute-arglist-offset docstring)))
185     (if pos
186     (multiple-value-bind (arglist errorp)
187     (ignore-errors
188     (values (read-from-string docstring t nil :start pos)))
189 gcarncross 1.39 (if (or errorp (not (listp arglist)))
190     :not-available
191     (cdr arglist)))
192 trittweiler 1.32 :not-available ))))
193    
194 jgarcia 1.1 (defimplementation arglist (name)
195 trittweiler 1.32 (cond ((special-operator-p name)
196     (grovel-docstring-for-arglist name 'function))
197     ((macro-function name)
198     (grovel-docstring-for-arglist name 'function))
199     ((or (functionp name) (fboundp name))
200     (multiple-value-bind (name fndef)
201     (if (functionp name)
202     (values (function-name name) name)
203     (values name (fdefinition name)))
204     (typecase fndef
205     (generic-function
206     (clos::generic-function-lambda-list fndef))
207     (compiled-function
208     (grovel-docstring-for-arglist name 'function))
209     (function
210     (let ((fle (function-lambda-expression fndef)))
211     (case (car fle)
212     (si:lambda-block (caddr fle))
213     (t :not-available)))))))
214     (t :not-available)))
215 jgarcia 1.1
216 heller 1.6 (defimplementation function-name (f)
217 jgarcia 1.1 (si:compiled-function-name f))
218    
219     (defimplementation macroexpand-all (form)
220     ;;; FIXME! This is not the same as a recursive macroexpansion!
221     (macroexpand form))
222    
223     (defimplementation describe-symbol-for-emacs (symbol)
224     (let ((result '()))
225     (dolist (type '(:VARIABLE :FUNCTION :CLASS))
226     (let ((doc (describe-definition symbol type)))
227     (when doc
228     (setf result (list* type doc result)))))
229     result))
230    
231     (defimplementation describe-definition (name type)
232     (case type
233     (:variable (documentation name 'variable))
234     (:function (documentation name 'function))
235     (:class (documentation name 'class))
236     (t nil)))
237    
238     ;;; Debugging
239    
240 heller 1.29 (eval-when (:compile-toplevel :load-toplevel :execute)
241 heller 1.28 (import
242     '(si::*break-env*
243     si::*ihs-top*
244     si::*ihs-current*
245     si::*ihs-base*
246     si::*frs-base*
247     si::*frs-top*
248     si::*tpl-commands*
249     si::*tpl-level*
250     si::frs-top
251     si::ihs-top
252     si::ihs-fun
253     si::ihs-env
254     si::sch-frs-base
255     si::set-break-env
256     si::set-current-ihs
257     si::tpl-commands)))
258 jgarcia 1.1
259 gcarncross 1.20 (defvar *backtrace* '())
260    
261 gcarncross 1.21 (defun in-swank-package-p (x)
262 gcarncross 1.22 (and
263     (symbolp x)
264     (member (symbol-package x)
265     (list #.(find-package :swank)
266     #.(find-package :swank-backend)
267     #.(ignore-errors (find-package :swank-mop))
268     #.(ignore-errors (find-package :swank-loader))))
269     t))
270    
271     (defun is-swank-source-p (name)
272     (setf name (pathname name))
273     (pathname-match-p
274     name
275     (make-pathname :defaults swank-loader::*source-directory*
276     :name (pathname-name name)
277     :type (pathname-type name)
278     :version (pathname-version name))))
279    
280     (defun is-ignorable-fun-p (x)
281     (or
282     (in-swank-package-p (frame-name x))
283     (multiple-value-bind (file position)
284     (ignore-errors (si::bc-file (car x)))
285     (declare (ignore position))
286     (if file (is-swank-source-p file)))))
287 gcarncross 1.21
288 gcarncross 1.40 (defmacro find-ihs-top (x)
289     (if (< ext:+ecl-version-number+ 90601)
290     `(si::ihs-top ,x)
291     '(si::ihs-top)))
292    
293 jgarcia 1.1 (defimplementation call-with-debugging-environment (debugger-loop-fn)
294     (declare (type function debugger-loop-fn))
295     (let* ((*tpl-commands* si::tpl-commands)
296 gcarncross 1.40 (*ihs-top* (find-ihs-top 'call-with-debugging-environment))
297 trittweiler 1.31 (*ihs-current* *ihs-top*)
298     (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top))))
299     (*frs-top* (frs-top))
300     (*read-suppress* nil)
301     (*tpl-level* (1+ *tpl-level*))
302 gcarncross 1.40 (*backtrace* (loop for ihs from 0 below *ihs-top*
303 gcarncross 1.21 collect (list (si::ihs-fun ihs)
304 gcarncross 1.20 (si::ihs-env ihs)
305     nil))))
306 gcarncross 1.40 (declare (special *ihs-current*))
307 gcarncross 1.20 (loop for f from *frs-base* until *frs-top*
308     do (let ((i (- (si::frs-ihs f) *ihs-base* 1)))
309     (when (plusp i)
310     (let* ((x (elt *backtrace* i))
311     (name (si::frs-tag f)))
312 gcarncross 1.23 (unless (si::fixnump name)
313 gcarncross 1.20 (push name (third x)))))))
314 gcarncross 1.22 (setf *backtrace* (remove-if #'is-ignorable-fun-p (nreverse *backtrace*)))
315 trittweiler 1.31 (setf *tmp* *backtrace*)
316 jgarcia 1.1 (set-break-env)
317     (set-current-ihs)
318 gcarncross 1.20 (let ((*ihs-base* *ihs-top*))
319     (funcall debugger-loop-fn))))
320    
321     (defimplementation call-with-debugger-hook (hook fun)
322     (let ((*debugger-hook* hook)
323 gcarncross 1.40 (*ihs-base* (find-ihs-top 'call-with-debugger-hook)))
324 gcarncross 1.20 (funcall fun)))
325 jgarcia 1.1
326     (defimplementation compute-backtrace (start end)
327 gcarncross 1.20 (when (numberp end)
328     (setf end (min end (length *backtrace*))))
329 trittweiler 1.31 (loop for f in (subseq *backtrace* start end)
330 heller 1.35 collect f))
331 gcarncross 1.20
332     (defun frame-name (frame)
333     (let ((x (first frame)))
334     (if (symbolp x)
335     x
336     (function-name x))))
337    
338     (defun function-position (fun)
339     (multiple-value-bind (file position)
340     (si::bc-file fun)
341     (and file (make-location `(:file ,file) `(:position ,position)))))
342    
343     (defun frame-function (frame)
344     (let* ((x (first frame))
345     fun position)
346     (etypecase x
347     (symbol (and (fboundp x)
348     (setf fun (fdefinition x)
349     position (function-position fun))))
350     (function (setf fun x position (function-position x))))
351     (values fun position)))
352    
353     (defun frame-decode-env (frame)
354     (let ((functions '())
355     (blocks '())
356     (variables '()))
357 gcarncross 1.40 #.(if (< ext:+ecl-version-number+ 90601)
358     '(setf frame (second frame))
359     '(setf frame (si::decode-ihs-env (second frame))))
360     (dolist (record frame)
361 gcarncross 1.20 (let* ((record0 (car record))
362     (record1 (cdr record)))
363 gcarncross 1.40 (cond ((or (symbolp record0) (stringp record0))
364 gcarncross 1.20 (setq variables (acons record0 record1 variables)))
365 gcarncross 1.23 ((not (si::fixnump record0))
366 gcarncross 1.20 (push record1 functions))
367     ((symbolp record1)
368     (push record1 blocks))
369     (t
370     ))))
371     (values functions blocks variables)))
372 jgarcia 1.1
373 heller 1.35 (defimplementation print-frame (frame stream)
374     (format stream "~A" (first frame)))
375 gcarncross 1.20
376 heller 1.41 (defimplementation frame-source-location (frame-number)
377 gcarncross 1.20 (nth-value 1 (frame-function (elt *backtrace* frame-number))))
378    
379     (defimplementation frame-catch-tags (frame-number)
380     (third (elt *backtrace* frame-number)))
381    
382     (defimplementation frame-locals (frame-number)
383     (loop for (name . value) in (nth-value 2 (frame-decode-env (elt *backtrace* frame-number)))
384     with i = 0
385     collect (list :name name :id (prog1 i (incf i)) :value value)))
386    
387     (defimplementation frame-var-value (frame-number var-id)
388     (elt (nth-value 2 (frame-decode-env (elt *backtrace* frame-number)))
389     var-id))
390    
391     (defimplementation disassemble-frame (frame-number)
392     (let ((fun (frame-fun (elt *backtrace* frame-number))))
393     (disassemble fun)))
394    
395     (defimplementation eval-in-frame (form frame-number)
396     (let ((env (second (elt *backtrace* frame-number))))
397     (si:eval-with-env form env)))
398 jgarcia 1.1
399     ;;;; Inspector
400    
401 heller 1.13 (defmethod emacs-inspect ((o t))
402 gcarncross 1.11 ; ecl clos support leaves some to be desired
403     (cond
404     ((streamp o)
405 heller 1.14 (list*
406     (format nil "~S is an ordinary stream~%" o)
407 gcarncross 1.11 (append
408     (list
409     "Open for "
410     (cond
411     ((ignore-errors (interactive-stream-p o)) "Interactive")
412     ((and (input-stream-p o) (output-stream-p o)) "Input and output")
413     ((input-stream-p o) "Input")
414     ((output-stream-p o) "Output"))
415     `(:newline) `(:newline))
416     (label-value-line*
417     ("Element type" (stream-element-type o))
418     ("External format" (stream-external-format o)))
419     (ignore-errors (label-value-line*
420     ("Broadcast streams" (broadcast-stream-streams o))))
421     (ignore-errors (label-value-line*
422     ("Concatenated streams" (concatenated-stream-streams o))))
423     (ignore-errors (label-value-line*
424     ("Echo input stream" (echo-stream-input-stream o))))
425     (ignore-errors (label-value-line*
426     ("Echo output stream" (echo-stream-output-stream o))))
427     (ignore-errors (label-value-line*
428     ("Output String" (get-output-stream-string o))))
429     (ignore-errors (label-value-line*
430     ("Synonym symbol" (synonym-stream-symbol o))))
431     (ignore-errors (label-value-line*
432     ("Input stream" (two-way-stream-input-stream o))))
433     (ignore-errors (label-value-line*
434     ("Output stream" (two-way-stream-output-stream o)))))))
435     (t
436     (let* ((cl (si:instance-class o))
437     (slots (clos:class-slots cl)))
438 heller 1.14 (list* (format nil "~S is an instance of class ~A~%"
439 gcarncross 1.11 o (clos::class-name cl))
440     (loop for x in slots append
441     (let* ((name (clos:slot-definition-name x))
442     (value (clos::slot-value o name)))
443     (list
444     (format nil "~S: " name)
445     `(:value ,value)
446     `(:newline)))))))))
447    
448 jgarcia 1.1 ;;;; Definitions
449    
450 gcarncross 1.19 (defimplementation find-definitions (name)
451     (if (fboundp name)
452     (let ((tmp (find-source-location (symbol-function name))))
453     `(((defun ,name) ,tmp)))))
454 gcarncross 1.9
455 gcarncross 1.17 (defimplementation find-source-location (obj)
456 gcarncross 1.19 (setf *tmp* obj)
457 gcarncross 1.17 (or
458     (typecase obj
459     (function
460 gcarncross 1.20 (multiple-value-bind (file pos) (ignore-errors (si::bc-file obj))
461 gcarncross 1.17 (if (and file pos)
462 gcarncross 1.18 (make-location
463 gcarncross 1.19 `(:file ,(namestring file))
464 gcarncross 1.18 `(:position ,pos)
465     `(:snippet
466     ,(with-open-file (s file)
467 gcarncross 1.40 (if (< ext:+ecl-version-number+ 90601)
468     (skip-toplevel-forms pos s)
469     (file-position s pos))
470 gcarncross 1.18 (skip-comments-and-whitespace s)
471     (read-snippet s))))))))
472 gcarncross 1.17 `(:error (format nil "Source definition of ~S not found" obj))))
473    
474 gcarncross 1.42 ;;;; Profiling
475    
476     (eval-when (:compile-toplevel :load-toplevel :execute)
477     (require 'profile))
478    
479     (defimplementation profile (fname)
480     (when fname (eval `(profile:profile ,fname))))
481    
482     (defimplementation unprofile (fname)
483     (when fname (eval `(profile:unprofile ,fname))))
484    
485     (defimplementation unprofile-all ()
486     (profile:unprofile-all)
487     "All functions unprofiled.")
488    
489     (defimplementation profile-report ()
490     (profile:report))
491    
492     (defimplementation profile-reset ()
493     (profile:reset)
494     "Reset profiling counters.")
495    
496     (defimplementation profiled-functions ()
497     (profile:profile))
498    
499 gcarncross 1.43 (defimplementation profile-package (package callers methods)
500     (declare (ignore callers methods))
501     (eval `(profile:profile ,(package-name (find-package package)))))
502    
503    
504 gcarncross 1.9 ;;;; Threads
505    
506     #+threads
507     (progn
508     (defvar *thread-id-counter* 0)
509    
510     (defvar *thread-id-counter-lock*
511     (mp:make-lock :name "thread id counter lock"))
512    
513     (defun next-thread-id ()
514     (mp:with-lock (*thread-id-counter-lock*)
515     (incf *thread-id-counter*)))
516    
517     (defparameter *thread-id-map* (make-hash-table))
518 heller 1.26 (defparameter *id-thread-map* (make-hash-table))
519 gcarncross 1.9
520     (defvar *thread-id-map-lock*
521     (mp:make-lock :name "thread id map lock"))
522    
523     ; ecl doesn't have weak pointers
524     (defimplementation spawn (fn &key name)
525     (let ((thread (mp:make-process :name name))
526     (id (next-thread-id)))
527     (mp:process-preset
528     thread
529     #'(lambda ()
530     (unwind-protect
531     (mp:with-lock (*thread-id-map-lock*)
532 heller 1.26 (setf (gethash id *thread-id-map*) thread)
533     (setf (gethash thread *id-thread-map*) id))
534 gcarncross 1.9 (funcall fn)
535     (mp:with-lock (*thread-id-map-lock*)
536 heller 1.26 (remhash thread *id-thread-map*)
537 gcarncross 1.9 (remhash id *thread-id-map*)))))
538     (mp:process-enable thread)))
539    
540     (defimplementation thread-id (thread)
541     (block thread-id
542     (mp:with-lock (*thread-id-map-lock*)
543 heller 1.26 (or (gethash thread *id-thread-map*)
544     (let ((id (next-thread-id)))
545     (setf (gethash id *thread-id-map*) thread)
546     (setf (gethash thread *id-thread-map*) id)
547     id)))))
548 gcarncross 1.9
549     (defimplementation find-thread (id)
550     (mp:with-lock (*thread-id-map-lock*)
551     (gethash id *thread-id-map*)))
552    
553     (defimplementation thread-name (thread)
554     (mp:process-name thread))
555    
556     (defimplementation thread-status (thread)
557     (if (mp:process-active-p thread)
558     "RUNNING"
559     "STOPPED"))
560    
561     (defimplementation make-lock (&key name)
562     (mp:make-lock :name name))
563    
564     (defimplementation call-with-lock-held (lock function)
565     (declare (type function function))
566     (mp:with-lock (lock) (funcall function)))
567    
568     (defimplementation current-thread ()
569     mp:*current-process*)
570    
571     (defimplementation all-threads ()
572     (mp:all-processes))
573    
574     (defimplementation interrupt-thread (thread fn)
575     (mp:interrupt-process thread fn))
576    
577     (defimplementation kill-thread (thread)
578     (mp:process-kill thread))
579    
580     (defimplementation thread-alive-p (thread)
581     (mp:process-active-p thread))
582    
583     (defvar *mailbox-lock* (mp:make-lock :name "mailbox lock"))
584    
585     (defstruct (mailbox (:conc-name mailbox.))
586     (mutex (mp:make-lock :name "process mailbox"))
587     (queue '() :type list))
588    
589     (defun mailbox (thread)
590     "Return THREAD's mailbox."
591     (mp:with-lock (*mailbox-lock*)
592     (or (find thread *mailboxes* :key #'mailbox.thread)
593     (let ((mb (make-mailbox :thread thread)))
594     (push mb *mailboxes*)
595     mb))))
596    
597     (defimplementation send (thread message)
598     (let* ((mbox (mailbox thread))
599     (mutex (mailbox.mutex mbox)))
600     (mp:interrupt-process
601     thread
602     (lambda ()
603     (mp:with-lock (mutex)
604     (setf (mailbox.queue mbox)
605     (nconc (mailbox.queue mbox) (list message))))))))
606    
607     (defimplementation receive ()
608     (block got-mail
609     (let* ((mbox (mailbox mp:*current-process*))
610     (mutex (mailbox.mutex mbox)))
611     (loop
612     (mp:with-lock (mutex)
613     (if (mailbox.queue mbox)
614     (return-from got-mail (pop (mailbox.queue mbox)))))
615     ;interrupt-process will halt this if it takes longer than 1sec
616     (sleep 1)))))
617    
618     (defmethod stream-finish-output ((stream stream))
619     (finish-output stream))
620    
621     )
622    

  ViewVC Help
Powered by ViewVC 1.1.5