;;; -*- Mode:Common-Lisp; Package:USER; Fonts:(CPTFONT CPTFONTB); Base:10 -*-

;1; Stuff to run the *"Dick Gabriel" Benchmark Series.
;1; Load the RUN-BENCHMARKS file first to define the benchmark accessor macros*

;;; Correction history:
;;;
;;; 11/11/86 LaMott Oren	Converted to Common-Lisp

(SETQ *bench-repeat-count* 1)			;1Set the number of times to do each test*

(DEFUN define-gabriel-benchmarks (bench-name repeat-count benchmarks)
  (PUTPROP bench-name repeat-count 'benchmark-repeat-count)
  (LOOP for benchmark on benchmarks
	with repeat-count = *bench-repeat-count*
	with name
	WHEN (ATOM (CAR benchmark))
	DO (WHEN (FIXNUMP (CAR benchmark)) (SETQ repeat-count (CAR benchmark)))
	else do
	(SETQ name (CAAR benchmark))
	(LOOP for class-name in (LIST '*all-benchmarks* bench-name)
	      for class = (SYMBOL-VALUE CLASS-NAME)
	      do (IF (NULL class)
		   (SET class-name (LIST name))
		   (UNLESS (MEMBER NAME CLASS :TEST #'EQ)
		     (NCONC class (LIST name)))))
	(putprop name (make-benchmark name name pretty-name name plist (LIST nil 'classes (LIST bench-name)))
		 my-benchmark-property)
	(LET ((bench (CDAR benchmark))
	      (bench-name name)
	      (bench-gc-flag (AND (SYMBOLP (SECOND benchmark)) (SECOND benchmark))))
	  (DECLARE (SPECIAL bench bench-name bench-gc-flag))
	  (PUTPROP name (CLOSURE '(bench bench-name bench-gc-flag) 'run-gabriel-benchmark) 'benchmark))
	))

(DEFUN run-gabriel-benchmark ()
  (DECLARE (SPECIAL bench bench-name bench-gc-flag))
  ;1; Use multiple-bench to run benchmark together where order is important *
  (COND ((EQ (CAR bench) 'multiple-bench)
	 (LOOP for benchmark in (CDR bench) do
	       (LET ((bench-name (CAR benchmark))
		     (bench (CDR benchmark))
		     (bench-gc-flag nil))
		 (DECLARE (SPECIAL bench bench-name bench-gc-flag))
		 (run-gabriel-benchmark))))
	((EQ (CAR bench) 'IGNORE) nil)
	(t (PRINT bench-name)
	   (LET-IF (AND (EQ bench-gc-flag 'no-gc) (PRINC 'no-gc))
		   ((benchmark-area working-storage-area))
	     (LET ((*package* (symbol-package (car bench))))
	       (record-benchmark (bench-name #+explorer ((:extra-pdl (area-size si:extra-pdl-area))))
		 (APPLY (CAR bench) (CDR bench)))))))
  (WHEN (EQ bench-gc-flag 'gc)
    (PRINC 'gc)
    (IF *allow-temporary-area* 
	(si:reset-temporary-area benchmark-area)
      (do-tgc))))