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