;;-*- Mode:LISP; Package:(RPG-BENCHMARKS :USE (VERIFICATION-GLOBAL GLOBAL)); BASE:10 -*-
;; (C) Copyright 1983, Lisp Machine, Inc.

(EXPORT '("*FPRINT-TEST-FILE*"
	  "TIMER" "TIMER-WITHOUT-INTERRUPTS"
	  "DEFARRAY"))
 
;; (MAKE-SYSTEM "RPG-BENCHMARKS")
;; Should set you up to run the benchmarks, each in its own package.
;;
;; This is intended to be run on Lisp Machine Inc machines,
;; the "CADR" and the "LAMBDA" the fourty-bit "LAMBDA"
;; and on machines made by the competition.
;; This may get haired up so that multiple versions of
;; a benchmark may be loaded, since we will be concerned with the
;; use of different amounts of special instructions and microcompilation.
;; Keeping track of all the results could get pretty confusing.

;; These were all gotten by net mail:
;; 3-Oct-83 14:58:41-EDT,63835;000000000000
;; Date: 3 Oct 83  1153 PDT
;; From: Dick Gabriel <RPG@SU-AI>
;; To:   rg%oz@MIT-MC
;;


(DEFCONST *fprint-test-file* nil)

(defun setup-fprint-test-file ()
  (setq *fprint-test-file* (FS:MAKE-PATHNAME :HOST (send (send (fs:parse-pathname "SYS:VERIFY;")
								:host)
							  :host)
					     :DIRECTORY "TMP"
					     :NAME "FPRINT"
					     :TYPE "TST"))
  (FS:CREATE-DIRECTORY *fprint-test-file*))

(add-initialization "setup fprint test file"
		    '(setup-fprint-test-file)
		    '(now site))
		   

(DEFCONST *rpg-benchmarks*
	  `((BOYER  (TIMIT))
	    ((BROWSE "MOD" "RANDOM") (TIMIT))
	    (CTAK (TIMIT))
	    (DDERIV (TIMIT))
	    (DERIV (TIMIT))
	    (DESTRU (TIMIT))
	    (DIV2 (TIMIT1) (TIMIT2))
	    (FFT (TIMIT) (TIMIT$))
	    (FPRINT (TIMIT))
	    (FREAD (TIMIT))
	    (FRPOLY (bench 2)
		    (bench 5)
		    (bench 10.)
		    (bench 15.))
	    ((PUZZLE "REMOVE" "CLASS") (TIMIT))
	    (STAK (TIMIT))
	    (TAK (TIMIT))
	    (TAKL (TIMIT))
	    (TAKR (TIMIT))
	    (TPRINT (TIMIT))
	    ((TRAVERSE "SELECT" "MOD" "REMOVE" "RANDOM")
	     (INIT-TIMIT) (TIMIT))
	    ((TRIANG "SEQUENCE") (TIMIT))))


(defconst *rpg-ubenchmarks*
  '(
    ((TRAVERSEU "SELECT" "MOD" "REMOVE" "RANDOM")
     (INIT-TIMIT) (TIMIT))
    
    ((BOYERU ) (TIMIT))
    
    ((BROWSEU "MOD" "RANDOM") (TIMIT))
    
;    (DDERIVU (TIMIT))
    (DERIVU (TIMIT))
    (DESTRUU (TIMIT))
    
    (DIV2U (TIMIT1) (TIMIT2))
    
    (FFTU (TIMIT) (TIMIT$))
    ((PUZZLEU "REMOVE" "CLASS") (TIMIT))
    (STAKU (TIMIT))
    
    (TAKU (TIMIT))
    (TAKLU (TIMIT))
;    (TAKRU (TIMIT))
    ((TRIANGU "SEQUENCE") (TIMIT))
    (FRPOLYU (bench 2)
		    (bench 5)
		    (bench 10.)
		    (bench 15.))

    ))


;;;	      '((MARLEEN (REVA) (REVB) (REVC) (ACKER-3-3)
;;;			 (ACKER-3-4) (ACKERT-3-3) (ACKERT-3-4))))

(defvar *timer-argl* ())

(defmacro timer (name form . args)
  `(progn'compile
     (verify:deftest ,name
		     :inputs ,(do ((l args (cdr l))
				   (j 0 (1+ j))
				   (v () (cons `(,(car l) (nth ,j *timer-argl*)) v)))
				  ((null l) (nreverse v)))
		     :outputs (the-output)
		     :code (setq the-output ,form))
     (defun ,name ,args
       (let ((*timer-argl* (list ,@args)))
	 (verify:run-test ',name))
       (verify:tvar the-output ,name))))

(defmacro timer-without-interrupts (name form . args)
  `(progn'compile
     (verify:deftest ,name
		     :inputs ,(do ((l args (cdr l))
				   (j 0 (1+ j))
				   (v () (cons `(,(car l) (nth ,j *timer-argl*)) v)))
				  ((null l)
				   (cons (list 'si:inhibit-scheduling-flag t)
					 (nreverse v))))
		     :outputs (the-output)
		     :code (setq the-output ,form))
     (defun ,name ,args
       (let ((*timer-argl* (list ,@args)))
	 (verify:run-test ',name))
       (verify:tvar the-output ,name))))

(defmacro defarray (name type &rest sizes)
  ;; this is our answer to the maclisp style function-style
  ;; array declaration. e.g. (ARRAY FOO T 100)
  ;; which makes (FOO 9) somewhat more fast to access
  ;; than (arraycall t *some-array-object* j).
  ;; 
  `(progn 'compile
	  (defprop ,name t meta-eval:no-setq)
	  (defmacro ,name (&rest l) `(aref ,',name ,@l))
	  (defconst ,name (*array nil ',type ,@sizes))))

(defun create-the-packages ()
  (mapc #'(lambda (x)
	    (let ((pkg-name (string-append "BENCH-" (if (atom (car x))
							(car x)
						      (caar x))))
		  (PKG-SHADOWS (IF (ATOM (CAR X))
				   ()
				 (CDAR X))))
	      (EVAL `(DEFPACKAGE ,PKG-NAME
		       :USE ("RPG-BENCHMARKS" "GLOBAL")
		       :SHADOW ,PKG-SHADOWS))))
	(append *rpg-benchmarks* *rpg-ubenchmarks*)))


(create-the-packages)

(defun create-the-defsystem (what)
  (let* ((name (intern (string-append "RPG-" what "MARKS")))
	 (list (symeval (intern (string-append "*" name "*"))))
	 (b (mapcar #'(lambda (x) (if (atom (car x)) (car x) (caar x)))
		    list)))
    (eval `(defsystem ,name
	     (:pathname-default "sys:verify;bench;")
	     (:patchable "sys:verify;object;" ,what)
	     ,@(mapcar #'(lambda (x) `(:module ,x ((,(get-pname x)
						    ,(format nil "sys:verify;object;~A qfasl"
							     x)))))
		       b)
	     ,@(mapcar #'(lambda (x) `(:compile-load ,x))
		       b)))))

(compile'create-the-defsystem)

(create-the-defsystem "BENCH")

(create-the-defsystem "UBENCH")

(defun run-rpg-benchmarks ()
  (mapc #'run-rpg-benchmark *rpg-benchmarks*))

(defun run-rpg-benchmark (x &aux (name (if (atom (car x))
					   (car x)
					 (caar x))))
  (format standard-output "~&; Running ~A benchmark~%" name)
  (mapc #'(lambda (y)
	    (let ((s (with-output-to-string (ss)
		       (print y ss))))
	      (format standard-output "~A ==> " s)
	      (let ((package (pkg-find-package (string-append "BENCH-" name))))
		(print (eval (read-from-string s))))))
	(cdr x)))

(compile 'run-rpg-benchmark)

(defun run-rpg-ubenchmarks ()
  (mapc #'run-rpg-ubenchmark *rpg-ubenchmarks*))

(defun run-rpg-ubenchmark (x &aux (name (if (atom (car x))
					   (car x)
					 (caar x))))
  (format standard-output "~&; Running ~A benchmark~%" name)
  (mapc #'(lambda (y)
	    (let ((s (with-output-to-string (ss)
		       (print y ss))))
	      (format standard-output "~A ==> " s)
	      (compiler:ma-reset)
	      (let ((package (pkg-find-package (string-append "BENCH-" name))))
		(eval (read-from-string "(load-ucode)"))
		(format t "~%ucode loaded")
		(print (eval (read-from-string s))))))
	(cdr x)))

(compile 'run-rpg-ubenchmark)

(defun rpg (name &optional ucoded?)
  (do ((l (if ucoded? *rpg-ubenchmarks* *rpg-benchmarks*) (cdr l)))
      ((null l) "benchmark not found")
    (let ((b (car l)))
      (if (if (atom (car b))
	      (string-equal (car b) name)
	    (string-equal (caar b) name))
	  (return (funcall (if ucoded? 'run-rpg-ubenchmark 'run-rpg-benchmark) b))))))

(compile 'rpg)

(defun what-rpg ()
  (grind-top-level (cons  '*rpg-benchmarks* *rpg-benchmarks*))
  (grind-top-level (cons '*rpg-ubenchmarks*  *rpg-ubenchmarks*)))