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

Contents of /slime/swank-allegro.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5