;;; -*- 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 Oren Convert to common-lisp ;;; 11/03/86 LaMott Oren Enable the paging-time meter when loading this file. ;;; 09/29/86 LaMott Oren Changed 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 'CDDR when (MEMBER (FIRST KEYWORD) '(NAME PRETTY-NAME COUNT UN-NORMALIZED-TIME HISTORY SORTED-HISTORY PLIST) :TEST #'EQ) collect (FIRST keyword) into result AND collect (SECOND keyword) into result finally (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, and DIFFERENCE-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-list for var in meter-vars when name collect `',name collect `(,(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 to specify 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... )