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

Contents of /slime/swank-allegro.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5