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