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