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