(FILECREATED "31-Dec-83 15:09:55" {PHYLUM}<LISPCORE>SOURCES>PCALLSTATS.;25 38796  

      changes to:  (VARS PCALLVARS)
		   (FNS GETFD)

      previous date: "23-OCT-83 16:38:02" {PHYLUM}<LISPCORE>SOURCES>PCALLSTATS.;24)


(* Copyright (c) 1982, 1983 by Xerox Corporation)

(PRETTYCOMPRINT PCALLSTATSCOMS)

(RPAQQ PCALLSTATSCOMS [(FILES APS)
	(VARS PCALLVARS PCALLEVENTS PCALLFORMAT PCALLPARAMS)
	(VARS * (PROGN PCALLPARAMS))
	(ADDVARS (PARAMNAMES PCALLPARAMS)
		 (APSVARNAMES PCALLVARS)
		 (EVENTSNAMES PCALLEVENTS)
		 (FORMATNAMES PCALLFORMAT))
	(DECLARE: DONTCOPY (RECORDS FunctionData FVARSTAT FVAREVENT)
		  (MACROS .FNHEADEREQUAL. .FNHEADERMEMB. PUNTFNP))
	(COMS (* Fns for handling specific stats events)
	      (FNS CALLEVENT RETURNEVENT FVAREVENT FVAREXITEVENT DISKEVENT)
	      (* User functions for controlling filtering)
	      (FNS APSBKDWN APSFLTR)
	      (* Fns to aid in the stats gathering)
	      (FNS BEGINWINDOW ENDWINDOW NOTECALLEDINFO INCREMENT.XREF INCREMENT.CALLS FILTERFN 
		   CHECKFILTERFNSWITCH GETFD PRINTPCSKIPFNS ADDSTATTIME))
	(COMS (* Fns for nicely printing the results of the stats)
	      (FNS PRINTPCALLHEADER PRINTFNINFO PRINTFVARINFO PRINTFVARINFO1 PRINTFVARBYFN 
		   PRINTFVARENTRY PRINTCALLINFO PRINTCALLINFOLST SIMPLELISTFROMHASHCOUNTS 
		   FREQLISTFROMHASHCOUNTS FNFROMHEADER SUBR#OF FNHEADEROF FNHEADERSOF 
		   COLLECTFNHEADERS TICKSTOMICROSECONDS))
	(DECLARE: EVAL@COMPILE DONTEVAL@LOAD DONTCOPY (FILES (LOADCOMP)
							     APS)
		  (GLOBALVARS * (MAPCAR (APPEND PCALLVARS PCALLPARAMS)
					(FUNCTION CAR)))
		  (GLOBALVARS FNDATASAV \INITSUBRS))
	[P (OR (LISTP (EVALV (QUOTE \INITSUBRS)))
	       (LOADVARS (QUOTE \INITSUBRS)
			 (QUOTE LLSUBRS]
	(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA APSFLTR APSBKDWN)
									      (NLAML)
									      (LAMA])
(FILESLOAD APS)

(RPAQQ PCALLVARS ((FNCOUNTMAX 63)
		  (FNCOUNTS (ARRAY (ADD1 FNCOUNTMAX)
				   (QUOTE POINTER)
				   NIL 0))
		  (FLTCNTS (HARRAY 300))
		  (FNHEADERTABLE NIL)
		  (CURRENTFN NIL)
		  (FNDATA NIL)
		  (LASTFNTIME NIL)
		  (FVARSTARTED)
		  (FVAREVENTLST)
		  (NABL (NOT APSBKDWNFN))
		  (APSSKIPFNSNUMS (MAPCONC APSSKIPFNS (FUNCTION FNHEADERSOF)))
		  (APSFLTRFNSNUMS (MAPCONC APSFLTRFNS (FUNCTION FNHEADERSOF)))
		  (APSBKDWNFNSNUMS (MAPCONC APSBKDWNFNS (FUNCTION FNHEADERSOF)))
		  (APSBKDWNFNNUM (FNHEADEROF APSBKDWNFN))
		  (FLTRFLG NIL)
		  (DISTRIBUTIONLST NIL)
		  (CALLEDPUNTFN NIL)
		  (PUNTCOUNTS NIL)
		  (PARALLELSTACK NIL)
		  (PSTACKFLAG (OR RETFROMSTACKFLG APSBKDWNFN APSBKDWNFNS))))

(RPAQQ PCALLEVENTS ((CALLEVENT 192 252)
		    (FVAREVENT 253)
		    (FVAREXITEVENT 254)
		    (RETURNEVENT 255)
		    (DISKEVENT 152 154)))

(RPAQQ PCALLFORMAT [(NIL PRINTPCALLHEADER NIL)
		    (NIL PRINTFNINFO "" FNCOUNTS FNTSMIN)
		    (NIL PRINTFNINFO "Filtered out fns" FLTCNTS FNTSMIN)
		    (NIL PRINTFVARINFO FVAREVENTLST .001)
		    (NIL PRINTFVARBYFN FVAREVENTLST .001)
		    (NIL PRINTFNINFO "Alphabetic" FNCOUNTS FNTSMINALL T)
		    (NIL PRINTCALLINFO FNTSMINALL)
		    (NIL OR APSTRACEFLG APSDEBUGFLG (SETQ FLTCNTS (SETQ FNCOUNTS NIL])

(RPAQQ PCALLPARAMS ((APSBKDWNFN NIL (* Window function))
	(APSBKDWNFNS NIL (* break down time with respect to these functions))
	(APSFLTRFNS (QUOTE (\ACTONVMEMPAGES \CLEANUPDISKQUEUE \CLEARCB \DOACTONDISKPAGES 
					    \DODISKCOMMAND \DOWRITEDISKPAGES \FAULTHANDLER \FLUSHPAGE 
					    \GETDISKCB \INSUREVMEMFILE \KEYHANDLER1 \LOADVMEMPAGE 
					    \LOOKUPFMAP \LOOKUPPAGEMAP \M44ACTONVMEMFILE 
					    \MARKPAGEVACANT \NWWInterrupt \PAGEFAULT \PageFault 
					    \REALDISKDA \SELECTREALPAGE \StackOverflow \StatsOverflow 
					    \TRANSFERPAGE \UPDATECHAIN \VIRTUALDISKDA))
		    (* filter out calls to these functions))
	(APSSKIPFNS (QUOTE (\GETKEY WAITFORINPUT DISMISS GATHERSTATS \GATHERSTATS RAID))
		    (* ignore any time attributed to these functions))
	(ALTOTICKTIME (FQUOTIENT 1000.0 \RCLKMILLISECOND))
	(RETFROMSTACKFLG NIL (* if NIL, won't keep stack to handle RETFROMs))
	(APSTRACEFLG NIL (* if T, causes printout of every CALL and RETURN event when read))
	(DISTRIBUTIONFN NIL (* if set, this is the function whose time distribution is analyzed))
	(TOTALTIMEFLG NIL (* if T, total time is analyzed rather than time per function))
	(NOTECALLINFOFLG T (* if T, prints out a table of who calls who))
	(FNTSMIN .001 (* threshold for function listing))
	(FNTSMINALL 0 (* threshold for alphabetic listing))))

(RPAQ APSBKDWNFN NIL (* Window function))

(RPAQ APSBKDWNFNS NIL (* break down time with respect to these functions))

(RPAQQ APSFLTRFNS (\ACTONVMEMPAGES \CLEANUPDISKQUEUE \CLEARCB \DOACTONDISKPAGES \DODISKCOMMAND 
				   \DOWRITEDISKPAGES \FAULTHANDLER \FLUSHPAGE \GETDISKCB 
				   \INSUREVMEMFILE \KEYHANDLER1 \LOADVMEMPAGE \LOOKUPFMAP 
				   \LOOKUPPAGEMAP \M44ACTONVMEMFILE \MARKPAGEVACANT \NWWInterrupt 
				   \PAGEFAULT \PageFault \REALDISKDA \SELECTREALPAGE \StackOverflow 
				   \StatsOverflow \TRANSFERPAGE \UPDATECHAIN \VIRTUALDISKDA))

(RPAQQ APSSKIPFNS (\GETKEY WAITFORINPUT DISMISS GATHERSTATS \GATHERSTATS RAID))

(RPAQ ALTOTICKTIME (FQUOTIENT 1000.0 \RCLKMILLISECOND))

(RPAQ RETFROMSTACKFLG NIL (* if NIL, won't keep stack to handle RETFROMs))

(RPAQ APSTRACEFLG NIL (* if T, causes printout of every CALL and RETURN event when read))

(RPAQ DISTRIBUTIONFN NIL (* if set, this is the function whose time distribution is analyzed))

(RPAQ TOTALTIMEFLG NIL (* if T, total time is analyzed rather than time per function))

(RPAQ NOTECALLINFOFLG T (* if T, prints out a table of who calls who))

(RPAQ FNTSMIN .001 (* threshold for function listing))

(RPAQ FNTSMINALL 0 (* threshold for alphabetic listing))

(ADDTOVAR PARAMNAMES PCALLPARAMS)

(ADDTOVAR APSVARNAMES PCALLVARS)

(ADDTOVAR EVENTSNAMES PCALLEVENTS)

(ADDTOVAR FORMATNAMES PCALLFORMAT)
(DECLARE: DONTCOPY 
[DECLARE: EVAL@COMPILE 

(RECORD FunctionData ((#OfCalls . TotalTime)
		      CalledFns CallingFns FnName . CallInfoList)
		     [ACCESSFNS FunctionData (ExternalTime (FIXR (FTIMES (fetch TotalTime
									    of DATUM)
									 ALTOTICKTIME]
		     CalledFns ←(CONS)
		     CallingFns ←(CONS))

(RECORD FVARSTAT (FVARNAME . FVAREVENTS))

(RECORD FVAREVENT (FVARCALLEDBY FVARTIME . FVARCOUNTS))
]

(DECLARE: EVAL@COMPILE 

(PUTPROPS .FNHEADEREQUAL. MACRO [OPENLAMBDA (X Y)
					    (AND (EQ (CDR X)
						     (CDR Y))
						 (EQ (CAR X)
						     (CAR Y])

(PUTPROPS .FNHEADERMEMB. MACRO ((HEADER LST)
				(find H in LST suchthat (.FNHEADEREQUAL. H HEADER))))

(PUTPROPS PUNTFNP MACRO ((FNHEADER)
			 (EQ (CAR FNHEADER)
			     0)))
)
)



(* Fns for handling specific stats events)

(DEFINEQ

(CALLEVENT
  [LAMBDA (ARG ARG2 ARG3)                                    (* lmm "26-MAR-82 13:43")
    (DECLARE (USEDFREE APSTRACEFLG PSTACKFLAG APSBKDWNFNNUM EVENT NABL FNDATA CURRENTFN PARALLELSTACK)
	     )
    (COND
      ([OR NABL (COND
	     ((EQUAL ARG APSBKDWNFNNUM)                      (* turning on analysis.)
	       (BEGINWINDOW ARG)
	       (SETQ NABL T]                                 (* a call has been made to the function CALLEDFN at 
							     NOWTIME.)
	(PROG ((CALLEDFN ARG)
	       (NARGS (LOGAND EVENT 77Q))
	       NEWDATA
	       (NOWTIME (CONVTIMER ARG2 ARG3)))
	      (COND
		(APSTRACEFLG (printout T "called " (FNFROMHEADER CALLEDFN)
				       " at " 36Q NOWTIME T)))

          (* note the function left by this call on the stack. So that CURRENTFN is the function being run and the top of 
	  the stack is the one that called it.)


	      (COND
		((FILTERFN CALLEDFN)
		  (ADDSTATTIME FNDATA NOWTIME)
		  (INCREMENT.CALLS (SETQ NEWDATA (GETFD CALLEDFN NARGS))
				   NARGS)
		  (NOTECALLEDINFO FNDATA (SETQ FNDATA NEWDATA)))
		(T                                           (* if the guy who is being called is not being filtered,
							     don't change FNDATA)
		   NIL))
	      (COND
		(PSTACKFLAG (push PARALLELSTACK CURRENTFN)))
	      (SETQ CURRENTFN CALLEDFN)
	      (RETURN])

(RETURNEVENT
  [LAMBDA (ARG ARG2 ARG3)          (* lmm "13-FEB-83 15:28")
    (COND
      (NABL 

          (* a function (unknown by the event but known to us as CURRENTFN) has returned to the function TOFN.
	  Charge the time interval between LASTFNTIME and now to CURRENTFN and reset some variable.)


	    (PROG ((NOWTIME (CONVTIMER ARG2 ARG3))
		   (TOFN ARG))
	          (DECLARE (SPECVARS NOWTIME))
	          (COND
		    (APSTRACEFLG (printout T "Returnto" , (FNFROMHEADER TOFN)
					   , "at" 36Q NOWTIME T)))
                                   (* if the function being returned to is not the top of PARALLELSTACK, this is a 
				   RETFROM.)
	          [COND
		    ((OR (NOT PSTACKFLAG)
			 (EQUAL (CAR PARALLELSTACK)
				TOFN))
                                   (* everything is ok)
		      (CHECKFILTERFNSWITCH CURRENTFN TOFN)

          (* the TOFN is left on the stack during the CHECKFILTERSWITCH so that it can get time added to it by ADDSTATTIME if 
	  keeping track of total time.)


		      (AND PSTACKFLAG (pop PARALLELSTACK)))
		    [(EQUAL CURRENTFN APSBKDWNFNNUM)

          (* leaving the window function. TOFN is not the top of stack because analysis was turned off when window fn was 
	  entered so we don't know who called it. Stack should be empty)


		      (CHECKFILTERFNSWITCH CURRENTFN TOFN)
		      (COND
			((SETQ PARALLELSTACK (CDR PARALLELSTACK))
			  (HELP "ITEMS STILL ON PARALLELSTACK"]
		    (T             (* retfrom event)
		       (PROG (TOSTACK)
                                   (* find location on stack to return to.)
			     (COND
			       ((SETQ TOSTACK (MEMBER TOFN (CDDR PARALLELSTACK)))

          (* CDDR is to get out of the frame that did the call to RETFROM. ie. CAR is RETTO0, and CADR should be the caller 
	  who cannot be RETTOed.)



          (* leave TOSTACK pointing to the fn being returned to so that we can distinquish the return to top of stack from the
	  return off stack cases.)


				 NIL)
			       (T 

          (* fn not on stack: assume it is a return to a function whose call was not logged. That is clear the parallel stack 
	  if there is one, if not, switch functions.)


				  (SETQ TOSTACK NIL)))
                                   (* check for another possible place to return to and print warning.)
			     (COND
			       ((MEMBER TOFN (CDR TOSTACK))
				 (printout T "WARNING: " (FNFROMHEADER TOFN)
					   " HAS BEEN RETTOed WITHIN A RECURSIVE CALL." T)))

          (* simulate return events for all skipped entries on the stack. Since NOWTIME and LASTFNTIME are global, these 
	  should add 0 to stats of all except the first skipped one to being monitored. This is necessary to allow 
	  CHECKFILTERFNSWITCH to check for breakdown function, filtering functions and to reset the APSTK.)


			     (for X on (LDIFF PARALLELSTACK (CDR TOSTACK))
				do (CHECKFILTERFNSWITCH (CAR X)
							(CADR X))
				when (CADR X))
                                   (* update the parallel stack)
			     (COND
			       (TOSTACK (SETQ PARALLELSTACK (CDR TOSTACK)))
			       (T 
                                   (* if ran off stack, switch from top of stack to new TO function.)
				  (CHECKFILTERFNSWITCH CURRENTFN TOFN)
				  (SETQ PARALLELSTACK NIL)))
			     (RETURN]
	          (RETURN])

(FVAREVENT
  [LAMBDA (ARG ARG2 ARG3)                                    (* bvm: "21-OCT-83 15:03")
    (PROG ((FVARTIME (CONVTIMER ARG2 ARG3)))
          (COND
	    (APSTRACEFLG (printout T "Fvar looked up from " (FNFROMHEADER ARG)
				   " at " FVARTIME T)))
          (SETQ FVARSTARTED (CONS FVARTIME ARG])

(FVAREXITEVENT
  [LAMBDA (ARG ARG2 ARG3)                                    (* bvm: "21-OCT-83 16:55")
    (PROG ((FVARTIME (CONVTIMER ARG2 ARG3))
	   (NAME (\INDEXATOMVAL (CDR ARG)))
	   (HIBINDING (CAR ARG))
	   TIM ENTRY EVENT)
          (OR FVARSTARTED (HELP "Fvar exit with no Fvar start"))
          (SETQ TIM (IDIFFERENCE FVARTIME (CAR FVARSTARTED)))
          [OR (SETQ ENTRY (find X in FVAREVENTLST suchthat (EQ (fetch FVARNAME of X)
							       NAME)))
	      (push FVAREVENTLST (SETQ ENTRY (create FVARSTAT
						     FVARNAME ← NAME]
          [COND
	    ([SETQ EVENT (find X in (fetch FVAREVENTS of ENTRY) suchthat (.FNHEADEREQUAL.
									   (fetch FVARCALLEDBY
									      of X)
									   (CDR FVARSTARTED]
	      (add (fetch FVARTIME of EVENT)
		   TIM))
	    (T (push (fetch FVAREVENTS of ENTRY)
		     (SETQ EVENT (create FVAREVENT
					 FVARCALLEDBY ←(CDR FVARSTARTED)
					 FVARTIME ← TIM]
          (for X in (fetch FVARCOUNTS of EVENT) when (EQ (CAR X)
							 HIBINDING)
	     do (add (CDR X)
		     1)
		(RETURN)
	     finally (push (fetch FVARCOUNTS of EVENT)
			   (CONS HIBINDING 1)))
          (SETQ FVARSTARTED)
          (COND
	    (APSTRACEFLG (printout T "Fvar lookup of " NAME " took " (TICKSTOMICROSECONDS TIM)
				   " usecs, found hiloc " HIBINDING T])

(DISKEVENT
  [LAMBDA (N INX)                                            (* bvm: "22-FEB-82 14:56")

          (* there has been a disk operation for Swap reading, writing or buffer dumping from the BCPL code.
	  note stats and change the LASTFNTIME to filter time from function call stats)


    (DECLARE (SPECVARS DUMMYEVENT))
    (PROG ((DUMMYEVENT T)
	   [DISKEVENTTYPE (CONS 0 (SUBR#OF (SELECTQ (LOGAND EVENT 2)
						    ((0 1)
						      (QUOTE \PageFault))
						    (2 (QUOTE \StatsOverflow))
						    (ERROR "Unknown disk swap event" EVENT]
	   END FD BEG)
          [ADDSTATTIME FNDATA (SETQ BEG (CONVTIMER (BIN2 INX)
						   (BIN2 INX]
          (COND
	    (APSTRACEFLG (printout T 6 (FNFROMHEADER DISKEVENTTYPE)
				   , "began at" 40 BEG T)))
                                                             (* charge to the current fn the time before the disk 
							     event and charge the interval now to disk type.)
          [ADDSTATTIME (SETQ FD (GETFD DISKEVENTTYPE 0))
		       (SETQ END (CONVTIMER (BIN2 INX)
					    (BIN2 INX]
          (INCREMENT.CALLS FD 0)
          (COND
	    (APSTRACEFLG (printout T 6 (FNFROMHEADER DISKEVENTTYPE)
				   " ended at" 40 END T])
)



(* User functions for controlling filtering)

(DEFINEQ

(APSBKDWN
  [NLAMBDA X                                                 (* lmm " 3-DEC-80 15:44")
                                                             (* modified by rrb to allow the breakdown functions to 
							     be unnumbered at the time of specification.)
    (COND
      ((MEMB (QUOTE ERRORSET)
	     X)
	(printout T "WARNING: Cannot breakdown on ERRORSET" T)))
    (SETQ APSBKDWNFN (OR (CAR X)
			 (AND (CDR X)
			      APSBKDWNFN)))
    (SETQ APSBKDWNFNS (COND
	((CDR X)
	  (NCONC (AND APSBKDWNFN (LIST APSBKDWNFN))
		 (CDR X])

(APSFLTR
  [NLAMBDA X                                                 (* lmm " 3-DEC-80 13:45")
                                                             (* modified by rrb to allow filter breakdown functions 
							     to be unnumbered at the time of specification.)
    (SETQ APSFLTRFNS X])
)



(* Fns to aid in the stats gathering)

(DEFINEQ

(BEGINWINDOW
  [LAMBDA (WINDOWFN)                                         (* bvm: "16-FEB-82 14:10")
                                                             (* debugging fn which marks the entering of the window 
							     function.)
    (COND
      (APSDEBUGFLG (PRIN1 "Beginning to analyse ")
		   (PRINT (FNFROMHEADER WINDOWFN])

(ENDWINDOW
  [LAMBDA (WINDOWFN)                                         (* bvm: "16-FEB-82 14:10")
                                                             (* debugging fn which marks the exit from the window 
							     function.)
    (COND
      (APSDEBUGFLG (printout NIL "No longer analysing " (FNFROMHEADER WINDOWFN])

(NOTECALLEDINFO
  [LAMBDA (CALLINGDATA CALLEDDATA)                           (* bvm: "22-FEB-82 14:55")
                                                             (* notes the fact that one function called another.)
    (COND
      ((AND NOTECALLINFOFLG (fetch CallingFns of CALLEDDATA))
                                                             (* Don't record punt calls (their CALLINGFNS start out 
							     NIL instead of (NIL)))
	(INCREMENT.XREF (fetch CalledFns of CALLINGDATA)
			CALLEDDATA)
	(INCREMENT.XREF (fetch CallingFns of CALLEDDATA)
			CALLINGDATA])

(INCREMENT.XREF
  [LAMBDA (ALST KEY)                                         (* bvm: "22-FEB-82 14:43")
                                                             (* increments a field in an alist.
							     KEY is a GETFD value. Assumes the alist has at least one
							     element.)
    (COND
      ((LISTP ALST)
	(PROG ((D (FASSOC KEY ALST)))
	      (COND
		(D                                           (* bucket already exists, add to it.)
		   (add (CDR D)
			1))
		(T                                           (* first call with KEY, create a new bucket.)
		   (FRPLACD ALST (CONS (CONS KEY 1)
				       (CDR ALST])

(INCREMENT.CALLS
  [LAMBDA (FNNODE NARGS)                                     (* lmm "22-JUN-80 16:10")
                                                             (* updates the fields in the FunctionData record which 
							     keep track of calls.)
    (PROG (D)                                                (* increment the number of times called with NARGS 
							     arguments)
          (COND
	    ([NULL (SETQ D (FASSOC NARGS (fetch CallInfoList of FNNODE]
                                                             (* first call with NARGS, create a new bucket.)
	      (ATTACH (CONS NARGS 1)
		      (fetch CallInfoList of FNNODE)))
	    (T                                               (* bucket already exists, add to it.)
	       (add (CDR D)
		    1)))                                     (* add to total number of calls.)
          (add (fetch #OfCalls of FNNODE)
	       1])

(FILTERFN
  [LAMBDA (FNN)                                              (* bvm: " 5-OCT-83 12:39")

          (* is FNN a function of interest? Interesting functions are either those being broken down on or those being 
	  filtered on. If filtering function, set up to stop adding events and look for end of filtering.)


    (COND
      (FLTRFLG                                               (* if we are filtering, ignore all except the function 
							     that started the filtering.)
	       (.FNHEADEREQUAL. FNN FLTRFLG))
      [(.FNHEADERMEMB. FNN APSSKIPFNSNUMS)                   (* begin filtering the events, save the current function
							     data record so that after filtering stops, it can be 
							     reinstalled by CHECKFILTERFWSWITCH)
	(SETQ FLTRFLG FNN)
	(SETQ FNDATASAV FNDATA)
	(COND
	  (APSTRACEFLG (printout T "Starting to ignore events. Called " (FNFROMHEADER FNN)
				 " at " NOWTIME T]
      (T (OR (NULL APSBKDWNFNSNUMS)
	     (.FNHEADERMEMB. FNN APSBKDWNFNSNUMS])

(CHECKFILTERFNSWITCH
  [LAMBDA (FROMFN TOFN)                                      (* bvm: " 5-OCT-83 12:41")

          (* A switch is being made from FROMFN to TOFN. This checks to see if FROMFN is being monitored for filtering or 
	  breakdown and If FROMFN is, the appropriate special variables are changed to close out and add in its time.
	  CURRENTFN is the function now being executed regardless of breakinf down or filtering, FNDATA is the data record 
	  of the function to whom time is being charged If FLTRFLG is non-NIL, time is being disguarded and FLTRFN is the 
	  function which started the filtering.)



          (* This fn was created by rrb to apply it to the elements that were skipped by a retfrom. It is only called from 
	  RETURNEVENT.)


    (DECLARE (USEDFREE CURRENTFN FNDATA FNDATASAV NOWTIME FLTRFLG DISTRIBUTIONFN NABL LASTFNTIME))
    [PROG NIL
          [COND
	    ((AND DISTRIBUTIONFN FNDATA LASTFNTIME (.FNHEADEREQUAL. DISTRIBUTIONFN FROMFN))
                                                             (* check for the one function to get a distribution on.)
	      (push DISTRIBUTIONLST (IDIFFERENCE NOWTIME LASTFNTIME]
          (COND
	    [FLTRFLG (COND
		       [(.FNHEADEREQUAL. FROMFN FLTRFLG)

          (* the only function of interest is the function that started filtering and it is just now being returned from.
	  reset time and return to monitoring state.)


			 (SETQ FLTRFLG NIL)
			 (SETQ LASTFNTIME NOWTIME)           (* restore FNDATA to value before began filtering.)
			 (SETQ FNDATA FNDATASAV)
			 (COND
			   (APSTRACEFLG (printout T "Resuming looking at events. Left " (FNFROMHEADER
						    FROMFN)
						  , "at" , LASTFNTIME T]
		       (T (RETURN]
	    (T (ADDSTATTIME FNDATA NOWTIME)))
          (COND
	    ((.FNHEADEREQUAL. FROMFN APSBKDWNFNNUM)
	      (ENDWINDOW FROMFN)                             (* returning from bkdwn fn, turn off stats)
	      (SETQ NABL NIL)
	      (SETQ FNDATA NIL)
	      (SETQ LASTFNTIME NIL))
	    ((FILTERFN TOFN)
	      (SETQ FNDATA (GETFD TOFN]
    (SETQ CURRENTFN TOFN])

(GETFD
  [LAMBDA (FN NARGS)                                         (* rmk: "31-Dec-83 14:42")
                                                             (* retrieves or creates the function data record for 
							     function FN. FN is a dotted pair representing a function
							     header. Two-level hash scheme here)
    (PROG [(BUCKET (FASTELT FNCOUNTS (CAR FN]
          [OR BUCKET (FASTSETA FNCOUNTS (CAR FN)
			       (SETQ BUCKET (HARRAY 100]
          (RETURN (OR (GETHASH (CDR FN)
			       BUCKET)
		      (AND (NEQ NARGS T)
			   (PUTHASH (CDR FN)
				    (create FunctionData
					    #OfCalls ← 0
					    TotalTime ← 0
					    CallInfoList ←(AND NARGS (LIST (CONS NARGS 0)))
					    CallingFns ←(AND (NOT (PUNTFNP FN))
							     (CONS)))
				    BUCKET])

(PRINTPCSKIPFNS
  [LAMBDA (MSG LST)                                          (* rrb "16-JAN-81 15:38")
    (COND
      (LST (MAPRINT LST NIL MSG NIL ", ")
	   (TERPRI])

(ADDSTATTIME
  [LAMBDA (FNNODE NTIME)                                     (* lmm "22-JUN-80 16:08")
                                                             (* adds the current time interval to NTIME and resets 
							     the variable LASTFNTIME to hold the new time.)
                                                             (* most of this COND checks for initialization.
							     All of the work is done by add and replace.)
    [COND
      (FNNODE (COND
		(LASTFNTIME
		  (COND
		    [(ILESSP NTIME LASTFNTIME)
		      (COND
			((AND (IGREATERP LASTFNTIME 67104768)
			      (ILESSP NTIME 4095))           (* assume the clock has wrapped around charge only the 
							     ntime.)
			  (add (fetch TotalTime of FNNODE)
			       NTIME))
			(T                                   (* check for monotone time)
			   (HELP "non-increasing time" NTIME]
		    (T                                       (* if flag on, add time interval to everybody who is on 
							     the stack.)
		       [AND TOTALTIMEFLG (NULL DUMMYEVENT)
			    (PROG ((INTERVALTIME (IDIFFERENCE NTIME LASTFNTIME)))
			          (OR (ZEROP INTERVALTIME)
				      (for INFNTAIL on PARALLELSTACK
					 do                  (* check for the NIL which is on top of the stack and 
							     recursive calls.)
					    (AND (CAR INFNTAIL)
						 (NOT (MEMBER (CAR INFNTAIL)
							      (CDR INFNTAIL)))
						 (add (fetch TotalTime of (GETFD (CAR INFNTAIL)))
						      INTERVALTIME]
		       (add (fetch TotalTime of FNNODE)
			    (IDIFFERENCE NTIME LASTFNTIME]
    (SETQ LASTFNTIME NTIME])
)



(* Fns for nicely printing the results of the stats)

(DEFINEQ

(PRINTPCALLHEADER
  [LAMBDA NIL                                                (* bvm: " 6-OCT-83 14:59")
    (COND
      (APSBKDWNFN (printout NIL "Windowing on " APSBKDWNFN T))
      (T (printout NIL "Not Windowing" T)))                  (* move all of the data about filtered functions into 
							     another array.)
    (COLLECTFNHEADERS)
    (PROG (SKIPPEDFNS FILTEREDFNS)
          (DECLARE (SPECVARS I SKIPPEDFNS FILTEREDFNS))
          (for I from 0 to FNCOUNTMAX bind BUCKET when (SETQ BUCKET (FASTELT FNCOUNTS I))
	     do [MAPHASH BUCKET (FUNCTION (LAMBDA (ENTRY KEY DUMMY)
			     (DECLARE (USEDFREE I SKIPPEDFNS FILTEREDFNS))
			     (SETQ DUMMY (CONS I KEY))
			     (OR (fetch FnName of ENTRY)
				 (replace FnName of ENTRY with (FNFROMHEADER DUMMY T)))
			     (COND
			       ((OR (AND (.FNHEADERMEMB. DUMMY APSFLTRFNSNUMS)
					 (PROGN (pushnew FILTEREDFNS (fetch FnName of ENTRY))
						T))
				    (AND (.FNHEADERMEMB. DUMMY APSSKIPFNSNUMS)
					 (PROGN (pushnew SKIPPEDFNS (fetch FnName of ENTRY))
						T)))
				 (PUTHASH KEY NIL BUCKET)
				 (PUTHASH DUMMY ENTRY FLTCNTS]
	     finally (SETQ FLTCNTS (ARRAY 1 (QUOTE POINTER)
					  FLTCNTS 0)))
          (PRINTPCSKIPFNS "Breaking down wrt " APSBKDWNFNS)
          (PRINTPCSKIPFNS "Filtering out " FILTEREDFNS)
          (PRINTPCSKIPFNS "Ignoring time for " SKIPPEDFNS])

(PRINTFNINFO
  [LAMBDA (STR COUNTS MIN ALPHFLG)                           (* bvm: "21-OCT-83 17:39")
    (printout NIL "Function timings" (COND
		(STR ": ")
		(T ""))
	      STR 43 "#ofCalls   PerCall" T)
    (PROG ((TOTAL#OFCALLS 0)
	   TOTALTIME)
          (SETQ TOTALTIME (PFREQ [SORT (FREQLISTFROMHASHCOUNTS COUNTS)
				       (COND
					 [ALPHFLG (FUNCTION (LAMBDA (X Y)
						      (ALPHORDER (fetch FnName of (CAR X))
								 (fetch FnName of (CAR Y]
					 (T (FUNCTION CDRGTP]
				 [FUNCTION (LAMBDA (FDATA FLAG)
				     (COND
				       (FLAG (COND
					       ((STRINGP (SETQ FLAG (fetch FnName of FDATA)))
						 (PRIN1 FLAG))
					       (T (PRIN2 FLAG)))
                                                             (* print number of calls and the time per call.)
					     [for D in (SETQ FLAG (SORT (fetch CallInfoList
									   of FDATA)
									(FUNCTION CDRGTP)))
						do (printout NIL " [" (CAR D)
							     (QUOTE %]))
						   (COND
						     ((CDR FLAG)
						       (PRIN2 (CDR D]
					     [printout NIL 45 .I6 (fetch #OfCalls of FDATA)
						       53 .I8
						       (IQUOTIENT (fetch ExternalTime of FDATA)
								  (COND
								    ((ZEROP (SETQ FDATA
									      (fetch #OfCalls
										 of FDATA)))
								      1)
								    (T FDATA]
					     (add TOTAL#OFCALLS FDATA))
				       (T 100]
				 MIN
				 (OR [AND TOTALTIMEFLG
					  (PROGN             (* if keeping track of total time under each fn and 
							     there is a breakdown function, use it's time as the 
							     total.)
						 (COND
						   (APSBKDWNFN (fetch ExternalTime
								  of (GETFD APSBKDWNFNNUM)))
						   ((GETD (QUOTE STATSDUMMYFUNCTION))
                                                             (* no top level function, use STATSDUMMYFUNCTION if it 
							     has a definition.)
						     (PROG ((DATA (GETFD (FNHEADEROF (QUOTE 
									       STATSDUMMYFUNCTION))
									 T)))
						           (RETURN (AND DATA (fetch ExternalTime
										of DATA]
				     T)))
          (printout NIL 45 .I6 TOTAL#OFCALLS T)
          (COND
	    ((AND (NOT ALPHFLG)
		  (EQ COUNTS FNCOUNTS))
	      (SETQ TOTALFNTIME TOTALTIME])

(PRINTFVARINFO
  [LAMBDA (COUNTS MINCNT)                                    (* bvm: "23-OCT-83 16:27")
    (COND
      (COUNTS (printout NIL T "Free Variable Lookup Times" 40 "Looked Up By" 68 
			" uSecs [number of lookups]"
			T)
	      (PRINTFVARINFO1 COUNTS MINCNT])

(PRINTFVARINFO1
  [LAMBDA (COUNTS MINCNT)                                    (* bvm: "23-OCT-83 16:27")
    (PFREQ (SORT [for FV in COUNTS collect (CONS FV (TICKSTOMICROSECONDS (for EVENT
									    in (fetch FVAREVENTS
										  of FV)
									    sum (fetch FVARTIME
										   of EVENT]
		 (FUNCTION CDRGTP))
	   (FUNCTION PRINTFVARENTRY)
	   MINCNT TOTALFNTIME)
    (TERPRI])

(PRINTFVARBYFN
  [LAMBDA (COUNTS MINCNT)                                    (* bvm: "23-OCT-83 16:27")
    (COND
      (COUNTS (printout NIL T "Free Variable Lookup by Function" 40 "Variable Name" 68 
			" uSecs [number of lookups]"
			T)
	      (PROG (NEWCOUNTS)
		    [for FV in COUNTS
		       do (for EVENT in (fetch FVAREVENTS of FV) bind FN
			     do (SETQ FN (fetch FVARCALLEDBY of EVENT))
				(push [fetch FVAREVENTS
					 of (OR (find ENTRY in NEWCOUNTS
						   suchthat (.FNHEADEREQUAL. (fetch FVARNAME
										of ENTRY)
									     FN))
						(PROGN (push NEWCOUNTS (create FVARSTAT
									       FVARNAME ← FN))
						       (CAR NEWCOUNTS]
				      (create FVAREVENT using EVENT FVARCALLEDBY ←(fetch FVARNAME
										     of FV]
		    (PRINTFVARINFO1 NEWCOUNTS MINCNT])

(PRINTFVARENTRY
  [LAMBDA (FDATA FLG)                                        (* bvm: "23-OCT-83 16:25")
    (COND
      ((NULL FLG)
	100)
      (T (PROG ((EVENTS (fetch FVAREVENTS of FDATA)))
	       [printout NIL .P2 (COND
			   ((LITATOM (fetch FVARNAME of FDATA))
			     (fetch FVARNAME of FDATA))
			   (T (FNFROMHEADER (fetch FVARNAME of FDATA]
	       [COND
		 ((CDR EVENTS)
		   (SORT EVENTS (FUNCTION (LAMBDA (X Y)
			     (IGREATERP (fetch FVARTIME of X)
					(fetch FVARTIME of Y]
	       (for EVENT in EVENTS bind (VALHI ←(\HILOC \VALSPACE))
		  do (printout NIL 40 .P2 [COND
				 ((LITATOM (fetch FVARCALLEDBY of EVENT))
				   (fetch FVARCALLEDBY of EVENT))
				 (T (FNFROMHEADER (fetch FVARCALLEDBY of EVENT]
			       68 .I6 (TICKSTOMICROSECONDS (fetch FVARTIME of EVENT)))
		     (for CNT in (fetch FVARCOUNTS of EVENT)
			do (printout NIL " [" (CDR CNT)
				     "]")
			   (COND
			     ((OR (NEQ (CAR CNT)
				       \STACKHI)
				  (CDR (fetch FVARCOUNTS of EVENT)))
			       (printout NIL (COND
					   ((EQ (CAR CNT)
						\STACKHI)
					     "Stack")
					   ((EQ (CAR CNT)
						VALHI)
					     "Global")
					   (T "OffStack"])

(PRINTCALLINFO
  [LAMBDA NIL                                                (* bvm: "20-FEB-82 00:11")
                                                             (* prints the called/calling info from FNCOUNTS hash 
							     array)
    (COND
      (NOTECALLINFOFLG (printout NIL "Call Information:" T T)
		       (for FDATA in [SORT (SIMPLELISTFROMHASHCOUNTS FNCOUNTS)
					   (FUNCTION (LAMBDA (A B)
					       (ALPHORDER (fetch FnName of A)
							  (fetch FnName of B]
			  when (OR (fetch CallingFns of FDATA)
				   (fetch CalledFns of FDATA))
			  do                                 (* FDATA is of the form (fname . FunctionDataRec))
			     (PRINT (fetch FnName of FDATA))
			     (PRINTCALLINFOLST "Calls:" (fetch CalledFns of FDATA))
			     (PRINTCALLINFOLST "Callers:" (fetch CallingFns of FDATA])

(PRINTCALLINFOLST
  [LAMBDA (SCR L)                                            (* bvm: "22-FEB-82 15:17")
                                                             (* Prints the list of callers or callees)
    (COND
      ((SORT L (FUNCTION CDRGTP))
	(printout NIL 10 SCR 19)                             (* Print the passed in heading)
	[for X on L bind (EOLPOS ←(LINELENGTH)) do (SETQ SCR (fetch FnName of (CAAR X)))
						   (COND
						     ((ILESSP EOLPOS (IPLUS (POSITION)
									    (NCHARS SCR)
									    (NCHARS (CDAR X))
									    3))
						       (printout NIL .TAB0 19)
                                                             (* New line if this wont fit)
						       ))
						   (printout NIL SCR " (" (CDAR X)
							     ")")
						   (COND
						     ((CDR X)
                                                             (* More to come so sneak in as much punctuation as we 
							     have room for)
						       (PRIN1 (SELECTQ (IDIFFERENCE EOLPOS (POSITION))
								       (0 "")
								       (1 ",")
								       ", "]
	(TERPRI)
	L])

(SIMPLELISTFROMHASHCOUNTS
  [LAMBDA (COUNTARRAY)                                       (* bvm: " 6-OCT-83 14:54")
                                                             (* creates a list of the FunctionData records that are 
							     stored in COUNTARRAY)
    (COND
      ((EQ (CAR (LISTP (FASTELT COUNTARRAY 0)))
	   (QUOTE RESULT))                                   (* Result was cached)
	(CDR (FASTELT COUNTARRAY 0)))
      (COUNTARRAY (for I from 0 to (SUB1 (ARRAYSIZE COUNTARRAY)) bind L BUCKET declare (SPECVARS
											 L)
		     when (SETQ BUCKET (FASTELT COUNTARRAY I))
		     do [MAPHASH BUCKET (FUNCTION (LAMBDA (ENTRY KEY)
				     (DECLARE (USEDFREE L))
				     (replace CalledFns of ENTRY with (DREMOVE NIL
									       (fetch CalledFns
										  of ENTRY)))
				     (replace CallingFns of ENTRY
					with (DREMOVE NIL (fetch CallingFns of ENTRY)))
				     (push L ENTRY]
		     finally                                 (* Cache result)
			     (FASTSETA COUNTARRAY 0 (CONS (QUOTE RESULT)
							  L))
			     (RETURN L])

(FREQLISTFROMHASHCOUNTS
  [LAMBDA (COUNTS)                                           (* bvm: " 5-OCT-83 15:10")
                                                             (* creates a list of the FunctionData records that are 
							     stored in COUNTS, paired with their totaltimes)
    (for ENTRY in (SIMPLELISTFROMHASHCOUNTS COUNTS) collect (CONS ENTRY (fetch ExternalTime
									   of ENTRY])

(FNFROMHEADER
  [LAMBDA (FNHEADER CAREFUL)                                 (* bvm: "23-OCT-83 16:02")

          (* FNHEADER is dotted pair hiloc,loloc. Returns name of frame. Normally the names are determined by a MAPATOMS 
	  after the analysis, at which time CAREFUL is set, in which case this function just returns an octal string.
	  If CAREFUL is NIL, we try looking inside the indicated FNHEADER for a framename, and verify that the name's 
	  definition cell matches)


    (COND
      [(ZEROP (CAR FNHEADER))
	(CONCAT "Subr." (CAR (NTH \INITSUBRS (ADD1 (CDR FNHEADER]
      (T (PROG ((FD (AND (NOT CAREFUL)
			 (GETFD FNHEADER T)))
		FRAMENAME)
	       (RETURN (COND
			 ((AND FD (fetch FnName of FD)))
			 ((COND
			     [(AND (NOT CAREFUL)
				   (PROG1 (ILESSP [\HILOC (SETQ FRAMENAME (fetch (FNHEADER FRAMENAME)
									     of (\VAG2 (CAR FNHEADER)
										       (CDR FNHEADER]
						  64)        (* Need this test until such time as Dolphin and Dorado 
							     microcode filters out invalid vp's in NTYPX)
					  )
				   (LITATOM FRAMENAME))
			       (EQ (fetch (LITATOM DEFPOINTER) of FRAMENAME)
				   (\VAG2 (CAR FNHEADER)
					  (CDR FNHEADER]
			     (T (SETQ FRAMENAME "")
				NIL))
			   (AND FD (replace FnName of FD with FRAMENAME))
			   FRAMENAME)
			 (T (CONCAT (QUOTE #)
				    (OCTALSTRING (CAR FNHEADER))
				    (QUOTE ,)
				    (OCTALSTRING (CDR FNHEADER))
				    (COND
				      ((LITATOM FRAMENAME)
					(CONCAT (QUOTE /)
						FRAMENAME))
				      (T ""])

(SUBR#OF
  [LAMBDA (SUBRNAME)                                         (* bvm: "13-APR-82 11:41")
    (for S in \INITSUBRS as CNT from 0 do (COND
					    ((EQ S SUBRNAME)
					      (RETURN CNT])

(FNHEADEROF
  [LAMBDA (FN)                                               (* bvm: "16-FEB-82 16:24")
    (PROG ((SB (SUBR#OF FN)))
          (RETURN (COND
		    (SB (CONS 0 SB))
		    (T (LOC (fetch (LITATOM DEFPOINTER) of (\DTEST FN (QUOTE LITATOM])

(FNHEADERSOF
  [LAMBDA (FN)                                               (* bvm: "18-FEB-82 16:33")
    (PROG ((SB (SUBR#OF FN)))
          (RETURN (CONS [LOC (fetch (LITATOM DEFPOINTER) of (\DTEST FN (QUOTE LITATOM]
			(AND SB (LIST (CONS 0 SB])

(COLLECTFNHEADERS
  [LAMBDA NIL                                                (* bvm: "16-FEB-82 14:58")
    (MAPATOMS (FUNCTION (LAMBDA (ATM CELL)
		  (SETQ CELL (fetch (LITATOM DEFINITIONCELL) of ATM))
		  (COND
		    ((AND (fetch CCODEP of CELL)
			  (SETQ CELL (GETFD (LOC (fetch DEFPOINTER of CELL))
					    T)))
		      (replace FnName of CELL with ATM])

(TICKSTOMICROSECONDS
  [LAMBDA (TICKS)                                            (* bvm: "21-OCT-83 16:53")
    (FIXR (FTIMES TICKS ALTOTICKTIME])
)
(DECLARE: EVAL@COMPILE DONTEVAL@LOAD DONTCOPY 
(FILESLOAD (LOADCOMP)
	   APS)

(DECLARE: DOEVAL@COMPILE DONTCOPY

(ADDTOVAR GLOBALVARS FNCOUNTMAX FNCOUNTS FLTCNTS FNHEADERTABLE CURRENTFN FNDATA LASTFNTIME 
	  FVARSTARTED FVAREVENTLST NABL APSSKIPFNSNUMS APSFLTRFNSNUMS APSBKDWNFNSNUMS APSBKDWNFNNUM 
	  FLTRFLG DISTRIBUTIONLST CALLEDPUNTFN PUNTCOUNTS PARALLELSTACK PSTACKFLAG APSBKDWNFN 
	  APSBKDWNFNS APSFLTRFNS APSSKIPFNS ALTOTICKTIME RETFROMSTACKFLG APSTRACEFLG DISTRIBUTIONFN 
	  TOTALTIMEFLG NOTECALLINFOFLG FNTSMIN FNTSMINALL)
)

(DECLARE: DOEVAL@COMPILE DONTCOPY

(ADDTOVAR GLOBALVARS FNDATASAV \INITSUBRS)
)
)
(OR (LISTP (EVALV (QUOTE \INITSUBRS)))
    (LOADVARS (QUOTE \INITSUBRS)
	      (QUOTE LLSUBRS)))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA APSFLTR APSBKDWN)

(ADDTOVAR NLAML )

(ADDTOVAR LAMA )
)
(PUTPROPS PCALLSTATS COPYRIGHT ("Xerox Corporation" 1982 1983))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (6742 14601 (CALLEVENT 6752 . 8144) (RETURNEVENT 8146 . 11573) (FVAREVENT 11575 . 11899)
 (FVAREXITEVENT 11901 . 13341) (DISKEVENT 13343 . 14599)) (14655 15547 (APSBKDWN 14665 . 15230) (
APSFLTR 15232 . 15545)) (15594 24442 (BEGINWINDOW 15604 . 15962) (ENDWINDOW 15964 . 16315) (
NOTECALLEDINFO 16317 . 16942) (INCREMENT.XREF 16944 . 17604) (INCREMENT.CALLS 17606 . 18573) (FILTERFN
 18575 . 19617) (CHECKFILTERFNSWITCH 19619 . 21778) (GETFD 21780 . 22584) (PRINTPCSKIPFNS 22586 . 
22762) (ADDSTATTIME 22764 . 24440)) (24504 37846 (PRINTPCALLHEADER 24514 . 25984) (PRINTFNINFO 25986
 . 28305) (PRINTFVARINFO 28307 . 28593) (PRINTFVARINFO1 28595 . 29033) (PRINTFVARBYFN 29035 . 29944) (
PRINTFVARENTRY 29946 . 31261) (PRINTCALLINFO 31263 . 32185) (PRINTCALLINFOLST 32187 . 33327) (
SIMPLELISTFROMHASHCOUNTS 33329 . 34487) (FREQLISTFROMHASHCOUNTS 34489 . 34932) (FNFROMHEADER 34934 . 
36510) (SUBR#OF 36512 . 36735) (FNHEADEROF 36737 . 37006) (FNHEADERSOF 37008 . 37275) (
COLLECTFNHEADERS 37277 . 37687) (TICKSTOMICROSECONDS 37689 . 37844)))))
STOP