;;; -*-Mode:Common-Lisp; Package:System-Internals; Base:8.-*-

;;;
;;;                           RESTRICTED RIGHTS LEGEND
;;;
;;;Use, duplication, or disclosure by the Government is subject to
;;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in
;;;Technical Data and Computer Software clause at 52.227-7013.
;;;
;;;                     TEXAS INSTRUMENTS INCORPORATED.
;;;                              P.O. BOX 2909
;;;                           AUSTIN, TEXAS 78769
;;;                                 MS 2151
;;;
;;; Copyright (C) 1989 Texas Instruments Incorporated. All rights reserved.
;;;
;;; Change history:
;;;
;;;  Date       Author        Description
;;; -------------------------------------------------------------------------------------
;;; 03/29/88	jho		original

(DefEnum SubMeter-Elements (Q-corresponding-variable-lists
		     System-Constant-Lists)
  (
   %FUNCTION-KEY
   %TOTAL-TIME-1
   %TOTAL-TIME-2
   %DISK-TOTAL-TIME-1
   %DISK-TOTAL-TIME-2
   %GC-TOTAL-TIME-1
   %GC-TOTAL-TIME-2
   %TOTAL-CONS-WORK-1
   %TOTAL-CONS-WORK-2
   %TOTAL-PAGES-READ-1
   %TOTAL-PAGES-READ-2
   %TOTAL-SCAVENGER-WORK-1
   %TOTAL-SCAVENGER-WORK-2
   %SUBMETER-SPARE-ENTRY-1
   %SUBMETER-SPARE-ENTRY-2		;; To adjust length to 16. (power of 2)
   %CALL-COUNT
   %SUBMETER-LENGTH
   ))


(DefEnum SUBMETER-SORTS (Q-corresponding-variable-lists
		     System-Constant-Lists)
  (
   %METER-FUNCTION
   %METER-COUNT
   %METER-TOTAL-TIME
   %METER-CPU-TIME
   %METER-DISK-TOTAL-TIME
   %METER-GC-TOTAL-TIME
   %METER-TOTAL-CONS-WORK
   %METER-TOTAL-PAGES-READ
   %METER-TOTAL-SCAVENGER-WORK
   %SUBMETER-SORT-LENGTH
   ))

(DefAlternate Meter-Enables (Q-corresponding-variable-lists
                             System-Constant-Lists)
    (%%METER-PAGE-FAULT-ENABLE 0001			;Page fault metering
     %%METER-CONS-ENABLE 0101			;Cons metering
     %%METER-FUNCTION-ENTRY-EXIT-ENABLE 0201		;Function call metering
     %%METER-STACK-GROUP-SWITCH-ENABLE 0301		;Stack group metering
     %%SUB-METER-ENABLE 0401				; Do sub-metering
     %%SUB-METER-RESTART 0501				;   Restart metering
     )
  )
;; SUBMETER-HASH-TABLE will be wired but not in the cache.
;;  To have this in the cache could affect the timing of
;;  other functions.
;;  We already have this table in Virtual Memory.  Not quite
;;  sure of this impact.

(DEFVAR SUBMETER-HASH-TABLE NIL)

(DEFVAR SUBMETER-SORTED-ARRAY NIL)

(DEFVAR SUBMETER-TOTALS NIL)

(DEFVAR SUBMETER-ENTRY-COUNT NIL)

(DEFVAR SUBMETER-SORT 0)

(DEFVAR SUBMETER-AREA
	(MAKE-AREA :NAME 'SUBMETER
	     :GC :STATIC))

(DEFVAR SUBMETER-STRINGS
	(MAKE-ARRAY %SUBMETER-SORT-LENGTH
		    :type 'ART-Q
		    :INITIAL-CONTENTS
		    '("empty slot"
		       "Times Called"
		       "Total Real Time"
		       "Total CPU Time"
		       "Total Disk Time"
		       "Total GC Time"
		       "Total Qs Consed"
		       "Total Pages Read"
		       "Total Qs Scavenged"
		      )))

(DEFVAR submetered-objects nil "List of objects being submetered.")

(DEFUN SUBMETER-INITIALIZE (&KEY (FUNCTIONS 2048.) (ITEMS '(T)))
  "Creates the data structures needed to support submetering.
 Once SUBMETER-INITIALIZE is exectuted, submetering starts with
 submeter-enable and stops with submeter-disable.

 FUNCTIONS specifies the approximate number of functions
 that will be metered.  A hash table overflow will occur if more
 functions than FUNCTIONS are attempted.  One should attempt
 to make FUNCTIONS a power of 2 and large enough such that the actual 
 number of functions metered approximates 60% or less of FUNCTIONS.

 ITEMS is T (DEFAULT) for metering all processes or a list
 of stack groups or processes to meter."
  (SETF SUBMETER-HASH-TABLE
	(MAKE-HASH-ARRAY :size FUNCTIONS :area SUBMETER-AREA :number-of-values (- %SUBMETER-LENGTH 1)
			 :actual-size FUNCTIONS
			 ))
  (SETF SUBMETER-TOTALS
	(MAKE-ARRAY %SUBMETER-SORT-LENGTH :initial-element 0))
  (SETF SUBMETER-SORT 0)
  (SETF SUBMETER-SORTED-ARRAY NIL)
  (SETF SUBMETER-ENTRY-COUNT FUNCTIONS)
  (WIRE-ARRAY SUBMETER-HASH-TABLE)
  (SETF submetered-objects nil)
  
  (DOLIST (thing items)
    (IF (EQ thing t)
	(SETQ si:%meter-global-enable t)
	(SETQ thing (meter:enable-stack-group thing 1)))
    (PUSHNEW thing submetered-objects))
  
  (Setq si:%meter-buffer-pointer submeter-hash-table)
  )
  

(DEFUN SUBMETER-REPORT (&KEY sort brief verbose)
  "Analyzes the results of submetering.
   Sorts the data generated based on the keyword argument :SORT.
   Values of :SORT (default %METER-CPU-TIME) can be:

   1	%METER-COUNT		       Number of times a function was called
   2	%METER-TOTAL-TIME	       Actual Real time spent in the function
   3 	%METER-CPU-TIME		       Raw CPU time
   4	%METER-DISK-TOTAL-TIME	       Paging Disk time
   5	%METER-GC-TOTAL-TIME	       GC time
   6	%METER-TOTAL-CONS-WORK	       Number of Qs consed while in the function
   7	%METER-TOTAL-PAGES-READ	       Number of pages read 
   8	%METER-TOTAL-SCAVENGER-WORK    Number of Qs scavenged

   Keyword :BRIEF if T will only print the top 75% of SORT.
		  if NIL will print all.
		  if x will only print top x%.
   Keyword :VERBOSE if T still sorts based on SORT but prints the
             		other pieces of data.

  Most common form of execution (SUBMETER-ANALYZE :verbose t :brief t)
  which is roughly equivalent to what we would want from each other."
  
  (when (not sort)
    (setf sort %METER-CPU-TIME))
  
  (if (numberp brief)
      (setf brief (/ brief 100.))
      (if brief
	  (setf brief .75)
	  (setf brief 1)))
  
  
  (If (or (> sort (- %submeter-sort-length 1))
	  (< sort %meter-count)) 
      
      (FERROR "Meter sort argument is beyond range.  See a value of the list %submeter-sort.")
      (progn
	(WHEN (NOT SUBMETER-SORTED-ARRAY)
	  (initialize-intermediate-array))
	(WHEN (NOT (= SUBMETER-SORT SORT))
	  (setf SUBMETER-SORT SORT)
	  (setf submeter-sorted-array
		(sort-grouped-array-group-key submeter-sorted-array
					      %submeter-sort-length
					      #'submeter-predicate))
	  )
	(do* ((base-index 0 (+ base-index %SUBMETER-SORT-LENGTH))
	      (function-index 1 (1+ function-index))
	      (percentage
		(if (or (= 0 (aref submeter-totals SORT))
			(= base-index (fill-pointer submeter-sorted-array)))
		    0
		    (/ (aref submeter-sorted-array (+ base-index SORT))
		       (aref submeter-totals SORT)))
		(if (or (= 0 (aref submeter-totals SORT))
			(= base-index (fill-pointer submeter-sorted-array)))
		    0
		    (/ (aref submeter-sorted-array (+ base-index SORT))
		       (aref submeter-totals SORT))))
	      (cum-percentage 0)
	      )
	     ((or
		(= base-index (fill-pointer submeter-sorted-array))
		(> (+ cum-percentage percentage) brief)))
	  (format t
		  "~%~% ~:d ~2@T ~s ~% ~2@T % ~3@T Cum. ~1@T ~a  ~35T Average"
		  function-index 
		  (aref submeter-sorted-array (+ base-index %METER-FUNCTION))
		  (aref submeter-strings SORT))
	  (format t "~% ~1@T ~4,2,2F ~9T ~4,2,2F ~16T ~:d  ~35T ~3$"
		  percentage
		  (setf cum-percentage (+ cum-percentage percentage))
		  
		  (aref submeter-sorted-array (+ base-index SORT))
		  (if (= 0 (aref submeter-sorted-array (+ base-index SORT)))
		      0
		      (/ (aref submeter-sorted-array (+ base-index SORT))
			 (if (= SORT %METER-DISK-TOTAL-TIME)
			     (aref submeter-sorted-array (+ base-index %METER-TOTAL-PAGES-READ))
			     (aref submeter-sorted-array (+ base-index %METER-COUNT))))))
	  (when verbose
	    (do ((x 1 (1+ x)))
		((= x %SUBMETER-SORT-LENGTH))
	      (when  (NOT (= SORT x))
		(format t "~%~45T~a: ~66T~:d"
			(aref submeter-strings x)
			(aref submeter-sorted-array (+ base-index x))))))
	  
	  )
	)      ))

(DEFUN submeter-predicate (array1 index1 array2 index2)
  (> (aref array1 (+ index1 submeter-sort))
     (aref array2 (+ index2 submeter-sort)))
  )

(DEFUN initialize-intermediate-array ()
  (WHEN SUBMETER-HASH-TABLE
    (setf submeter-sorted-array
	  (make-array (* SUBMETER-ENTRY-COUNT %submeter-sort-length)
		      :fill-pointer 0))
    (maphash #'record-meter-function submeter-hash-table)
    )
  )


(DEFUN RECORD-METER-FUNCTION  (FUNCTION TOTAL-TIME-1 TOTAL-TIME-2 TOTAL-DISK-1 TOTAL-DISK-2
			       TOTAL-GC-TIME-1 TOTAL-GC-TIME-2 TOTAL-CONS-1 TOTAL-CONS-2
			       TOTAL-PAGES-READ-1 TOTAL-PAGES-READ-2
			       TOTAL-SCAVENGER-WORK-1 TOTAL-SCAVENGER-WORK-2
			       SPARE-1 SPARE-2 COUNT)
  (let*((total-time (METER-TOTAL-TIME TOTAL-TIME-1 TOTAL-TIME-2))
	(gc-time (METER-TOTAL-TIME TOTAL-GC-TIME-1 TOTAL-GC-TIME-2))
	(disk-time (METER-TOTAL-TIME TOTAL-DISK-1 TOTAL-DISK-2))
	(cpu-time (- total-time (+ gc-time disk-time)))
	(cons-total (METER-TOTAL-TIME TOTAL-CONS-1 TOTAL-CONS-2))
	(pages-total (METER-TOTAL-TIME TOTAL-PAGES-READ-1 TOTAL-PAGES-READ-2))
	(scavenger-total (METER-TOTAL-TIME TOTAL-SCAVENGER-WORK-1 TOTAL-SCAVENGER-WORK-2)) 
	)
    
    (WHEN COUNT
      
      (VECTOR-PUSH-EXTEND FUNCTION SUBMETER-SORTED-ARRAY)
      (VECTOR-PUSH-EXTEND COUNT SUBMETER-SORTED-ARRAY)
      (VECTOR-PUSH-EXTEND total-time SUBMETER-SORTED-ARRAY)
      (VECTOR-PUSH-EXTEND cpu-time SUBMETER-SORTED-ARRAY)
      (VECTOR-PUSH-EXTEND disk-time SUBMETER-SORTED-ARRAY)
      (VECTOR-PUSH-EXTEND gc-time SUBMETER-SORTED-ARRAY)
      (VECTOR-PUSH-EXTEND cons-total SUBMETER-SORTED-ARRAY)
      (VECTOR-PUSH-EXTEND pages-total SUBMETER-SORTED-ARRAY)
      (VECTOR-PUSH-EXTEND scavenger-total SUBMETER-SORTED-ARRAY)
      
      ;; Now increment grand totals in array for percentage calculations later on
      (SETF (AREF SUBMETER-TOTALS %METER-COUNT)
	    (+ (AREF SUBMETER-TOTALS %METER-COUNT) COUNT))
      (SETF (AREF SUBMETER-TOTALS %METER-TOTAL-TIME)
	    (+ (AREF SUBMETER-TOTALS %METER-TOTAL-TIME) total-time))
      (SETF (AREF SUBMETER-TOTALS %METER-CPU-TIME)
	    (+ (AREF SUBMETER-TOTALS %METER-CPU-TIME) cpu-time))
      (SETF (AREF SUBMETER-TOTALS %METER-DISK-TOTAL-TIME)
	    (+ (AREF SUBMETER-TOTALS %METER-DISK-TOTAL-TIME) disk-time))
      (SETF (AREF SUBMETER-TOTALS %METER-GC-TOTAL-TIME)
	    (+ (AREF SUBMETER-TOTALS %METER-GC-TOTAL-TIME) gc-time))
      (SETF (AREF SUBMETER-TOTALS %METER-TOTAL-CONS-WORK)
	    (+ (AREF SUBMETER-TOTALS %METER-TOTAL-CONS-WORK) cons-total))
      (SETF (AREF SUBMETER-TOTALS %METER-TOTAL-PAGES-READ)
	    (+ (AREF SUBMETER-TOTALS %METER-TOTAL-PAGES-READ) pages-total))
      (SETF (AREF SUBMETER-TOTALS %METER-TOTAL-SCAVENGER-WORK)
	    (+ (AREF SUBMETER-TOTALS %METER-TOTAL-SCAVENGER-WORK) scavenger-total))
      )))
  

(DEFUN METER-TOTAL-TIME (x y)
;; y is number of max fixnums or nil.  x is remaider.
  (if y
      (+ x (* y #x1ffffff))
      x))

(DEFUN SUBMETER-ENABLE ()
  "Begins to meter all functions.  This function adds to (as opposed to 
starts over) the current function information."
  (IF (BOUNDP 'SUBMETER-HASH-TABLE)
      (progn 
	(setf submeter-sort 0)
	(setf submeter-sorted-array nil)

	(SETQ si:%meter-micro-enables (DPB 1 %%SUB-METER-ENABLE
					   (DPB 1 %%METER-FUNCTION-ENTRY-EXIT-ENABLE
						(DPB 1 %%SUB-METER-RESTART 0))))
	)
      (format t "~%~%Submetering cannot be enabled until submeter-initialize is executed")
      ))

(DEFUN SUBMETER-DISABLE ()
  "Turns off submetering for the time being.  To begin again (add to the
 current function information) execute SUBMETER-ENABLE."
  (SETQ si:%meter-micro-enables 0)
  (setf submeter-sort 0)
  (setf submeter-sorted-array nil)
  )

(DEFUN SUBMETER-RESET ()
  "Rids system of ALL current function information and submetering virtual memory.
  Enables one to begin anew in the submetering process"
  (SETQ si:%meter-micro-enables 0)
  (setf submeter-sort 0)
  (setf submeter-sorted-array nil)
  (setf submeter-hash-table nil)
  )

(defvar z 0)

(defvar test-time 0)

(defun count-test (x1)
  (dotimes (y x1)
    (counter)))

(defun counter ()
  (incf z))

(defun mega-count-test (x2)
  (without-interrupts
    (si:submeter-enable)
    (si:count-test x2)
    (si:submeter-disable)))

(defun mega-timer-test (x2)
  (without-interrupts
    (si:submeter-enable)
    (si:timer-test x2)
    (si:submeter-disable)))

(defun timer-test (x1)
  (dotimes (y x1)
    (timeit (:microseconds :collect test-time) (counter))))


(defun mega-total-time (var)
  (let ((c 0))
    (dolist (cpu var)
      (setf c (+  c (car cpu))))))

(defun mega-gc-test ()
  (without-interrupts
    (si:submeter-enable)
    (si:gc-immediately)
    (si:submeter-disable)))