add merge in Ron's 11/21/2020 lispcore
This commit is contained in:
Larry Masinter
84
CLTL2/TIME
Normal file
84
CLTL2/TIME
Normal file
@@ -0,0 +1,84 @@
|
||||
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "LISP")
|
||||
(IL:FILECREATED "22-May-91 09:08:00" IL:|{DSK}<new>sources>lispcore>sources>TIME.;2| 11273
|
||||
|
||||
IL:|previous| IL:|date:| "17-May-90 15:51:58" IL:|{DSK}<new>sources>lispcore>sources>TIME.;1|
|
||||
)
|
||||
|
||||
|
||||
; Copyright (c) 1986, 1987, 1988, 1990, 1991 by Venue & Xerox Corporation. All rights reserved.
|
||||
|
||||
(IL:PRETTYCOMPRINT IL:TIMECOMS)
|
||||
|
||||
(IL:RPAQQ IL:TIMECOMS ((IL:STRUCTURES STATS-OBJECT) (IL:FUNCTIONS %COPY-TIME-STATS %STATS-OBJECT-DIFFERENCE) (IL:FUNCTIONS %GET-TIMING-INFO TIME-CALL TIME) (IL:FUNCTIONS %CAPTURE-COUNTERS-BEFORE %CAPTURE-COUNTERS-AFTER TIME-FORMAT %PRINT-TIMING-ITEM %PRINT-TIMING-INFO) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FUNCTIONS %CAPTURE-BEFORE-STATS %CAPTURE-AFTER-STATS %MOVE-FIXP-FIELD)) (IL:SPECIAL-FORMS TIME) (IL:COMMANDS "TIME") (IL:* IL:|;;| "Interlisp Timeall function") (IL:FNS IL:TIMEALL) (IL:* IL:|;;| "file package stuff") (IL:PROP IL:FILETYPE TIME) (IL:PROP IL:MAKEFILE-ENVIRONMENT TIME) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY (IL:LOCALVARS . T)) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS (IL:ADDVARS (IL:NLAMA) (IL:NLAML IL:TIMEALL) (IL:LAMA)))))
|
||||
|
||||
(DEFSTRUCT (STATS-OBJECT (:TYPE LIST) (:COPIER NIL) (:PREDICATE NIL)) (ELAPSED-TIME (IL:CLOCK 0)) (TIME-BLOCK (IL:|create| IL:MISCSTATS)) (DATA-COUNTERS (MAKE-ARRAY (1+ IL:|\\MaxTypeNumber|) :ELEMENT-TYPE (QUOTE (SIGNED-BYTE 32)) :INITIAL-ELEMENT 0)) DATATYPES)
|
||||
|
||||
(DEFUN %COPY-TIME-STATS (REFERENCE-BLOCK DESTINATION-BLOCK) (IL:* IL:|;;| "Copies various fields from one miscstats block to another. Both reference-block and destination-block should be unboxed hunks (made by (IL:create IL:miscstats)), but IL:\\\\miscstats is also a valid value for reference-block") (%MOVE-FIXP-FIELD (IL:MISCSTATS IL:SWAPWAITTIME) DESTINATION-BLOCK REFERENCE-BLOCK) (%MOVE-FIXP-FIELD (IL:MISCSTATS IL:GCTIME) DESTINATION-BLOCK REFERENCE-BLOCK) (%MOVE-FIXP-FIELD (IL:MISCSTATS IL:PAGEFAULTS) DESTINATION-BLOCK REFERENCE-BLOCK) (%MOVE-FIXP-FIELD (IL:MISCSTATS IL:SWAPWRITES) DESTINATION-BLOCK REFERENCE-BLOCK) (%MOVE-FIXP-FIELD (IL:MISCSTATS IL:TOTALTIME) DESTINATION-BLOCK REFERENCE-BLOCK) (%MOVE-FIXP-FIELD (IL:MISCSTATS IL:DISKIOTIME) DESTINATION-BLOCK REFERENCE-BLOCK) (%MOVE-FIXP-FIELD (IL:MISCSTATS IL:NETIOTIME) DESTINATION-BLOCK REFERENCE-BLOCK) (%MOVE-FIXP-FIELD (IL:MISCSTATS IL:DISKOPS) DESTINATION-BLOCK REFERENCE-BLOCK) DESTINATION-BLOCK)
|
||||
|
||||
(DEFUN %STATS-OBJECT-DIFFERENCE (BEFORE AFTER) (IL:* IL:|;;| "puts the differences between the stat-object after and stat-object before back into after.") (LET ((BEFORE-DATA-COUNTERS (STATS-OBJECT-DATA-COUNTERS BEFORE)) (BEFORE-TIME-BLOCK (STATS-OBJECT-TIME-BLOCK BEFORE)) (AFTER-DATA-COUNTERS (STATS-OBJECT-DATA-COUNTERS AFTER)) (AFTER-TIME-BLOCK (STATS-OBJECT-TIME-BLOCK AFTER))) (DOTIMES (I (LENGTH BEFORE-DATA-COUNTERS)) (DECF (AREF AFTER-DATA-COUNTERS I) (AREF BEFORE-DATA-COUNTERS I))) (DECF (STATS-OBJECT-ELAPSED-TIME AFTER) (STATS-OBJECT-ELAPSED-TIME BEFORE)) (DECF (IL:|fetch| (IL:MISCSTATS IL:SWAPWAITTIME) IL:|of| AFTER-TIME-BLOCK) (IL:|fetch| (IL:MISCSTATS IL:SWAPWAITTIME) IL:|of| BEFORE-TIME-BLOCK)) (DECF (IL:|fetch| (IL:MISCSTATS IL:GCTIME) IL:|of| AFTER-TIME-BLOCK) (IL:|fetch| (IL:MISCSTATS IL:GCTIME) IL:|of| BEFORE-TIME-BLOCK)) (DECF (IL:|fetch| (IL:MISCSTATS IL:DISKIOTIME) IL:|of| AFTER-TIME-BLOCK) (IL:|fetch| (IL:MISCSTATS IL:DISKIOTIME) IL:|of| BEFORE-TIME-BLOCK)) (DECF (IL:|fetch| (IL:MISCSTATS IL:PAGEFAULTS) IL:|of| AFTER-TIME-BLOCK) (IL:|fetch| (IL:MISCSTATS IL:PAGEFAULTS) IL:|of| BEFORE-TIME-BLOCK)) (DECF (IL:|fetch| (IL:MISCSTATS IL:SWAPWRITES) IL:|of| AFTER-TIME-BLOCK) (IL:|fetch| (IL:MISCSTATS IL:SWAPWRITES) IL:|of| BEFORE-TIME-BLOCK)) (DECF (IL:|fetch| (IL:MISCSTATS IL:DISKOPS) IL:|of| AFTER-TIME-BLOCK) (IL:|fetch| (IL:MISCSTATS IL:DISKOPS) IL:|of| BEFORE-TIME-BLOCK)) AFTER))
|
||||
|
||||
(DEFUN %GET-TIMING-INFO (TIMED-FUNCTION TIME-BEFORE TIME-AFTER &OPTIONAL (REPEAT 1)) (IL:* IL:|;;| "Side-effects TIME-BEFORE and TIME-AFTER. Returns the value (or values of TIMED-FUNCTION, and the timing-info in TIME-AFTER.") (LET ((VALUES NIL)) (%CAPTURE-BEFORE-STATS TIME-BEFORE) (DOTIMES (I (1- REPEAT)) (FUNCALL TIMED-FUNCTION)) (SETQ VALUES (MULTIPLE-VALUE-LIST (FUNCALL TIMED-FUNCTION))) (%CAPTURE-AFTER-STATS TIME-AFTER) (%STATS-OBJECT-DIFFERENCE TIME-BEFORE TIME-AFTER) (VALUES-LIST VALUES)))
|
||||
|
||||
(DEFUN TIME-CALL (TIMED-FUNCTION &KEY (OUTPUT *TRACE-OUTPUT*) (TIMED-FORM NIL TIMED-FORM-P) (DATA-TYPES (IL:DATATYPES)) (REPEAT 1)) (LET ((VALUES NIL) (TIME-BEFORE (MAKE-STATS-OBJECT)) (TIME-AFTER (MAKE-STATS-OBJECT)) (TIME-DO-NOTHING (MAKE-STATS-OBJECT))) (IL:* IL:|;;| "Calibrate") (%GET-TIMING-INFO (FUNCTION (LAMBDA NIL NIL)) TIME-BEFORE TIME-DO-NOTHING) (SETQ VALUES (MULTIPLE-VALUE-LIST (%GET-TIMING-INFO TIMED-FUNCTION TIME-BEFORE TIME-AFTER REPEAT))) (%STATS-OBJECT-DIFFERENCE TIME-DO-NOTHING TIME-AFTER) (IF TIMED-FORM-P (TIME-FORMAT OUTPUT "Timing for ~[~;~:;~:* ~D x~]:~20T ~S~&" REPEAT TIMED-FORM)) (%PRINT-TIMING-ITEM OUTPUT "Elapsed time" (STATS-OBJECT-ELAPSED-TIME TIME-AFTER) T T) (%PRINT-TIMING-INFO OUTPUT TIME-AFTER DATA-TYPES) (VALUES-LIST VALUES)))
|
||||
|
||||
(DEFMACRO TIME (TIMED-FORM &REST KEYWORDS) (IL:BQUOTE (TIME-CALL (FUNCTION (LAMBDA NIL (IL:\\\, TIMED-FORM))) :TIMED-FORM (QUOTE (IL:\\\, TIMED-FORM)) (IL:\\\,@ KEYWORDS))))
|
||||
|
||||
(DEFUN %CAPTURE-COUNTERS-BEFORE (VECTOR) (IL:* IL:|;;| "Record box count for all known datatypes before timing. Note, IL:BOXCOUNT may create fixp's, so count down, so the FIXP count is recorded last") (DO ((I (1- (LENGTH VECTOR)) (1- I))) ((< I 0) VECTOR) (SETF (AREF VECTOR I) (IL:BOXCOUNT I))))
|
||||
|
||||
(DEFUN %CAPTURE-COUNTERS-AFTER (VECTOR) (IL:* IL:|;;| "Record box count for all known datatypes after timing. Note, IL:BOXCOUNT may create fixp's, so count up, so the FIXP count is recorded first") (DOTIMES (I (LENGTH VECTOR) VECTOR) (SETF (AREF VECTOR I) (IL:BOXCOUNT I))))
|
||||
|
||||
(DEFUN TIME-FORMAT (STREAM FORMAT-STRING &REST ARGS) (IF (EQ STREAM :EXEC) (APPLY (QUOTE XCL:EXEC-FORMAT) FORMAT-STRING ARGS) (APPLY (QUOTE FORMAT) STREAM FORMAT-STRING ARGS)))
|
||||
|
||||
(DEFUN %PRINT-TIMING-ITEM (STREAM STRING NUM TIME-P ALWAYS-P) (IF (OR ALWAYS-P (> NUM 0)) (IF TIME-P (TIME-FORMAT STREAM "~&~A ~20,5T= ~9,3F seconds~&" STRING (MAX 0 (/ NUM 1000.0))) (TIME-FORMAT STREAM "~&~A ~20,5T= ~9D~&" STRING NUM))))
|
||||
|
||||
(DEFUN %PRINT-TIMING-INFO (STREAM STATS-OBJECT DATA-TYPES) (LET ((TIME-BLOCK (STATS-OBJECT-TIME-BLOCK STATS-OBJECT)) (DATA-TYPE-INFO (LET ((DATA-COUNTER (STATS-OBJECT-DATA-COUNTERS STATS-OBJECT)) (RESULT NIL) (RESULT-TAIL NIL) CNT TYPE-NAME) (DOTIMES (I (MIN (LENGTH DATA-COUNTER) (1+ IL:|\\MaxTypeNumber|)) RESULT) (SETQ CNT (AREF DATA-COUNTER I)) (WHEN (> CNT 0) (SETQ TYPE-NAME (IL:\\TYPENAMEFROMNUMBER I)) (IF (MEMBER TYPE-NAME DATA-TYPES :TEST (FUNCTION EQ)) (IF RESULT (RPLACD RESULT-TAIL (SETQ RESULT-TAIL (LIST (LIST CNT TYPE-NAME)))) (SETQ RESULT (SETQ RESULT-TAIL (LIST (LIST CNT TYPE-NAME))))))))))) (%PRINT-TIMING-ITEM STREAM "SWAP time" (IL:|fetch| (IL:MISCSTATS IL:SWAPWAITTIME) IL:|of| TIME-BLOCK) T) (%PRINT-TIMING-ITEM STREAM "reclaim time" (IL:|fetch| (IL:MISCSTATS IL:GCTIME) IL:|of| TIME-BLOCK) T) (%PRINT-TIMING-ITEM STREAM "Disk i/o time" (IL:|fetch| (IL:MISCSTATS IL:DISKIOTIME) IL:|of| TIME-BLOCK) T) (%PRINT-TIMING-ITEM STREAM "net compute time" (- (STATS-OBJECT-ELAPSED-TIME STATS-OBJECT) (IL:|fetch| (IL:MISCSTATS IL:SWAPWAITTIME) IL:|of| TIME-BLOCK) (IL:|fetch| (IL:MISCSTATS IL:GCTIME) IL:|of| TIME-BLOCK) (IL:|fetch| (IL:MISCSTATS IL:DISKIOTIME) IL:|of| TIME-BLOCK) (IL:|fetch| (IL:MISCSTATS IL:NETIOTIME) IL:|of| TIME-BLOCK)) T) (%PRINT-TIMING-ITEM STREAM "Page faults" (IL:|fetch| (IL:MISCSTATS IL:PAGEFAULTS) IL:|of| TIME-BLOCK)) (%PRINT-TIMING-ITEM STREAM "Swap writes" (IL:|fetch| (IL:MISCSTATS IL:SWAPWRITES) IL:|of| TIME-BLOCK)) (%PRINT-TIMING-ITEM STREAM "Disk operations" (IL:|fetch| (IL:MISCSTATS IL:DISKOPS) IL:|of| TIME-BLOCK)) (IF DATA-TYPE-INFO (TIME-FORMAT STREAM "~&Storage allocated:~%~{~{~D ~A~}~^, ~}~&" DATA-TYPE-INFO)) (TIME-FORMAT STREAM "~%")))
|
||||
(IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE
|
||||
|
||||
(DEFMACRO %CAPTURE-BEFORE-STATS (STATS-OBJECT) (IL:* IL:|;;| "Capture machine state before timeing an evaluation. Note that ordering is important") (IL:BQUOTE (LET ((%$$STATS-OBJECT (IL:\\\, STATS-OBJECT))) (%CAPTURE-COUNTERS-BEFORE (STATS-OBJECT-DATA-COUNTERS %$$STATS-OBJECT)) (%COPY-TIME-STATS IL:\\MISCSTATS (STATS-OBJECT-TIME-BLOCK %$$STATS-OBJECT)) (IL:CLOCK0 (STATS-OBJECT-ELAPSED-TIME %$$STATS-OBJECT)))))
|
||||
|
||||
(DEFMACRO %CAPTURE-AFTER-STATS (STATS-OBJECT) (IL:BQUOTE (LET ((%$$STATS-OBJECT (IL:\\\, STATS-OBJECT))) (IL:CLOCK0 (STATS-OBJECT-ELAPSED-TIME %$$STATS-OBJECT)) (%COPY-TIME-STATS IL:\\MISCSTATS (STATS-OBJECT-TIME-BLOCK %$$STATS-OBJECT)) (%CAPTURE-COUNTERS-AFTER (STATS-OBJECT-DATA-COUNTERS %$$STATS-OBJECT)))))
|
||||
|
||||
(DEFMACRO %MOVE-FIXP-FIELD (FIELD-NAME DEST SOURCE) (IL:BQUOTE (IL:\\BLT (IL:LOCF (IL:FETCH (IL:\\\, FIELD-NAME) IL:OF (IL:\\\, DEST))) (IL:LOCF (IL:FETCH (IL:\\\, FIELD-NAME) IL:OF (IL:\\\, SOURCE))) 2)))
|
||||
)
|
||||
|
||||
(XCL:DEFINE-SPECIAL-FORM TIME (TIMED-FORM &KEY (DATA-TYPES (QUOTE (IL:DATATYPES))) (REPEAT 1) (OUTPUT (QUOTE *TRACE-OUTPUT*)) &ENVIRONMENT ENV &AUX *EVALHOOK* *APPLYHOOK*) (TIME-CALL (FUNCTION (LAMBDA NIL (EVAL TIMED-FORM ENV))) :TIMED-FORM TIMED-FORM :DATA-TYPES (EVAL DATA-TYPES ENV) :REPEAT (EVAL REPEAT ENV) :OUTPUT (EVAL OUTPUT ENV)))
|
||||
|
||||
(XCL:DEFCOMMAND "TIME" (FORM &KEY (REPEAT 1) &ENVIRONMENT ENV) "Time evaluation of form, output here" (TIME-CALL (FUNCTION (LAMBDA NIL (EVAL FORM ENV))) :OUTPUT :EXEC :REPEAT (EVAL REPEAT ENV)))
|
||||
|
||||
|
||||
|
||||
(IL:* IL:|;;| "Interlisp Timeall function")
|
||||
|
||||
(IL:DEFINEQ
|
||||
|
||||
(IL:TIMEALL
|
||||
(IL:NLAMBDA (IL:TIMEFORM IL:NUMBEROFTIMES IL:TIMEWHAT IL:INTERPFLG) (IL:* IL:\; "Edited 29-Jan-87 18:48 by jop") (IL:* IL:|;;| "collects and prints stats on TIMEFORM. TIMEWHAT indicates what to collect stats on: if T, all of the system times are collected; if NIL, the system times plus all data allocations are kept; if a list, it should be a list of DATATYPES (or numbers) . ") (LET ((IL:DATATYPES (COND ((NULL IL:TIMEWHAT) (IL:DATATYPES)) ((EQ IL:TIMEWHAT T) NIL) (T (IL:|for| IL:X IL:|inside| IL:TIMEWHAT IL:|bind| IL:NAME IL:|join| (COND ((IL:SETQ IL:NAME (IL:DATATYPEP IL:X)) (CONS IL:NAME)) ((EQ IL:X (QUOTE TIME)) NIL) (T (IL:|printout| T IL:X " is not a datatype." T) NIL)))))) IL:VALUE) (OR (IL:NUMBERP IL:NUMBEROFTIMES) (IL:SETQ IL:NUMBEROFTIMES 1)) (LET ((IL:STRF T) (IL:LCFIL NIL)) (DECLARE (IL:SPECVARS IL:STRF IL:LCFIL)) (IL:COMPILE1 (QUOTE IL:TIMEDUMMYFUNCTION) (IL:BQUOTE (IL:LAMBDA NIL (IL:\\\, IL:TIMEFORM)))) (TIME-CALL (QUOTE IL:TIMEDUMMYFUNCTION) :OUTPUT (IL:GETSTREAM NIL (QUOTE IL:OUTPUT)) :TIMED-FORM IL:TIMEFORM :DATA-TYPES IL:DATATYPES :REPEAT IL:NUMBEROFTIMES))))
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
|
||||
(IL:* IL:|;;| "file package stuff")
|
||||
|
||||
|
||||
(IL:PUTPROPS TIME IL:FILETYPE COMPILE-FILE)
|
||||
|
||||
(IL:PUTPROPS TIME IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "LISP"))
|
||||
(IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY
|
||||
(IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY
|
||||
|
||||
(IL:LOCALVARS . T)
|
||||
)
|
||||
)
|
||||
(IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS
|
||||
|
||||
(IL:ADDTOVAR IL:NLAMA)
|
||||
|
||||
(IL:ADDTOVAR IL:NLAML IL:TIMEALL)
|
||||
|
||||
(IL:ADDTOVAR IL:LAMA)
|
||||
)
|
||||
(IL:PUTPROPS TIME IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991))
|
||||
(IL:DECLARE\: IL:DONTCOPY
|
||||
(IL:FILEMAP (NIL (9569 10697 (IL:TIMEALL 9582 . 10695)))))
|
||||
IL:STOP
|
||||
Reference in New Issue
Block a user