1-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
2-- All rights reserved.
3--
4-- Redistribution and use in source and binary forms, with or without
5-- modification, are permitted provided that the following conditions are
6-- met:
7--
8--     - Redistributions of source code must retain the above copyright
9--       notice, this list of conditions and the following disclaimer.
10--
11--     - Redistributions in binary form must reproduce the above copyright
12--       notice, this list of conditions and the following disclaimer in
13--       the documentation and/or other materials provided with the
14--       distribution.
15--
16--     - Neither the name of The Numerical ALgorithms Group Ltd. nor the
17--       names of its contributors may be used to endorse or promote products
18--       derived from this software without specific prior written permission.
19--
20-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
21-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
22-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
23-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
24-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
25-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
26-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
27-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
28-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
29-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
30-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31
32)package "BOOT"
33
34--% Code instrumentation facilities
35--  These functions can be used with arbitrary lists of
36--  named stats (listofnames) grouped in classes (listofclasses)
37--  and with measurement types (property, classproperty).
38
39makeLongStatStringByProperty _
40 (listofnames, listofclasses, property, classproperty, units, flag) ==
41  total := 0
42  str := '""
43  otherStatTotal := GET('other, property)
44  for [name,class,:ab] in listofnames repeat
45    name = 'other => 'iterate
46    cl := first LASSOC(class, listofclasses)
47    n := GET(name, property)
48    PUT(cl, classproperty, n + GET(cl, classproperty))
49    total := total + n
50    if n >= 0.01
51      then timestr := normalizeStatAndStringify n
52      else
53        timestr := '""
54        otherStatTotal := otherStatTotal + n
55    str := makeStatString(str,timestr,ab,flag)
56  otherStatTotal := otherStatTotal
57  PUT('other, property, otherStatTotal)
58  if otherStatTotal > 0 then
59    str := makeStatString(str,normalizeStatAndStringify otherStatTotal,'O,flag)
60    total := total + otherStatTotal
61    cl := first LASSOC('other, listofnames)
62    cl := first LASSOC(cl, listofclasses)
63    PUT(cl, classproperty, otherStatTotal + GET(cl, classproperty))
64  if flag ~= 'long then
65    total := 0
66    str := '""
67    for [class,name,:ab] in listofclasses repeat
68      n := GET(name, classproperty)
69      n = 0.0 => 'iterate
70      total := total + n
71      timestr := normalizeStatAndStringify n
72      str := makeStatString(str,timestr,ab,flag)
73  total := STRCONC(normalizeStatAndStringify total,'" ", units)
74  str = '"" =>  total
75  STRCONC(str, '" = ", total)
76
77normalizeStatAndStringify t ==
78  FLOATP t =>
79      t := roundStat t
80      t = 0.0 => '"0"
81      FORMAT(nil,'"~,2F",t)
82  INTEGERP t =>
83      K := 1024
84      M := K*K
85      t > 9*M => CONCAT(STRINGIMAGE((t + 512*K)/M), '"M")
86      t > 9*K => CONCAT(STRINGIMAGE((t + 512)/K),   '"K")
87      STRINGIMAGE t
88  STRINGIMAGE t
89
90significantStat t ==
91   FLOATP t => (t > 0.01)
92   INTEGERP  t => (t > 100)
93   true
94
95roundStat t ==
96  not FLOATP t => t
97  (TRUNCATE (0.5 + t * 1000.0)) / 1000.0
98
99makeStatString(oldstr,time,abb,flag) ==
100  time = '"" => oldstr
101  opening := (flag = 'long => '"("; '" (")
102  oldstr = '"" => STRCONC(time,opening,abb,'")")
103  STRCONC(oldstr,'" + ",time,opening,abb,'")")
104
105peekTimedName() == IFCAR $timedNameStack
106
107popTimedName() ==
108  name := IFCAR $timedNameStack
109  $timedNameStack := IFCDR $timedNameStack
110  name
111
112pushTimedName name ==
113  PUSH(name,$timedNameStack)
114
115startTimingProcess name ==
116  updateTimedName peekTimedName()
117  pushTimedName name
118  if EQ(name, 'load) then          statRecordLoadEvent()
119
120stopTimingProcess name ==
121  (name ~= peekTimedName()) and null $InteractiveMode =>
122    keyedSystemError("S2GL0015",[name,peekTimedName()])
123  updateTimedName peekTimedName()
124  popTimedName()
125
126--% Instrumentation specific to the interpreter
127DEFPARAMETER($oldElapsedSpace, 0)
128DEFPARAMETER($oldElapsedGCTime, 0.0)
129DEFPARAMETER($oldElapsedTime, 0.0)
130DEFPARAMETER($gcTimeTotal, 0.0)
131
132-- $timedNameStack is used to hold the names of sections of the
133-- code being timed.
134
135DEFPARAMETER($timedNameStack, '(other))
136
137DEFPARAMETER($interpreterTimedNames, '(
138-- name         class abbrev
139  (algebra        2 .   B) _
140  (analysis       1 .   A) _
141  (coercion       1 .   C) _
142  (compilation    3 .   T) _
143  (debug          3 .   D) _
144  (evaluation     2 .   E) _
145  (gc             4 .   G) _
146  (history        3 .   H) _
147  (instantiation  3 .   I) _
148  (load           3 .   L) _
149  (modemaps       1 .   M) _
150  (optimization   3 .   Z) _
151  (querycoerce    1 .   Q) _
152  (other          3 .   O) _
153  (diskread       3 .   K) _
154  (resolve        1 .   R) _
155  ))
156
157DEFPARAMETER($interpreterTimedClasses, '(
158-- number class name    short name
159  ( 1    interpreter     .  IN) _
160  ( 2    evaluation      .  EV) _
161  ( 3    other           .  OT) _
162  ( 4    reclaim         .  GC) _
163  ))
164
165initializeTimedNames(listofnames,listofclasses) ==
166  for [name,:.] in listofnames repeat
167    PUT(name, 'TimeTotal, 0.0)
168    PUT(name, 'SpaceTotal,  0)
169  for [.,name,:.] in listofclasses repeat
170    PUT( name, 'ClassTimeTotal, 0.0)
171    PUT( name, 'ClassSpaceTotal,  0)
172  $timedNameStack := '(other)
173  computeElapsedTime()
174  PUT('gc, 'TimeTotal, 0.0)
175  PUT('gc, 'SpaceTotal,  0)
176  NIL
177
178updateTimedName name ==
179  count := (GET(name, 'TimeTotal) or 0) + computeElapsedTime()
180  PUT(name, 'TimeTotal, count)
181
182makeLongTimeString(listofnames,listofclasses) ==
183  makeLongStatStringByProperty(listofnames, listofclasses,  _
184                               'TimeTotal, 'ClassTimeTotal, _
185                               '"sec", $printTimeIfTrue)
186
187makeLongSpaceString(listofnames,listofclasses) ==
188  makeLongStatStringByProperty(listofnames, listofclasses,    _
189                               'SpaceTotal, 'ClassSpaceTotal, _
190                               '"bytes", $printStorageIfTrue)
191
192DEFPARAMETER($inverseTimerTicksPerSecond, 1.0/$timerTicksPerSecond)
193
194computeElapsedTime() ==
195  -- in total time lists, CAR is VIRTCPU and CADR is TOTCPU
196  currentTime:= elapsedUserTime()
197  currentGCTime:= elapsedGcTime()
198  gcDelta := currentGCTime - $oldElapsedGCTime
199  elapsedSeconds:= $inverseTimerTicksPerSecond *
200     (currentTime-$oldElapsedTime-gcDelta)
201  PUT('gc, 'TimeTotal, GET('gc, 'TimeTotal) +
202                   $inverseTimerTicksPerSecond*gcDelta)
203  $oldElapsedTime := currentTime
204  $oldElapsedGCTime := currentGCTime
205  elapsedSeconds
206
207computeElapsedSpace() ==
208  currentElapsedSpace := HEAPELAPSED()
209  elapsedBytes := currentElapsedSpace - $oldElapsedSpace
210  $oldElapsedSpace := currentElapsedSpace
211  elapsedBytes
212
213timedAlgebraEvaluation(code) ==
214  startTimingProcess 'algebra
215  r := eval code
216  stopTimingProcess 'algebra
217  r
218
219timedOptimization(code) ==
220  startTimingProcess 'optimization
221  r := lispize code
222  if $reportOptimization then
223    sayBrightlyI bright '"Optimized LISP code:"
224    pp r
225  stopTimingProcess 'optimization
226  r
227
228timedEVALFUN(code) ==
229  startTimingProcess 'evaluation
230  r := timedEvaluate code
231  stopTimingProcess 'evaluation
232  r
233
234timedEvaluate code ==
235  code is ["LIST",:a] and #a > 200 =>
236    "append"/[eval ["LIST",:x] for x in splitIntoBlocksOf200 a]
237  eval code
238
239displayHeapStatsIfWanted() ==
240   $printStorageIfTrue => sayBrightly OLDHEAPSTATS()
241
242--% stubs for the stats summary fns
243statRecordInstantiationEvent() == nil
244statRecordLoadEvent()          == nil
245
246statisticsSummary()  == '"No statistics available."
247