diff --git a/changelog b/changelog index 85b2081..a7720e6 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,7 @@ +20090816 tpd src/axiom-website/patches.html 20090816.07.tpd.patch +20090816 tpd src/interp/Makefile move g-timer.boot to g-timer.lisp +20090816 tpd src/interp/g-timer.lisp added, rewritten from g-timer.boot +20090816 tpd src/interp/g-timer.boot removed, rewritten to g-timer.lisp 20090816 tpd src/axiom-website/patches.html 20090816.06.tpd.patch 20090816 tpd src/interp/Makefile move g-opt.boot to g-opt.lisp 20090816 tpd src/interp/g-opt.lisp added, rewritten from g-opt.boot diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 3ced185..1fbc068 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -1808,6 +1808,8 @@ Makefile change make assignments from = to :=
g-error.lisp rewrite from boot to lisp
20090816.06.tpd.patch g-opt.lisp rewrite from boot to lisp
+20090816.07.tpd.patch +g-timer.lisp rewrite from boot to lisp
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index 2e32af0..2c3e81d 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -424,7 +424,6 @@ DOCFILES=${DOC}/as.boot.dvi \ ${DOC}/foam_l.lisp.dvi \ ${DOC}/fortcall.boot.dvi \ ${DOC}/functor.boot.dvi \ - ${DOC}/g-timer.boot.dvi \ ${DOC}/g-util.boot.dvi ${DOC}/hashcode.boot.dvi \ ${DOC}/htcheck.boot.dvi \ ${DOC}/ht-util.boot.dvi \ @@ -2974,46 +2973,26 @@ ${MID}/g-opt.lisp: ${IN}/g-opt.lisp.pamphlet @ -\subsection{g-timer.boot} +\subsection{g-timer.lisp} <>= -${OUT}/g-timer.${O}: ${MID}/g-timer.clisp - @ echo 269 making ${OUT}/g-timer.${O} from ${MID}/g-timer.clisp - @ (cd ${MID} ; \ +${OUT}/g-timer.${O}: ${MID}/g-timer.lisp + @ echo 136 making ${OUT}/g-timer.${O} from ${MID}/g-timer.lisp + @ ( cd ${MID} ; \ if [ -z "${NOISE}" ] ; then \ - echo '(progn (compile-file "${MID}/g-timer.clisp"' \ + echo '(progn (compile-file "${MID}/g-timer.lisp"' \ ':output-file "${OUT}/g-timer.${O}") (${BYE}))' | ${DEPSYS} ; \ else \ - echo '(progn (compile-file "${MID}/g-timer.clisp"' \ + echo '(progn (compile-file "${MID}/g-timer.lisp"' \ ':output-file "${OUT}/g-timer.${O}") (${BYE}))' | ${DEPSYS} \ >${TMP}/trace ; \ fi ) @ -<>= -${MID}/g-timer.clisp: ${IN}/g-timer.boot.pamphlet - @ echo 270 making ${MID}/g-timer.clisp from ${IN}/g-timer.boot.pamphlet +<>= +${MID}/g-timer.lisp: ${IN}/g-timer.lisp.pamphlet + @ echo 137 making ${MID}/g-timer.lisp from ${IN}/g-timer.lisp.pamphlet @ (cd ${MID} ; \ - ${TANGLE} ${IN}/g-timer.boot.pamphlet >g-timer.boot ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (boottran::boottocl "g-timer.boot") (${BYE}))' \ - | ${DEPSYS} ; \ - else \ - echo '(progn (boottran::boottocl "g-timer.boot") (${BYE}))' \ - | ${DEPSYS} >${TMP}/trace ; \ - fi ; \ - rm g-timer.boot ) - -@ -<>= -${DOC}/g-timer.boot.dvi: ${IN}/g-timer.boot.pamphlet - @echo 271 making ${DOC}/g-timer.boot.dvi \ - from ${IN}/g-timer.boot.pamphlet - @(cd ${DOC} ; \ - cp ${IN}/g-timer.boot.pamphlet ${DOC} ; \ - ${DOCUMENT} ${NOISE} g-timer.boot ; \ - rm -f ${DOC}/g-timer.boot.pamphlet ; \ - rm -f ${DOC}/g-timer.boot.tex ; \ - rm -f ${DOC}/g-timer.boot ) + ${TANGLE} ${IN}/g-timer.lisp.pamphlet >g-timer.lisp ) @ @@ -6675,8 +6654,7 @@ clean: <> <> -<> -<> +<> <> <> diff --git a/src/interp/g-timer.boot.pamphlet b/src/interp/g-timer.boot.pamphlet deleted file mode 100644 index fdfe1a2..0000000 --- a/src/interp/g-timer.boot.pamphlet +++ /dev/null @@ -1,292 +0,0 @@ -\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} -<>= --- 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. - -@ -<<*>>= -<> - ---% 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 := +/[GET(name,property) for [name,:.] in listofnames] - for [name,:.] in listofnames repeat - n := GET(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 := GET('other, property) - for [name,class,:ab] in listofnames repeat - name = 'other => 'iterate - cl := CAR LASSOC(class,listofclasses) - n := GET( name, property) - PUT(cl,classproperty, n + GET(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 + GET(cl,classproperty)) - if flag ^= 'long then - total := 0 - str := '"" - for [class,name,:ab] in listofclasses repeat - n := GET(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 := (GET(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,GET('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} diff --git a/src/interp/g-timer.lisp.pamphlet b/src/interp/g-timer.lisp.pamphlet new file mode 100644 index 0000000..834d39a --- /dev/null +++ b/src/interp/g-timer.lisp.pamphlet @@ -0,0 +1,686 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp g-timer.lisp} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +<<*>>= + +(IN-PACKAGE "BOOT" ) + +;--% 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 := +/[GET(name,property) for [name,:.] in listofnames] +; for [name,:.] in listofnames repeat +; n := GET(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) + +(DEFUN |printNamedStatsByProperty| (|listofnames| |property|) + (PROG (|total| |name| |n| |strname| |strval|) + (RETURN + (SEQ + (PROGN + (SPADLET |total| + (PROG (#0=#:G166065) + (SPADLET #0# 0) + (RETURN + (DO ((#1=#:G166071 |listofnames| (CDR #1#)) (#2=#:G166057 NIL)) + ((OR (ATOM #1#) + (PROGN (SETQ #2# (CAR #1#)) NIL) + (PROGN (PROGN (SPADLET |name| (CAR #2#)) #2#) NIL)) #0#) + (SEQ (EXIT (SETQ #0# (PLUS #0# (GETL |name| |property|))))))))) + (DO ((#3=#:G166086 |listofnames| (CDR #3#)) (#4=#:G166061 NIL)) + ((OR (ATOM #3#) + (PROGN (SETQ #4# (CAR #3#)) NIL) + (PROGN (PROGN (SPADLET |name| (CAR #4#)) #4#) NIL)) + NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |n| (GETL |name| |property|)) + (SPADLET |strname| (STRINGIMAGE |name|)) + (SPADLET |strval| (STRINGIMAGE |n|)) + (|sayBrightly| + (|concat| + (|bright| |strname|) + (|fillerSpaces| + (SPADDIFFERENCE (SPADDIFFERENCE 70 (|#| |strname|)) (|#| |strval|)) (MAKESTRING ".")) + (|bright| |strval|))))))) + (|sayBrightly| (|bright| (|fillerSpaces| 72 (MAKESTRING "-")))) + (|sayBrightly| + (|concat| + (|bright| "Total") + (|fillerSpaces| (SPADDIFFERENCE 65 (|#| (STRINGIMAGE |total|))) ".") + (|bright| (STRINGIMAGE |total|))))))))) + +; +;makeLongStatStringByProperty _ +; (listofnames, listofclasses, property, classproperty, units, flag) == +; total := 0 +; str := '"" +; otherStatTotal := GET('other, property) +; for [name,class,:ab] in listofnames repeat +; name = 'other => 'iterate +; cl := CAR LASSOC(class,listofclasses) +; n := GET( name, property) +; PUT(cl,classproperty, n + GET(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 + GET(cl,classproperty)) +; if flag ^= 'long then +; total := 0 +; str := '"" +; for [class,name,:ab] in listofclasses repeat +; n := GET(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) + +(DEFUN |makeLongStatStringByProperty| + (|listofnames| |listofclasses| |property| |classproperty| |units| |flag|) + (PROG (|otherStatTotal| |cl| |class| |name| |ab| |n| |timestr| |str| |total|) + (RETURN + (SEQ + (PROGN + (SPADLET |total| 0) + (SPADLET |str| (MAKESTRING "")) + (SPADLET |otherStatTotal| (GETL (QUOTE |other|) |property|)) + (DO ((#0=#:G166123 |listofnames| (CDR #0#)) (#1=#:G166105 NIL)) + ((OR (ATOM #0#) + (PROGN (SETQ #1# (CAR #0#)) NIL) + (PROGN + (PROGN + (SPADLET |name| (CAR #1#)) + (SPADLET |class| (CADR #1#)) + (SPADLET |ab| (CDDR #1#)) + #1#) + NIL)) + NIL) + (SEQ + (EXIT + (COND + ((BOOT-EQUAL |name| (QUOTE |other|)) (QUOTE |iterate|)) + ((QUOTE T) + (SPADLET |cl| (CAR (LASSOC |class| |listofclasses|))) + (SPADLET |n| (GETL |name| |property|)) + (PUT |cl| |classproperty| (PLUS |n| (GETL |cl| |classproperty|))) + (SPADLET |total| (PLUS |total| |n|)) + (COND + ((>= |n| 0.01) + (SPADLET |timestr| (|normalizeStatAndStringify| |n|))) + ((QUOTE T) + (SPADLET |timestr| (MAKESTRING "")) + (SPADLET |otherStatTotal| (PLUS |otherStatTotal| |n|)))) + (SPADLET |str| (|makeStatString| |str| |timestr| |ab| |flag|))))))) + (SPADLET |otherStatTotal| |otherStatTotal|) + (PUT (QUOTE |other|) |property| |otherStatTotal|) + (COND + ((> |otherStatTotal| 0) + (SPADLET |str| + (|makeStatString| |str| + (|normalizeStatAndStringify| |otherStatTotal|) (QUOTE O) |flag|)) + (SPADLET |total| (PLUS |total| |otherStatTotal|)) + (SPADLET |cl| (CAR (LASSOC (QUOTE |other|) |listofnames|))) + (SPADLET |cl| (CAR (LASSOC |cl| |listofclasses|))) + (PUT |cl| |classproperty| + (PLUS |otherStatTotal| (GETL |cl| |classproperty|))))) + (COND + ((NEQUAL |flag| (QUOTE |long|)) + (SPADLET |total| 0) + (SPADLET |str| (MAKESTRING "")) + (DO ((#2=#:G166136 |listofclasses| (CDR #2#)) (#3=#:G166112 NIL)) + ((OR (ATOM #2#) + (PROGN (SETQ #3# (CAR #2#)) NIL) + (PROGN + (PROGN + (SPADLET |class| (CAR #3#)) + (SPADLET |name| (CADR #3#)) + (SPADLET |ab| (CDDR #3#)) + #3#) + NIL)) + NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |n| (GETL |name| |classproperty|)) + (COND + ((BOOT-EQUAL |n| 0.0) (QUOTE |iterate|)) + ((QUOTE T) + (SPADLET |total| (PLUS |total| |n|)) + (SPADLET |timestr| (|normalizeStatAndStringify| |n|)) + (SPADLET |str| + (|makeStatString| |str| |timestr| |ab| |flag|)))))))))) + (SPADLET |total| + (STRCONC (|normalizeStatAndStringify| |total|) " " |units|)) + (COND + ((BOOT-EQUAL |str| (MAKESTRING "")) |total|) + ((QUOTE T) (STRCONC |str| (MAKESTRING " = ") |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 + +(DEFUN |normalizeStatAndStringify| (|t|) + (PROG (K M) + (RETURN + (COND + ((RNUMP |t|) + (SPADLET |t| (|roundStat| |t|)) + (COND + ((BOOT-EQUAL |t| 0.0) (MAKESTRING "0")) + ((QUOTE T) (FORMAT NIL (MAKESTRING "~,2F") |t|)))) + ((INTP |t|) + (SPADLET K 1024) + (SPADLET M (TIMES K K)) + (COND + ((> |t| (TIMES 9 M)) + (CONCAT + (STRINGIMAGE (QUOTIENT (PLUS |t| (TIMES 512 K)) M)) + (MAKESTRING "M"))) + ((> |t| (TIMES 9 K)) + (CONCAT (STRINGIMAGE (QUOTIENT (PLUS |t| 512) K)) (MAKESTRING "K"))) + ((QUOTE T) (STRINGIMAGE |t|)))) + ((QUOTE T) (STRINGIMAGE |t|)))))) + +; +;significantStat t == +; RNUMP t => (t > 0.01) +; INTP t => (t > 100) +; true + +(DEFUN |significantStat| (|t|) + (COND + ((RNUMP |t|) (> |t| 0.01)) + ((INTP |t|) (> |t| 100)) + ((QUOTE T) (QUOTE T)))) +; +;roundStat t == +; not RNUMP t => t +; (FIX (0.5 + t * 1000.0)) / 1000.0 + +(DEFUN |roundStat| (|t|) + (COND + ((NULL (RNUMP |t|)) |t|) + ((QUOTE T) (QUOTIENT (FIX (PLUS 0.5 (TIMES |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,'")") + +(DEFUN |makeStatString| (|oldstr| |time| |abb| |flag|) + (PROG (|opening|) + (RETURN + (COND + ((BOOT-EQUAL |time| (MAKESTRING "")) |oldstr|) + ((QUOTE T) + (SPADLET |opening| + (COND + ((BOOT-EQUAL |flag| (QUOTE |long|)) (MAKESTRING "(")) + ((QUOTE T) (MAKESTRING " (")))) + (COND + ((BOOT-EQUAL |oldstr| (MAKESTRING "")) + (STRCONC |time| |opening| |abb| (MAKESTRING ")"))) + ((QUOTE T) + (STRCONC + |oldstr| + (MAKESTRING " + ") + |time| + |opening| + |abb| + (MAKESTRING ")"))))))))) + +; +;peekTimedName() == IFCAR $timedNameStack + +(DEFUN |peekTimedName| NIL (IFCAR |$timedNameStack|)) + +; +;popTimedName() == +; name := IFCAR $timedNameStack +; $timedNameStack := IFCDR $timedNameStack +; name + +(DEFUN |popTimedName| () + (PROG (|name|) + (RETURN + (PROGN + (SPADLET |name| (IFCAR |$timedNameStack|)) + (SPADLET |$timedNameStack| (IFCDR |$timedNameStack|)) + |name|)))) + +; +;pushTimedName name == +; PUSH(name,$timedNameStack) + +(DEFUN |pushTimedName| (|name|) (PUSH |name| |$timedNameStack|)) + +; +;--currentlyTimedName() == CAR $timedNameStack +; +;startTimingProcess name == +; updateTimedName peekTimedName() +; pushTimedName name +; if EQ(name, 'load) then statRecordLoadEvent() + +(DEFUN |startTimingProcess| (|name|) + (PROGN + (|updateTimedName| (|peekTimedName|)) + (|pushTimedName| |name|) + (COND + ((EQ |name| (QUOTE |load|)) (|statRecordLoadEvent|)) + ((QUOTE T) NIL)))) + +; +;stopTimingProcess name == +; (name ^= peekTimedName()) and null $InteractiveMode => +; keyedSystemError("S2GL0015",[name,peekTimedName()]) +; updateTimedName peekTimedName() +; popTimedName() + +(DEFUN |stopTimingProcess| (|name|) + (COND + ((AND (NEQUAL |name| (|peekTimedName|)) (NULL |$InteractiveMode|)) + (|keyedSystemError| 'S2GL0015 (CONS |name| (CONS (|peekTimedName|) NIL)))) + ((QUOTE T) (|updateTimedName| (|peekTimedName|)) (|popTimedName|)))) + +; +;--% Instrumentation specific to the interpreter +;SETANDFILEQ($oldElapsedSpace, 0) + +(SETANDFILEQ |$oldElapsedSpace| 0) + +;SETANDFILEQ($oldElapsedGCTime,0.0) + +(SETANDFILEQ |$oldElapsedGCTime| 0.0) + +;SETANDFILEQ($oldElapsedTime,0.0) + +(SETANDFILEQ |$oldElapsedTime| 0.0) + +;SETANDFILEQ($gcTimeTotal,0.0) + +(SETANDFILEQ |$gcTimeTotal| 0.0) + +; +;-- $timedNameStack is used to hold the names of sections of the +;-- code being timed. +; +;SETANDFILEQ($timedNameStack,'(other)) + +(SETANDFILEQ |$timedNameStack| (QUOTE (|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 |$interpreterTimedNames| + (QUOTE + ((|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) _ +; )) + +(SETANDFILEQ |$interpreterTimedClasses| + (QUOTE + ((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 + +(DEFUN |initializeTimedNames| (|listofnames| |listofclasses|) + (PROG (|name|) + (RETURN + (SEQ + (PROGN + (DO ((#0=#:G166232 |listofnames| (CDR #0#)) (#1=#:G166218 NIL)) + ((OR (ATOM #0#) + (PROGN (SETQ #1# (CAR #0#)) NIL) + (PROGN (PROGN (SPADLET |name| (CAR #1#)) #1#) NIL)) + NIL) + (SEQ + (EXIT + (PROGN + (PUT |name| (QUOTE |TimeTotal|) 0.0) + (PUT |name| (QUOTE |SpaceTotal|) 0))))) + (DO ((#2=#:G166245 |listofclasses| (CDR #2#)) (#3=#:G166222 NIL)) + ((OR (ATOM #2#) + (PROGN (SETQ #3# (CAR #2#)) NIL) + (PROGN (PROGN (SPADLET |name| (CADR #3#)) #3#) NIL)) + NIL) + (SEQ + (EXIT + (PROGN + (PUT |name| (QUOTE |ClassTimeTotal|) 0.0) + (PUT |name| (QUOTE |ClassSpaceTotal|) 0))))) + (SPADLET |$timedNameStack| (QUOTE (|other|))) + (|computeElapsedTime|) + (PUT (QUOTE |gc|) (QUOTE |TimeTotal|) 0.0) + (PUT (QUOTE |gc|) (QUOTE |SpaceTotal|) 0) + NIL))))) + +; +;updateTimedName name == +; count := (GET(name,'TimeTotal) or 0) + computeElapsedTime() +; PUT(name,'TimeTotal, count) + +(DEFUN |updateTimedName| (|name|) + (PROG (|count|) + (RETURN + (PROGN + (SPADLET |count| + (PLUS (OR (GETL |name| (QUOTE |TimeTotal|)) 0) (|computeElapsedTime|))) + (PUT |name| (QUOTE |TimeTotal|) |count|))))) +; +;printNamedStats listofnames == +; printNamedStatsByProperty(listofnames, 'TimeTotal) +; sayBrightly '" " +; sayBrightly '"Space (in bytes):" +; printNamedStatsByProperty(listofnames, 'SpaceTotal) + +(DEFUN |printNamedStats| (|listofnames|) + (PROGN + (|printNamedStatsByProperty| |listofnames| (QUOTE |TimeTotal|)) + (|sayBrightly| (MAKESTRING " ")) + (|sayBrightly| (MAKESTRING "Space (in bytes):")) + (|printNamedStatsByProperty| |listofnames| (QUOTE |SpaceTotal|)))) + +; +;makeLongTimeString(listofnames,listofclasses) == +; makeLongStatStringByProperty(listofnames, listofclasses, _ +; 'TimeTotal, 'ClassTimeTotal, _ +; '"sec", $printTimeIfTrue) + +(DEFUN |makeLongTimeString| (|listofnames| |listofclasses|) + (|makeLongStatStringByProperty| + |listofnames| + |listofclasses| + (QUOTE |TimeTotal|) + (QUOTE |ClassTimeTotal|) + (MAKESTRING "sec") + |$printTimeIfTrue|)) + +; +;makeLongSpaceString(listofnames,listofclasses) == +; makeLongStatStringByProperty(listofnames, listofclasses, _ +; 'SpaceTotal, 'ClassSpaceTotal, _ +; '"bytes", $printStorageIfTrue) + +(DEFUN |makeLongSpaceString| (|listofnames| |listofclasses|) + (|makeLongStatStringByProperty| + |listofnames| + |listofclasses| + (QUOTE |SpaceTotal|) + (QUOTE |ClassSpaceTotal|) + (MAKESTRING "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,GET('gc,'TimeTotal) + +; 1.*gcDelta/$timerTicksPerSecond) +; $oldElapsedTime := elapsedUserTime() +; $oldElapsedGCTime := elapsedGcTime() +; elapsedSeconds + +(DEFUN |computeElapsedTime| () + (PROG (|currentTime| |currentGCTime| |gcDelta| |elapsedSeconds|) + (RETURN + (PROGN + (SPADLET |currentTime| (|elapsedUserTime|)) + (SPADLET |currentGCTime| (|elapsedGcTime|)) + (SPADLET |gcDelta| (SPADDIFFERENCE |currentGCTime| |$oldElapsedGCTime|)) + (SPADLET |elapsedSeconds| + (COND + (|$cclSystem| + (QUOTIENT + (TIMES 1.0 (SPADDIFFERENCE |currentTime| |$oldElapsedTime|)) + |$timerTicksPerSecond|)) + ((QUOTE T) + (QUOTIENT + (TIMES 1.0 + (SPADDIFFERENCE + (SPADDIFFERENCE |currentTime| |$oldElapsedTime|) |gcDelta|)) + |$timerTicksPerSecond|)))) + (PUT (QUOTE |gc|) (QUOTE |TimeTotal|) + (PLUS + (GETL (QUOTE |gc|) (QUOTE |TimeTotal|)) + (QUOTIENT (TIMES 1.0 |gcDelta|) |$timerTicksPerSecond|))) + (SPADLET |$oldElapsedTime| (|elapsedUserTime|)) + (SPADLET |$oldElapsedGCTime| (|elapsedGcTime|)) + |elapsedSeconds|)))) + +; +;computeElapsedSpace() == +; currentElapsedSpace := HEAPELAPSED() +; elapsedBytes := currentElapsedSpace - $oldElapsedSpace +; $oldElapsedSpace := currentElapsedSpace +; elapsedBytes + +(DEFUN |computeElapsedSpace| () + (PROG (|currentElapsedSpace| |elapsedBytes|) + (RETURN + (PROGN + (SPADLET |currentElapsedSpace| (HEAPELAPSED)) + (SPADLET |elapsedBytes| + (SPADDIFFERENCE |currentElapsedSpace| |$oldElapsedSpace|)) + (SPADLET |$oldElapsedSpace| |currentElapsedSpace|) + |elapsedBytes|)))) + +; +;timedAlgebraEvaluation(code) == +; startTimingProcess 'algebra +; r := eval code +; stopTimingProcess 'algebra +; r + +(DEFUN |timedAlgebraEvaluation| (|code|) + (PROG (|r|) + (RETURN + (PROGN + (|startTimingProcess| (QUOTE |algebra|)) + (SPADLET |r| (|eval| |code|)) + (|stopTimingProcess| (QUOTE |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 + +(DEFUN |timedOptimization| (|code|) + (PROG (|$getDomainCode| |r|) + (DECLARE (SPECIAL |$getDomainCode|)) + (RETURN + (PROGN + (|startTimingProcess| (QUOTE |optimization|)) + (SPADLET |$getDomainCode| NIL) + (SPADLET |r| (|lispize| |code|)) + (COND + (|$reportOptimization| + (|sayBrightlyI| (|bright| "Optimized LISP code:")) (|pp| |r|))) + (|stopTimingProcess| (QUOTE |optimization|)) |r|)))) + +; +;timedEVALFUN(code) == +; startTimingProcess 'evaluation +; r := timedEvaluate code +; stopTimingProcess 'evaluation +; r + +(DEFUN |timedEVALFUN| (|code|) + (PROG (|r|) + (RETURN + (PROGN + (|startTimingProcess| (QUOTE |evaluation|)) + (SPADLET |r| (|timedEvaluate| |code|)) + (|stopTimingProcess| (QUOTE |evaluation|)) + |r|)))) + +; +;timedEvaluate code == +; code is ["LIST",:a] and #a > 200 => +; "append"/[eval ["LIST",:x] for x in splitIntoBlocksOf200 a] +; eval code + +(DEFUN |timedEvaluate| (|code|) + (PROG (|a|) + (RETURN + (SEQ + (COND + ((AND (PAIRP |code|) + (EQ (QCAR |code|) (QUOTE LIST)) + (PROGN (SPADLET |a| (QCDR |code|)) (QUOTE T)) + (> (|#| |a|) 200)) + (PROG (#0=#:G166311) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G166316 (|splitIntoBlocksOf200| |a|) (CDR #1#)) (|x| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |x| (CAR #1#)) NIL)) #0#) + (SEQ + (EXIT (SETQ #0# (APPEND #0# (|eval| (CONS (QUOTE LIST) |x|)))))))))) + ((QUOTE T) (|eval| |code|))))))) + +; +;displayHeapStatsIfWanted() == +; $printStorageIfTrue => sayBrightly OLDHEAPSTATS() + +(DEFUN |displayHeapStatsIfWanted| () + (SEQ + (COND (|$printStorageIfTrue| (EXIT (|sayBrightly| (OLDHEAPSTATS))))))) + +; +;--EVALANDFILEACTQ( +;-- PUTGCEXIT function displayHeapStatsIfWanted ) +; +;--% stubs for the stats summary fns +;statRecordInstantiationEvent() == nil + +(DEFUN |statRecordInstantiationEvent| () NIL) + +;statRecordLoadEvent() == nil + +(DEFUN |statRecordLoadEvent| () NIL) + +; +;statisticsSummary() == '"No statistics available." + +(DEFUN |statisticsSummary| () (MAKESTRING "No statistics available.")) + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document}