;;; -*- Mode:LISP; Package:Meter -*-
;;; Metering information analyzer

(DEFVAR BUFFER-ARRAY)				;Buffer for microcode to write out of
(DEFVAR BUFFER)					;Actual read-out buffer
(DEFVAR BUFFER-ADDRESS)				;Offset of page in meter buffer
(DEFVAR DISK-PARTITION-LENGTH)			;Length of disk count
(DEFVAR DISK-PARTITION-START)			;Origin of disk address
(DEFVAR DISK-RQB)				;Disk request block
(DEFVAR NEXT-DISK-BLOCK)			;Next disk block to return

;;; Maps over the data in buffers
(DEFMACRO DO-OVER-DATA (VAR-LIST END-FORMS &BODY BODY)
  `(MULTIPLE-VALUE-BIND (BUF INDEX)
       (FRAME-SETUP)
     (DO ,VAR-LIST
	 ((NULL BUF) . ,END-FORMS)
       ,@BODY
       (MULTIPLE-VALUE (BUF INDEX)
	 (NEXT-FRAME BUF INDEX)))))

;;; Metering enable functions
(DEFUN BUFFER-RESET ()
  (SETQ BUFFER-ARRAY (MAKE-ARRAY (* PAGE-SIZE 4) ':TYPE 'ART-16B))
  (MULTIPLE-VALUE (DISK-PARTITION-START DISK-PARTITION-LENGTH)
    (SI:FIND-DISK-PARTITION "METR"))
  (IF (NULL DISK-PARTITION-START)
      (FERROR NIL "No partition named METR to use for metering"))
  (STOP-GC-PROCESS)
  (SETQ BUFFER-ADDRESS (1+ (LOGIOR (%POINTER BUFFER-ARRAY)	;This is in Q's here
				   (1- PAGE-SIZE))))
  (SI:WIRE-PAGE BUFFER-ADDRESS)
  (SETQ BUFFER (MAKE-ARRAY (* PAGE-SIZE 2)
			   ':TYPE 'ART-16B
			   ':DISPLACED-TO BUFFER-ARRAY
			   ':DISPLACED-INDEX-OFFSET (* 2 (- BUFFER-ADDRESS
							    (%POINTER BUFFER-ARRAY) 2))))
  (RESET))

(DEFUN RESET ()
  (LET ((%METER-MICRO-ENABLES 0))
    (WITHOUT-INTERRUPTS
      (OR (BOUNDP 'BUFFER-ADDRESS) (BUFFER-RESET))
      (SETQ %METER-BUFFER-POINTER BUFFER-ADDRESS
	    %METER-DISK-COUNT DISK-PARTITION-LENGTH
	    %METER-DISK-ADDRESS DISK-PARTITION-START))))

(DEFMACRO PUSH* (ITEM LIST)
  `(OR (MEMQ ,ITEM ,LIST) (PUSH ,ITEM ,LIST)))

(DEFVAR METERED-OBJECTS NIL)

(DEFUN ENABLE (&REST THINGS)
  (IF (NOT (BOUNDP 'BUFFER-ARRAY))
      (BUFFER-RESET))
  (DOLIST (THING THINGS)
    (IF (EQ THING T)
	(SETQ %METER-GLOBAL-ENABLE T)
	(SETQ THING (ENABLE-STACK-GROUP THING 1)))
    (PUSH* THING METERED-OBJECTS)))

(DEFUN DISABLE (&REST THINGS)
  (IF (NULL THINGS)
      (SETQ THINGS METERED-OBJECTS))
  (DOLIST (THING THINGS)
    (IF (EQ THING T)
	(SETQ %METER-GLOBAL-ENABLE NIL)
	(SETQ THING (ENABLE-STACK-GROUP THING 0)))
    (IF (NOT (MEMQ THING METERED-OBJECTS))
	(CERROR T NIL NIL "~S was not metered" THING))
    (SETQ METERED-OBJECTS (DELQ THING METERED-OBJECTS))))

(DEFUN ENABLE-STACK-GROUP (THING OFF-OR-ON)
  (COND	((TYPEP THING ':STACK-GROUP))
	((EQ (DATA-TYPE THING) 'DTP-INSTANCE)
	 (LET ((WO (FUNCALL THING ':WHICH-OPERATIONS)))
	   (COND ((MEMQ ':STACK-GROUP WO)
		  (SETQ THING (FUNCALL THING ':STACK-GROUP)))
		 ((MEMQ ':PROCESS WO)
		  (SETQ THING (FUNCALL (FUNCALL THING ':PROCESS) ':STACK-GROUP))))))
	(T (FERROR NIL "Cant meter ~S" THING)))
  (WITHOUT-INTERRUPTS
    (IF (EQ THING %CURRENT-STACK-GROUP)
	(SETQ %MODE-FLAGS
	      (%LOGDPB OFF-OR-ON %%M-FLAGS-METER-ENABLE %MODE-FLAGS))
	(SETF (SI:SG-FLAGS-METER-ENABLE THING) OFF-OR-ON)))
  THING)

(DEFUN SUSPEND ()
  (SETQ %METER-DISK-COUNT 0))

;Mustn't let the GC process run while metering since it changes the
;meaning of addresses.
(DEFUN STOP-GC-PROCESS ()
  (AND (BOUNDP 'SI:GC-PROCESS)
       (FUNCALL SI:GC-PROCESS ':ARREST-REASON 'METERING)))

(DEFUN RESUME-GC-PROCESS ()
  (AND (BOUNDP 'SI:GC-PROCESS)
       (FUNCALL SI:GC-PROCESS ':REVOKE-ARREST-REASON 'METERING)))

;;; General utilities
(DEFUN TIME-DIFF (OLD-HIGH OLD-LOW NEW-HIGH NEW-LOW)
  (IF (> OLD-LOW NEW-LOW)
      (SETQ NEW-LOW (+ 1_16. NEW-LOW)
	    NEW-HIGH (1- NEW-HIGH)))
  (DPB (- NEW-HIGH OLD-HIGH) 2020 (- NEW-LOW OLD-LOW)))

(DEFUN FUNCTION-NAME (FCTN)
  (IF (EQ (DATA-TYPE FCTN) 'DTP-FEF-POINTER)
      (%P-CONTENTS-OFFSET FCTN %FEFHI-FCTN-NAME)
      FCTN))

;;; Frame hacking on read in
(DEFUN FRAME-SETUP ()
  (OR (BOUNDP 'DISK-RQB)
      (SETQ DISK-RQB (SI:GET-DISK-RQB)))
  (SETQ NEXT-DISK-BLOCK DISK-PARTITION-START)
  (GET-NEXT-DISK-BLOCK))

(DEFUN NEXT-FRAME (BUF INDEX)
  (SETQ INDEX (+ INDEX (* (AREF BUF (1+ INDEX)) 2)))
  (IF (EQ BUF BUFFER)
      ;;; In last buffer, I.E the one in the memory.
      (IF ( (LOGAND %METER-BUFFER-POINTER (1- PAGE-SIZE))	;Number of Q's in buffer
	     (// INDEX 2))
	  (VALUES NIL)
	  (VALUES BUF INDEX))
      ;;; In another buffer
      (IF (= INDEX (ARRAY-ACTIVE-LENGTH BUF))
	  (MULTIPLE-VALUE (BUF INDEX)
	    (GET-NEXT-DISK-BLOCK)))
      (IF (OR (NULL BUF) ( (AREF BUF (1+ INDEX)) 0))
	  (VALUES BUF INDEX)
	  ;;; Here get a new buffer
	  (GET-NEXT-DISK-BLOCK))))

(DEFUN GET-NEXT-DISK-BLOCK ()
  (COND ((< NEXT-DISK-BLOCK %METER-DISK-ADDRESS)
	 (DISK-READ DISK-RQB 0 NEXT-DISK-BLOCK)
	 (SETQ NEXT-DISK-BLOCK (1+ NEXT-DISK-BLOCK))
	 (VALUES (ARRAY-LEADER DISK-RQB %DISK-RQ-LEADER-BUFFER) 0))
	(T (IF (ZEROP (LOGAND %METER-BUFFER-POINTER (1- PAGE-SIZE)))
	       (VALUES NIL)
	       (VALUES BUFFER 0)))))

(DEFUN METER-FIX (BUF INDEX)
  (DPB (AREF BUF (1+ INDEX)) 2007 (LDB 0020 (AREF BUF INDEX))))

(DEFUN METER-Q (BUF INDEX)
  (LET ((TEMP (AREF BUF (1+ INDEX))))
    (%MAKE-POINTER (LDB 1005 TEMP)
		   (DPB TEMP 2010 (AREF BUF INDEX)))))


(DEFSTRUCT (BASIC-INFO :NAMED-ARRAY-LEADER)
  FILL-POINTER
  BASE-STATE
  NEXT-STATE)

;;; ANALYZE support
(DEFSTRUCT (STACK-STATE :NAMED-ARRAY)
  LOW-REAL-TIME
  HIGH-REAL-TIME
  LOW-DISK-TIME
  HIGH-DISK-TIME
  PAGE-FAULTS
  STACK-GROUP
  CURRENT-FUNCTION
  STACK-DEPTH
  )

(DEFRESOURCE STACK-STATE () :CONSTRUCTOR (MAKE-STACK-STATE))

(DEFMACRO EVENT-ALIAS (SYM EVENT)
  `(PUTPROP ',SYM  (SYMEVAL ',EVENT) 'EVENT-NUMBER))

(EVENT-ALIAS :PAGE-IN %METER-PAGE-IN-EVENT)
(EVENT-ALIAS :PAGE-OUT %METER-PAGE-OUT-EVENT)
(EVENT-ALIAS :CONS %METER-CONS-EVENT)
(EVENT-ALIAS :FUNCTION-ENTRY %METER-FUNCTION-ENTRY-EVENT)
(EVENT-ALIAS :FUNCTION-EXIT %METER-FUNCTION-EXIT-EVENT)
(EVENT-ALIAS :FUNCTION-UNWIND %METER-FUNCTION-UNWIND-EVENT)
(EVENT-ALIAS :STACK-SWITCH %METER-STACK-GROUP-SWITCH-EVENT)

(DEFSTRUCT (EVENT-TABLE :ARRAY-LEADER :NAMED
			(:MAKE-ARRAY (:LENGTH (1+ (LENGTH METER-EVENTS))))
			:CONC-NAME)
  EVENTS					;Other random events go here
  INIT-FUNCTION					;Called when analyze happens
  EXIT-FUNCTION					;Called when analysis is done
  )

(DEFMACRO DEFTABLE (TABLE-NAME &OPTIONAL (INIT-FUNCTION ''NO-FUNCTION)
			       (EXIT-FUNCTION ''NO-FUNCTION))
  `(DEFCONST ,TABLE-NAME (MAKE-EVENT-TABLE INIT-FUNCTION ,INIT-FUNCTION
					   EXIT-FUNCTION ,EXIT-FUNCTION)))

(DEFUN NO-FUNCTION (&REST IGNORE) NIL)

(DEFMACRO DEFANALYZE (EVENT-TABLE EVENT &BODY BODY)
  (IF (ATOM BODY)
      `(DEFANALYZE-1 ',EVENT-TABLE ',EVENT ',BODY)
      `(PROGN 'COMPILE
	      (DEFUN (,EVENT-TABLE ,EVENT) (BUF INDEX INFO STREAM)
		BUF INDEX INFO STREAM		;are used
		. ,BODY)
	      (DEFANALYZE-1 ',EVENT-TABLE ',EVENT (GET ',EVENT-TABLE ',EVENT)))))

(DEFUN DEFANALYZE-1 (TABLE-NAME EVENT FCTN)
  (LET ((EVENT-NUMBER (GET EVENT 'EVENT-NUMBER))
	(TABLE (SYMEVAL TABLE-NAME))
	(CELL))
    (IF (NOT (NUMBERP EVENT-NUMBER))
	(FERROR NIL "~S undefined EVENT"))
    (COND ((< EVENT-NUMBER (ARRAY-DIMENSION-N 1 TABLE))
	   (ASET FCTN TABLE EVENT-NUMBER))
	  (T (IF (SETQ CELL (ASSQ EVENT (EVENT-TABLE-EVENTS TABLE)))
		 (RPLACD CELL FCTN)
		 (PUSH (CONS EVENT-NUMBER FCTN)
		       (EVENT-TABLE-EVENTS TABLE)))))))

;;; Analysis driver function
(DEFUN ANALYZE (&REST OPTIONS &AUX RET-INFO INFO (FLUSH-INFO T))
  (UNWIND-PROTECT
    (LET ((STREAM STANDARD-OUTPUT)
	  (EVENT-TABLE (SYMEVAL 'TREE))
	  (OPT-LIST))
      (DO ((L OPTIONS (CDDR L)))
	  ((NULL L))
	(SELECTQ (FIRST L)
	  (:STREAM (SETQ STREAM (CADR L)))
	  (:BUFFER (SETQ STREAM (ZWEI:INTERVAL-STREAM (ZWEI:FIND-BUFFER-NAMED (CADR L) T))))
	  (:INFO (SETQ INFO (CADR L) FLUSH-INFO NIL))
	  (:FILTER (SETQ EVENT-TABLE (IF (TYPEP (CADR L) 'EVENT-TABLE)
					 (CADR L)
					 (SYMEVAL (CADR L)))))
	  (:RETURN (SETQ RET-INFO (CADR L) FLUSH-INFO NIL))
	  (OTHERWISE (PUTPROP (LOCF OPT-LIST) (CADR L) (CAR L)))))
      (IF (NULL INFO)
	  (DO-OVER-DATA ((MAX-INDEX (ARRAY-DIMENSION-N 1 EVENT-TABLE))
			 (FCTN (SETQ INFO (FUNCALL (EVENT-TABLE-INIT-FUNCTION EVENT-TABLE)
						   OPT-LIST STREAM BUF INDEX)))
			 (EVENT))
			()
	    (SETQ EVENT (COPY-FRAME-TO-STATE BUF INDEX (NEXT-STATE INFO)))
	    (SETQ FCTN (IF (< EVENT MAX-INDEX)
			   (AREF EVENT-TABLE EVENT)
			   (CDR (ASSQ EVENT (EVENT-TABLE-EVENTS EVENT-TABLE)))))
	    (IF FCTN
		(FUNCALL FCTN BUF INDEX INFO STREAM))))
      (FUNCALL (EVENT-TABLE-EXIT-FUNCTION EVENT-TABLE) INFO STREAM OPT-LIST)
      (AND RET-INFO INFO))
    (AND FLUSH-INFO INFO (ANALYZE-FREE INFO))))

(DEFUN ANALYZE-FREE (INFO)
  (LET ((SYM (NAMED-STRUCTURE-SYMBOL INFO)))
    (IF (AND SYM (SETQ SYM (GET SYM 'RETURN-FUNCTION)))
	(FUNCALL SYM INFO))
    NIL))

(DEFUN COPY-FRAME-TO-STATE (BUF INDEX STATE)
  (LET ((EVENT (AREF BUF INDEX))
	(LENGTH (AREF BUF (1+ INDEX))))
    (COND (( LENGTH 0)
	   (SETF (LOW-REAL-TIME STATE) (AREF BUF (+ INDEX 2)))
	   (SETF (HIGH-REAL-TIME STATE) (AREF BUF (+ INDEX 3)))
	   (SETF (LOW-DISK-TIME STATE) (AREF BUF (+ INDEX 4)))
	   (SETF (HIGH-DISK-TIME STATE) (AREF BUF (+ INDEX 5)))
	   (SETF (PAGE-FAULTS STATE) (METER-FIX BUF (+ INDEX 6)))
	   (SETF (STACK-GROUP STATE) (METER-Q BUF (+ INDEX 10)))
	   (SETF (CURRENT-FUNCTION STATE) (METER-Q BUF (+ INDEX 12)))
	   (SETF (STACK-DEPTH STATE) (METER-FIX BUF (+ INDEX 14)))
	   EVENT)
	  (T NIL))))

(DEFUN STATE-RELATIVE-INFO (BASE-STATE NEW-STATE)
  (LET ((REAL-TIME (TIME-DIFF (HIGH-REAL-TIME BASE-STATE) (LOW-REAL-TIME BASE-STATE)
			      (HIGH-REAL-TIME NEW-STATE) (LOW-REAL-TIME NEW-STATE)))
	(DISK-TIME (TIME-DIFF (HIGH-DISK-TIME BASE-STATE) (LOW-DISK-TIME BASE-STATE)
				    (HIGH-DISK-TIME NEW-STATE) (LOW-DISK-TIME NEW-STATE))))
    (VALUES REAL-TIME
	    (- REAL-TIME DISK-TIME)
	    (%24-BIT-DIFFERENCE (PAGE-FAULTS NEW-STATE) (PAGE-FAULTS BASE-STATE)))))

;;; List of events analysis function
(DEFTABLE LIST-EVENTS 'INIT-LIST-EVENTS)

(DEFANALYZE LIST-EVENTS :PAGE-IN . LIST-EVENT-FUNCTION)
(DEFANALYZE LIST-EVENTS :PAGE-OUT . LIST-EVENT-FUNCTION)
(DEFANALYZE LIST-EVENTS :CONS . LIST-EVENT-FUNCTION)
(DEFANALYZE LIST-EVENTS :FUNCTION-ENTRY . LIST-EVENT-FUNCTION)
(DEFANALYZE LIST-EVENTS :FUNCTION-EXIT . LIST-EVENT-FUNCTION)
(DEFANALYZE LIST-EVENTS :FUNCTION-UNWIND . LIST-EVENT-FUNCTION)
(DEFANALYZE LIST-EVENTS :STACK-SWITCH . LIST-EVENT-FUNCTION)

(DEFUN INIT-LIST-EVENTS (PLIST IGNORE BUF INDEX)
  (LET ((INFO (MAKE-BASIC-INFO)))
    (IF (NOT (NULL PLIST))
	(FERROR NIL "~S Bad options" PLIST))
    (SETF (BASE-STATE INFO) (ALLOCATE-RESOURCE 'STACK-STATE))
    (SETF (NEXT-STATE INFO) (ALLOCATE-RESOURCE 'STACK-STATE))
    (IF BUF
	(COPY-FRAME-TO-STATE BUF INDEX (BASE-STATE INFO)))
    INFO))

(DEFUN (BASIC-INFO RETURN-FUNCTION) (INFO)
  (DEALLOCATE-RESOURCE 'STACK-STATE (BASE-STATE INFO))
  (DEALLOCATE-RESOURCE 'STACK-STATE (NEXT-STATE INFO)))

(DEFUN LIST-EVENT-FUNCTION (BUF INDEX INFO STREAM)
  (LET ((REAL-TIME)
	(RUN-TIME)
	(PAGE-FAULTS)
	(NEW-STATE)
	(EVENT (AREF BUF INDEX)))
  (MULTIPLE-VALUE (REAL-TIME RUN-TIME PAGE-FAULTS)
    (STATE-RELATIVE-INFO (BASE-STATE INFO) (SETQ NEW-STATE (NEXT-STATE INFO))))
  (FORMAT STREAM "~&~9D ~9D ~4D ~20A ~20S ~5D "
	  REAL-TIME RUN-TIME PAGE-FAULTS
	  (SG-NAME (STACK-GROUP NEW-STATE))
	  (FUNCTION-NAME (CURRENT-FUNCTION NEW-STATE))
	  (STACK-DEPTH NEW-STATE))
  (SELECT EVENT
    ((%METER-FUNCTION-ENTRY-EVENT %METER-FUNCTION-EXIT-EVENT)
     (FORMAT STREAM "~:[RET ~;CALL~] ~S"
	     (= EVENT %METER-FUNCTION-ENTRY-EVENT)
	     (FUNCTION-NAME (METER-Q BUF (+ INDEX 14.)))))
    (%METER-FUNCTION-UNWIND-EVENT
     (FORMAT STREAM "UNWIND"))
    ((%METER-PAGE-IN-EVENT %METER-PAGE-OUT-EVENT)
     (LET ((VMA (METER-FIX BUF (+ INDEX 14.)))
	   (UPC (METER-FIX BUF (+ INDEX 16.)))
	   (MICRO-NAME))
       (SETQ MICRO-NAME (CC:CC-FIND-CLOSEST-SYM (+ CC:RACMO (LDB 0020 UPC))))
       (IF (LISTP MICRO-NAME)
	   (SETQ MICRO-NAME (CAR MICRO-NAME)))
       (FORMAT STREAM "~:[PAGI~;PAGO~]~%~10T~8O (~S) ~S"
	       (= EVENT %METER-PAGE-OUT-EVENT)
	       VMA
	       (AREF #'AREA-NAME (%AREA-NUMBER VMA))
	       (OR MICRO-NAME (LDB 0020 UPC)))))
    (%METER-STACK-GROUP-SWITCH-EVENT
     (FORMAT STREAM "~A" (SG-NAME (METER-Q BUF (+ INDEX 14.)))))
    (:OTHERWISE
     (FORMAT STREAM "~&Bad event")))))


;;; Tree hacking info
(DEFSTRUCT (TREE-INFO :NAMED-ARRAY-LEADER (:INCLUDE BASIC-INFO)
		      (:MAKE-ARRAY (:LENGTH (* TREE-SIZE 150.)))
		      :CONC-NAME)
  STACK-GROUPS
  CURRENT-FUNCTION
  OUTPUT-FUNCTION
  OUTPUT-PLIST
  )

(DEFSTRUCT (TREE :GROUPED-ARRAY :CONC-NAME :SIZE-SYMBOL)
  CALLER
  FUNCTION
  REAL-TIME
  RUN-TIME
  PAGE-FAULTS
  CALLED-FUNCTIONS
  CALLED-REAL-TIME
  CALLED-RUN-TIME
  CALLED-PAGE-FAULTS
  STACK-DEPTH
  NEXT-CALLED
  )

(DEFRESOURCE TREE-INFO () :CONSTRUCTOR (MAKE-TREE-INFO))

(DEFTABLE TREE 'TREE-INIT 'TREE-EXIT)

(DEFUN TREE-INIT (PLIST IGNORE BUF INDEX)
  (LET ((INFO (ALLOCATE-RESOURCE 'TREE-INFO))
	(BASE-STATE (ALLOCATE-RESOURCE 'STACK-STATE)))
    (SETF (FILL-POINTER INFO) 0)
    (IF BUF
	(COPY-FRAME-TO-STATE BUF INDEX BASE-STATE))
    (SETF (BASE-STATE INFO) BASE-STATE)
    (SETF (NEXT-STATE INFO) (ALLOCATE-RESOURCE 'STACK-STATE))
    (SETF (TREE-INFO-STACK-GROUPS INFO) NIL)
    (SETF (TREE-INFO-CURRENT-FUNCTION INFO) NIL)
    ;Would process non-output options here if there were any
    PLIST ;there aren't, so ignore plist
    INFO))

(DEFUN (TREE-INFO RETURN-FUNCTION) (INFO)
  (DEALLOCATE-RESOURCE 'STACK-STATE (BASE-STATE INFO))
  (DEALLOCATE-RESOURCE 'STACK-STATE (NEXT-STATE INFO))
  (DEALLOCATE-RESOURCE 'TREE-INFO INFO))

(DEFUN TREE-EXIT (INFO STREAM PLIST)
  ;Decide output function and its options
  (SETF (TREE-INFO-OUTPUT-FUNCTION INFO) 'SUMMARIZE-TREE)
  (SETF (TREE-INFO-OUTPUT-PLIST INFO) NIL)
  (DO ((L PLIST (CDDR L))
       (OPLIST (GET (TREE-INFO-OUTPUT-FUNCTION INFO) 'OUTPUT-OPTIONS)))
      ((NULL L))
    (SELECTQ (CAR L)
      (:OUTPUT (SETF (TREE-INFO-OUTPUT-FUNCTION INFO) (CADR L))
	       (IF (NOT (NULL (TREE-INFO-OUTPUT-PLIST INFO)))
		   (FERROR NIL "Output options specified before output function"))
	       (SETQ OPLIST (GET (CADR L) 'OUTPUT-OPTIONS)))
      (:FIND-CALLERS
        (SETF (TREE-INFO-OUTPUT-FUNCTION INFO) 'TREE-FIND-CALLERS)
	(IF (NOT (NULL (TREE-INFO-OUTPUT-PLIST INFO)))
	    (FERROR NIL "Output options specified before output function"))
	(PUSH (CADR L) (TREE-INFO-OUTPUT-PLIST INFO))
	(PUSH ':FIND-CALLERS (TREE-INFO-OUTPUT-PLIST INFO))
	(SETQ OPLIST (GET 'TREE-FIND-CALLERS 'OUTPUT-OPTIONS)))
      (OTHERWISE
       (COND ((MEMQ (CAR L) OPLIST)
	      (PUSH (CADR L) (TREE-INFO-OUTPUT-PLIST INFO))
	      (PUSH (CAR L) (TREE-INFO-OUTPUT-PLIST INFO)))
	     (T (FERROR NIL "~S Bad option" (CAR L)))))))
  ;Finish off tree
  (LET* ((CUR-STACK (STACK-GROUP (BASE-STATE INFO)))
	 (INF (ASSQ CUR-STACK (TREE-INFO-STACK-GROUPS INFO))))
    (IF (AND (NULL INF) (NOT (NULL (TREE-INFO-CURRENT-FUNCTION INFO))))
	(PUSH (CONS CUR-STACK (TREE-INFO-CURRENT-FUNCTION INFO))
	      (TREE-INFO-STACK-GROUPS INFO))))
  (DOLIST (L (TREE-INFO-STACK-GROUPS INFO))
    (RPLACD L (FIND-ROOT INFO (CDR L))))
  ;Print
  (FUNCALL (TREE-INFO-OUTPUT-FUNCTION INFO) INFO STREAM))

(DEFUN FIND-ROOT (INFO INDEX)
  (IF INDEX
      (DO ((ROOT INDEX (TREE-CALLER ROOT INFO)))
	  ((NULL ROOT) INDEX)
	(SETQ INDEX ROOT))))

(DEFANALYZE TREE :FUNCTION-ENTRY
  (LET ((CALLEE (GET-TREE INFO))
	(CALLER (TREE-INFO-CURRENT-FUNCTION INFO))
	(NEW-STATE (NEXT-STATE INFO))
	(BASE-STATE (BASE-STATE INFO)))
    (COND ((NULL CALLER)
	   (SETQ CALLER (GET-TREE INFO))
	   (SETF (TREE-FUNCTION CALLER INFO) (CURRENT-FUNCTION NEW-STATE))))
    (SETF (TREE-NEXT-CALLED CALLEE INFO) (TREE-CALLED-FUNCTIONS CALLER INFO))
    (SETF (TREE-CALLED-FUNCTIONS CALLER INFO) CALLEE)
    (MULTIPLE-VALUE-BIND (REAL-TIME RUN-TIME PAGE-FAULTS)
	(STATE-RELATIVE-INFO BASE-STATE NEW-STATE)
      (INCF (TREE-REAL-TIME CALLER INFO) REAL-TIME)
      (INCF (TREE-RUN-TIME CALLER INFO) RUN-TIME)
      (INCF (TREE-PAGE-FAULTS CALLER INFO) PAGE-FAULTS))
    (SETF (TREE-CALLER CALLEE INFO) CALLER)
    (SETF (TREE-FUNCTION CALLEE INFO) (METER-Q BUF (+ INDEX 14.)))
    (SETF (TREE-STACK-DEPTH CALLEE INFO) (STACK-DEPTH NEW-STATE))
    (SETF (TREE-INFO-CURRENT-FUNCTION INFO) CALLEE)
    (SETF (BASE-STATE INFO) NEW-STATE)
    (SETF (NEXT-STATE INFO) BASE-STATE)))

(DEFANALYZE TREE :FUNCTION-EXIT
  (SELECT (%DATA-TYPE (METER-Q BUF (+ INDEX 14.)))
    ((DTP-U-ENTRY DTP-STACK-GROUP) NIL)
    (OTHERWISE 
     (TREE-FUNCTION-EXIT BUF INDEX INFO)
     (LET ((NEW-STATE (NEXT-STATE INFO)))
       (SETF (NEXT-STATE INFO) (BASE-STATE INFO))
       (SETF (BASE-STATE INFO) NEW-STATE)))))

(DEFUN TREE-FUNCTION-EXIT (BUF INDEX INFO)
  (LET* ((NEW-STATE (NEXT-STATE INFO))
	 (BASE-STATE (BASE-STATE INFO))
	 (RETURNER (TREE-INFO-CURRENT-FUNCTION INFO))
	 (RETURNEE (AND RETURNER (TREE-CALLER RETURNER INFO))))
    (COND ((NULL RETURNER)
	   (SETQ RETURNER (GET-TREE INFO))
	   (SETF (TREE-FUNCTION RETURNER INFO) (METER-Q BUF (+ INDEX 14.)))))
    (COND ((NULL RETURNEE)
	   (SETQ RETURNEE (GET-TREE INFO))
	   (SETF (TREE-FUNCTION RETURNEE INFO) (CURRENT-FUNCTION NEW-STATE))
	   (SETF (TREE-NEXT-CALLED RETURNER INFO) (TREE-CALLED-FUNCTIONS RETURNEE INFO))
	   (SETF (TREE-CALLED-FUNCTIONS RETURNEE INFO) RETURNER)))
    (OR (TREE-CALLER RETURNER INFO)
	(SETF (TREE-CALLER RETURNER INFO) RETURNEE))
    (MULTIPLE-VALUE-BIND (REAL-TIME RUN-TIME PAGE-FAULTS)
	(STATE-RELATIVE-INFO BASE-STATE NEW-STATE)
      (INCF (TREE-REAL-TIME RETURNER INFO) REAL-TIME)
      (INCF (TREE-RUN-TIME RETURNER INFO) RUN-TIME)
      (INCF (TREE-PAGE-FAULTS RETURNER INFO) PAGE-FAULTS))
    (INCF (TREE-CALLED-REAL-TIME RETURNEE INFO)
	  (+ (TREE-REAL-TIME RETURNER INFO)
	     (TREE-CALLED-REAL-TIME RETURNER INFO)))
    (INCF (TREE-CALLED-RUN-TIME RETURNEE INFO)
	  (+ (TREE-RUN-TIME RETURNER INFO)
	     (TREE-CALLED-RUN-TIME RETURNER INFO)))
    (INCF (TREE-CALLED-PAGE-FAULTS RETURNEE INFO)
	  (+ (TREE-PAGE-FAULTS RETURNER INFO)
	     (TREE-CALLED-PAGE-FAULTS RETURNER INFO)))
    (SETF (TREE-CALLED-FUNCTIONS RETURNER INFO)
	  (REVCALLEES RETURNER INFO))
    (SETF (TREE-INFO-CURRENT-FUNCTION INFO) RETURNEE)))

;;; This reverses the list of callees
(DEFUN REVCALLEES (CALLEES INFO)
  (IF CALLEES
      (DO ((PREV NIL NEXT)
	   (NEXT (TREE-CALLED-FUNCTIONS CALLEES INFO) NEXT-NEXT)
	   (NEXT-NEXT))
	  ((NULL NEXT) PREV)
	(SETQ NEXT-NEXT (TREE-NEXT-CALLED NEXT INFO))
	(SETF (TREE-NEXT-CALLED NEXT INFO) PREV))
      NIL))

(DEFANALYZE TREE :STACK-SWITCH
  (LET* ((FCTN (TREE-INFO-CURRENT-FUNCTION INFO))
	 (NEW-STATE (NEXT-STATE INFO)))
    (IF (NOT (NULL FCTN))
	(MULTIPLE-VALUE-BIND (REAL-TIME RUN-TIME PAGE-FAULTS)
	    (STATE-RELATIVE-INFO (BASE-STATE INFO) NEW-STATE)
	  (INCF (TREE-REAL-TIME FCTN INFO) REAL-TIME)
	  (INCF (TREE-RUN-TIME FCTN INFO) RUN-TIME)
	  (INCF (TREE-PAGE-FAULTS FCTN INFO) PAGE-FAULTS)))
    (LET ((OLD-STACK-GROUP (METER-Q BUF (+ INDEX 14.)))
	  (INF))
      (IF (SETQ INF (ASSQ OLD-STACK-GROUP (TREE-INFO-STACK-GROUPS INFO)))
	  (RPLACD INF FCTN)
	  (AND FCTN (PUSH (CONS OLD-STACK-GROUP FCTN) (TREE-INFO-STACK-GROUPS INFO)))))
    (SETF (TREE-INFO-CURRENT-FUNCTION INFO)
	  (CDR (ASSQ (STACK-GROUP NEW-STATE) (TREE-INFO-STACK-GROUPS INFO))))
    (SETF (NEXT-STATE INFO) (BASE-STATE INFO))
    (SETF (BASE-STATE INFO) NEW-STATE)))

(DEFUN GET-TREE (TREE)
  (LET* ((IDX (ARRAY-ACTIVE-LENGTH TREE))
	 (EXTENSION (* TREE-SIZE (// (// IDX TREE-SIZE) 3))))
    (ARRAY-PUSH-EXTEND TREE NIL EXTENSION)	;Caller
    (ARRAY-PUSH TREE NIL)			;Function
    (ARRAY-PUSH TREE 0)				;Real time
    (ARRAY-PUSH TREE 0)				;Run time
    (ARRAY-PUSH TREE 0)				;Page faults
    (ARRAY-PUSH TREE NIL)			;Called functions
    (ARRAY-PUSH TREE 0)				;Called real time
    (ARRAY-PUSH TREE 0)				;Called run time
    (ARRAY-PUSH TREE 0)				;Called page faults
    (ARRAY-PUSH TREE 0)				;Stack depth
    (ARRAY-PUSH TREE NIL)			;Next called
    IDX))

;;; Output functions for TREE manipulation
(DEFUN TREE-NULL (IGNORE IGNORE))

(DEFPROP TREE-PRINT (:STACK-GROUP) OUTPUT-OPTIONS)
(DEFUN TREE-PRINT (INFO STREAM &AUX STK-GROUP)
  (DO ((PL (TREE-INFO-OUTPUT-PLIST INFO) (CDDR PL)))
      ((NULL PL))
    (SELECTQ (CAR PL)
      (:STACK-GROUP (SETQ STK-GROUP (CADR PL)))
      (OTHERWISE (FERROR NIL "Output option ~S not recognized" (CAR PL)))))
  (DOLIST (L (TREE-INFO-STACK-GROUPS INFO))
    (COND ((AND (OR (NULL STK-GROUP) (EQ (CAR L) STK-GROUP)
		    (AND (LISTP STK-GROUP) (MEMQ (CAR L) STK-GROUP)))
		(NOT (NULL (CDR L))))
	   (FORMAT STREAM "~&Stack Group: ~A" (SG-NAME (CAR L)))
	   (TREE-PRINT-INTERNAL INFO (CDR L) 0 STREAM)))))

(DEFUN TREE-PRINT-INTERNAL (INFO INDEX LEVEL STREAM)
  (COND (INDEX
	 (FORMAT STREAM "~&[~3D]~30S ~8D ~8D ~8D ~10D ~10D ~8D" LEVEL
		 (FUNCTION-NAME (TREE-FUNCTION INDEX INFO))
		 (TREE-REAL-TIME INDEX INFO)
		 (TREE-RUN-TIME INDEX INFO)
		 (TREE-PAGE-FAULTS INDEX INFO)
		 (TREE-CALLED-REAL-TIME INDEX INFO)
		 (TREE-CALLED-RUN-TIME INDEX INFO)
		 (TREE-CALLED-PAGE-FAULTS INDEX INFO))
	 (DO ((L (TREE-CALLED-FUNCTIONS INDEX INFO) (TREE-NEXT-CALLED L INFO)))
	     ((NULL L))
	   (TREE-PRINT-INTERNAL INFO L (1+ LEVEL) STREAM)))))


(DEFSTRUCT (SUMMARY-INFO :GROUPED-ARRAY :SIZE-SYMBOL :CONC-NAME)
  NAME
  CALLS
  REAL-TIME
  RUN-TIME
  PAGE-FAULTS)

(DEFRESOURCE SUMMARY-INFOS ()
  :CONSTRUCTOR (MAKE-SUMMARY-INFO :TIMES 100. :MAKE-ARRAY (:LEADER-LIST '(0))))
(DEFRESOURCE SUMMARY-TABLES ()
  :CONSTRUCTOR (MAKE-HASH-TABLE ':SIZE 100.))

(DEFPROP SUMMARIZE-TREE (:STACK-GROUP :SORT-FUNCTION :SUMMARIZE :INCLUSIVE) OUTPUT-OPTIONS)
(LOCAL-DECLARE ((SPECIAL HASH SUMM ONLY-FOR INCLUSIVE))
(DEFUN SUMMARIZE-TREE (INFO STREAM
		       &AUX STK-GROUP (SORT-FCTN 'MAX-RUN-TIME) ONLY-FOR INCLUSIVE)
  (DO ((PL (TREE-INFO-OUTPUT-PLIST INFO) (CDDR PL)))
      ((NULL PL))
    (SELECTQ (CAR PL)
      (:STACK-GROUP (SETQ STK-GROUP (CADR PL)))
      (:SORT-FUNCTION (SETQ SORT-FCTN (CADR PL)))
      (:SUMMARIZE (SETQ ONLY-FOR (FUNCTION-LIST (CADR PL))))
      (:INCLUSIVE (SETQ INCLUSIVE (CADR PL)))
      (OTHERWISE (FERROR NIL "Output option ~S not recognized" (CAR PL)))))
  (USING-RESOURCE (HASH SUMMARY-TABLES)
    (USING-RESOURCE (SUMM SUMMARY-INFOS)
      (CLRHASH HASH)
      (STORE-ARRAY-LEADER 0 SUMM 0)
      (DOLIST (L (TREE-INFO-STACK-GROUPS INFO))
	(COND ((AND (OR (NULL STK-GROUP) (EQ (CAR L) STK-GROUP)
		    (AND (LISTP STK-GROUP) (MEMQ (CAR L) STK-GROUP)))
		(NOT (NULL (CDR L))))
	       (FORMAT STREAM "~&Stack Group: ~A" (SG-NAME (CAR L)))
	       (SUMMARY-BRANCH INFO (CDR L)))))
      (PRINT-SUMMARY-INFORMATION SUMM SORT-FCTN STREAM))))

(DEFUN SUMMARY-BRANCH (INFO INDEX)
  (IF (OR (NULL ONLY-FOR) (MEMQ (TREE-FUNCTION INDEX INFO) ONLY-FOR))
      (SUMMARIZE-NODE INFO INDEX))
  (DO ((IND (TREE-CALLED-FUNCTIONS INDEX INFO) (TREE-NEXT-CALLED IND INFO)))
      ((NULL IND))
    (SUMMARY-BRANCH INFO IND)))

(DEFUN SUMMARIZE-NODE (INFO INDEX)
  (MULTIPLE-VALUE-BIND (VALUE FOUND)
      (GETHASH (TREE-FUNCTION INDEX INFO) HASH)
    (COND ((NOT FOUND)
	   (SETQ VALUE (ARRAY-ACTIVE-LENGTH SUMM))
	   (PUTHASH (TREE-FUNCTION INDEX INFO) VALUE HASH)
	   (ARRAY-PUSH-EXTEND SUMM (TREE-FUNCTION INDEX INFO) (* 100. SUMMARY-INFO-SIZE))
	   (ARRAY-PUSH SUMM 0)			;Calls
	   (ARRAY-PUSH SUMM 0)			;Real time
	   (ARRAY-PUSH SUMM 0)			;Run time
	   (ARRAY-PUSH SUMM 0)))		;Page faults
    (INCF (SUMMARY-INFO-CALLS VALUE SUMM))
    (INCF (SUMMARY-INFO-REAL-TIME VALUE SUMM) (TREE-REAL-TIME INDEX INFO))
    (IF INCLUSIVE
	(INCF (SUMMARY-INFO-REAL-TIME VALUE SUMM) (TREE-CALLED-REAL-TIME INDEX INFO)))
    (INCF (SUMMARY-INFO-RUN-TIME VALUE SUMM) (TREE-RUN-TIME INDEX INFO))
    (IF INCLUSIVE
	(INCF (SUMMARY-INFO-RUN-TIME VALUE SUMM) (TREE-CALLED-RUN-TIME INDEX INFO)))
    (INCF (SUMMARY-INFO-PAGE-FAULTS VALUE SUMM) (TREE-PAGE-FAULTS INDEX INFO))
    (IF INCLUSIVE
	(INCF (SUMMARY-INFO-PAGE-FAULTS VALUE SUMM) (TREE-CALLED-PAGE-FAULTS INDEX INFO)))))
);LOCAL-DECLARE

(DEFUN PRINT-SUMMARY-INFORMATION (SUMM SORT-FCTN STREAM)
  (SORT-GROUPED-ARRAY-GROUP-KEY SUMM SUMMARY-INFO-SIZE SORT-FCTN)
  (FORMAT STREAM "~&~55A~6@A ~10@A ~6@A ~10@A"
	  "Functions" "# calls" "Run T" "Faults" "Real T")
  (DO ((IDX 0 (+ IDX SUMMARY-INFO-SIZE))
       (TOTAL-CALLS 0)
       (TOTAL-REAL-TIME 0)
       (TOTAL-RUN-TIME 0)
       (TOTAL-PAGE-FAULTS 0))
      (( IDX (ARRAY-ACTIVE-LENGTH SUMM))
       (FORMAT STREAM "~2%~55A ~6D ~10D ~6D ~10D"
	       "Total" TOTAL-CALLS TOTAL-RUN-TIME TOTAL-PAGE-FAULTS TOTAL-REAL-TIME))
    (FORMAT STREAM "~&~55S ~6D ~10D ~6D ~10D"
	    (FUNCTION-NAME (SUMMARY-INFO-NAME IDX SUMM))
	    (SUMMARY-INFO-CALLS IDX SUMM)
	    (SUMMARY-INFO-RUN-TIME IDX SUMM)
	    (SUMMARY-INFO-PAGE-FAULTS IDX SUMM)
	    (SUMMARY-INFO-REAL-TIME IDX SUMM))
    (SETQ TOTAL-CALLS (+ TOTAL-CALLS (SUMMARY-INFO-CALLS IDX SUMM))
	  TOTAL-REAL-TIME (+ TOTAL-REAL-TIME (SUMMARY-INFO-REAL-TIME IDX SUMM))
	  TOTAL-RUN-TIME (+ TOTAL-RUN-TIME (SUMMARY-INFO-RUN-TIME IDX SUMM))
	  TOTAL-PAGE-FAULTS (+ TOTAL-PAGE-FAULTS
			       (SUMMARY-INFO-PAGE-FAULTS IDX SUMM)))))

;;; Sorting functions
(DEFUN MAX-CALLS (ARY1 IDX1 ARY2 IDX2)
  (> (SUMMARY-INFO-CALLS IDX1 ARY1)
     (SUMMARY-INFO-CALLS IDX2 ARY2)))

(DEFUN MAX-RUN-TIME (ARY1 IDX1 ARY2 IDX2)
  (> (SUMMARY-INFO-RUN-TIME IDX1 ARY1)
     (SUMMARY-INFO-RUN-TIME IDX2 ARY2)))

(DEFUN MAX-REAL-TIME (ARY1 IDX1 ARY2 IDX2)
  (> (SUMMARY-INFO-REAL-TIME IDX1 ARY1)
     (SUMMARY-INFO-REAL-TIME IDX2 ARY2)))

(DEFUN MAX-PAGE-FAULTS (ARY1 IDX1 ARY2 IDX2)
  (> (SUMMARY-INFO-PAGE-FAULTS IDX1 ARY1)
     (SUMMARY-INFO-PAGE-FAULTS IDX2 ARY2)))

(DEFUN MAX-RUN-TIME-PER-CALL (ARY1 IDX1 ARY2 IDX2)
  (> (IF (> (SUMMARY-INFO-CALLS IDX1 ARY1) 0)
	 (// (FLOAT (SUMMARY-INFO-RUN-TIME IDX1 ARY1))
	     (SUMMARY-INFO-CALLS IDX1 ARY1))
	 0)
     (IF (> (SUMMARY-INFO-CALLS IDX2 ARY2) 0)
	 (// (FLOAT (SUMMARY-INFO-RUN-TIME IDX2 ARY2))
	     (SUMMARY-INFO-CALLS IDX2 ARY2))
	 0)))

(DEFPROP TREE-FIND-CALLERS (:STACK-GROUP) OUTPUT-OPTIONS)
(LOCAL-DECLARE ((SPECIAL STREAM))
(DEFUN TREE-FIND-CALLERS (INFO STREAM &AUX STK-GROUP CALLEES)
  (DO ((PL (TREE-INFO-OUTPUT-PLIST INFO) (CDDR PL)))
      ((NULL PL))
    (SELECTQ (CAR PL)
      (:STACK-GROUP (SETQ STK-GROUP (CADR PL)))
      (:FIND-CALLERS
       (SETQ CALLEES (FUNCTION-LIST (CADR PL))))
      (OTHERWISE (FERROR NIL "Output option ~S not recognized" (CAR PL)))))
  (USING-RESOURCE (HASH SUMMARY-TABLES)
    (CLRHASH HASH)
    (DOLIST (L (TREE-INFO-STACK-GROUPS INFO))
      (COND ((AND (OR (NULL STK-GROUP) (EQ (CAR L) STK-GROUP)
		      (AND (LISTP STK-GROUP) (MEMQ (CAR L) STK-GROUP)))
		  (NOT (NULL (CDR L))))
	     (FORMAT STREAM "~&Stack Group: ~A~%" (SG-NAME (CAR L)))
	     (FIND-CALLERS-BRANCH INFO (CDR L) HASH CALLEES))))
    (MAPHASH #'(LAMBDA (CALLEE ALIST)
		 (LOOP FOR (CALLER . N-TIMES) IN ALIST
		       DO (FORMAT STREAM "~S called ~S ~D time~:P.~%"
				  (FUNCTION-NAME CALLER) (FUNCTION-NAME CALLEE) N-TIMES))
		 (FUNCALL STREAM ':TYO #\CR))
	     HASH))))

(DEFUN FIND-CALLERS-BRANCH (INFO INDEX HASH CALLEES)
  (LOOP FOR IND = (TREE-CALLED-FUNCTIONS INDEX INFO) THEN (TREE-NEXT-CALLED IND INFO)
	    WHILE IND
	AS CALLEE = (TREE-FUNCTION IND INFO)
	WHEN (MEMQ CALLEE CALLEES)
	  DO (PUTHASH CALLEE (INCASSQ (TREE-FUNCTION INDEX INFO) (GETHASH CALLEE HASH)) HASH)
	DO (FIND-CALLERS-BRANCH INFO IND HASH CALLEES)))

(DEFUN INCASSQ (KEY ALIST &AUX TEM)
  (IF (SETQ TEM (ASSQ KEY ALIST))
      (INCF (CDR TEM))
      (PUSH (CONS KEY 1) ALIST))
  ALIST)

;Spec can be symbol, function spec, or list of such
;Returns a list of functions (NOT function names)
(DEFUN FUNCTION-LIST (SPEC)
  (IF (OR (ATOM SPEC)
	  (MEMQ (CAR SPEC) '(:METHOD :PROPERTY :INTERNAL)))	;No doubt there are more...
      (LIST (FDEFINITION SPEC))
      (MAPCAR #'FDEFINITION SPEC)))

;;; Random functions
(DEFUN TEST (FORM &OPTIONAL (ENABLES 14))
  (SETQ %METER-MICRO-ENABLES 0)
  (RESET)
  (ENABLE %CURRENT-STACK-GROUP)
  (LET-GLOBALLY ((%METER-MICRO-ENABLES ENABLES))
    (EVAL FORM))
  (DISABLE))