;;; -*- Mode:LISP; Package:VERIFICATION-INTERNALS; Base:10; Readtable:CL -*-

;;; Copyright LISP Machine, Inc. 1984
;;;   See filename "Copyright" for
;;; licensing and release information.

(defun map-with-line-in (f filename &optional cons-lines?)
  (with-open-file (stream filename)
    (do ((line-number 0 (1+ line-number))
	 (string)
	 (eofp))
	(())
      (multiple-value (string eofp) (send stream :line-in (not cons-lines?)))
      (cond (eofp
	     (if (= (string-length string) 0)
		 (return ())
	       (return (funcall f line-number string)))))
      (or (funcall f line-number string)
	  (return ())))))

;; Parse comments in a file which look like the following:
; Running BOYER benchmark
; TIMIT NORMAL looping 1 time is ok.
; realtime of 52.1 second
; disk wait time of 6.715 second


(defun first-of-string-match-and-snarf (first string)
  (let ((n (string-length first)))
    (if (string-equal first string 0 0 n n)
	(si:read-from-string string nil n))))


(defun string-matchp (string1 string2)
  (if (string-search "*" string1)
      (string-matchp-1 string1 0 (string-length string1)
			string2 0 (string-length string2))
    (string-equal string1 string2)))

(defun string-matchp-1 (string1 i1 n1 string2 i2 n2)
  (prog ()
	loop
	(if (and (= i1 n1) (= i2 n2)) (return t))
	(if (= i1 n1) (return nil))
	(if (= i2 n2) (go check-star))
	(when (char-equal (aref string1 i1) (aref string2 i2))
	  (setq i1 (1+ i1) i2 (1+ i2))
	  (go loop))
	check-star
	(if (char-equal (aref string1 i1) #\*)
	    (cond ((= (1+ i1) n1) (return t))
		  ((= i2 n2) (return nil))
		  ((string-matchp-1 string1 (1+ i1) n1 string2 (1+ i2) n2)
		   (return t))
		  ((string-matchp-1 string1 i1 n1 string2 (1+ i2) n2)
		   (return t))
		  ('else
		   (setq i1 (1+ i1))
		   (go loop)))
	    (return nil))))

(defun digest-rpg-benchmark-file (name &optional output-name)
  (let ((all-results nil)(a-result nil)(looping-count))
    (map-with-line-in
      #'(lambda (line-number string) line-number
		(let (temp)
		  (cond ((and (> (string-length string) 0)
			      (char= #\; (aref string 0)))
			 (cond ((setq temp (first-of-string-match-and-snarf
					     "; Running "
					     string))
				(setq looping-count nil)
				(and a-result (push a-result all-results))
				(setq a-result (list temp)))
			       ((string-matchp "; * * looping * time* is ok.*" string)
				(setq looping-count (parse-number string
								  (+ (string-length "looping ")
								     (string-search "looping "
										    string)))))
			       ((setq temp (first-of-string-match-and-snarf
					     "; realtime of "
					     string))
				(push (/ temp looping-count)
				      (get a-result :real-time)))
			       ((setq temp (first-of-string-match-and-snarf
					     "; disk wait time of "
					     string))
				(push (/ temp looping-count)
				      (get a-result :disk-wait-time)))))))
		t)
      name)
    (and a-result (push a-result all-results))
    (setq all-results (nreverse all-results))
    (mapc #'(lambda (x)
	      (setf (get x :real-time) (nreverse (get x :real-time))))
	  all-results)
    (mapc  #'(lambda (x)
	      (setf (get x :disk-wait-time) (nreverse (get x :disk-wait-time))))
	   all-results)
    (if output-name
	(with-open-file (stream output-name :out)
	  (print-rpg-benchmark-digest all-results stream)))
    all-results))

(defun print-rpg-benchmark-digest (digest &optional (stream standard-output))
  (format stream "~&~17<Benchmark/subrun~;~>~17<~;Real-Time~;~>~
                  ~17<~;Disk-Wait-Time~;~> ~17<~;Difference~;~>~%")
  (do ((l digest (cdr l)))
      ((null l))
    (let ((b (car l)))
      (format stream "~17A~%" (car b))
      (do ((j 1 (1+ j))
	   (dw (get b :disk-wait-time) (cdr dw))
	   (rt (get b :real-time) (cdr rt)))
	  ((null dw))
	(format stream "~10D             ~17S ~17S ~17S~%"
		j (car rt) (car dw) (- (car rt) (car dw)))))))


;; the filesystem with the output files went down, but the digest files
;; are still available, so now we get more ad-hoc file parsing functions.

(defun check-digest-file-head (stream string)
  (or (string-equal string (read stream))
      (ferror nil "not a benchmark digest file: ~S" stream)))

;(defun read-digest-file (filename)
;  (with-open-file (stream filename)
;    (read-digest-file stream "Benchmarksubrun")
;    (read-digest-file stream "Real-Time")
;    (read-digest-file stream "Disk-Wait-Time")
;    (read-digest-file stream "Difference")
;    (do ((test-name)(tests))
;	((null (setq test-name (read stream nil)))
;	 (nreverse tests))
;      
;      (let ((j (read stream nil)))
;	(if (null j) (return (nreverse tests)))
;	(

;(defun compare-digest-files (filename1 filename2 filename3)

(defun print-digest-to-file (exp filename)
  (let* ((p (fs:parse-pathname filename))
	 (n (send p :name))
	 (s1 (intern (string-append "*" n "-BENCHMARK-DIGEST*") "USER"))
	 (s2 (intern (string-append "*" n "-BENCHMARK*") "USER"))
	 (package (pkg-find-package "USER")))
    (with-open-file (stream filename :out)
      (format stream ";;-*-mode:lisp;package:user-*-~%")
      (format stream "(or (boundp '*benchmark-result-symbols*)~
                    ~%    (setq *benchmark-result-symbols* nil))~
                    ~%(or (memq '~S *benchmark-result-symbols*)~
                    ~%    (push '~S *benchmark-result-symbols*))~%~%"
	      s2 s2)
      (print `(defconst ,s1 ',(mapcar #'(lambda (test) (cons (intern (string (car test)))
							     (cdr test)))
				      exp))
		stream)
      (print `(defconst ,s2 ',(mapkan #'(lambda (plist)
					  (do ((name (car plist))
					       (reals (get plist :real-time) (cdr reals))
					       (disks (get plist :disk-wait-time) (cdr disks))
					       (result nil
						       `((,(intern (format nil "~A-~D"
									   name j))
							  ,(- (car reals) (car disks)))
							 ,@result))
					       (j 1 (1+ j)))
					      ((null reals) (nreverse result))))
				      exp))
	     stream))))


(defun call-on-open-file-if-filename (f filename &rest l)
  (if filename
      (with-open-file (stream filename :out)
	(lexpr-funcall f stream l))
    (lexpr-funcall f standard-output l)))

(defun print-benchmark-results (sym1 sym2 &optional filename)
  (call-on-open-file-if-filename
    #'(lambda (stream sym1 sym2)
	(print-benchmark-results-to-stream sym1 sym2 stream))
    filename
    sym1
    sym2))

(defun various-combinations (elements &aux result)
  (dolist (a elements)
    (dolist (b elements)
      (or (eq a b)
	  (push (cons a b) result))))
  result)

(defun print-various-benchmark-results (symbols &optional filename)
  (call-on-open-file-if-filename
    #'(lambda (stream symbols)
	(do ((l (various-combinations symbols) (cdr l)))
	    ((null l))
	  (print-benchmark-results-to-stream (caar l) (cdar l) stream)
	  (or (eq stream standard-output) (null l) (send stream :tyo #\form))))
    filename
    symbols))


(defconst *print-results-rev-args? nil)


(defun print-a-result-menu ()
  (print-benchmark-results-to-stream (tv:menu-choose user:*benchmark-result-symbols*)
				      (tv:menu-choose user:*benchmark-result-symbols*)
				      standard-output))



(defun print-results-menu (picks filename)
  (with-open-file (stream filename :out)
    (dotimes (j picks)
      (print-benchmark-results-to-stream (tv:menu-choose user:*benchmark-result-symbols*)
					 (tv:menu-choose user:*benchmark-result-symbols*)
					 stream)
      (send stream :tyo #\form))))

(defun print-benchmark-results-to-stream (sym1 sym2 stream)
  (if *print-results-rev-args?
      (setq sym1 (prog1 sym2 (Setq sym2 sym1))))
  (let ((b1 (symeval sym1))
	(b2 (symeval sym2))
	(psym1 (pretty-benchmark-name sym1))
	(psym2 (pretty-benchmark-name sym2))
	(1-wins 0)
	(2-wins 0))
    (format stream "~&Comparision of ~A and ~A~%~
                  ~%~17<~;test~;~>~25<~;~A~>~
                  ~25<~;~A~>~10<~;ratio~;~>~%~%"
	    psym1 psym2 psym1 psym2)
    (do ((l (union (mapcar #'car b1) (mapcar #'car b2)) (cdr l)))
	((null l))
      (let* ((t1 (cadr (assq (car l) b1)))
	     (t2 (cadr (assq (car l) b2)))
	     (ratio (catch-error (/ t1 t2) nil)))
	(cond ((null ratio))
	      ((> ratio 1.0)
	       (incf 2-wins))
	      ((< ratio 1.0)
	       (incf 1-wins)))
	(format stream "~17<~;~A~;~>~3,1,20$~3,1,25$~2,1,13$~%"
		(car l) t1 t2 ratio)))
    (format stream "~2%~40@A: ~2D wins.~%~40@A: ~2D wins.~%"
	    psym1 1-wins psym2 2-wins)))

(special verify-output-file-info)

(defun verify-output-file-info (filename)
  (let ((verify-output-file-info (list 'verify-output-file-info)))
    (map-with-line-in
      #'(lambda (line-number string)
	  (let (temp)
	    (cond ((= line-number 1)
		   (putprop verify-output-file-info
			    (substring string 1)
			    :time-string)
		   (putprop verify-output-file-info
			    (time:parse-universal-time (get verify-output-file-info
							    :time-string))
			    :universal-time)
		   t)
		  ((setq temp (string-search "micro-timing-ram" string))
		   (multiple-value (nil temp) (si:read-from-string string nil temp))
		   (putprop verify-output-file-info
			    (let ((ibase 10.))
			      (si:read-from-string string nil temp))
			    :micro-timing-ram))
		  ((setq temp (string-search "system" string))
		   (multiple-value (nil temp) (si:read-from-string string nil temp))
		   (putprop verify-output-file-info
			    (si:read-from-string string nil temp)
			    :system-version)
		   t)
		  ((setq temp (string-search "extra-filename-information" string))
		   (multiple-value (nil temp) (si:read-from-string string nil temp))
		   (putprop verify-output-file-info
			    (si:read-from-string string nil temp)
			    :extra-filename-information))
		  ((setq temp (string-search "microcode" string))
		   (multiple-value (nil temp) (si:read-from-string string nil temp))
		   (putprop verify-output-file-info
			    (let ((ibase 10.))
			      (si:read-from-string string nil temp))
			    :microcode-version)
		   nil)
		  ('else t))))
      filename)
     verify-output-file-info))

(defun construct-filename-from-info (info)
  (let ((basic (multiple-value-bind (nil nil nil day month)
		   (time:decode-universal-time (get info :universal-time))
		 (format nil "S~D-U~D-~A~D"
			 (fix (or (let ((tem (get info :system-version)))
				    (and (numberp tem)
					 tem))
				  0))
			 (get info :microcode-version)
			 (time:month-string month :short)
			 day))))
    (if (get info :micro-timing-ram)
	(setq basic (format nil "~A-T~D~D"
			    basic
			    (car (get info :micro-timing-ram))
			    (cadr (get info :micro-timing-ram)))))
    (if (get info :extra-filename-information)
	(setq basic (string-append basic "-" (get info :extra-filename-information))))
    basic))

(defun digest-consistently (input-filename output-default)
  "Generate the output filename using microcode version number from input file"
  (let ((pathname (send (fs:parse-pathname output-default)
			:new-name
			(construct-filename-from-info (verify-output-file-info input-filename)))))
    (print-digest-to-file (digest-rpg-benchmark-file input-filename
						     (send pathname :new-type "TEXT"))
			  (send pathname :new-type "LISP"))))




(defvar user:*benchmark-result-symbols* nil)

(defun print-results-vs (&optional symbol filename)
  (or symbol (setq symbol (tv:menu-choose user:*benchmark-result-symbols*)))
  (call-on-open-file-if-filename
    #'(lambda (stream symbol)
	(dolist (sym user:*benchmark-result-symbols*)
	  (cond ((not (eq sym symbol))
		 (print-benchmark-results-to-stream sym symbol stream)
		 (formfeed-if-needed-between-marks stream sym)))))
    filename
    symbol))

(defun formfeed-if-needed-between-marks (stream sym)
  (if (and (not (eq stream standard-output))
	   (not (eq sym (car (last user:*benchmark-result-symbols*)))))
      (send stream :tyo #\form)))

(defun digest-consistently-map (input-filename-pattern output-default)
  (dolist (file (mapcar #'car (cdr (fs:directory-list input-filename-pattern))))
    (format t "~&;Digesting ~S~%" file)
    (digest-consistently file output-default)))


(defun load-map (filename-pattern)
  "for loading the data files out of the data directory"
  (dolist (file (mapcar #'car (cdr (fs:directory-list filename-pattern))))
    (load file))
  (hack-incore-data))

(defun all-benchmark-names ()
  (union ()
	 (mapkan #'(lambda (sym) (mapcar #'car (symeval sym)))
		  user:*benchmark-result-symbols*)))

(defun print-ratios-vs (&optional symbol filename)
  (or symbol (setq symbol (tv:menu-choose user:*benchmark-result-symbols*)))
  (call-on-open-file-if-filename
    #'(lambda (stream symbol)
	(let ((all-benchmarks (all-benchmark-names)))
	  (format stream "~&~15<~;Test~>~25<~;~A~>~%~%" (pretty-benchmark-name symbol))
	  (dolist (b all-benchmarks)
	    (format stream "~15<~;~A~>~2,1,25$~%" b (cadr (assq b (symeval symbol)))))
	  (formfeed-if-needed-between-marks stream nil)
	  (dolist (sym user:*benchmark-result-symbols*)
	    (cond ((not (eq sym symbol))
		   (format stream "~&~20<~;~A~>~%" (pretty-benchmark-name sym))
		   (dolist (b all-benchmarks)
		     (format stream "~2,1,20$~%"
			     (catch-error (/ (cadr (assq b (symeval sym)))
					     (cadr (assq b (symeval symbol))))
					  nil)))
		   (formfeed-if-needed-between-marks stream nil))))))
    filename
    symbol))


(defun pretty-benchmark-name (symbol)
  (let ((s (string-trim "*" symbol)))
    (let ((n (string-search "-BENCHMARK" s)))
      (if n
	  (substring s 0 n)
	s))))


;; a word-count generator for lisp code.
;; Doesn't walk code or anything, just crude and fast reading.
;; could get away without reading too given the semantics.

(defun lisp-word-count-stream (input-stream output ignore)
  (do ((wc nil (word-count-form form wc))
       (form))
      ((eq (setq form (read input-stream input-stream)) input-stream)
       (print-word-count-results wc output)
       wc)))

(defun lisp-word-count (filename &optional (output ""))
  (verify-file filename
	       :terminal-stream nil
	       :output-filename output
	       :driver 'lisp-word-count-stream))

(defun lisp-word-count-map (filename)
  (mapcar #'lisp-word-count (mapcar #'car (cdr (fs:directory-list filename)))))

(defun word-count-form (form alist)
  (prog ()
	loop
	   (cond ((atom form)
		  (cond ((symbolp form)
			 (let ((cell (assq form alist)))
			   (cond ((null cell)
				  (return (cons (cons form 1) alist)))
				 ('else
				  (setf (cdr cell) (1+ (cdr cell)))
				  (return alist)))))
			(t (return alist))))
		 ('else
		  (setq alist (word-count-form (car form) alist))
		  (setq form (cdr form))
		  (go loop)))))


(defun sorted-alist-by-package (alist)
  (do ((sorted ())
       (l alist (cdr l)))
      ((null l)
       (sort
	 (mapc #'(lambda (x)
		   (setf (cdr x) (sort (cdr x) #'(lambda (a b) (> (cdr a) (cdr b))))))
	       sorted)
	 #'(lambda (x y) (string-lessp (package-name (car x))
				       (package-name (car y))))))
      (let ((cell (assq (symbol-package (caar l)) sorted)))
	(if cell
	    (push (car l) (cdr cell))
	  (push (list (symbol-package (caar l)) (car l)) sorted)))))


(defun print-word-count-results (wc stream)
  (dolist (x (sorted-alist-by-package wc))
    (format stream "~&~%Symbols in Package: ~A~%" (car x))
    (let ((max-width 0))
      (dolist (y (cdr x))
	(setq max-width (max (string-length (car y)) max-width)))
      (dolist (y (cdr x))				
	(format stream "~V@A ~3D~%" max-width (car y) (cdr y))))))


(defun late-model-data-p (sym &aux ind num)
  ;; as of 3/14/85 21:18:15 i have added the looping <n> feature to
  ;; the results parser, but not enabled that as the way the looping
  ;; is actually done.
  (let ((s (get-pname sym)))
    (and (string-equal "*S" s :start1 0 :end1 2 :start2 0 :end2 2)
	 (or (and (> (setq num (parse-number s 2 (setq ind (string-search "-" s)))) 98.)
		  (< num 104.))
	     (and (= num 98.)
		  (>= (parse-number s (+ 2 ind) (string-search "-" s (1+ ind))) 726.))))))

(defun hack-incore-data ()
  (dolist (sym user:*benchmark-result-symbols*)
    (when (string-matchp "*S*-U*-*-U*-BENCHMARK*" (get-pname sym))
      (dolist (elem (symeval sym))
	(unless (memq :mashed elem)
	  (let* ((name (get-pname (car elem)))
		 (index (string-search "U-" name)))
	    (setf (car elem)
		  (intern (string-append (substring name 0 index)
					 (substring name (1+ index)))
			  "USER"))
	    (nconc elem (list :mashed))))))
    (when (late-model-data-p sym)
      (dolist (elem (symeval sym))
	(unless (memq :hacked elem)
	  (let ((amount (cadr (assq (car elem)
				    'user:((frpoly-1 0.01)
					   (frpoly-2 0.01)
					   (frpoly-3 0.01)
					   (frpoly-4 0.10)
					   (frpoly-5 0.10)
					   (frpoly-6 0.10))))))
	    (when amount
	      (setf (cadr elem) (times amount (cadr elem)))
	      (nconc elem (list :hacked)))))))))



(defun combine-best (name &optional
		     (s1 (tv:menu-choose user:*benchmark-result-symbols*))
		     (s2  (tv:menu-choose user:*benchmark-result-symbols*)))
  (let ((symbol (intern (string-append "*" name "-BENCHMARK*") "USER"))
	(l1 (symeval s1))
	(l2 (symeval s2))
	(result))
    (dolist (elem l1)
      (let ((cell (assq (car elem) l2)))
	(cond ((null cell)
	       (push elem result))
	      ((< (cadr cell) (cadr elem))
	       (push cell result))
	      ('else
	       (push elem result)))))
    (dolist (elem l2)
      (unless (assq (car elem) result)
	(push elem result)))
    (set symbol (reverse result))
    (pushnew symbol user:*benchmark-result-symbols*)
    symbol))



(defun edit-benchmark (name)
  (let ((symbol (intern (string-append "*" name "-BENCHMARK*") "USER")))
    (format t "~&Editing value of ~S~%" symbol)
    (dolist (elem (symeval symbol))
      (let ((key (car elem))
	    (value (cadr elem)))
	(WITH-INPUT-EDITING (T `((:INITIAL-INPUT ,(FORMAT NIL "~D" VALUE))))
	    (SETQ VALUE (PROMPT-AND-READ '(:number :input-radix 10)
					 "Change ~A result from ~D to: " key value))
	    (setf (cadr elem) value))))))