// 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)
]