// IfsAllocSpy.bcpl -- Allocator spy server -- swappable when not in use
// Copyright Xerox Corporation 1979, 1980, 1981, 1982
// Last modified September 29, 1982  10:21 AM by Taft

get "Pup.decl"
get "IfsOverlays.decl"
get "IfsXEmulator.decl"

external
[
// outgoing procedures
InitAllocSpy; StartAllocSpy

// incoming procedures
GetAllocSpyCtx
TruePredicate; FalsePredicate; Usc
Allocate; Free; Enqueue; Unqueue; CallersFrame
InitializeContext; Block; Dismiss; CreateEvent; AllocSpyEvent
OpenLevel1Socket; OpenRTPSocket; CreateBSPStream
CloseLevel1Socket; CloseRTPSocket; CloseBSPSocket
BSPForceOutput; BSPWriteBlock; FlushQueue; LockCell; UnlockCell
Endofs; Gets; Puts

// outgoing statics
allocSpySoc

// incoming statics
sysZone; chunkQ; ifsCtxQ; FirstOD; EndOD; CtxRunning
ovFirstPage; logOvPageSize; numOvXMPagesPerBank; offsetResidentXM
]

static
[
allocSpySoc; savedFree; savedAllocate
spyStream = 0
allocLock = false
allocSpyCtx = 0
numFramesIgnored = 1
]

manifest numFramesToSend = 3

manifest socketAllocSpy = 51b	// with a 1 in the high 16 bits

// following structure copied from IfsResUtilb
structure ZC:	//zone chunk
[
link word	//link to next chunk
base word	//base of chunk
length word	//length of chunk
zone word	//zone owning chunk
]
manifest lenZC = size ZC/16

//---------------------------------------------------------------------------
let InitAllocSpy() be
//---------------------------------------------------------------------------
[
allocSpySoc = Allocate(sysZone, lenBSPSoc)
OpenLevel1Socket(allocSpySoc, table [ 0; 1; socketAllocSpy ])
CreateEvent(AllocSpyEvent)
]

//---------------------------------------------------------------------------
and StartAllocSpy() be
//---------------------------------------------------------------------------
[
// GetAllocSpyCtx is an assembly-language procedure which, when called,
// causes the AllocSpy overlay to be swapped into bank 0 if presently in XM.
// The ctx is in the same overlay and is thereby made accessible.
allocSpyCtx = GetAllocSpyCtx()
LockCell(lv allocSpyCtx)  // Lock down the overlay

Enqueue(ifsCtxQ, InitializeContext(allocSpyCtx, allocSpyCtx!-1, AllocSpy))
]

//---------------------------------------------------------------------------
and AllocSpy(ctx) be
//---------------------------------------------------------------------------
// Context that runs while the allocator spy is active.
[
if OpenRTPSocket(allocSpySoc, 0, modeListenAndWait, 0, 0, 100) then
   [
   spyStream = CreateBSPStream(allocSpySoc)
   spyStream>>ST.error = SpyError
   allocLock = false
   savedAllocate = sysZone!0; sysZone!0 = SpyAllocate
   savedFree = sysZone!1; sysZone!1 = SpyFree
   SendZoneMap()
      [
      Dismiss(100)
      BSPForceOutput(allocSpySoc)
      if allocSpySoc>>RTPSoc.state ne stateOpen %
       spyStream>>ST.puts eq FalsePredicate break
      until Endofs(spyStream) do
         [
         Gets(spyStream)
         SendZoneMap()
         ]
      ] repeat
   sysZone!0 = savedAllocate
   sysZone!1 = savedFree
   while allocLock do Block()
   spyStream = 0
   CloseBSPSocket(allocSpySoc)
   OpenLevel1Socket(allocSpySoc, table [ 0; 1; socketAllocSpy ])
   ]
FlushQueue(lv allocSpySoc>>PupSoc.iQ)
CreateEvent(AllocSpyEvent)
Unqueue(ifsCtxQ, ctx)
ctx!0 = 0  // so CallContextList will start over -- CtxRunning has no successor!
UnlockCell(lv allocSpyCtx)
Block()
]

//---------------------------------------------------------------------------
and SpyError(str, ec) = valof
//---------------------------------------------------------------------------
// Called if the BSP stream times out
[
str>>ST.puts = FalsePredicate  // return false from all subsequent Puts
str>>ST.gets = TruePredicate
resultis false
]

//---------------------------------------------------------------------------
and SpyAllocate(zone, length, returnOnFail, even; numargs na) = valof
//---------------------------------------------------------------------------
[
if na ls 4 then even = false
if na ls 3 then returnOnFail = false
while allocLock do Block()
allocLock = CtxRunning
let sb = savedAllocate(zone, length, returnOnFail, even)
if spyStream ne 0 then
   [
   Puts(spyStream, $A)  // an allocate event
   PutWord(spyStream, sb)
   PutWord(spyStream, length)
   WhereFrom()
   ]
allocLock = false
resultis sb
]

//---------------------------------------------------------------------------
and SpyFree(zone, sb) be
//---------------------------------------------------------------------------
[
while allocLock do Block()
allocLock = CtxRunning
if spyStream ne 0 then
   [
   Puts(spyStream, $F)  //a free event
   PutWord(spyStream, sb)
   //PutWord(spyStream, sb!-1)
   //WhereFrom()
   ]
savedFree(zone, sb)
allocLock = false
]

//---------------------------------------------------------------------------
and WhereFrom() be
//---------------------------------------------------------------------------
//analyzes the call stack, and for each frame of interest sends 3 things:
//	absolute core address of caller of the frame
//	overlay number in which the caller lives
//	offset into the overlay of point of call
//if the caller is not within an overlay, the last two items are zero.
//if the caller is within an overlay, the first item is uninteresting.
//if the stack runs out, the rest of the triples are zero
[
let frame = CallersFrame()  //frame of SpyAllocate or SpyFree
for i = 1 to numFramesIgnored do
   if frame!0 ne 0 then frame = frame!0
for i = 1 to numFramesToSend do
   [
   let callersPC = 0
   let ovNumber = 0
   let ovOffset = 0
   if frame ne 0 then
      [
      callersPC = frame!1 -1
      test callersPC eq (lv (frame!xArgs))-1
         ifso
            [  // Extended caller
            callersPC = frame!xPC -2
            let bank = frame!xJmp & 3
            let page = ovFirstPage + (bank-1)*numOvXMPagesPerBank +
             callersPC rshift logOvPageSize
            test page ge EndOD>>OD.firstPn  // resident proc moved to XM?
               ifso callersPC = callersPC - offsetResidentXM
               ifnot for od = FirstOD to EndOD by lOD do
                  if page ge od>>OD.firstPn &
                   page ls (od+lOD)>>OD.firstPn then
                     [
                     ovNumber = (od-FirstOD)/lOD +1 //counting from 1
                     ovOffset = (page - od>>OD.firstPn) lshift logOvPageSize +
                      (callersPC & (1 lshift logOvPageSize)-1) - #21
                     break
                     ]
            ]
         ifnot
            for od = FirstOD to EndOD by lOD do if od>>OD.core ne 0 then
               [
               let core = od>>OD.core
               let codeBegin = core + #21  //length of B-file header+1
               if Usc(callersPC-codeBegin, core!1) le 0 then //core!1=code len
                  [
                  ovNumber = (od-FirstOD)/lOD +1 //counting from 1
                  ovOffset = callersPC - codeBegin
                  break
                  ]
               ]
      frame = frame!0
      ]
   PutWord(spyStream, callersPC)
   PutWord(spyStream, ovNumber)
   PutWord(spyStream, ovOffset)
   ]
]

//---------------------------------------------------------------------------
and SendZoneMap() be
//---------------------------------------------------------------------------
//Locks out all allocator activity, (bsp better not try to allocate
// anything) and then enumerates the chunkQ describing every block
// within every chunk.
[
while allocLock do Block()
allocLock = CtxRunning  //prevent any changes to the zones
Puts(spyStream, $M)  //a zone map event
let chunk = chunkQ!0; while chunk ne 0 do
   [
   BSPWriteBlock(spyStream, chunk, 0, lenZC*2)  //chunk description
   let sb = chunk>>ZC.base  //a storage block in the chunk
      [
      PutWord(spyStream, @sb)  //block length (+ free, - allocated)
      sb = sb + (@sb ls 0? -@sb, @sb)  //on to next block
      ] repeatuntil sb-chunk>>ZC.base ge chunk>>ZC.length-1
   chunk = chunk!0  //on to next chunk
   ]
allocLock = false
]

//---------------------------------------------------------------------------
and PutWord(stream, wrd) be
//---------------------------------------------------------------------------
[
Puts(stream, wrd rshift 8)
Puts(stream, wrd & 377b)
]