1%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2% 3% File: PU:QUALIFIED-COUNTING.SL 4% Description: counting function execution with callers ref. 5% Author: Herbert Melenk and Winfried Neun, ZIB Berlin 6% Created: 5 September 1986 7% Status: Open Source: BSD License 8% Mode: Lisp 9% Package: Utilities 10% 11% Redistribution and use in source and binary forms, with or without 12% modification, are permitted provided that the following conditions are met: 13% 14% * Redistributions of source code must retain the relevant copyright 15% notice, this list of conditions and the following disclaimer. 16% * Redistributions in binary form must reproduce the above copyright 17% notice, this list of conditions and the following disclaimer in the 18% documentation and/or other materials provided with the distribution. 19% 20% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 21% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, 22% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 23% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR 24% CONTRIBUTORS 25% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 26% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 27% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 28% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 29% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 30% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 31% POSSIBILITY OF SUCH DAMAGE. 32% 33%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 34 35(cond ((not (getd 'priv-equal)) (copyd 'priv-equal 'equal))) 36(cond ((not (getd 'priv-get)) (copyd 'priv-get 'get))) 37(cond ((not (getd 'priv-put)) (copyd 'priv-put 'put))) 38 39(de priv-assoc (u v) 40 %. Return first (U . xxx) in V, or NIL 41 (cond ((not (pairp v)) nil) 42 ((and (pairp (car v)) (priv-equal u (caar v))) (car v)) 43 (t (priv-assoc u (cdr v))))) 44 45(imports '(compiler addr2id)) 46 47(on comp) 48 49(dm qualcount (u) 50 (mapc (cdr u) (function qualcount1))) 51 52(de qualcount1 (u) 53 (let ((name (intern (gensym))) 54 (name2 (intern (gensym))) 55 (args (qualcount-args (getd u) u)) 56 ) 57 (when (not (numberp args)) 58 59 (put 'quallap 'opencode 60 `((*move (frame ,(plus 3 (length args)))(reg 1))) 61 ) 62 63 (eval 64 `(progn 65 (copyd ',name ',u) 66 (de ,name2 ,args 67 (prog (retadr countpos) 68 (setq retadr (quallap)) 69 (setq countpos (priv-assoc retadr (priv-get ',u 'qualcount))) 70 (cond (countpos 71 (rplacd countpos (wplus2 1 (cdr countpos)))) 72 (t (priv-put ',u 'qualcount 73 (cons (cons retadr 1) 74 (priv-get ',u 'qualcount))))) 75 (return (,name . ,args)) 76 ) ) 77 (compile (list ',name2)) 78 (copyd ',u ',name2) 79) )))) 80 81(de qualcount-args(type name) 82 (let ((u '(x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15))) 83 (cond ((null type) nil) 84 ((not (eqcar type 'expr)) 85 (printf "cannot qualcount undef or non-expr function %w" name) 86 0) 87 ((pairp (setq type (cdr type))) % is a lambda 88 (cadr type)) 89 (t (setq type (getmem (wdifference (inf type) 90 addressingunitsperitem))) 91 (while (wgreaterp (length u) type) 92 (setq u (cdr u))) 93 u) 94))) 95 96 97(fluid '(*bordervalue*)) 98 99(setq *bordervalue* 20) 100 101(dm print-qualcount (u) (mapobl (function print-qualcount1))) 102 103(de print-qualcount1 (r) 104 105 (if (not (priv-get r 'qualcount)) nil 106 (prog (x) 107 (prin2 "************* calls for function ") 108 (prin2 r) 109 (prin2t " ************* ") 110 (setq x (priv-get r 'qualcount)) 111 aa 112 (when ( null x) (return (terpri))) 113 (when (wgreaterp (cdar x) *bordervalue*) 114 (terpri) 115 (prin2 "number of calls : ") (prin2 (cdar x)) 116 (prin2 " from ") 117 (prin2t (code-address-to-symbol (caar x)))) 118 (setq x (cdr x)) 119 (go aa) 120 ) 121 )) 122 123(de reset-qualcount() (mapobl (function (lambda (x) 124 (remprop x 'qualcount))))) 125 126(prin2t "use (qualcount function function ...), (print-qualcount)") 127(prin2t "and (reset-qualcount)") 128(prin2t "use *bordervalue* as level for printing") 129