← Back to branch summary

~ubuntu-branches/ubuntu/quantal/gclcvs/quantal

« back to all changes in this revision

Viewing changes to misc/warn-slow.lsp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2004-06-24 15:13:46 UTC
  • Revision ID: james.westby@ubuntu.com-20040624151346-xh0xaaktyyp7aorc
Tags: 2.7.0-26
C_GC_OFFSET is 2 on m68k-linux

Show diffs side-by-side

added added

removed removed

Lines of Context:
misc/warn-slow.lsp
 
1
;; Warn of some slow calls.
 
2
(in-package 'compiler)
 
3
 
 
4
;; slow if the result type is type T
 
5
(dolist (v '(+ * / mod - float 1- 1+))
 
6
  (setf (get v 'slow-test)
 
7
        #'(lambda (name x) (or (null x)  (eql (cadar x) t)))))
 
8
 
 
9
;; slow if the first arg is type T
 
10
(dolist (v '(aref si::aset < <= > >=))
 
11
  (setf (get v 'slow-test)
 
12
        #'(lambda (name x) (or (null x) (eql (caar x) t)))))
 
13
 
 
14
(dolist (v '(typep))
 
15
  (setf (get v 'slow-test)
 
16
        #'(lambda (name x) (null x))))
 
17
 
 
18
 
 
19
;; turn the compiler expressions back into something vaguely
 
20
;; readable.
 
21
(defun lispify (x)
 
22
   (let ((tem  (car x)))
 
23
     (cond ((equal tem 'var)
 
24
            (var-name (car (third x))))
 
25
           ((eq tem 'call-global)
 
26
            (cons (third x)
 
27
                  (mapcar 'lispify (fourth x))))
 
28
           ((eq tem 'fixnum-value)
 
29
            (third x))
 
30
           ((eq tem 'location)
 
31
            (lispify (third x)))
 
32
           (t x))))
 
33
 
 
34
(eval-when (load eval)
 
35
 (trace (get-inline-info :entry nil
 
36
        :entrycond nil
 
37
        :exitcond
 
38
        (and (not (equal (car values) nil))
 
39
             (let ((s (get (car si::arglist) 'slow-test)))
 
40
               (and s (funcall s (car si::arglist) (car values))))
 
41
             (progn
 
42
               (cmpwarn "Slow code: ~a: "
 
43
                  (cons (car si::arglist)
 
44
                        (mapcar 'lispify (second si::arglist))))
 
45
               (format t " ~a --> ~a~%"
 
46
                       (mapcar #'(lambda (form) (info-type (cadr form)))
 
47
                               (second si::arglist))
 
48
                       (third si::arglist)))
 
49
             nil)))
 
50
)          
 
 
b'\\ No newline at end of file'