1%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2% 3% File: spy.sl 4% Description: Spying by ticks 5% Author: H. Melenk ,W. Neun ZIB Berlin 6% Created: 10-Mar-89 , derived from Cray version 7% Mode: Lisp 8% Package: Utilities 9% Status: Open Source: BSD License 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(compiletime (remprop 'car 'openfn)) 36(compiletime (remprop 'cdr 'openfn)) 37 38(compiletime (flag '(spyjoin spysort spysort1 getaddresstable) 39 'internalfunction)) 40 41(fluid '(&spylow& &spyhigh& % interval of interest during spy run 42 &spyres& % intermediate: address list of functions 43 % list of pairs ( addr . function) 44 % will be sorted by addresses 45 &spybucket& % bucket size from initialization call 46 &spyminimum& % minimum refs during printing 47 &spying& % indicator that spy is active 48 &spymintime& % minimal time slice for spying 49 &spytotal& % total refs counter while printing 50 &spysysrefs& % address table of those functions, which are 51 % not known at runtime via symfnc 52 % list of pairs ( addr . function) 53 heap 54 )) 55 56(setq &spyminimum& 5) 57(setq &spymintime& 40) 58(setq &spying& nil) 59(setq &spysysrefs& nil) 60 61(de spyon (fwa lwa timeslice bucketsize power) %building table for f$spy 62 (prog (vbl diff ) 63 (setq diff (wquotient (wplus2 (wdifference lwa fwa) bucketsize) 64 bucketsize)) 65 (setq &spying& (gtwarray (wshift (wplus2 3 diff) -1 ))) 66 (clear-memory &spying& (wshift (wplus2 3 diff) -1)) % set to zero 67 (putmem &spying& (wshift (wplus2 2 diff) -1)) 68 (setq &spying& (mkvec &spying&)) 69 (setq vbl (gtvect 6)) 70 (unix-profile (mkfixn (wplus2 (inf &spying&) 4)) % buffer 71 (wshift diff 1) % buffersize in bytes 72 fwa % fwa 73 (wshift 16#10000 (wminus power))) % magic, see: man profil 74) ) 75 76(de spyoff (bufferleng) 77 (prog (vbl buffer) 78 (unix-profile 0 0 0 0) % spy off 79 (setq buffer &spying&) 80 (setq &spying& nil) 81 (return buffer) 82) ) 83 84(de spywhole (bucket) %spy whole code area 85 (prog (power) 86 (if (memq bucket '(1 2 4 8 16 32 64 128 256)) t (setq bucket 4)) 87 (setq power (cadr (assoc bucket '((2 0) (4 1) (8 2) (16 3) (32 4) 88 (64 5) (128 6) (256 7))))) 89 (setq &spyhigh& lastbps) 90 (setq &spylow& bpslowerbound) 91 (setq &spybucket& bucket) 92 (spyon &spylow& &spyhigh& &spymintime& bucket power) 93)) 94 95(de spyprint () %print results sorted 96 (prog (length result addresstable) 97 98 (when (not &spying&) (return nil)) 99 100 (setq length (wquotient (wdifference &spyhigh& &spylow&) 101 &spybucket&)) 102 (setq length (wplus2 length 1)) 103 (setq result (spyoff length)) 104 (setq addresstable (getaddresstable)) 105 (setq addresstable (spyjoin addresstable result )) 106 (mapc addresstable (function (lambda (x) 107 (when (wgreaterp (car x) 108 &spyminimum&) 109 (prin2 (car x)) 110 (tab 10) 111 (let ((z (quotient 112 (times2 (car x)1000) 113 &spytotal& ))) 114 (prin2 (wquotient z 10)) 115 (prin2 ".") 116 (prin2 (wremainder z 10)) 117 (prin2 "%") 118 (tab 20) 119 (prin2t (cdr x))))))))) 120 121(de getaddresstable () 122 (setq &spyres& (append &spySysRefs& nil)) 123 (mapobl (function (lambda (x) 124 (cond 125 ((funboundp x) nil) 126 ((flambdalinkp x) nil) 127 (t (setq &spyres& 128 (cons (cons (symfnc (idinf x)) x) &spyres&))) 129 ) ) ) ) 130 (setq &spyres& (cons (cons heap 'end-of-code) &spyres&)) 131 (spysort (prog1 &spyres& 132 (setq &spyres& nil))) 133) 134 135(compiletime 136 (ds spyvecitm (x y) 137 (prog2 138 (setq v (vecitm x (wshift y -1))) 139 (if (eq (wand y 1) 1) (wand v 16#ffff) 140 (wshift v -16)))) 141) 142 143(de spyjoin (addrtable vector) 144 (prog (base counter currentfunction currenthigh currentcount 145 final veclength nextbucket v) 146 (setq veclength (veclen (vecinf vector))) 147 (setq vector (inf vector)) 148 (setq counter 0) 149 (setq &spytotal& 0) 150 loop 151 (while (and (wlessp counter veclength) 152 (spyvecitm vector (wplus2 counter 4)) 153 (eq (spyvecitm vector counter) 0)) 154 (setq counter (wplus2 counter 1))) 155 (setq base (wplus2 &spylow& (wtimes2 &spybucket& counter))) 156 (while (and addrtable (wlessp (caadr addrtable) base)) 157 (setq addrtable (cdr addrtable))) 158 159 (when (or (wgeq counter veclength) (not addrtable) 160 (not (spyvecitm vector (wplus2 counter 4)))) 161 (return (spysort1 final))) 162 163 (setq currentfunction (cdar addrtable)) 164 (setq currentcount 0) 165 (setq currenthigh (caadr addrtable)) 166 (setq nextbucket (wplus2 base &spybucket&)) 167 168 (while (and (wleq nextbucket currenthigh) 169 (spyvecitm vector (wplus2 counter 4)) 170 (wlessp counter veclength)) 171 (setq currentcount (wplus2 currentcount 172 (spyvecitm vector counter))) 173 (setq base (wplus2 base &spybucket&)) 174 (setq nextbucket (wplus2 base &spybucket&)) 175 (setq counter (wplus2 counter 1)) 176 ) 177 (setq currentcount (wplus2 currentcount 178 (spyvecitm vector counter))) 179 (when (and (wgreaterp currentcount 0) 180 (not (memq currentfunction '(buildrelocationfields 181 externalmarkfrombase updatesymbols 182 copyfromstaticheap current-stack-pointer 183 externalupdateitem makeidfreelist !%reclaim 184 markfromvectorregisters updateallbases)))) 185% keep gc off percentage 186 (setq &spytotal& (wplus2 &spytotal& currentcount)) 187 (setq final 188 (cons (cons currentcount currentfunction) final))) 189 (when (pairp addrtable) (setq addrtable (cdr addrtable))) 190 % because vector size calculation is sometimes a little bit 191 % wrong (too large) 192 (go loop) 193) ) 194 195(de spysort (l) % sort labels to ascending sequence 196 (prog (changed actptr x1 caractptr cdractptr) 197 loop (setq changed nil) 198 (setq actptr l) 199 (while (setq cdractptr (cdr actptr)) 200 (setq caractptr (car actptr)) 201 (when (wgreaterp (car caractptr) (caar cdractptr)) 202 (setq changed t) 203 (setq x1 (car cdractptr)) 204 (rplaca cdractptr caractptr) 205 (rplaca actptr x1)) 206 (setq actptr cdractptr)) 207 (when changed (go loop)) 208 (return l) 209) ) 210 211(de spysort1 (l) % sort labels to descending sequence 212 (prog (changed actptr x1) 213 (when (null l) (return NIL)) 214 loop (setq changed nil) 215 (setq actptr l) 216 (while (cdr actptr) 217 (when (wlessp (caar actptr) (caadr actptr)) 218 (setq changed t) 219 (setq x1 (cadr actptr)) 220 (rplaca (cdr actptr)(car actptr)) 221 (rplaca actptr x1)) 222 (setq actptr (cdr actptr))) 223 (when changed (go loop)) 224 (return l) 225) ) 226 227(de clear-memory (ptr amount) 228% (fast-clear ptr amount)) 229 (for (from i 0 amount) 230 (do (putmem (wplus2 (inf ptr) (wshift i 2)) 0)))) 231 232 233