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

Contents of /slime/swank-allegro.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.159 - (show annotations)
Fri Feb 8 14:11:23 2013 UTC (14 months, 1 week ago) by heller
Branch: MAIN
Changes since 1.158: +12 -4 lines
* swank-allegro.lisp (handle-compiler-warning): Ignore "Closure
will be stack allocated" notes.  Those are harmless and there are
too many of them.
(pc-source-location, ldb-code-to-src-loc): Handle case when
excl::ldb-code-pc returns nil.
1 ;;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;;* "; -*-
2 ;;;
3 ;;; swank-allegro.lisp --- Allegro CL specific code for SLIME.
4 ;;;
5 ;;; Created 2003
6 ;;;
7 ;;; This code has been placed in the Public Domain. All warranties
8 ;;; are disclaimed.
9 ;;;
10
11 (in-package :swank-backend)
12
13 (eval-when (:compile-toplevel :load-toplevel :execute)
14 (require :sock)
15 (require :process)
16 #+(version>= 8 2)
17 (require 'lldb)
18 )
19
20 (import-from :excl *gray-stream-symbols* :swank-backend)
21
22 ;;; swank-mop
23
24 (import-swank-mop-symbols :clos '(:slot-definition-documentation))
25
26 (defun swank-mop:slot-definition-documentation (slot)
27 (documentation slot t))
28
29
30 ;;;; UTF8
31
32 (define-symbol-macro utf8-ef
33 (load-time-value
34 (excl:crlf-base-ef (excl:find-external-format :utf-8))
35 t))
36
37 (defimplementation string-to-utf8 (s)
38 (excl:string-to-octets s :external-format utf8-ef
39 :null-terminate nil))
40
41 (defimplementation utf8-to-string (u)
42 (excl:octets-to-string u :external-format utf8-ef))
43
44
45 ;;;; TCP Server
46
47 (defimplementation preferred-communication-style ()
48 :spawn)
49
50 (defimplementation create-socket (host port &key backlog)
51 (socket:make-socket :connect :passive :local-port port
52 :local-host host :reuse-address t
53 :backlog (or backlog 5)))
54
55 (defimplementation local-port (socket)
56 (socket:local-port socket))
57
58 (defimplementation close-socket (socket)
59 (close socket))
60
61 (defimplementation accept-connection (socket &key external-format buffering
62 timeout)
63 (declare (ignore buffering timeout))
64 (let ((s (socket:accept-connection socket :wait t)))
65 (when external-format
66 (setf (stream-external-format s) external-format))
67 s))
68
69 (defimplementation socket-fd (stream)
70 (excl::stream-input-handle stream))
71
72 (defvar *external-format-to-coding-system*
73 '((:iso-8859-1
74 "latin-1" "latin-1-unix" "iso-latin-1-unix"
75 "iso-8859-1" "iso-8859-1-unix")
76 (:utf-8 "utf-8" "utf-8-unix")
77 (:euc-jp "euc-jp" "euc-jp-unix")
78 (:us-ascii "us-ascii" "us-ascii-unix")
79 (:emacs-mule "emacs-mule" "emacs-mule-unix")))
80
81 (defimplementation find-external-format (coding-system)
82 (let ((e (rassoc-if (lambda (x) (member coding-system x :test #'equal))
83 *external-format-to-coding-system*)))
84 (and e (excl:crlf-base-ef
85 (excl:find-external-format (car e)
86 :try-variant t)))))
87
88 ;;;; Unix signals
89
90 (defimplementation getpid ()
91 (excl::getpid))
92
93 (defimplementation lisp-implementation-type-name ()
94 "allegro")
95
96 (defimplementation set-default-directory (directory)
97 (let* ((dir (namestring (truename (merge-pathnames directory)))))
98 (setf *default-pathname-defaults* (pathname (excl:chdir dir)))
99 dir))
100
101 (defimplementation default-directory ()
102 (namestring (excl:current-directory)))
103
104 ;;;; Misc
105
106 (defimplementation arglist (symbol)
107 (handler-case (excl:arglist symbol)
108 (simple-error () :not-available)))
109
110 (defimplementation macroexpand-all (form)
111 #+(version>= 8 0)
112 (excl::walk-form form)
113 #-(version>= 8 0)
114 (excl::walk form))
115
116 (defimplementation describe-symbol-for-emacs (symbol)
117 (let ((result '()))
118 (flet ((doc (kind &optional (sym symbol))
119 (or (documentation sym kind) :not-documented))
120 (maybe-push (property value)
121 (when value
122 (setf result (list* property value result)))))
123 (maybe-push
124 :variable (when (boundp symbol)
125 (doc 'variable)))
126 (maybe-push
127 :function (if (fboundp symbol)
128 (doc 'function)))
129 (maybe-push
130 :class (if (find-class symbol nil)
131 (doc 'class)))
132 result)))
133
134 (defimplementation describe-definition (symbol namespace)
135 (ecase namespace
136 (:variable
137 (describe symbol))
138 ((:function :generic-function)
139 (describe (symbol-function symbol)))
140 (:class
141 (describe (find-class symbol)))))
142
143 (defimplementation type-specifier-p (symbol)
144 (or (ignore-errors
145 (subtypep nil symbol))
146 (not (eq (type-specifier-arglist symbol) :not-available))))
147
148 ;;;; Debugger
149
150 (defvar *sldb-topframe*)
151
152 (defimplementation call-with-debugging-environment (debugger-loop-fn)
153 (let ((*sldb-topframe* (find-topframe))
154 (excl::*break-hook* nil))
155 (funcall debugger-loop-fn)))
156
157 (defimplementation sldb-break-at-start (fname)
158 ;; :print-before is kind of mis-used but we just want to stuff our
159 ;; break form somewhere. This does not work for setf, :before and
160 ;; :after methods, which need special syntax in the trace call, see
161 ;; ACL's doc/debugging.htm chapter 10.
162 (eval `(trace (,fname
163 :print-before
164 ((break "Function start breakpoint of ~A" ',fname)))))
165 `(:ok ,(format nil "Set breakpoint at start of ~S" fname)))
166
167 (defun find-topframe ()
168 (let ((magic-symbol (intern (symbol-name :swank-debugger-hook)
169 (find-package :swank)))
170 (top-frame (excl::int-newest-frame (excl::current-thread))))
171 (loop for frame = top-frame then (next-frame frame)
172 for name = (debugger:frame-name frame)
173 for i from 0
174 when (eq name magic-symbol)
175 return (next-frame frame)
176 until (= i 10) finally (return top-frame))))
177
178 (defun next-frame (frame)
179 (let ((next (excl::int-next-older-frame frame)))
180 (cond ((not next) nil)
181 ((debugger:frame-visible-p next) next)
182 (t (next-frame next)))))
183
184 (defun nth-frame (index)
185 (do ((frame *sldb-topframe* (next-frame frame))
186 (i index (1- i)))
187 ((zerop i) frame)))
188
189 (defimplementation compute-backtrace (start end)
190 (let ((end (or end most-positive-fixnum)))
191 (loop for f = (nth-frame start) then (next-frame f)
192 for i from start below end
193 while f collect f)))
194
195 (defimplementation print-frame (frame stream)
196 (debugger:output-frame stream frame :moderate))
197
198 (defimplementation frame-locals (index)
199 (let ((frame (nth-frame index)))
200 (loop for i from 0 below (debugger:frame-number-vars frame)
201 collect (list :name (debugger:frame-var-name frame i)
202 :id 0
203 :value (debugger:frame-var-value frame i)))))
204
205 (defimplementation frame-var-value (frame var)
206 (let ((frame (nth-frame frame)))
207 (debugger:frame-var-value frame var)))
208
209 (defimplementation disassemble-frame (index)
210 (let ((frame (nth-frame index)))
211 (multiple-value-bind (x fun xx xxx pc) (debugger::dyn-fd-analyze frame)
212 (format t "pc: ~d (~s ~s ~s)~%fun: ~a~%" pc x xx xxx fun)
213 (disassemble (debugger:frame-function frame)))))
214
215 (defimplementation frame-source-location (index)
216 (let* ((frame (nth-frame index)))
217 (multiple-value-bind (x fun xx xxx pc) (debugger::dyn-fd-analyze frame)
218 (declare (ignore x xx xxx))
219 (cond ((and pc
220 #+(version>= 8 2)
221 (pc-source-location fun pc)
222 #-(version>= 8 2)
223 (function-source-location fun)))
224 (t ; frames for unbound functions etc end up here
225 (cadr (car (fspec-definition-locations
226 (car (debugger:frame-expression frame))))))))))
227
228 (defun function-source-location (fun)
229 (cadr (car (fspec-definition-locations
230 (xref::object-to-function-name fun)))))
231
232 #+(version>= 8 2)
233 (defun pc-source-location (fun pc)
234 (let* ((debug-info (excl::function-source-debug-info fun)))
235 (cond ((not debug-info)
236 (function-source-location fun))
237 (t
238 (let* ((code-loc (find-if (lambda (c)
239 (<= (- pc (sys::natural-width))
240 (let ((x (excl::ldb-code-pc c)))
241 (or x -1))
242 pc))
243 debug-info)))
244 (cond ((not code-loc)
245 (ldb-code-to-src-loc (aref debug-info 0)))
246 (t
247 (ldb-code-to-src-loc code-loc))))))))
248
249 #+(version>= 8 2)
250 (defun ldb-code-to-src-loc (code)
251 (declare (optimize debug))
252 (let* ((func (excl::ldb-code-func code))
253 (debug-info (excl::function-source-debug-info func))
254 (start (loop for i from (excl::ldb-code-index code) downto 0
255 for bpt = (aref debug-info i)
256 for start = (excl::ldb-code-start-char bpt)
257 when start return start))
258 (src-file (excl:source-file func)))
259 (cond (start
260 (buffer-or-file-location src-file start))
261 (func
262 (let* ((debug-info (excl::function-source-debug-info func))
263 (whole (aref debug-info 0))
264 (paths (source-paths-of (excl::ldb-code-source whole)
265 (excl::ldb-code-source code)))
266 (path (if paths (longest-common-prefix paths) '()))
267 (start 0))
268 (buffer-or-file
269 src-file
270 (lambda (file)
271 (make-location `(:file ,file)
272 `(:source-path (0 . ,path) ,start)))
273 (lambda (buffer bstart)
274 (make-location `(:buffer ,buffer)
275 `(:source-path (0 . ,path)
276 ,(+ bstart start)))))))
277 (t
278 nil))))
279
280 (defun longest-common-prefix (sequences)
281 (assert sequences)
282 (flet ((common-prefix (s1 s2)
283 (let ((diff-pos (mismatch s1 s2)))
284 (if diff-pos (subseq s1 0 diff-pos) s1))))
285 (reduce #'common-prefix sequences)))
286
287 (defun source-paths-of (whole part)
288 (let ((result '()))
289 (labels ((walk (form path)
290 (cond ((eq form part)
291 (push (reverse path) result))
292 ((consp form)
293 (loop for i from 0 while (consp form) do
294 (walk (pop form) (cons i path)))))))
295 (walk whole '())
296 (reverse result))))
297
298 (defimplementation eval-in-frame (form frame-number)
299 (let ((frame (nth-frame frame-number)))
300 ;; let-bind lexical variables
301 (let ((vars (loop for i below (debugger:frame-number-vars frame)
302 for name = (debugger:frame-var-name frame i)
303 if (symbolp name)
304 collect `(,name ',(debugger:frame-var-value frame i)))))
305 (debugger:eval-form-in-context
306 `(let* ,vars ,form)
307 (debugger:environment-of-frame frame)))))
308
309 (defimplementation frame-package (frame-number)
310 (let* ((frame (nth-frame frame-number))
311 (exp (debugger:frame-expression frame)))
312 (typecase exp
313 ((cons symbol) (symbol-package (car exp)))
314 ((cons (cons (eql :internal) (cons symbol)))
315 (symbol-package (cadar exp))))))
316
317 (defimplementation return-from-frame (frame-number form)
318 (let ((frame (nth-frame frame-number)))
319 (multiple-value-call #'debugger:frame-return
320 frame (debugger:eval-form-in-context
321 form
322 (debugger:environment-of-frame frame)))))
323
324 (defimplementation frame-restartable-p (frame)
325 (handler-case (debugger:frame-retryable-p frame)
326 (serious-condition (c)
327 (funcall (read-from-string "swank::background-message")
328 "~a ~a" frame (princ-to-string c))
329 nil)))
330
331 (defimplementation restart-frame (frame-number)
332 (let ((frame (nth-frame frame-number)))
333 (cond ((debugger:frame-retryable-p frame)
334 (apply #'debugger:frame-retry frame (debugger:frame-function frame)
335 (cdr (debugger:frame-expression frame))))
336 (t "Frame is not retryable"))))
337
338 ;;;; Compiler hooks
339
340 (defvar *buffer-name* nil)
341 (defvar *buffer-start-position*)
342 (defvar *buffer-string*)
343 (defvar *compile-filename* nil)
344
345 (defun compiler-note-p (object)
346 (member (type-of object) '(excl::compiler-note compiler::compiler-note)))
347
348 (defun redefinition-p (condition)
349 (and (typep condition 'style-warning)
350 (every #'char-equal "redefin" (princ-to-string condition))))
351
352 (defun compiler-undefined-functions-called-warning-p (object)
353 (typep object 'excl:compiler-undefined-functions-called-warning))
354
355 (deftype compiler-note ()
356 `(satisfies compiler-note-p))
357
358 (deftype redefinition ()
359 `(satisfies redefinition-p))
360
361 (defun signal-compiler-condition (&rest args)
362 (apply #'signal 'compiler-condition args))
363
364 (defun handle-compiler-warning (condition)
365 (declare (optimize (debug 3) (speed 0) (space 0)))
366 (cond ((and (not *buffer-name*)
367 (compiler-undefined-functions-called-warning-p condition))
368 (handle-undefined-functions-warning condition))
369 ((and (typep condition 'excl::compiler-note)
370 (let ((format (slot-value condition 'excl::format-control)))
371 (and (search "Closure" format)
372 (search "will be stack allocated" format))))
373 ;; Ignore "Closure <foo> will be stack allocated" notes.
374 ;; That occurs often but is usually uninteresting.
375 )
376 (t
377 (signal-compiler-condition
378 :original-condition condition
379 :severity (etypecase condition
380 (redefinition :redefinition)
381 (style-warning :style-warning)
382 (warning :warning)
383 (compiler-note :note)
384 (reader-error :read-error)
385 (error :error))
386 :message (format nil "~A" condition)
387 :location (if (typep condition 'reader-error)
388 (location-for-reader-error condition)
389 (location-for-warning condition))))))
390
391 (defun location-for-warning (condition)
392 (let ((loc (getf (slot-value condition 'excl::plist) :loc)))
393 (cond (*buffer-name*
394 (make-location
395 (list :buffer *buffer-name*)
396 (list :offset *buffer-start-position* 0)))
397 (loc
398 (destructuring-bind (file . pos) loc
399 (let ((start (cond ((consp pos) ; 8.2 and newer
400 (car pos))
401 (t pos))))
402 (make-location
403 (list :file (namestring (truename file)))
404 (list :position (1+ start))))))
405 (t
406 (make-error-location "No error location available.")))))
407
408 (defun location-for-reader-error (condition)
409 (let ((pos (car (last (slot-value condition 'excl::format-arguments))))
410 (file (pathname (stream-error-stream condition))))
411 (if (integerp pos)
412 (if *buffer-name*
413 (make-location `(:buffer ,*buffer-name*)
414 `(:offset ,*buffer-start-position* ,pos))
415 (make-location `(:file ,(namestring (truename file)))
416 `(:position ,pos)))
417 (make-error-location "No error location available."))))
418
419 ;; TODO: report it as a bug to Franz that the condition's plist
420 ;; slot contains (:loc nil).
421 (defun handle-undefined-functions-warning (condition)
422 (let ((fargs (slot-value condition 'excl::format-arguments)))
423 (loop for (fname . locs) in (car fargs) do
424 (dolist (loc locs)
425 (multiple-value-bind (pos file) (ecase (length loc)
426 (2 (values-list loc))
427 (3 (destructuring-bind
428 (start end file) loc
429 (declare (ignore end))
430 (values start file))))
431 (signal-compiler-condition
432 :original-condition condition
433 :severity :warning
434 :message (format nil "Undefined function referenced: ~S"
435 fname)
436 :location (make-location (list :file file)
437 (list :position (1+ pos)))))))))
438
439 (defimplementation call-with-compilation-hooks (function)
440 (handler-bind ((warning #'handle-compiler-warning)
441 (compiler-note #'handle-compiler-warning)
442 (reader-error #'handle-compiler-warning))
443 (funcall function)))
444
445 (defimplementation swank-compile-file (input-file output-file
446 load-p external-format
447 &key policy)
448 (declare (ignore policy))
449 (handler-case
450 (with-compilation-hooks ()
451 (let ((*buffer-name* nil)
452 (*compile-filename* input-file))
453 (compile-file *compile-filename*
454 :output-file output-file
455 :load-after-compile load-p
456 :external-format external-format)))
457 (reader-error () (values nil nil t))))
458
459 (defun call-with-temp-file (fn)
460 (let ((tmpname (system:make-temp-file-name)))
461 (unwind-protect
462 (with-open-file (file tmpname :direction :output :if-exists :error)
463 (funcall fn file tmpname))
464 (delete-file tmpname))))
465
466 (defvar *temp-file-map* (make-hash-table :test #'equal)
467 "A mapping from tempfile names to Emacs buffer names.")
468
469 (defun compile-from-temp-file (string buffer offset file)
470 (call-with-temp-file
471 (lambda (stream filename)
472 (let ((excl:*load-source-file-info* t)
473 (sys:*source-file-types* '(nil)) ; suppress .lisp extension
474 #+(version>= 8 2)
475 (compiler:save-source-level-debug-info-switch t)
476 #+(version>= 8 2)
477 (excl:*load-source-debug-info* t) ; NOTE: requires lldb
478 )
479 (write-string string stream)
480 (finish-output stream)
481 (multiple-value-bind (binary-filename warnings? failure?)
482 (excl:without-redefinition-warnings
483 ;; Suppress Allegro's redefinition warnings; they are
484 ;; pointless when we are compiling via a temporary
485 ;; file.
486 (compile-file filename :load-after-compile t))
487 (declare (ignore warnings?))
488 (when binary-filename
489 (setf (gethash (pathname stream) *temp-file-map*)
490 (list buffer offset file))
491 (delete-file binary-filename))
492 (not failure?))))))
493
494 (defimplementation swank-compile-string (string &key buffer position filename
495 policy)
496 (declare (ignore policy))
497 (handler-case
498 (with-compilation-hooks ()
499 (let ((*buffer-name* buffer)
500 (*buffer-start-position* position)
501 (*buffer-string* string)
502 (*default-pathname-defaults*
503 (if filename
504 (merge-pathnames (pathname filename))
505 *default-pathname-defaults*)))
506 (compile-from-temp-file string buffer position filename)))
507 (reader-error () nil)))
508
509 ;;;; Definition Finding
510
511 (defun buffer-or-file (file file-fun buffer-fun)
512 (let* ((probe (gethash file *temp-file-map*)))
513 (cond (probe
514 (destructuring-bind (buffer start file) probe
515 (declare (ignore file))
516 (funcall buffer-fun buffer start)))
517 (t (funcall file-fun (namestring (truename file)))))))
518
519 (defun buffer-or-file-location (file offset)
520 (buffer-or-file file
521 (lambda (filename)
522 (make-location `(:file ,filename)
523 `(:position ,(1+ offset))))
524 (lambda (buffer start)
525 (make-location `(:buffer ,buffer)
526 `(:offset ,start ,offset)))))
527
528 (defun fspec-primary-name (fspec)
529 (etypecase fspec
530 (symbol fspec)
531 (list (fspec-primary-name (second fspec)))))
532
533 (defun find-definition-in-file (fspec type file top-level)
534 (let* ((part
535 (or (scm::find-definition-in-definition-group
536 fspec type (scm:section-file :file file)
537 :top-level top-level)
538 (scm::find-definition-in-definition-group
539 (fspec-primary-name fspec)
540 type (scm:section-file :file file)
541 :top-level top-level)))
542 (start (and part
543 (scm::source-part-start part)))
544 (pos (if start
545 (list :position (1+ start))
546 (list :function-name (string (fspec-primary-name fspec))))))
547 (make-location (list :file (namestring (truename file)))
548 pos)))
549
550 (defun find-fspec-location (fspec type file top-level)
551 (handler-case
552 (etypecase file
553 (pathname
554 (let ((probe (gethash file *temp-file-map*)))
555 (cond (probe
556 (destructuring-bind (buffer offset file) probe
557 (declare (ignore file))
558 (make-location `(:buffer ,buffer)
559 `(:offset ,offset 0))))
560 (t
561 (find-definition-in-file fspec type file top-level)))))
562 ((member :top-level)
563 (make-error-location "Defined at toplevel: ~A"
564 (fspec->string fspec))))
565 (error (e)
566 (make-error-location "Error: ~A" e))))
567
568 (defun fspec->string (fspec)
569 (typecase fspec
570 (symbol (let ((*package* (find-package :keyword)))
571 (prin1-to-string fspec)))
572 (list (format nil "(~A ~A)"
573 (prin1-to-string (first fspec))
574 (let ((*package* (find-package :keyword)))
575 (prin1-to-string (second fspec)))))
576 (t (princ-to-string fspec))))
577
578 (defun fspec-definition-locations (fspec)
579 (cond
580 ((and (listp fspec)
581 (eql (car fspec) :top-level-form))
582 (destructuring-bind (top-level-form file &optional (position 0)) fspec
583 (declare (ignore top-level-form))
584 `((,fspec
585 ,(buffer-or-file-location file position)))))
586 ((and (listp fspec) (eq (car fspec) :internal))
587 (destructuring-bind (_internal next _n) fspec
588 (declare (ignore _internal _n))
589 (fspec-definition-locations next)))
590 (t
591 (let ((defs (excl::find-source-file fspec)))
592 (when (and (null defs)
593 (listp fspec)
594 (string= (car fspec) '#:method))
595 ;; If methods are defined in a defgeneric form, the source location is
596 ;; recorded for the gf but not for the methods. Therefore fall back to
597 ;; the gf as the likely place of definition.
598 (setq defs (excl::find-source-file (second fspec))))
599 (if (null defs)
600 (list
601 (list fspec
602 (make-error-location "Unknown source location for ~A"
603 (fspec->string fspec))))
604 (loop for (fspec type file top-level) in defs collect
605 (list (list type fspec)
606 (find-fspec-location fspec type file top-level))))))))
607
608 (defimplementation find-definitions (symbol)
609 (fspec-definition-locations symbol))
610
611 ;;;; XREF
612
613 (defmacro defxref (name relation name1 name2)
614 `(defimplementation ,name (x)
615 (xref-result (xref:get-relation ,relation ,name1 ,name2))))
616
617 (defxref who-calls :calls :wild x)
618 (defxref calls-who :calls x :wild)
619 (defxref who-references :uses :wild x)
620 (defxref who-binds :binds :wild x)
621 (defxref who-macroexpands :macro-calls :wild x)
622 (defxref who-sets :sets :wild x)
623
624 (defun xref-result (fspecs)
625 (loop for fspec in fspecs
626 append (fspec-definition-locations fspec)))
627
628 ;; list-callers implemented by groveling through all fbound symbols.
629 ;; Only symbols are considered. Functions in the constant pool are
630 ;; searched recursively. Closure environments are ignored at the
631 ;; moment (constants in methods are therefore not found).
632
633 (defun map-function-constants (function fn depth)
634 "Call FN with the elements of FUNCTION's constant pool."
635 (do ((i 0 (1+ i))
636 (max (excl::function-constant-count function)))
637 ((= i max))
638 (let ((c (excl::function-constant function i)))
639 (cond ((and (functionp c)
640 (not (eq c function))
641 (plusp depth))
642 (map-function-constants c fn (1- depth)))
643 (t
644 (funcall fn c))))))
645
646 (defun in-constants-p (fun symbol)
647 (map-function-constants fun
648 (lambda (c)
649 (when (eq c symbol)
650 (return-from in-constants-p t)))
651 3))
652
653 (defun function-callers (name)
654 (let ((callers '()))
655 (do-all-symbols (sym)
656 (when (fboundp sym)
657 (let ((fn (fdefinition sym)))
658 (when (in-constants-p fn name)
659 (push sym callers)))))
660 callers))
661
662 (defimplementation list-callers (name)
663 (xref-result (function-callers name)))
664
665 (defimplementation list-callees (name)
666 (let ((result '()))
667 (map-function-constants (fdefinition name)
668 (lambda (c)
669 (when (fboundp c)
670 (push c result)))
671 2)
672 (xref-result result)))
673
674 ;;;; Profiling
675
676 ;; Per-function profiling based on description in
677 ;; http://www.franz.com/support/documentation/8.0/\
678 ;; doc/runtime-analyzer.htm#data-collection-control-2
679
680 (defvar *profiled-functions* ())
681 (defvar *profile-depth* 0)
682
683 (defmacro with-redirected-y-or-n-p (&body body)
684 ;; If the profiler is restarted when the data from the previous
685 ;; session is not reported yet, the user is warned via Y-OR-N-P.
686 ;; As the CL:Y-OR-N-P question is (for some reason) not directly
687 ;; sent to the Slime user, the function CL:Y-OR-N-P is temporarily
688 ;; overruled.
689 `(let* ((pkg (find-package :common-lisp))
690 (saved-pdl (excl::package-definition-lock pkg))
691 (saved-ynp (symbol-function 'cl:y-or-n-p)))
692 (setf (excl::package-definition-lock pkg) nil
693 (symbol-function 'cl:y-or-n-p)
694 (symbol-function (read-from-string "swank:y-or-n-p-in-emacs")))
695 (unwind-protect
696 (progn ,@body)
697 (setf (symbol-function 'cl:y-or-n-p) saved-ynp
698 (excl::package-definition-lock pkg) saved-pdl))))
699
700 (defun start-acl-profiler ()
701 (with-redirected-y-or-n-p
702 (prof:start-profiler :type :time :count t
703 :start-sampling-p nil :verbose nil)))
704 (defun acl-profiler-active-p ()
705 (not (eq (prof:profiler-status :verbose nil) :inactive)))
706
707 (defun stop-acl-profiler ()
708 (prof:stop-profiler :verbose nil))
709
710 (excl:def-fwrapper profile-fwrapper (&rest args)
711 ;; Ensures sampling is done during the execution of the function,
712 ;; taking into account recursion.
713 (declare (ignore args))
714 (cond ((zerop *profile-depth*)
715 (let ((*profile-depth* (1+ *profile-depth*)))
716 (prof:start-sampling)
717 (unwind-protect (excl:call-next-fwrapper)
718 (prof:stop-sampling))))
719 (t
720 (excl:call-next-fwrapper))))
721
722 (defimplementation profile (fname)
723 (unless (acl-profiler-active-p)
724 (start-acl-profiler))
725 (excl:fwrap fname 'profile-fwrapper 'profile-fwrapper)
726 (push fname *profiled-functions*))
727
728 (defimplementation profiled-functions ()
729 *profiled-functions*)
730
731 (defimplementation unprofile (fname)
732 (excl:funwrap fname 'profile-fwrapper)
733 (setq *profiled-functions* (remove fname *profiled-functions*)))
734
735 (defimplementation profile-report ()
736 (prof:show-flat-profile :verbose nil)
737 (when *profiled-functions*
738 (start-acl-profiler)))
739
740 (defimplementation profile-reset ()
741 (when (acl-profiler-active-p)
742 (stop-acl-profiler)
743 (start-acl-profiler))
744 "Reset profiling counters.")
745
746 ;;;; Inspecting
747
748 (excl:without-redefinition-warnings
749 (defmethod emacs-inspect ((o t))
750 (allegro-inspect o)))
751
752 (defmethod emacs-inspect ((o function))
753 (allegro-inspect o))
754
755 (defmethod emacs-inspect ((o standard-object))
756 (allegro-inspect o))
757
758 (defun allegro-inspect (o)
759 (loop for (d dd) on (inspect::inspect-ctl o)
760 append (frob-allegro-field-def o d)
761 until (eq d dd)))
762
763 (defun frob-allegro-field-def (object def)
764 (with-struct (inspect::field-def- name type access) def
765 (ecase type
766 ((:unsigned-word :unsigned-byte :unsigned-natural
767 :unsigned-long :unsigned-half-long
768 :unsigned-3byte :unsigned-long32)
769 (label-value-line name (inspect::component-ref-v object access type)))
770 ((:lisp :value :func)
771 (label-value-line name (inspect::component-ref object access)))
772 (:indirect
773 (destructuring-bind (prefix count ref set) access
774 (declare (ignore set prefix))
775 (loop for i below (funcall count object)
776 append (label-value-line (format nil "~A-~D" name i)
777 (funcall ref object i))))))))
778
779 ;;;; Multithreading
780
781 (defimplementation initialize-multiprocessing (continuation)
782 (mp:start-scheduler)
783 (funcall continuation))
784
785 (defimplementation spawn (fn &key name)
786 (mp:process-run-function name fn))
787
788 (defvar *id-lock* (mp:make-process-lock :name "id lock"))
789 (defvar *thread-id-counter* 0)
790
791 (defimplementation thread-id (thread)
792 (mp:with-process-lock (*id-lock*)
793 (or (getf (mp:process-property-list thread) 'id)
794 (setf (getf (mp:process-property-list thread) 'id)
795 (incf *thread-id-counter*)))))
796
797 (defimplementation find-thread (id)
798 (find id mp:*all-processes*
799 :key (lambda (p) (getf (mp:process-property-list p) 'id))))
800
801 (defimplementation thread-name (thread)
802 (mp:process-name thread))
803
804 (defimplementation thread-status (thread)
805 (princ-to-string (mp:process-whostate thread)))
806
807 (defimplementation thread-attributes (thread)
808 (list :priority (mp:process-priority thread)
809 :times-resumed (mp:process-times-resumed thread)))
810
811 (defimplementation make-lock (&key name)
812 (mp:make-process-lock :name name))
813
814 (defimplementation call-with-lock-held (lock function)
815 (mp:with-process-lock (lock) (funcall function)))
816
817 (defimplementation current-thread ()
818 mp:*current-process*)
819
820 (defimplementation all-threads ()
821 (copy-list mp:*all-processes*))
822
823 (defimplementation interrupt-thread (thread fn)
824 (mp:process-interrupt thread fn))
825
826 (defimplementation kill-thread (thread)
827 (mp:process-kill thread))
828
829 (defvar *mailbox-lock* (mp:make-process-lock :name "mailbox lock"))
830
831 (defstruct (mailbox (:conc-name mailbox.))
832 (lock (mp:make-process-lock :name "process mailbox"))
833 (queue '() :type list)
834 (gate (mp:make-gate nil)))
835
836 (defun mailbox (thread)
837 "Return THREAD's mailbox."
838 (mp:with-process-lock (*mailbox-lock*)
839 (or (getf (mp:process-property-list thread) 'mailbox)
840 (setf (getf (mp:process-property-list thread) 'mailbox)
841 (make-mailbox)))))
842
843 (defimplementation send (thread message)
844 (let* ((mbox (mailbox thread)))
845 (mp:with-process-lock ((mailbox.lock mbox))
846 (setf (mailbox.queue mbox)
847 (nconc (mailbox.queue mbox) (list message)))
848 (mp:open-gate (mailbox.gate mbox)))))
849
850 (defimplementation receive-if (test &optional timeout)
851 (let ((mbox (mailbox mp:*current-process*)))
852 (assert (or (not timeout) (eq timeout t)))
853 (loop
854 (check-slime-interrupts)
855 (mp:with-process-lock ((mailbox.lock mbox))
856 (let* ((q (mailbox.queue mbox))
857 (tail (member-if test q)))
858 (when tail
859 (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
860 (return (car tail)))
861 (mp:close-gate (mailbox.gate mbox))))
862 (when (eq timeout t) (return (values nil t)))
863 (mp:process-wait-with-timeout "receive-if" 0.5
864 #'mp:gate-open-p (mailbox.gate mbox)))))
865
866 (let ((alist '())
867 (lock (mp:make-process-lock :name "register-thread")))
868
869 (defimplementation register-thread (name thread)
870 (declare (type symbol name))
871 (mp:with-process-lock (lock)
872 (etypecase thread
873 (null
874 (setf alist (delete name alist :key #'car)))
875 (mp:process
876 (let ((probe (assoc name alist)))
877 (cond (probe (setf (cdr probe) thread))
878 (t (setf alist (acons name thread alist))))))))
879 nil)
880
881 (defimplementation find-registered (name)
882 (mp:with-process-lock (lock)
883 (cdr (assoc name alist)))))
884
885 (defimplementation set-default-initial-binding (var form)
886 (push (cons var form)
887 #+(version>= 9 0)
888 excl:*required-thread-bindings*
889 #-(version>= 9 0)
890 excl::required-thread-bindings))
891
892 (defimplementation quit-lisp ()
893 (excl:exit 0 :quiet t))
894
895
896 ;;Trace implementations
897 ;;In Allegro 7.0, we have:
898 ;; (trace <name>)
899 ;; (trace ((method <name> <qualifier>? (<specializer>+))))
900 ;; (trace ((labels <name> <label-name>)))
901 ;; (trace ((labels (method <name> (<specializer>+)) <label-name>)))
902 ;; <name> can be a normal name or a (setf name)
903
904 (defimplementation toggle-trace (spec)
905 (ecase (car spec)
906 ((setf)
907 (toggle-trace-aux spec))
908 (:defgeneric (toggle-trace-generic-function-methods (second spec)))
909 ((setf :defmethod :labels :flet)
910 (toggle-trace-aux (process-fspec-for-allegro spec)))
911 (:call
912 (destructuring-bind (caller callee) (cdr spec)
913 (toggle-trace-aux callee
914 :inside (list (process-fspec-for-allegro caller)))))))
915
916 (defun tracedp (fspec)
917 (member fspec (eval '(trace)) :test #'equal))
918
919 (defun toggle-trace-aux (fspec &rest args)
920 (cond ((tracedp fspec)
921 (eval `(untrace ,fspec))
922 (format nil "~S is now untraced." fspec))
923 (t
924 (eval `(trace (,fspec ,@args)))
925 (format nil "~S is now traced." fspec))))
926
927 (defun toggle-trace-generic-function-methods (name)
928 (let ((methods (mop:generic-function-methods (fdefinition name))))
929 (cond ((tracedp name)
930 (eval `(untrace ,name))
931 (dolist (method methods (format nil "~S is now untraced." name))
932 (excl:funtrace (mop:method-function method))))
933 (t
934 (eval `(trace (,name)))
935 (dolist (method methods (format nil "~S is now traced." name))
936 (excl:ftrace (mop:method-function method)))))))
937
938 (defun process-fspec-for-allegro (fspec)
939 (cond ((consp fspec)
940 (ecase (first fspec)
941 ((setf) fspec)
942 ((:defun :defgeneric) (second fspec))
943 ((:defmethod) `(method ,@(rest fspec)))
944 ((:labels) `(labels ,(process-fspec-for-allegro (second fspec))
945 ,(third fspec)))
946 ((:flet) `(flet ,(process-fspec-for-allegro (second fspec))
947 ,(third fspec)))))
948 (t
949 fspec)))
950
951
952 ;;;; Weak hashtables
953
954 (defimplementation make-weak-key-hash-table (&rest args)
955 (apply #'make-hash-table :weak-keys t args))
956
957 (defimplementation make-weak-value-hash-table (&rest args)
958 (apply #'make-hash-table :values :weak args))
959
960 (defimplementation hash-table-weakness (hashtable)
961 (cond ((excl:hash-table-weak-keys hashtable) :key)
962 ((eq (excl:hash-table-values hashtable) :weak) :value)))
963
964
965
966 ;;;; Character names
967
968 (defimplementation character-completion-set (prefix matchp)
969 (loop for name being the hash-keys of excl::*name-to-char-table*
970 when (funcall matchp prefix name)
971 collect (string-capitalize name)))

  ViewVC Help
Powered by ViewVC 1.1.5