Revert commits to the wrong tree.

1 files changed, 292 insertions, 0 deletions

diff --git a/src/interp/g-timer.boot.pamphlet b/src/interp/g-timer.boot.pamphlet
new file mode 100644
index 00000000..513e367d
--- /dev/null
+++ b/src/interp/g-timer.boot.pamphlet
@@ -0,0 +1,292 @@
+\documentclass{article}
+\usepackage{axiom}
+\begin{document}
+\title{\$SPAD/src/interp g-timer.boot}
+\author{The Axiom Team}
+\maketitle
+\begin{abstract}
+\end{abstract}
+\eject
+\tableofcontents
+\eject
+\section{License}
+<<license>>=
+-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
+-- All rights reserved.
+--
+-- Redistribution and use in source and binary forms, with or without
+-- modification, are permitted provided that the following conditions are
+-- met:
+--
+--     - Redistributions of source code must retain the above copyright
+--       notice, this list of conditions and the following disclaimer.
+--
+--     - Redistributions in binary form must reproduce the above copyright
+--       notice, this list of conditions and the following disclaimer in
+--       the documentation and/or other materials provided with the
+--       distribution.
+--
+--     - Neither the name of The Numerical ALgorithms Group Ltd. nor the
+--       names of its contributors may be used to endorse or promote products
+--       derived from this software without specific prior written permission.
+--
+-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
+-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
+-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
+-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+@
+<<*>>=
+<<license>>
+
+--% Code instrumentation facilities
+--  These functions can be used with arbitrary lists of
+--  named stats (listofnames) grouped in classes (listofclasses)
+--  and with measurement types (property, classproperty).
+ 
+printNamedStatsByProperty(listofnames, property) ==
+  total := +/[GETL(name,property) for [name,:.] in listofnames]
+  for [name,:.] in listofnames repeat
+    n := GETL(name, property)
+    strname := STRINGIMAGE name
+    strval  := STRINGIMAGE n
+    sayBrightly concat(bright strname,
+      fillerSpaces(70-#strname-#strval,'"."),bright strval)
+  sayBrightly bright fillerSpaces(72,'"-")
+  sayBrightly concat(bright '"Total",
+    fillerSpaces(65-# STRINGIMAGE total,'"."),bright STRINGIMAGE total)
+ 
+makeLongStatStringByProperty _
+ (listofnames, listofclasses, property, classproperty, units, flag) ==
+  total := 0
+  str := '""
+  otherStatTotal := GETL('other, property)
+  for [name,class,:ab] in listofnames repeat
+    name = 'other => 'iterate
+    cl := CAR LASSOC(class,listofclasses)
+    n := GETL( name, property)
+    PUT(cl,classproperty, n + GETL(cl,classproperty))
+    total := total + n
+    if n >= 0.01
+      then timestr := normalizeStatAndStringify n
+      else
+        timestr := '""
+        otherStatTotal := otherStatTotal + n
+    str := makeStatString(str,timestr,ab,flag)
+  otherStatTotal := otherStatTotal
+  PUT('other, property, otherStatTotal)
+  if otherStatTotal > 0 then
+    str := makeStatString(str,normalizeStatAndStringify otherStatTotal,'O,flag)
+    total := total + otherStatTotal
+    cl := CAR LASSOC('other,listofnames)
+    cl := CAR LASSOC(cl,listofclasses)
+    PUT(cl,classproperty, otherStatTotal + GETL(cl,classproperty))
+  if flag ^= 'long then
+    total := 0
+    str := '""
+    for [class,name,:ab] in listofclasses repeat
+      n := GETL(name, classproperty)
+      n = 0.0 => 'iterate
+      total := total + n
+      timestr := normalizeStatAndStringify n
+      str := makeStatString(str,timestr,ab,flag)
+  total := STRCONC(normalizeStatAndStringify total,'" ", units)
+  str = '"" =>  total
+  STRCONC(str, '" = ", total)
+ 
+normalizeStatAndStringify t ==
+  RNUMP t =>
+      t := roundStat t
+      t = 0.0 => '"0"
+      FORMAT(nil,'"~,2F",t)
+  INTP t =>
+      K := 1024
+      M := K*K
+      t > 9*M => CONCAT(STRINGIMAGE((t + 512*K)/M), '"M")
+      t > 9*K => CONCAT(STRINGIMAGE((t + 512)/K),   '"K")
+      STRINGIMAGE t
+  STRINGIMAGE t
+ 
+significantStat t ==
+   RNUMP t => (t > 0.01)
+   INTP  t => (t > 100)
+   true
+ 
+roundStat t ==
+  not RNUMP t => t
+  (FIX (0.5 + t * 1000.0)) / 1000.0
+ 
+makeStatString(oldstr,time,abb,flag) ==
+  time = '"" => oldstr
+  opening := (flag = 'long => '"("; '" (")
+  oldstr = '"" => STRCONC(time,opening,abb,'")")
+  STRCONC(oldstr,'" + ",time,opening,abb,'")")
+ 
+peekTimedName() == IFCAR $timedNameStack
+ 
+popTimedName() ==
+  name := IFCAR $timedNameStack
+  $timedNameStack := IFCDR $timedNameStack
+  name
+ 
+pushTimedName name ==
+  PUSH(name,$timedNameStack)
+ 
+--currentlyTimedName() == CAR $timedNameStack
+ 
+startTimingProcess name ==
+  updateTimedName peekTimedName()
+  pushTimedName name
+  if EQ(name, 'load) then          statRecordLoadEvent()
+ 
+stopTimingProcess name ==
+  (name ^= peekTimedName()) and null $InteractiveMode =>
+    keyedSystemError("S2GL0015",[name,peekTimedName()])
+  updateTimedName peekTimedName()
+  popTimedName()
+ 
+--% Instrumentation specific to the interpreter
+SETANDFILEQ($oldElapsedSpace, 0)
+SETANDFILEQ($oldElapsedGCTime,0.0)
+SETANDFILEQ($oldElapsedTime,0.0)
+SETANDFILEQ($gcTimeTotal,0.0)
+ 
+-- $timedNameStack is used to hold the names of sections of the
+-- code being timed.
+ 
+SETANDFILEQ($timedNameStack,'(other))
+ 
+SETANDFILEQ($interpreterTimedNames,'(
+-- name         class abbrev
+  (algebra        2 .   B) _
+  (analysis       1 .   A) _
+  (coercion       1 .   C) _
+  (compilation    3 .   T) _
+  (debug          3 .   D) _
+  (evaluation     2 .   E) _
+  (gc             4 .   G) _
+  (history        3 .   H) _
+  (instantiation  3 .   I) _
+  (load           3 .   L) _
+  (modemaps       1 .   M) _
+  (optimization   3 .   Z) _
+  (querycoerce    1 .   Q) _
+  (other          3 .   O) _
+  (diskread       3 .   K) _
+  (print          3 .   P) _
+  (resolve        1 .   R) _
+  ))
+ 
+SETANDFILEQ($interpreterTimedClasses, '(
+-- number class name    short name
+  ( 1    interpreter     .  IN) _
+  ( 2    evaluation      .  EV) _
+  ( 3    other           .  OT) _
+  ( 4    reclaim         .  GC) _
+  ))
+ 
+initializeTimedNames(listofnames,listofclasses) ==
+  for [name,:.] in listofnames repeat
+    PUT(name, 'TimeTotal, 0.0)
+    PUT(name, 'SpaceTotal,  0)
+  for [.,name,:.] in listofclasses repeat
+    PUT( name, 'ClassTimeTotal, 0.0)
+    PUT( name, 'ClassSpaceTotal,  0)
+  $timedNameStack := '(other)
+  computeElapsedTime()
+  PUT('gc, 'TimeTotal, 0.0)
+  PUT('gc, 'SpaceTotal,  0)
+  NIL
+ 
+updateTimedName name ==
+  count := (GETL(name,'TimeTotal) or 0) + computeElapsedTime()
+  PUT(name,'TimeTotal, count) 
+ 
+printNamedStats listofnames ==
+  printNamedStatsByProperty(listofnames, 'TimeTotal)
+  sayBrightly '" "
+  sayBrightly '"Space (in bytes):"
+  printNamedStatsByProperty(listofnames, 'SpaceTotal)
+ 
+makeLongTimeString(listofnames,listofclasses) ==
+  makeLongStatStringByProperty(listofnames, listofclasses,  _
+                               'TimeTotal, 'ClassTimeTotal, _
+                               '"sec", $printTimeIfTrue)
+ 
+makeLongSpaceString(listofnames,listofclasses) ==
+  makeLongStatStringByProperty(listofnames, listofclasses,    _
+                               'SpaceTotal, 'ClassSpaceTotal, _
+                               '"bytes", $printStorageIfTrue)
+ 
+computeElapsedTime() ==
+  -- in total time lists, CAR is VIRTCPU and CADR is TOTCPU
+  currentTime:= elapsedUserTime()
+  currentGCTime:= elapsedGcTime()
+  gcDelta := currentGCTime - $oldElapsedGCTime
+  elapsedSeconds:=
+     -- In CCL total time does not include GC time.
+     $cclSystem => 1.*(currentTime-$oldElapsedTime)/$timerTicksPerSecond
+     1.*(currentTime-$oldElapsedTime-gcDelta)/$timerTicksPerSecond
+  PUT('gc, 'TimeTotal,GETL('gc,'TimeTotal) +
+                   1.*gcDelta/$timerTicksPerSecond)
+  $oldElapsedTime := elapsedUserTime()
+  $oldElapsedGCTime := elapsedGcTime()
+  elapsedSeconds
+ 
+computeElapsedSpace() ==
+  currentElapsedSpace := HEAPELAPSED()
+  elapsedBytes := currentElapsedSpace - $oldElapsedSpace
+  $oldElapsedSpace := currentElapsedSpace
+  elapsedBytes
+ 
+timedAlgebraEvaluation(code) ==
+  startTimingProcess 'algebra
+  r := eval code
+  stopTimingProcess 'algebra
+  r
+ 
+timedOptimization(code) ==
+  startTimingProcess 'optimization
+  $getDomainCode : local := NIL
+  r := lispize code
+  if $reportOptimization then
+    sayBrightlyI bright '"Optimized LISP code:"
+    pp r
+  stopTimingProcess 'optimization
+  r
+ 
+timedEVALFUN(code) ==
+  startTimingProcess 'evaluation
+  r := timedEvaluate code
+  stopTimingProcess 'evaluation
+  r
+ 
+timedEvaluate code ==
+  code is ["LIST",:a] and #a > 200 =>
+    "append"/[eval ["LIST",:x] for x in splitIntoBlocksOf200 a]
+  eval code
+ 
+displayHeapStatsIfWanted() ==
+   $printStorageIfTrue => sayBrightly OLDHEAPSTATS()
+ 
+--EVALANDFILEACTQ(
+--  PUTGCEXIT function displayHeapStatsIfWanted )
+ 
+--% stubs for the stats summary fns
+statRecordInstantiationEvent() == nil
+statRecordLoadEvent()          == nil
+ 
+statisticsSummary()  == '"No statistics available."
+@
+\eject
+\begin{thebibliography}{99}
+\bibitem{1} nothing
+\end{thebibliography}
+\end{document}