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

Contents of /slime/swank-allegro.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.158 - (show annotations)
Sat Feb 2 10:11:16 2013 UTC (14 months, 2 weeks ago) by sboukarev
Branch: MAIN
Changes since 1.157: +5 -0 lines
* swank-backend.lisp (type-specifier-p): New.
Implement it for ACL, ECL, CCL, Clisp, SBCL, LW.

* contrib/swank-util.lisp (symbol-classification-string): Use
type-specifier-p.
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 (excl::ldb-code-pc c)
241 pc))
242 debug-info)))
243 (cond ((not code-loc)
244 (ldb-code-to-src-loc (aref debug-info 0)))
245 (t
246 (ldb-code-to-src-loc code-loc))))))))
247
248 #+(version>= 8 2)
249 (defun ldb-code-to-src-loc (code)
250 (declare (optimize debug))
251 (let* ((func (excl::ldb-code-func code))
252 (debug-info (excl::function-source-debug-info func))
253 (start (loop for i downfrom (excl::ldb-code-index code)
254 for bpt = (aref debug-info i)
255 for start = (excl::ldb-code-start-char bpt)
256 when start return start))
257 (src-file (excl:source-file func)))
258 (cond (start
259 (buffer-or-file-location src-file start))
260 (func
261 (let* ((debug-info (excl::function-source-debug-info func))
262 (whole (aref debug-info 0))
263 (paths (source-paths-of (excl::ldb-code-source whole)
264 (excl::ldb-code-source code)))
265 (path (if paths (longest-common-prefix paths) '()))
266 (start 0))
267 (buffer-or-file
268 src-file
269 (lambda (file)
270 (make-location `(:file ,file)
271 `(:source-path (0 . ,path) ,start)))
272 (lambda (buffer bstart)
273 (make-location `(:buffer ,buffer)
274 `(:source-path (0 . ,path)
275 ,(+ bstart start)))))))
276 (t
277 nil))))
278
279 (defun longest-common-prefix (sequences)
280 (assert sequences)
281 (flet ((common-prefix (s1 s2)
282 (let ((diff-pos (mismatch s1 s2)))
283 (if diff-pos (subseq s1 0 diff-pos) s1))))
284 (reduce #'common-prefix sequences)))
285
286 (defun source-paths-of (whole part)
287 (let ((result '()))
288 (labels ((walk (form path)
289 (cond ((eq form part)
290 (push (reverse path) result))
291 ((consp form)
292 (loop for i from 0 while (consp form) do
293 (walk (pop form) (cons i path)))))))
294 (walk whole '())
295 (reverse result))))
296
297 (defimplementation eval-in-frame (form frame-number)
298 (let ((frame (nth-frame frame-number)))
299 ;; let-bind lexical variables
300 (let ((vars (loop for i below (debugger:frame-number-vars frame)
301 for name = (debugger:frame-var-name frame i)
302 if (symbolp name)
303 collect `(,name ',(debugger:frame-var-value frame i)))))
304 (debugger:eval-form-in-context
305 `(let* ,vars ,form)
306 (debugger:environment-of-frame frame)))))
307
308 (defimplementation frame-package (frame-number)
309 (let* ((frame (nth-frame frame-number))
310 (exp (debugger:frame-expression frame)))
311 (typecase exp
312 ((cons symbol) (symbol-package (car exp)))
313 ((cons (cons (eql :internal) (cons symbol)))
314 (symbol-package (cadar exp))))))
315
316 (defimplementation return-from-frame (frame-number form)
317 (let ((frame (nth-frame frame-number)))
318 (multiple-value-call #'debugger:frame-return
319 frame (debugger:eval-form-in-context
320 form
321 (debugger:environment-of-frame frame)))))
322
323 (defimplementation frame-restartable-p (frame)
324 (handler-case (debugger:frame-retryable-p frame)
325 (serious-condition (c)
326 (funcall (read-from-string "swank::background-message")
327 "~a ~a" frame (princ-to-string c))
328 nil)))
329
330 (defimplementation restart-frame (frame-number)
331 (let ((frame (nth-frame frame-number)))
332 (cond ((debugger:frame-retryable-p frame)
333 (apply #'debugger:frame-retry frame (debugger:frame-function frame)
334 (cdr (debugger:frame-expression frame))))
335 (t "Frame is not retryable"))))
336
337 ;;;; Compiler hooks
338
339 (defvar *buffer-name* nil)
340 (defvar *buffer-start-position*)
341 (defvar *buffer-string*)
342 (defvar *compile-filename* nil)
343
344 (defun compiler-note-p (object)
345 (member (type-of object) '(excl::compiler-note compiler::compiler-note)))
346
347 (defun redefinition-p (condition)
348 (and (typep condition 'style-warning)
349 (every #'char-equal "redefin" (princ-to-string condition))))
350
351 (defun compiler-undefined-functions-called-warning-p (object)
352 (typep object 'excl:compiler-undefined-functions-called-warning))
353
354 (deftype compiler-note ()
355 `(satisfies compiler-note-p))
356
357 (deftype redefinition ()
358 `(satisfies redefinition-p))
359
360 (defun signal-compiler-condition (&rest args)
361 (apply #'signal 'compiler-condition args))
362
363 (defun handle-compiler-warning (condition)
364 (declare (optimize (debug 3) (speed 0) (space 0)))
365 (cond ((and (not *buffer-name*)
366 (compiler-undefined-functions-called-warning-p condition))
367 (handle-undefined-functions-warning condition))
368 (t
369 (signal-compiler-condition
370 :original-condition condition
371 :severity (etypecase condition
372 (redefinition :redefinition)
373 (style-warning :style-warning)
374 (warning :warning)
375 (compiler-note :note)
376 (reader-error :read-error)
377 (error :error))
378 :message (format nil "~A" condition)
379 :location (if (typep condition 'reader-error)
380 (location-for-reader-error condition)
381 (location-for-warning condition))))))
382
383 (defun location-for-warning (condition)
384 (let ((loc (getf (slot-value condition 'excl::plist) :loc)))
385 (cond (*buffer-name*
386 (make-location
387 (list :buffer *buffer-name*)
388 (list :offset *buffer-start-position* 0)))
389 (loc
390 (destructuring-bind (file . pos) loc
391 (let ((start (cond ((consp pos) ; 8.2 and newer
392 (car pos))
393 (t pos))))
394 (make-location
395 (list :file (namestring (truename file)))
396 (list :position (1+ start))))))
397 (t
398 (make-error-location "No error location available.")))))
399
400 (defun location-for-reader-error (condition)
401 (let ((pos (car (last (slot-value condition 'excl::format-arguments))))
402 (file (pathname (stream-error-stream condition))))
403 (if (integerp pos)
404 (if *buffer-name*
405 (make-location `(:buffer ,*buffer-name*)
406 `(:offset ,*buffer-start-position* ,pos))
407 (make-location `(:file ,(namestring (truename file)))
408 `(:position ,pos)))
409 (make-error-location "No error location available."))))
410
411 ;; TODO: report it as a bug to Franz that the condition's plist
412 ;; slot contains (:loc nil).
413 (defun handle-undefined-functions-warning (condition)
414 (let ((fargs (slot-value condition 'excl::format-arguments)))
415 (loop for (fname . locs) in (car fargs) do
416 (dolist (loc locs)
417 (multiple-value-bind (pos file) (ecase (length loc)
418 (2 (values-list loc))
419 (3 (destructuring-bind
420 (start end file) loc
421 (declare (ignore end))
422 (values start file))))
423 (signal-compiler-condition
424 :original-condition condition
425 :severity :warning
426 :message (format nil "Undefined function referenced: ~S"
427 fname)
428 :location (make-location (list :file file)
429 (list :position (1+ pos)))))))))
430
431 (defimplementation call-with-compilation-hooks (function)
432 (handler-bind ((warning #'handle-compiler-warning)
433 (compiler-note #'handle-compiler-warning)
434 (reader-error #'handle-compiler-warning))
435 (funcall function)))
436
437 (defimplementation swank-compile-file (input-file output-file
438 load-p external-format
439 &key policy)
440 (declare (ignore policy))
441 (handler-case
442 (with-compilation-hooks ()
443 (let ((*buffer-name* nil)
444 (*compile-filename* input-file))
445 (compile-file *compile-filename*
446 :output-file output-file
447 :load-after-compile load-p
448 :external-format external-format)))
449 (reader-error () (values nil nil t))))
450
451 (defun call-with-temp-file (fn)
452 (let ((tmpname (system:make-temp-file-name)))
453 (unwind-protect
454 (with-open-file (file tmpname :direction :output :if-exists :error)
455 (funcall fn file tmpname))
456 (delete-file tmpname))))
457
458 (defvar *temp-file-map* (make-hash-table :test #'equal)
459 "A mapping from tempfile names to Emacs buffer names.")
460
461 (defun compile-from-temp-file (string buffer offset file)
462 (call-with-temp-file
463 (lambda (stream filename)
464 (let ((excl:*load-source-file-info* t)
465 (sys:*source-file-types* '(nil)) ; suppress .lisp extension
466 #+(version>= 8 2)
467 (compiler:save-source-level-debug-info-switch t)
468 #+(version>= 8 2)
469 (excl:*load-source-debug-info* t) ; NOTE: requires lldb
470 )
471 (write-string string stream)
472 (finish-output stream)
473 (multiple-value-bind (binary-filename warnings? failure?)
474 (excl:without-redefinition-warnings
475 ;; Suppress Allegro's redefinition warnings; they are
476 ;; pointless when we are compiling via a temporary
477 ;; file.
478 (compile-file filename :load-after-compile t))
479 (declare (ignore warnings?))
480 (when binary-filename
481 (setf (gethash (pathname stream) *temp-file-map*)
482 (list buffer offset file))
483 (delete-file binary-filename))
484 (not failure?))))))
485
486 (defimplementation swank-compile-string (string &key buffer position filename
487 policy)
488 (declare (ignore policy))
489 (handler-case
490 (with-compilation-hooks ()
491 (let ((*buffer-name* buffer)
492 (*buffer-start-position* position)
493 (*buffer-string* string)
494 (*default-pathname-defaults*
495 (if filename
496 (merge-pathnames (pathname filename))
497 *default-pathname-defaults*)))
498 (compile-from-temp-file string buffer position filename)))
499 (reader-error () nil)))
500
501 ;;;; Definition Finding
502
503 (defun buffer-or-file (file file-fun buffer-fun)
504 (let* ((probe (gethash file *temp-file-map*)))
505 (cond (probe
506 (destructuring-bind (buffer start file) probe
507 (declare (ignore file))
508 (funcall buffer-fun buffer start)))
509 (t (funcall file-fun (namestring (truename file)))))))
510
511 (defun buffer-or-file-location (file offset)
512 (buffer-or-file file
513 (lambda (filename)
514 (make-location `(:file ,filename)
515 `(:position ,(1+ offset))))
516 (lambda (buffer start)
517 (make-location `(:buffer ,buffer)
518 `(:offset ,start ,offset)))))
519
520 (defun fspec-primary-name (fspec)
521 (etypecase fspec
522 (symbol fspec)
523 (list (fspec-primary-name (second fspec)))))
524
525 (defun find-definition-in-file (fspec type file top-level)
526 (let* ((part
527 (or (scm::find-definition-in-definition-group
528 fspec type (scm:section-file :file file)
529 :top-level top-level)
530 (scm::find-definition-in-definition-group
531 (fspec-primary-name fspec)
532 type (scm:section-file :file file)
533 :top-level top-level)))
534 (start (and part
535 (scm::source-part-start part)))
536 (pos (if start
537 (list :position (1+ start))
538 (list :function-name (string (fspec-primary-name fspec))))))
539 (make-location (list :file (namestring (truename file)))
540 pos)))
541
542 (defun find-fspec-location (fspec type file top-level)
543 (handler-case
544 (etypecase file
545 (pathname
546 (let ((probe (gethash file *temp-file-map*)))
547 (cond (probe
548 (destructuring-bind (buffer offset file) probe
549 (declare (ignore file))
550 (make-location `(:buffer ,buffer)
551 `(:offset ,offset 0))))
552 (t
553 (find-definition-in-file fspec type file top-level)))))
554 ((member :top-level)
555 (make-error-location "Defined at toplevel: ~A"
556 (fspec->string fspec))))
557 (error (e)
558 (make-error-location "Error: ~A" e))))
559
560 (defun fspec->string (fspec)
561 (typecase fspec
562 (symbol (let ((*package* (find-package :keyword)))
563 (prin1-to-string fspec)))
564 (list (format nil "(~A ~A)"
565 (prin1-to-string (first fspec))
566 (let ((*package* (find-package :keyword)))
567 (prin1-to-string (second fspec)))))
568 (t (princ-to-string fspec))))
569
570 (defun fspec-definition-locations (fspec)
571 (cond
572 ((and (listp fspec)
573 (eql (car fspec) :top-level-form))
574 (destructuring-bind (top-level-form file &optional (position 0)) fspec
575 (declare (ignore top-level-form))
576 `((,fspec
577 ,(buffer-or-file-location file position)))))
578 ((and (listp fspec) (eq (car fspec) :internal))
579 (destructuring-bind (_internal next _n) fspec
580 (declare (ignore _internal _n))
581 (fspec-definition-locations next)))
582 (t
583 (let ((defs (excl::find-source-file fspec)))
584 (when (and (null defs)
585 (listp fspec)
586 (string= (car fspec) '#:method))
587 ;; If methods are defined in a defgeneric form, the source location is
588 ;; recorded for the gf but not for the methods. Therefore fall back to
589 ;; the gf as the likely place of definition.
590 (setq defs (excl::find-source-file (second fspec))))
591 (if (null defs)
592 (list
593 (list fspec
594 (make-error-location "Unknown source location for ~A"
595 (fspec->string fspec))))
596 (loop for (fspec type file top-level) in defs collect
597 (list (list type fspec)
598 (find-fspec-location fspec type file top-level))))))))
599
600 (defimplementation find-definitions (symbol)
601 (fspec-definition-locations symbol))
602
603 ;;;; XREF
604
605 (defmacro defxref (name relation name1 name2)
606 `(defimplementation ,name (x)
607 (xref-result (xref:get-relation ,relation ,name1 ,name2))))
608
609 (defxref who-calls :calls :wild x)
610 (defxref calls-who :calls x :wild)
611 (defxref who-references :uses :wild x)
612 (defxref who-binds :binds :wild x)
613 (defxref who-macroexpands :macro-calls :wild x)
614 (defxref who-sets :sets :wild x)
615
616 (defun xref-result (fspecs)
617 (loop for fspec in fspecs
618 append (fspec-definition-locations fspec)))
619
620 ;; list-callers implemented by groveling through all fbound symbols.
621 ;; Only symbols are considered. Functions in the constant pool are
622 ;; searched recursively. Closure environments are ignored at the
623 ;; moment (constants in methods are therefore not found).
624
625 (defun map-function-constants (function fn depth)
626 "Call FN with the elements of FUNCTION's constant pool."
627 (do ((i 0 (1+ i))
628 (max (excl::function-constant-count function)))
629 ((= i max))
630 (let ((c (excl::function-constant function i)))
631 (cond ((and (functionp c)
632 (not (eq c function))
633 (plusp depth))
634 (map-function-constants c fn (1- depth)))
635 (t
636 (funcall fn c))))))
637
638 (defun in-constants-p (fun symbol)
639 (map-function-constants fun
640 (lambda (c)
641 (when (eq c symbol)
642 (return-from in-constants-p t)))
643 3))
644
645 (defun function-callers (name)
646 (let ((callers '()))
647 (do-all-symbols (sym)
648 (when (fboundp sym)
649 (let ((fn (fdefinition sym)))
650 (when (in-constants-p fn name)
651 (push sym callers)))))
652 callers))
653
654 (defimplementation list-callers (name)
655 (xref-result (function-callers name)))
656
657 (defimplementation list-callees (name)
658 (let ((result '()))
659 (map-function-constants (fdefinition name)
660 (lambda (c)
661 (when (fboundp c)
662 (push c result)))
663 2)
664 (xref-result result)))
665
666 ;;;; Profiling
667
668 ;; Per-function profiling based on description in
669 ;; http://www.franz.com/support/documentation/8.0/\
670 ;; doc/runtime-analyzer.htm#data-collection-control-2
671
672 (defvar *profiled-functions* ())
673 (defvar *profile-depth* 0)
674
675 (defmacro with-redirected-y-or-n-p (&body body)
676 ;; If the profiler is restarted when the data from the previous
677 ;; session is not reported yet, the user is warned via Y-OR-N-P.
678 ;; As the CL:Y-OR-N-P question is (for some reason) not directly
679 ;; sent to the Slime user, the function CL:Y-OR-N-P is temporarily
680 ;; overruled.
681 `(let* ((pkg (find-package :common-lisp))
682 (saved-pdl (excl::package-definition-lock pkg))
683 (saved-ynp (symbol-function 'cl:y-or-n-p)))
684 (setf (excl::package-definition-lock pkg) nil
685 (symbol-function 'cl:y-or-n-p)
686 (symbol-function (read-from-string "swank:y-or-n-p-in-emacs")))
687 (unwind-protect
688 (progn ,@body)
689 (setf (symbol-function 'cl:y-or-n-p) saved-ynp
690 (excl::package-definition-lock pkg) saved-pdl))))
691
692 (defun start-acl-profiler ()
693 (with-redirected-y-or-n-p
694 (prof:start-profiler :type :time :count t
695 :start-sampling-p nil :verbose nil)))
696 (defun acl-profiler-active-p ()
697 (not (eq (prof:profiler-status :verbose nil) :inactive)))
698
699 (defun stop-acl-profiler ()
700 (prof:stop-profiler :verbose nil))
701
702 (excl:def-fwrapper profile-fwrapper (&rest args)
703 ;; Ensures sampling is done during the execution of the function,
704 ;; taking into account recursion.
705 (declare (ignore args))
706 (cond ((zerop *profile-depth*)
707 (let ((*profile-depth* (1+ *profile-depth*)))
708 (prof:start-sampling)
709 (unwind-protect (excl:call-next-fwrapper)
710 (prof:stop-sampling))))
711 (t
712 (excl:call-next-fwrapper))))
713
714 (defimplementation profile (fname)
715 (unless (acl-profiler-active-p)
716 (start-acl-profiler))
717 (excl:fwrap fname 'profile-fwrapper 'profile-fwrapper)
718 (push fname *profiled-functions*))
719
720 (defimplementation profiled-functions ()
721 *profiled-functions*)
722
723 (defimplementation unprofile (fname)
724 (excl:funwrap fname 'profile-fwrapper)
725 (setq *profiled-functions* (remove fname *profiled-functions*)))
726
727 (defimplementation profile-report ()
728 (prof:show-flat-profile :verbose nil)
729 (when *profiled-functions*
730 (start-acl-profiler)))
731
732 (defimplementation profile-reset ()
733 (when (acl-profiler-active-p)
734 (stop-acl-profiler)
735 (start-acl-profiler))
736 "Reset profiling counters.")
737
738 ;;;; Inspecting
739
740 (excl:without-redefinition-warnings
741 (defmethod emacs-inspect ((o t))
742 (allegro-inspect o)))
743
744 (defmethod emacs-inspect ((o function))
745 (allegro-inspect o))
746
747 (defmethod emacs-inspect ((o standard-object))
748 (allegro-inspect o))
749
750 (defun allegro-inspect (o)
751 (loop for (d dd) on (inspect::inspect-ctl o)
752 append (frob-allegro-field-def o d)
753 until (eq d dd)))
754
755 (defun frob-allegro-field-def (object def)
756 (with-struct (inspect::field-def- name type access) def
757 (ecase type
758 ((:unsigned-word :unsigned-byte :unsigned-natural
759 :unsigned-long :unsigned-half-long
760 :unsigned-3byte :unsigned-long32)
761 (label-value-line name (inspect::component-ref-v object access type)))
762 ((:lisp :value :func)
763 (label-value-line name (inspect::component-ref object access)))
764 (:indirect
765 (destructuring-bind (prefix count ref set) access
766 (declare (ignore set prefix))
767 (loop for i below (funcall count object)
768 append (label-value-line (format nil "~A-~D" name i)
769 (funcall ref object i))))))))
770
771 ;;;; Multithreading
772
773 (defimplementation initialize-multiprocessing (continuation)
774 (mp:start-scheduler)
775 (funcall continuation))
776
777 (defimplementation spawn (fn &key name)
778 (mp:process-run-function name fn))
779
780 (defvar *id-lock* (mp:make-process-lock :name "id lock"))
781 (defvar *thread-id-counter* 0)
782
783 (defimplementation thread-id (thread)
784 (mp:with-process-lock (*id-lock*)
785 (or (getf (mp:process-property-list thread) 'id)
786 (setf (getf (mp:process-property-list thread) 'id)
787 (incf *thread-id-counter*)))))
788
789 (defimplementation find-thread (id)
790 (find id mp:*all-processes*
791 :key (lambda (p) (getf (mp:process-property-list p) 'id))))
792
793 (defimplementation thread-name (thread)
794 (mp:process-name thread))
795
796 (defimplementation thread-status (thread)
797 (princ-to-string (mp:process-whostate thread)))
798
799 (defimplementation thread-attributes (thread)
800 (list :priority (mp:process-priority thread)
801 :times-resumed (mp:process-times-resumed thread)))
802
803 (defimplementation make-lock (&key name)
804 (mp:make-process-lock :name name))
805
806 (defimplementation call-with-lock-held (lock function)
807 (mp:with-process-lock (lock) (funcall function)))
808
809 (defimplementation current-thread ()
810 mp:*current-process*)
811
812 (defimplementation all-threads ()
813 (copy-list mp:*all-processes*))
814
815 (defimplementation interrupt-thread (thread fn)
816 (mp:process-interrupt thread fn))
817
818 (defimplementation kill-thread (thread)
819 (mp:process-kill thread))
820
821 (defvar *mailbox-lock* (mp:make-process-lock :name "mailbox lock"))
822
823 (defstruct (mailbox (:conc-name mailbox.))
824 (lock (mp:make-process-lock :name "process mailbox"))
825 (queue '() :type list)
826 (gate (mp:make-gate nil)))
827
828 (defun mailbox (thread)
829 "Return THREAD's mailbox."
830 (mp:with-process-lock (*mailbox-lock*)
831 (or (getf (mp:process-property-list thread) 'mailbox)
832 (setf (getf (mp:process-property-list thread) 'mailbox)
833 (make-mailbox)))))
834
835 (defimplementation send (thread message)
836 (let* ((mbox (mailbox thread)))
837 (mp:with-process-lock ((mailbox.lock mbox))
838 (setf (mailbox.queue mbox)
839 (nconc (mailbox.queue mbox) (list message)))
840 (mp:open-gate (mailbox.gate mbox)))))
841
842 (defimplementation receive-if (test &optional timeout)
843 (let ((mbox (mailbox mp:*current-process*)))
844 (assert (or (not timeout) (eq timeout t)))
845 (loop
846 (check-slime-interrupts)
847 (mp:with-process-lock ((mailbox.lock mbox))
848 (let* ((q (mailbox.queue mbox))
849 (tail (member-if test q)))
850 (when tail
851 (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
852 (return (car tail)))
853 (mp:close-gate (mailbox.gate mbox))))
854 (when (eq timeout t) (return (values nil t)))
855 (mp:process-wait-with-timeout "receive-if" 0.5
856 #'mp:gate-open-p (mailbox.gate mbox)))))
857
858 (let ((alist '())
859 (lock (mp:make-process-lock :name "register-thread")))
860
861 (defimplementation register-thread (name thread)
862 (declare (type symbol name))
863 (mp:with-process-lock (lock)
864 (etypecase thread
865 (null
866 (setf alist (delete name alist :key #'car)))
867 (mp:process
868 (let ((probe (assoc name alist)))
869 (cond (probe (setf (cdr probe) thread))
870 (t (setf alist (acons name thread alist))))))))
871 nil)
872
873 (defimplementation find-registered (name)
874 (mp:with-process-lock (lock)
875 (cdr (assoc name alist)))))
876
877 (defimplementation set-default-initial-binding (var form)
878 (push (cons var form)
879 #+(version>= 9 0)
880 excl:*required-thread-bindings*
881 #-(version>= 9 0)
882 excl::required-thread-bindings))
883
884 (defimplementation quit-lisp ()
885 (excl:exit 0 :quiet t))
886
887
888 ;;Trace implementations
889 ;;In Allegro 7.0, we have:
890 ;; (trace <name>)
891 ;; (trace ((method <name> <qualifier>? (<specializer>+))))
892 ;; (trace ((labels <name> <label-name>)))
893 ;; (trace ((labels (method <name> (<specializer>+)) <label-name>)))
894 ;; <name> can be a normal name or a (setf name)
895
896 (defimplementation toggle-trace (spec)
897 (ecase (car spec)
898 ((setf)
899 (toggle-trace-aux spec))
900 (:defgeneric (toggle-trace-generic-function-methods (second spec)))
901 ((setf :defmethod :labels :flet)
902 (toggle-trace-aux (process-fspec-for-allegro spec)))
903 (:call
904 (destructuring-bind (caller callee) (cdr spec)
905 (toggle-trace-aux callee
906 :inside (list (process-fspec-for-allegro caller)))))))
907
908 (defun tracedp (fspec)
909 (member fspec (eval '(trace)) :test #'equal))
910
911 (defun toggle-trace-aux (fspec &rest args)
912 (cond ((tracedp fspec)
913 (eval `(untrace ,fspec))
914 (format nil "~S is now untraced." fspec))
915 (t
916 (eval `(trace (,fspec ,@args)))
917 (format nil "~S is now traced." fspec))))
918
919 (defun toggle-trace-generic-function-methods (name)
920 (let ((methods (mop:generic-function-methods (fdefinition name))))
921 (cond ((tracedp name)
922 (eval `(untrace ,name))
923 (dolist (method methods (format nil "~S is now untraced." name))
924 (excl:funtrace (mop:method-function method))))
925 (t
926 (eval `(trace (,name)))
927 (dolist (method methods (format nil "~S is now traced." name))
928 (excl:ftrace (mop:method-function method)))))))
929
930 (defun process-fspec-for-allegro (fspec)
931 (cond ((consp fspec)
932 (ecase (first fspec)
933 ((setf) fspec)
934 ((:defun :defgeneric) (second fspec))
935 ((:defmethod) `(method ,@(rest fspec)))
936 ((:labels) `(labels ,(process-fspec-for-allegro (second fspec))
937 ,(third fspec)))
938 ((:flet) `(flet ,(process-fspec-for-allegro (second fspec))
939 ,(third fspec)))))
940 (t
941 fspec)))
942
943
944 ;;;; Weak hashtables
945
946 (defimplementation make-weak-key-hash-table (&rest args)
947 (apply #'make-hash-table :weak-keys t args))
948
949 (defimplementation make-weak-value-hash-table (&rest args)
950 (apply #'make-hash-table :values :weak args))
951
952 (defimplementation hash-table-weakness (hashtable)
953 (cond ((excl:hash-table-weak-keys hashtable) :key)
954 ((eq (excl:hash-table-values hashtable) :weak) :value)))
955
956
957
958 ;;;; Character names
959
960 (defimplementation character-completion-set (prefix matchp)
961 (loop for name being the hash-keys of excl::*name-to-char-table*
962 when (funcall matchp prefix name)
963 collect (string-capitalize name)))

  ViewVC Help
Powered by ViewVC 1.1.5