LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760032563. :SYSTEM-TYPE :LOGICAL :VERSION 249. :TYPE "LISP" :NAME "RUN_BENCHMARKS" :DIRECTORY ("REL3-PUBLIC" "PUBLIC" "BENCH") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-PUBLIC\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2753213319. :AUTHOR "REL3" :LENGTH-IN-BYTES 37213. :LENGTH-IN-BLOCKS 37. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                               ;;; -*- Mode:Common-Lisp; Package:USER; Base:10 -*-;===============================================================================;;   (c) Unpublished Copyright 1986 by Texas Instruments.  All rights reserved.;;===============================================================================;;; Created 10/22/85 12:58:19 by LaMott G. OREN;;; These are the routines for defining running and analyzing benchmarks;;; Written for the Zippel benchmarks by Zippel, Fuqua and Oren;;; Correction history:;;;;;; 11/11/86 LaMott OrenConvert to common-lisp;;; 11/03/86 LaMott OrenEnable the paging-time meter when loading this file.;;; 09/29/86 LaMott OrenChanged DEFINE-BENCHMARK to repeat a benchmark when;;;DISK-TIME is zero.  Previously, this waited for PAGING-TIME;;;to be zero, which caused endless looping for benchmarks;;;that consed a lot.  Also moved the reset-temporary-area;;;call inside this loop, to prevent the creation of extra regions.;; True when temporary areas work.(DEFVAR *allow-temporary-area* #+explorer (not (variable-boundp si:tgc-indirection-cell-area))         #-explorer t)(defvar *all-benchmarks* ())(DEFVAR *all-benchmark-classes* '(all-benchmarks) "List of all benchmark class lists")(DEFPARAMETER benchmark-property-alist  '((symbolics . symbolics-benchmark)    (explorer . explorer-benchmark)    (lambda . lambda-benchmark)    (CADR . cadr-benchmark)))    (DEFPARAMETER my-machine-type #+symbolics 'symbolics                          #+explorer 'explorer  #+lambda 'lambda  #+cadr 'cadr)(DEFPARAMETER my-benchmark-property   (CDR (ASSOC MY-MACHINE-TYPE BENCHMARK-PROPERTY-ALIST :TEST #'EQ))  "The name of the benchmark property for this machine.")(defvar *all-machines* (LIST my-benchmark-property) "The list of all loaded machines types");;; The following structure describes the results of a benchmark run on a machine.;;; It is stored as the machine-name property of the benchmark name symbol.;;; The code to run the benchmark is stored as the BENCHMARK property of the benchmark name symbol.;;; The machine-name defaults to the value of MY-BENCHMARK-PROPERTY (see above);;; Benchmark results for other machines are created by RESTORE-RESULTS (below)(defstruct (benchmark :named :array      #+explorer (:callable-constructors nil)      (:constructor 1make-benchmark))  name  pretty-name  (count 0)  (un-normalized-time 0); Total time without normalization  history; A list of (time disk-time page-faults consing) for each run  sorted-history  PLIST; Property list for misc. stuff  );; These are fields that used to be in the benchmark structure, and are no longer needed;  (total-time 0);In microseconds;  (consing 0); Words consed in default cons area for this benchmark;  (disk-time 0); Total disk wait time in microseconds;  time-list; A list of the times added into total-time.;  (average-time 0);In microseconds;  (page-faults 0);; Define a compatability macro(DEFMACRO make-benchmark (&rest keyword-value-pairs)  "Make a benchmark structure.  Ignores keyword/values not defined in the benchmasrk structure."  (LOOP for keyword on keyword-value-pairs by 'CDDRwhen (MEMBER (FIRST KEYWORD)     '(NAME PRETTY-NAME COUNT UN-NORMALIZED-TIME HISTORY SORTED-HISTORY PLIST) :TEST #'EQ)collect (FIRST keyword) into result ANDcollect (SECOND keyword) into resultfinally (RETURN `(1make-benchmark ,@result))))(DEFUN make-benchmark-internal (&key name pretty-name count un-normalized-time history sorted-history plist)  "Make a benchmark structure, keeping the lists of benchmark classes updated."  (1make-benchmark name name pretty-name pretty-name count count un-normalized-time un-normalized-time   history history sorted-history sorted-history plist plist))(DEFUN update-benchmark-classes (bench)  "keep the lists of benchmark classes updated."  (LET ((name (benchmark-name bench))(classes (GET (benchmark-plist bench) 'classes)))    (UNLESS (MEMBER NAME *ALL-BENCHMARKS* :TEST #'EQ)      (SETQ *all-benchmarks* (NCONC *all-benchmarks* (LIST name))))    ;; Keep a list of the members of each benchmark class in the class-name symbol    (LOOP for class-name in classes  for class = (AND (BOUNDP class-name) (SYMBOL-VALUE CLASS-NAME))  do (UNLESS (MEMBER CLASS-NAME *ALL-BENCHMARK-CLASSES* :TEST #'EQ) (PUSH class-name *all-benchmark-classes*))  (IF (NULL class)      (SET class-name (LIST name))    (UNLESS (MEMBER NAME CLASS :TEST #'EQ)      (NCONC class (LIST name)))))    bench));; Everytime a benchmark is run, the following structure is put at the;; end of the list in the BENCHMARK-HISTORY slot of the benchmark structure (above)(DEFSTRUCT (benchmark-history (:type list) #+explorer (:callable-constructors nil))  real-time  (disk-time 0)  (page-faults 0)  (consing 0)  (cpu-time 0)  (paging-time 0))(COMMENT defselect ((:property benchmark named-structure-invoke))  (:print-self (benchmark stream ignore ignore)   (si:printing-random-object (benchmark stream :no-pointer)     (format stream "~A: ~A (~D), ~D total fault~:P"     (OR (benchmark-pretty-name benchmark) (benchmark-name benchmark))     (pretty-time (benchmark-average-time benchmark))     (benchmark-count benchmark)     (benchmark-page-faults benchmark)))));; This used to be a slot of the benchmark structure, but we calculate it now.(DEFUN benchmark-average-time (benchmark)  (LET ((default-cons-area working-storage-area)) ;; This can be called while using benchmark-area    (LOOP with history = (benchmark-history benchmark)  for entry in history  summing (benchmark-history-real-time entry) into total  finally (RETURN (/ total (FLOAT (LENGTH history)))))));; Benchmark names sometimes get rather long.  ;; When printing in columns, chop it off with this function.(DEFUN benchmark-short-pretty-name (bench &optional (len 25))  (LET ((name (benchmark-pretty-name bench)))    (UNLESS name      (SETQ name (OR (AND (FBOUNDP 'zwei:make-command-name)  (zwei:make-command-name (benchmark-name bench)))     (STRING (benchmark-name bench))))      (SETF (benchmark-pretty-name bench) name))    (IF (> (LENGTH (string name)) len)(SUBSEQ (STRING NAME) 0 LEN)      name)));;;;;;  We really only need this area for the 3600, because all the consing here is;;;  number-consing, which the explorer does in the extra-pdl (and, through careful;;;  manipulation of the tests, never has to copy out), while the 3600 treats numbers;;;  like any other consing.  On the other hand, 3600 single-floats are only one word.(defvar benchmark-area nil)(eval-when (load)  (when (null benchmark-area)    ;;;  Create a temporary area for the consing parts of the tests.    (make-area :name 'benchmark-area       :region-size #o300000       :representation :list       :gc (IF *allow-temporary-area* :temporary :dynamic)       :room t)    ;;;  Ensure that there is real stuff in the area before wiring it.    (let ((default-cons-area benchmark-area))      (make-array 4.)      (make-list 5.));;    ;;;  Now wire the stuff, so benchmark-area will never page, and there will be no disk time.;;    (loop for region = (si:area-region-list benchmark-area) then (si:region-list-thread region);;  until (minusp region);;  unless (zerop (si:region-free-pointer region));;  doing (si:wire-words (si:region-origin region) (si:region-free-pointer region)))    ))  ;;  End of eval-when(defmacro using-temporary-area (area &body body)   `(progn 'compile   (WHEN *allow-temporary-area* (si:reset-temporary-area ,area))   (let ((default-cons-area ,area))     ,@body)));;;  Analogue of time-difference;  handles wraparound.(defparameter maximum-usec-timer-value #x+100000000)(defun microsecond-time-difference (end start)  (let ((diff (- end start)))    (if (< diff 0)(+ end (- maximum-usec-timer-value start))      diff)))(defmacro do-many-times (repcount &body body)  (cond ((= repcount 1) `(progn ,@body))((< repcount 20.)  `(progn    ,@(loop for i below repcount    appending body)))(t `(loop for i below ,(quotient repcount 20)  do (progn ,@(loop for j below 20 appending body))  finally (progn ,@(loop for j below (rem repcount 20) appending body))))))(defmacro report (STREAM &rest args)  `(#+explorer cli:format #-explorer format ,stream ,@args))(defmacro microsecond-clock ()  #+3600 '(sys:%microsecond-clock)  #+CADR '(time:microsecond-time)  #-(or 3600 cadr) '(si:%microsecond-time)  )(DEFMACRO disk-wait-time ()  "Measure the time spent waiting for the disk"  #-3600 '(read-meter 'si:%disk-wait-time)  #+3600 'si:*ms-time-page-fault*) ;;total time spent in page fault(WHEN (VARIABLE-BOUNDP si:%disk-switches) ;; Enable paging-time metering  (SETF (LDB si:%%Time-Page-Faults-Enable si:%disk-switches) 1))(DEFMACRO paging-time ()  "Measure the time spent processing page faults.This is disk-wait-time plus the time for creating new pages"  #-3600 'si:(IF (MEMBER '%TOTAL-PAGE-FAULT-TIME A-MEMORY-COUNTER-BLOCK-NAMES :TEST #'EQ) (read-meter 'si:%total-page-fault-time) ;; Release 3       (read-meter 'si:%disk-wait-time))     ;; Release 2  #+3600 'si:(+ *ms-time-page-fault* *ms-time-create-pages*));; Note: It would be nice to use si:fixnum-read-meter-for-scheduler instead of read-meter;;       because read-meter has a lot of overhead.  Maybe we can switch after release 3;;       when the system stabalizes...(defmacro hard-page-fault-count ()  #-3600 'si:(IF (MEMBER '%COUNT-DISK-PAGE-READ-OPERATIONS A-MEMORY-COUNTER-BLOCK-NAMES :TEST #'EQ) (READ-METER 'si:%count-disk-page-read-operations) ;; Release 2       (+ (read-meter '%count-disk-page-reads)  (READ-METER 'si:%count-fresh-pages)))            ;; Release 3 only  ;; except this is a new meter, and won't compile yet...  #+3600 'si:*count-page-fetches*);; The following lists of meters are included here as an aid to understanding what's really;; being measured, and what new measurements may be included for the benchmarks - lgo#+comment (DefSysConst A-Memory-Counter-Block-Names  ;; These are the explorer meters from the release 2 QCOM.LISP file     '(  %COUNT-FIRST-LEVEL-MAP-RELOADS;# FIRST LEVEL MAP RELOADS  %COUNT-SECOND-LEVEL-MAP-RELOADS;# SECOND LEVEL MAP RELOADS  %COUNT-PDL-BUFFER-READ-FAULTS;# TOOK PGF AND DID READ FROM PDL-BUFFER  %COUNT-PDL-BUFFER-WRITE-FAULTS;# TOOK PGF AND DID WRITE TO PDL-BUFFER  %COUNT-PDL-BUFFER-MEMORY-FAULTS;# TOOK PGF FOR PDL-BUF, BUT DATA IN MAIN MEM.  %COUNT-DISK-PAGE-READS;COUNT OF PAGES READ FROM DISK  %COUNT-DISK-PAGE-WRITES;COUNT OF PAGES WRITTEN TO DISK#-explorer  %COUNT-DISK-ERRORS;COUNT OF RECOVERABLE ERRS        ;#A-90 - deleted#-explorer  %COUNT-FRESH-PAGES;COUNT OF FRESH PAGES             ;#A-90 - deleted ; GENERATED IN CORE INSTEAD OF READ FROM DISK  %COUNT-AGED-PAGES;NUMBER OF TIMES AGER SET AGE TRAP  %COUNT-AGE-FLUSHED-PAGES;NUMBER OF TIMES AGE TRAP -> FLUSHABLE#-explorer  %COUNT-DISK-READ-COMPARE-REWRITES;COUNT OF WRITES REDONE DUE TO    ;#A-90 - deleted                                        ;   FAILURE TO READ-COMPARE #-explorer  %COUNT-DISK-RECALIBRATES;DUE TO SEEK ERRORS               ;#A-90 - deleted  %COUNT-META-BITS-MAP-RELOADS;# SECOND LEVEL MAP RELOADS TO META-BITS-ONLY#-explorer  %COUNT-CHAOS-TRANSMIT-ABORTS;# of transmit aborts in ucode    ;#A-90 - deleted#-explorer  %COUNT-DISK-READ-COMPARE-DIFFERENCES;# of read-compare differences    ;#A-90 - deleted;  without accompanying disk read error  %COUNT-CONS-WORK;GC parameter  %COUNT-SCAVENGER-WORK;..  %TV-CLOCK-RATE;TV frame rate divided by this is seq brk clock  %AGING-DEPTH;Number of laps to age a page.  Don't make > 3!!#-explorer  %COUNT-DISK-ECC-CORRECTED-ERRORS;Number of soft ECC errors        ;#A-90 - deleted  %COUNT-FINDCORE-STEPS;Number of iterations finding mem to swap out  %COUNT-FINDCORE-EMERGENCIES;Number of times FINDCORE had to age all pages#-explorer  %COUNT-DISK-READ-COMPARE-REREADS;Reads done over due to r/c diff or error       ;#A-90 - deleted  %COUNT-DISK-PAGE-READ-OPERATIONS;Read operations (count once even if multipage)  %COUNT-DISK-PAGE-WRITE-OPERATIONS;Write operations (count once even if multipage)  %COUNT-DISK-PAGE-WRITE-WAITS;Waiting for a page to get written, to reclaim core#-explorer  %COUNT-DISK-PAGE-WRITE-BUSYS;Waiting for a page to get written, to use disk ;#A-90 - deleted  %COUNT-DISK-PREPAGES-USED;Counts prepaged pages that were wanted#-explorer  %COUNT-DISK-PREPAGES-NOT-USED;Counts prepaged pages that were reclaimed      ;#A-90 - deleted#-explorer  %DISK-ERROR-LOG-POINTER;Address of next 4-word block in 600-637        ;#A-90 - deleted  %DISK-WAIT-TIME;Microseconds of waiting for disk time  %COUNT-DISK-PAGE-WRITE-APPENDS;Pages appended to swapout operations.#-explorer  %COUNT-DISK-PAGE-READ-APPENDS;Pages appended to swapin operations.           ;#A-90 - deleted  %LOWEST-DIRECT-VIRTUAL-ADDRESS;Not a counter (except maybe down, slowly..); Normally equal to LOWEST-A-MEM-VIRTUAL-ADDRESS,; set this lower if you need more direct address; space, ie, for video buffer of new color display. #-explorer  %UNIBUS-TIMED-OUTPUT-CSR-ADDRESS      ;These two are used to start output on the                                        ;  timestamped output device when the interval                                        ;  timer interrupts.#-explorer  %UNIBUS-TIMED-OUTPUT-CSR-BITS#+Explorer  %Max-Disk-Write-Size-Reached-Count;counts number of maximum page count disk writes#+Explorer  %Buffer-Page-Not-Ready-Emergencies;number of times page fault entered swapin without a buffer reserved#+Explorer  %COUNT-OF-NUBUS-GACBLS-RETRIES        ;number of NuBus GACBL conditions and retry attempts#+Explorer  %COUNT-OF-NUBUS-PARITY-ERRORS         ;number of NuBUS parity conditions and retry attempts  ))#+comment(comment  ;; From symbolics release 5.2 - These are the meters available for the symbolics  ;; Entry point timings  *ms-time-page-fault*; Total time spent in page fault  *ms-time-create-pages*; Total time spent creating CONS pages  *ms-time-user-prefetch-pages*; Total time spent in explicit prefetching  ;; Internal timings included in the entry timings  *ms-time-pending-wait*; Time in wired-wait for not-pending-p  *ms-time-page-idle-wait*; Time in wired-wait for page-idle-p  *ms-time-find-frame*; Time finding a flushable frame to use  *ms-time-pending-queue-full*; Time in wired-wait for pending queue  *ms-time-write-lock-wait*; Time waiting for write-lock to clear  *ms-time-smpt-create*; Time creating a new SMPT entry  *count-usable-pages*; Count of usable main memory page frames  ;; Start usable page counts  *count-normal-pages*; Count of normal pages  *count-flushable-pages*; Count of free pages  *count-busy-pages*; Count of pages with disk i/o in progress  *count-wired-pages*; Count of wired pages  ;; Sum of above should equal usable pages.  *count-locked-pages*; Number of pages with the frame locked  *count-pending*; Number of VPNs pending flush-writes  *count-flushc*; Count of pages in flushable page cashe  *count-swap-pages*; Total number of pages in swap space  *count-remaining-swap-pages*; Number of available pages in swap space  ;; Start page fault counts  *count-map-misses*; Number of map miss faults  *count-page-fetches*; Number of hard page faults  *count-write-first-faults*; Number of write-first faults  *count-flushable-page-faults*; Number of references to flushable pages  *count-prefetched-page-faults*; Number of references to prefetched pages  *count-busy-page-faults*; Number of references to pages in disk wait  ;; Sum of above meters should equal total number of page faults  *count-load-fetches*; Number of count-page-fetches from load map  *count-load-prefetches*; Number of prefetches from load map  *count-created-pages*; Number of pages created by consing  *count-page-prefetches*; Number of actual disk prefetches  *count-discarded-prefetched-pages*; Number of discarded prefetched page's  *count-forced-modified-page-writes*; Number of waits for write of a modified page  *count-flushc-miss*; Flushable cache empty  *count-smpt-inserts*; Number of inserts into SMPT (num of entries)  *count-smpt-right-inserts*; Inserted into neighboring right node  *count-smpt-left-inserts*; Inserted into neighboring left node  *count-smpt-appends*; Created a new empty node  *count-smpt-splits*; Created a node dividing full nodes contents  *count-pht-linear-probes*; Number of probes after rehash overflow  )(DEFPARAMETER benchmark-meter-list  '((nil (disk-wait-time) microsecond-time-difference)    (nil (paging-time) microsecond-time-difference)    (nil (hard-page-fault-count))    (nil (area-size)))  "List of benchmark meters.  Each element is a list of (KEYWORD FORM DIFFERENCE-FUNCTION)where KEYWORD is used to name the meter,FORM is a form that when evaluated will return the meter, andDIFFERENCE-FUNCTION is an optional difference function that defaults to -")(defmacro reporting-performance ((meter-list report-function . args) &body body)  "Execute BODY, then call REPORT-FUNCTION with arguments  ARGS followed by REAL-TIME in microseconds and the keyword arguments specified by METER-LIST."  (LET ((TIME (GENSYM))(new-time (GENSYM))(newer-time (GENSYM))(meter-vars (LOOP for x in meter-list collecting (GENSYM))))    `(let ((,time #+explorer (compiler::undefined-value))   (,new-time #+explorer (compiler::undefined-value))   (,newer-time #+explorer (compiler::undefined-value))   ,@(LOOP for meter in meter-list   for var in meter-vars   collect `(,var ,(SECOND meter)) into init-forms   finally (RETURN (NREVERSE init-forms))))       (setq ,time (microsecond-clock))       (PROGN 'compile ,@body)       (setq ,new-time (microsecond-clock))       (setq ,newer-time (microsecond-clock))       (,report-function ,@args(microsecond-time-difference  ,new-time (+ ,time (microsecond-time-difference ,newer-time ,new-time))) ;Total time,@(LOOP for (name function difference) in meter-listfor var in meter-varswhen name collect `',namecollect `(,(OR difference '-) ,function ,var))))))(defmacro benchmark-body ((repcount #+3600 &optional meter-list) &body body)  "Execute BODY REPCOUNT times, collecting the meters on benchmark-meter-list and METER-LIST.Returns a benchmark-history."  `(without-interrupts     ,@(WHEN (> repcount 1) body);To eliminate interaction with other test     (reporting-performance (,(APPEND benchmark-meter-list meter-list) make-history)       (do-many-times ,repcount ,@body))))(DEFUN make-history (real-time disk-time paging-time page-faults cons-count &rest others)  (LET ((default-cons-area working-storage-area))    (NCONC (make-benchmark-history     real-time real-time     disk-time disk-time     paging-time paging-time     cpu-time (- real-time disk-time)     page-faults page-faults     consing cons-count)   (COPY-LIST others))))(DEFCONSTANT sixtith-to-usec (* (/ 1 60.0) 1e6) "Conversion factor for 1/60 second to microseconds")(COMMENT defmacro process-body ((total-time page-faults disk-time cons-count repcount) &body body)  "Like benchmark-body, but only counts the time spent in this process.Semi useful for timeing programs that do lots of network i/o.Note that this is only accurate to 1/60th of a second  (16 ms)"  `(PROGN     ,@(WHEN (> repcount 1) body);To eliminate interaction with other test    (let (time new-time newer-time   (.cons-count. (area-size))   (.page-faults. (hard-page-fault-count))   (.disk-time. (si:process-disk-wait-time-low current-process)))       (setq time (si:process-total-run-time-low current-process))       (do-many-times ,repcount ,@body)       (setq new-time (si:process-total-run-time-low current-process))       (setq newer-time (si:process-total-run-time-low current-process))       (setq ,total-time (* (time-difference new-time (+ time (time-difference newer-time new-time)))    sixtith-to-usec))       ,(WHEN disk-time `(SETQ ,disk-time (* (time-difference (si:process-disk-wait-time-low current-process) .disk-time.)     sixtith-to-usec)))       (setq ,page-faults     (- (hard-page-fault-count) .page-faults.))       (SETQ ,cons-count (- (area-size) .cons-count.)))))(DEFMACRO record-benchmark ((name &optional meter-list) &body body &aux (repcount 1))  `(without-interrupts     (LET* ((benchmark (get ,name my-benchmark-property))    (default-cons-area benchmark-area)    (history (benchmark-body (,repcount ,meter-list)       ,@body)))       (update-benchmark-history benchmark history ,repcount 0))))(defmacro define-benchmark (name pretty-name repcount &body others)  "Define a benchmark. Body consists of one of keyword/value pairs,where the legal keywords are::classes :body :bindings :declartions :real-body :cleanup-form:normalization :meters :allow-page-faults"  (let (body real-body bindings cleanup-form meters declarations(classes ())(normalization 0)(allow-page-faults t))    (loop for (key form) on others by #'cddr  do (case key       (:classes (setq classes form))       (:body (setq body form))       (:bindings (SETQ bindings form))       (:declarations (SETQ declarations form))       (:real-body (setq real-body form))       (:cleanup-form (SETQ cleanup-form form))       (:normalization (setq normalization form))       (:meters (SETQ meters form))       (:allow-page-faults (setq allow-page-faults form))       (otherwise (ferror "Unknown keyword ~A in ~A" key pretty-name))))    `(progn 'compile    (putprop ',name (update-benchmark-classes      (make-benchmark-internal :name ',name :pretty-name ,pretty-name       :plist '(nil classes ,classes normalization ,normalization)))     my-benchmark-property)    (defun (:property ,name benchmark) ()      ,@(WHEN declarations `((DECLARE ,@declarations)))      (let* ((benchmark (get ',name my-benchmark-property))     history     ,@bindings),(IF allow-page-faults     `(SETQ history    ,(cond (body `(benchmark-body (,repcount ,meters)    ,body))   (real-body)   (t (ferror "No body for ~A benchmark?" pretty-name))))   `(using-temporary-area benchmark-area      (loop do     (SETQ history  ,(cond (body `(benchmark-body (,repcount ,meters)  ,body)) (real-body) (t (ferror "No body for ~A benchmark?" pretty-name))))  until (zerop (benchmark-history-disk-time history)))))(update-benchmark-history benchmark history ,repcount ,normalization),cleanup-form)))))(DEFMACRO dividef (a b)  "Setf A to A divided by B"  (UNLESS (EQ b 1)    `(SETF ,a (/ ,a (FLOAT ,b)))))(DEFUN update-benchmark-history (benchmark history repcount normalization)  (let ((default-cons-area working-storage-area)) ;; Just in case...    (UNLESS (AND (CONSP history) (> (LENGTH history) 4))      (FERROR "Benchmark body didn't return a history: ~s" history))    (INCF (benchmark-count benchmark) repcount)    (INCF (benchmark-un-normalized-time benchmark) (benchmark-history-real-time history))    (UNLESS (= repcount 1)      (Dividef (benchmark-history-real-time history) repcount)      (dividef (benchmark-history-disk-time history) repcount)      (dividef (benchmark-history-cpu-time history) repcount)      (dividef (benchmark-history-page-faults history) repcount)      (dividef (benchmark-history-consing history) repcount))    (DECF (benchmark-history-real-time history) normalization)    (DECF (benchmark-history-cpu-time history) normalization)    (SETF (benchmark-history benchmark)  (NCONC (benchmark-history benchmark) (LIST history)))))(defvar *loop-normalization*)(defun loop-normalization ()  (let ((i 1000000.))    (without-interrupts      (let (time    new-time)(setq time (microsecond-clock))(prog nil   a    (if (plusp (decf i)) (go a)))(setq new-time (microsecond-clock))(setq *loop-normalization* (- new-time time)))))  (setq *loop-normalization* (/ *loop-normalization* 1.0e6)))(defun bench-timer ()  (let ((times ()))    (without-interrupts      (do-many-times 20 (push (microsecond-clock) times)))    (loop for time on times  while (cdr time)  do (print (- (first time) (second time))))))      (defun get-benchmark (name &optional MACHINE-TYPE no-errorp)  (let ((temp name)(prop (OR machine-type my-benchmark-property)))    (unless (typep temp 'benchmark)      (setq temp (get name prop))      (UNLESS (typep temp 'benchmark)(OR no-errorp (FERROR "The ~a benchmark wasn't found for machine ~a" name prop))))    temp))(defun clear-benchmark (name &optional machine-type)  (WHEN (setq name (get-benchmark name machine-type :no-error))    (SETF (benchmark-un-normalized-time name) 0)    (setf (benchmark-count name) 0)    (setf (benchmark-history name) nil)    (setf (benchmark-sorted-history name) nil)))(defun clear-benchmarks (&key (benchmarks *all-benchmarks*) (recompute-normalizations :ask) (report-p t))  (DECLARE (SPECIAL *instructions*))  (loop for name in benchmarks do (clear-benchmark name))  (when (AND (variable-boundp *instructions*)     recompute-normalizations     (OR (NEQ recompute-normalizations :ask) (y-or-n-p "Recompute normalizations? ")))    (DOTIMES (i 10)      (perform-benchmarks *instructions* :repcount 20. :report-p nil))    (perform-benchmarks *instructions* :repcount 100. :report-p report-p)))(defun perform-benchmarks (benchmarks &key (repcount 10.) (report-p t) (clear t))  (WHEN clear    (clear-benchmarks :benchmarks benchmarks      :recompute-normalizations (eq clear :normalize)      :report-p (eq clear :normalize)))  (loop for name in benchmarks do(perform-benchmark name repcount))  (WHEN report-p    (report-benchmarks benchmarks)))(defun perform-benchmark (name &optional (repcount 1))  (LET ((benchmark (get-benchmark name nil t)))    (WHEN benchmark      (UNLESS *allow-temporary-area*(do-tgc))      (dotimes (var (- repcount (benchmark-count benchmark)))(funcall (get name 'benchmark))))))(DEFVAR *sum-all-areas* t "When NIL get the area size for the default cons area only.")(DEFUN area-size (&optional area-number)  "Return the number of words used in AREA-NUMBER, or all areas."  (IF *sum-all-areas*      (LOOP with *sum-all-areas* = nil    for area to (SYMBOL-VALUE (CAR (LAST AREA-LIST)));;    unless (si:area-temporary-p area)    unless #+explorer (= area si:extra-pdl-area) #-explorer nil    sum (area-size area))    (DO ((region (si:area-region-list area-number) (si:region-list-thread region)) (sum 0 (+ sum (si:REGION-FREE-POINTER REGION))))((MINUSP region) sum))))(DEFUN get-benchmark-herald ()  "Return the herald information saved for the benchmarks"  `((user ,(WITH-OUTPUT-TO-STRING (stream)     (REPORT stream "User ~a" user-id)))    (TIME ,(WITH-OUTPUT-TO-STRING (stream)     (time:print-universal-time (time:get-universal-time) stream)))    ,@(when (fboundp 'print-herald)        `((herald ,(WITH-OUTPUT-TO-STRING (*standard-output*)       (PRINT-HERALD)))))    ,@(when (fboundp 'software-version)`((system ,(software-version))))    ,@(when (fboundp 'machine-version)        `((machine ,(machine-VERSION))))    ,@(when (fboundp 'room)`((ROOM ,(WITH-OUTPUT-TO-STRING (*standard-output*)     (ROOM)))))    (disk-label ,(WITH-OUTPUT-TO-STRING (*standard-output*)   (PRINT-DISK-LABEL)   #+explorer (PRINT-DISK-LABEL 1)))    ))(DEFUN benchmark-herald (machine &optional type)  "Print the herald information for benchmarks from MACHINE.Type may be one of (user time herald room disk-label) or NIL for all of them.Note: Some older benchmark results use an old format that doesn't allow you tospecify TYPE - you always get all the information."  (LET ((herald (GET machine 'herald)))    (COND ((NULL herald) (FORMAT nil "Herald Not Found for machine ~s" machine))  ((OR (NULL type) (STRINGP herald)) herald)  (t (SECOND (ASSOC TYPE HERALD :TEST #'EQ))))))(DEFUN save-results (PATHNAME &optional (benchmark-list *all-benchmarks*) (machine my-benchmark-property))  "Save benchmark results to a file, so they may be consolidated."  (#+explorer WITH-ZETALISP-ON  #-explorer progn   (WITH-OPEN-FILE (STREAM pathname :direction :output)     (REPORT t "~&Saving results to ~a" (SEND stream :Truename))     (PRINT machine stream)     (PRINT (get-benchmark-herald) stream)     (LOOP for name in benchmark-list   for benchmark = (get-benchmark name machine t)   when benchmark do (write-benchmark benchmark stream)))))(DEFUN write-benchmark (benchmark stream)  #-explorer (DECLARE (SPECIAL *print-pretty*))  (LET ((*print-level* nil)       ;; Print it all(*print-length* nil)(*print-pretty* nil)   ;; Print it fast(si:print-readably t)) ;; Errors if can't read it back in    (PRINT `(make-benchmark-internal      :name ',(benchmark-name benchmark)      :pretty-name ',(benchmark-pretty-name benchmark)      :count ,(benchmark-count benchmark)      :history ',(benchmark-history benchmark)      :un-normalized-time ,(benchmark-un-normalized-time benchmark)      :plist ',(benchmark-plist benchmark)      )   stream)))(DEFUN update-results (PATHNAME &optional (benchmark-list *all-benchmarks*) (name my-benchmark-property))  "Update the result data-base file"  (#+explorer WITH-ZETALISP-ON  #-explorer progn   (WITH-OPEN-FILE (input pathname :if-does-not-exist nil)     (UNLESS input (FORMAT t "~%File ~a not found. Createing it." pathname))     (WITH-OPEN-FILE (STREAM pathname :direction :output)       (REPORT t "~%Updateing results on ~a" (SEND stream :Truename)); Handle the header       (LET ((prop (AND input (READ input)))     (herald (APPEND (get-benchmark-herald)     `((:benchmark-list ,benchmark-list))     (AND input (READ input))))) (SETQ prop (OR name prop)) (UNLESS (OR (EQ name prop) (EQ name my-benchmark-property))   (FSIGNAL "Data-base name ~s doesn't match the current name ~s" prop name)) (PUTPROP prop herald 'herald) (PRINT name stream) (PRINT herald stream); Copy data-base other than benchmark-list (WHEN input   (LOOP for make-bench = (READ input :eof) until (EQ make-bench :eof) for bench = (ignore-errors (eval make-bench)) when (and bench (not (MEMBER (BENCHMARK-NAME BENCH) BENCHMARK-LIST :TEST #'EQ))) do (write-benchmark bench stream)));; (WHEN input;;   (LOOP for make-bench = (READ input :eof);; until (EQ make-bench :eof);; for name = (second (third make-bench));; when (and name (not (MEMBER NAME BENCHMARK-LIST :TEST #'EQ))) do;; (print make-bench stream))); Copy benchmarks in benchmark-list (LOOP for name in benchmark-list       for benchmark = (get-benchmark name nil t)       when benchmark do (write-benchmark benchmark stream))))))  name)(DEFUN restore-results (PATHNAME &optional machine)  "Restore a benchmark result file.  The results will be known by MACHINE.  MACHINE defaults to the name saved in the file.  Returns MACHINE."  (#+explorer WITH-ZETALISP-ON  #-explorer progn   (WITH-OPEN-FILE (STREAM pathname)     (LET ((prop (READ stream)))       (SETQ prop (OR machine prop))       (PUTPROP prop (READ stream) 'herald)       (LOOP for make-bench = (READ stream nil :eof)     until (EQ make-bench :eof)     for bench = (eval make-bench)     for name = (benchmark-name bench)     do     (PUTPROP name bench prop) ;; Define the benchmark     (update-benchmark-classes bench))       (UNLESS (MEMBER MACHINE *ALL-MACHINES* :TEST #'EQ) (PUSH machine *all-machines*))       prop))));; Some machines don't have a SET-DIFFERENCE function, so redefine it here to make sure we've got it.(defun my-set-difference (list1 list2)  (do ((list (copy-list list1) (cdr list))       (result)       (old))      ((null list) result)    (cond ((not (MEMBER (CAR LIST) LIST2 :TEST #'EQ))   (or result (setq result list))   (setq old list))  (old   (rplacd old (cdr list))))))(DEFUN run-gabriel (name &optional addp)  (DECLARE (SPECIAL *gabriel-benchmarks*))  (run-benchmarks (string-append name "-gabriel") *gabriel-benchmarks* 5 addp))(DEFUN run-opt-gabriel (name &optional addp)  (DECLARE (SPECIAL *gabriel-opt-benchmarks*))  (run-benchmarks (string-append name "-opt-gabriel") *gabriel-opt-benchmarks* 5 addp))(DEFUN run-cl-gabriel (name &optional addp)  (DECLARE (SPECIAL *gabriel-cl-benchmarks*))  (run-benchmarks (string-append name "-cl-gabriel") *gabriel-cl-benchmarks* 5 addp))(DEFUN run-instruction (name &optional addp)  (DECLARE (SPECIAL *zippel-benchmarks* *instructions*))  (run-benchmarks name *zippel-benchmarks* 10 addp nil)  (save-results (STRING-APPEND "results:results;" name "-zippel.bench") (append *instructions* *zippel-benchmarks*)))(DEFUN run-extensions (name &optional addp)  (DECLARE (SPECIAL *pathname-benchmarks* *extended-zippels*))  (run-benchmarks name (my-set-difference *extended-zippels* *pathname-benchmarks*) 10 addp nil)  ;; do pathname benchmarks with chaos enabled  (perform-benchmarks *pathname-benchmarks* :clear (NOT addp) :repcount 100 :report-p nil)  (save-results (STRING-APPEND "results:results;" name "-extensions.bench") (append *extended-zippels* *pathname-benchmarks*))  )(DEFUN run-misc (name &optional addp)  (DECLARE (SPECIAL *misc-benchmarks*))  (run-benchmarks (STRING-APPEND name "-MISC") *misc-benchmarks* 5 addp))(DEFUN run-benchmarks (name benchmarks repcount &optional addp (updatep t));;  (UNLESS *allow-temporary-area* (GC-OFF))  (gc-off)  (SEND *terminal-io* :set-more-p nil)  (SEND *terminal-io* #-3600 :clear-screen #+3600 :clear-window)  #+3600 (neti:reset)  #-3600 (chaos:reset)  #-3600 (IF *ip-present* (ip:disable))              ;;; added 5/13/86 -- I thought I had put                                                     ;;; added ip conditionalization on 10/08/86                                                     ;;;   this in once before????  #-3600 (si:%nubus-write-16b #xf0 #xfc000 1.)       ;;; added on 5/13/86 to send a reset command                                                     ;;;   to the ethernet board's command register                                                     ;;;   which will make it go to sleep.  #-3600 (halt-mail)                                 ;;; added 7/09/86 to try to eliminate noise in the results.   #-3600 (kill-all-processes)                        ;;;   "  #-3600 (kill-all-windows)                          ;;;   "  (perform-benchmarks benchmarks :clear (AND (NOT addp) :normalize) :repcount repcount :report-p nil)  #+3600 (neti:enable)  #-3600 (chaos:reset t)                             ;;; changed from (chaos:enable) on 5/13/86   #-3600 (IF *ip-present* (ip:enable))               ;;; added on 5/13/86                                                     ;;; added ip conditionalization on 10/08/86  #-3600 (restart-mail)                              ;;; added 7/09/86  (WHEN updatep    (save-results (STRING-APPEND "results:results;" name ".bench") benchmarks)))(DEFUN run-all (name &optional addp)  (run-extensions name addp)  (run-instruction name addp)  (run-gabriel name addp))(DEFUN kill-all-processes ()                  ;;; added 7/09/86  "Kill all of the non-essential processes on the system.  This was written to clean up the environment   before every iteration of the interactive benchmarks, but may be used anywhere appropriate."  (loop for i in si:all-processes     unless (or (member (send i :name) '("Initial Process" "Chaos Background" "NUBUS receiver, #XF0"         "Mouse" "Keyboard" "Screen Manager Background"         "Dormant FILE connection GC" "STUFF" "GC Daemon" "Garbage Collector") :test #'string-equal)(eq i si:current-process))     do (format t "~& Killing process ~A" (send i :name))     (send i :kill)))(DEFUN kill-all-windows ()                    ;;; added 7/09/86  "Kill all windows inferior to the current window.  Written to be executed from Lisp Listener 1   (Initial Process) before every iteration of the interactive benchmarks, but may be used anywhere    appropriate";  (send tv:main-screen :inferiors)  (loop for i in (send tv:main-screen :inferiors)     unless (eql i *terminal-io*)     do (send i :kill))  (send tv:main-screen :inferiors))(DEFUN do-tgc ()  "Do temporaral (ephemeral) garbage collection."  (SLEEP 3) ;; Allow other processes a chance to run;;  (si:gc-reclaim-oldspace) ;; If gc is in progress, finish it now  #+explorer  (PROGN (GC-IMMEDIATELY :max-gen 0) ;; Do level 0 TGC now ;; Do something to create level 0 regions in BENCHMARK-AREA (let ((default-cons-area benchmark-area))   (make-array 4.)   (make-list 5.)))  ;; There must be a way to do this for Symbolics also...  )s &optional (reports '(instruction-compare     cpu-compare)))  (DECLARE (SPECIAL *zippel-benchmarks* *string-benchmarks* *storage-allocators* *list-access* *function-call*    *message-passing* *array-reference* *arithmetic* *fixnum-arithmetic* *flonum-arithmetic*    *bignum-arithmetic* *miscellaneous*    *instructions* *pathname-benchmarks* *extended-zippels* *hash-benchmarks* *graphics-benchmarks*    *array-push-benchmarks* *eval-benchmarks* *branch-benchmarks*))  (load-reports machines 'zippel 'push-local-normalization)  (WHEN (VARIABLE-BOUNDP *miscellaneous*) ;; Don't consider miscellaneous tests to be arithmetic    (setq *arithmetic* (my-SE