// Stats.bcpl. Lisp statistics buffer 
// Last change March 20, 1985  11:33 AM by Bill van Melle
// Last change May 25, 1983  11:12 AM by Bill van Melle
// Last change April 5, 1981  3:56 PM by Bill van Melle
// ConBrio change December 29, 1981  11:32 AM by Bill van Melle
// Tone change March 17, 1981  1:15 PM by Beau Sheil
// Bar change February 5, 1981  6:54 PM by Beau Sheil
// Phrase change November 23, 1980  5:50 PM by Beau Sheil
// Chord change November 20, 1980  1:01 PM by Beau Sheil
// Previous change August 4, 1980  9:38 PM by Beau Sheil

	get "LispBcpl.decl"
	get "Stats.decl"
	get "Streams.d"

external [	// procedures defined here
	StatsOverflow		// Punt Subr: WRITESTATS()
	WRITESTATS		// Subr: WRITESTATS(type, lvX)
	GATHERSTATS		// Subr: \GATHERSTATS(lvFID)
	OpenStats		// (fid, windowing)
	CloseStats		// ()
	InitStats		// ()
	WriteStatsX		// (x, y, z)
	DumpBlockToStats	// (eventN, addr, numBlocks, blockSize)
		// static defined here
	@MiscSTATSbase; statsFile
		// procedures used
	Bytes2; ReadClock; CallSwat; Smallp; SmallUnbox
	EqNIL; RAIDCode; MoveBlock; Closes; Puts; WriteBlock
        Version; Serial; IGetBase; @BGetBase; OutputStream; TruncateDiskStream
		// statics used
	@lvNIL; @lvKT; NPages; SwapBuf
	 ]

static  [
	statsFile = 0		// Stats disk stream
	MiscSTATSbase = 0
	]

let StatsOverflow() = valof
   [ 
   unless statsFile			// forget it if no stats file
	do [ @StatsPtr=StatsBase	// Reset stats pointer
	     resultis lvNIL
	   ]
   let t = vec 3			// space for two times
   ReadClock(t)				// time of overflow
   WriteBlock(statsFile, StatsBase, @StatsPtr-StatsBase)
   ReadClock(t+2)			// time disk write finished
   @StatsPtr=StatsBase			// Reset stats pointer
   WriteStatsX(evDmpBuff, 4, t)		// log the dump event
   resultis lvNIL
  ]

and WRITESTATS(lvType, lvX) = valof
   [
   let typ = SmallUnbox(lvType)<<LoByte
   let v = vec 10
   let lvArg = lvX
   for i=0 to 9 do				// only got room for 10
     [ unless Smallp(lvArg) break		// args are all smallp
       v!i = SmallUnbox(lvArg); lvArg = lvArg+2 ]	// sequential on stack
   test typ ls 200b
    ifso  WriteStatsX(typ, (v!0)<<LoByte, v!1)
    ifnot WriteStatsX(typ, (lvArg-lvX) rshift 1, v)
   resultis lvNIL
   ]

and GATHERSTATS(lvFID) =
   EqNIL(lvFID) ?
     valof [ CloseStats(); resultis lvNIL ] ,
     valof
       [
	if statsFile
	  then resultis RAIDCode("Multiple stats logs", lvNIL)
	statsFile = OutputStream(lvFID)		// create log stream
	InitStats()
	resultis lvKT
       ]

and InitStats() be
    [
    @StatsPtr = StatsBase
    let v = vec 5
    v!0, v!1, v!2, v!3, v!4, v!5 =
	Version(), Serial(), IGetBase(IFPRVersion), BcplVersion,
	IGetBase(IFPLVersion), NPages
    WriteStatsX(evVersions, 6, v)		// write version event
    DumpMiscStats()				// dump MiscStats at start
    ]

and CloseStats() be
    [ if statsFile
	then [  DumpMiscStats()
		StatsOverflow()
		Closes(statsFile)
		statsFile = 0 ]
      @StatsPtr = 0
    ]

and DumpMiscStats() be
    [ for i = 0 to lenMiscStats-1
	do @(SwapBuf+i) = BGetBase(STATSspace, MISCSTATSbase+i)
      WriteStatsX(evMStatsCnts, lenMiscStats, SwapBuf)
    ]

and WriteStatsX(x,y,z) be
  [ unless @StatsPtr return		// forget it if no stats action
    switchon x rshift 6 into		// EventType: #xyz -> #x
      [ case 0: @StatsPtr!0 = Bytes2(x, y)	// evnt, arg
                @StatsPtr = @StatsPtr+1
                endcase
        case 1: @StatsPtr!0 = Bytes2(x, y)	// evnt, arghi, arglo
		@StatsPtr!1 = z
                @StatsPtr = @StatsPtr+2
                endcase
        case 2: @StatsPtr!0 = Bytes2(x, y-1)	// evnt, N, lv Nwords
                MoveBlock(@StatsPtr+1, z, y)
                @StatsPtr = @StatsPtr+y+1
                endcase
        default: CallSwat("Invalid event number")
                 endcase
      ]
    if @StatsPtr gr StatsEdge then StatsOverflow()
  ]

// DumpBlockToStats dumps large blocks.  Dumps numBlocks of size blockSize
// word 0: {eventN,,blockSize}; word 1: {0, num in sequence}
// words 2 thru blockSize+1 {data}

and DumpBlockToStats(eventN, addr, numBlocks, blockSize) be
  [
   unless statsFile return
   WriteBlock(statsFile, StatsBase, @StatsPtr-StatsBase)	// empty stats buffer
   for i = 1 to numBlocks do
     [ Puts(statsFile, Bytes2(eventN, blockSize)); Puts(statsFile, i)
       WriteBlock(statsFile, addr, blockSize)
       addr = addr + blockSize
     ]
   @StatsPtr=StatsBase			// Reset stats pointer
  ]