// IfsVMemSpy.bcpl -- virtual memory spy server -- swappable
// Copyright Xerox Corporation 1980, 1982
// Last modified September 6, 1982  4:02 PM by Taft

get "Pup0.decl"
get "Pup1.decl"
get "IfsOverlays.decl"
get "IfsRs.decl"
get "VMem.d"
get "IfsVMem.decl"
get "IfsVMemSpy.decl"

external
[
// outgoing procedures
InitVMemSpy; VMemSpy

// incoming procedures
Allocate; Enqueue; Dequeue; MoveBlock; Zero
CreateEvent; VMemSpyEvent; Block; CleanupLocks; FindVMD
OpenLevel1Socket; CompletePup; ExchangePorts; ReleasePBI

// outgoing statics
vmemSpySoc

// incoming statics
ifsCtxQ; sysZone; snarfTable; @HASHMAP; @Bpt; jobT; lenJobT
FirstOD; EndOD; LockedCells; LastLockedCell; vmStats; freePageQ
]

static vmemSpySoc

//----------------------------------------------------------------------------
let InitVMemSpy() be
//----------------------------------------------------------------------------
[
vmemSpySoc = Allocate(sysZone, lenPupSoc)
OpenLevel1Socket(vmemSpySoc, table [ 0; 1; socketVMemSpy ])
CreateEvent(VMemSpyEvent)
]

//----------------------------------------------------------------------------
and VMemSpy() be
//----------------------------------------------------------------------------
// Called by VMemSpyEvent when a pbi arrives on vmemSpySoc
[
if vmemSpySoc>>PupSoc.iQ.head>>PBI.pup.type eq typeVMemSpyRequest then
   [
   let pbi = Dequeue(lv vmemSpySoc>>PupSoc.iQ)
   CleanupLocks()
   let vms = lv pbi>>PBI.pup.words; Zero(vms, lenVMS)

   // Hash Map
   for i = 0 to 63 do
      [
      let hm = HASHMAP + (Bpt + (i lshift 2))>>BPT.HASHX*2
      let vPage = not hm>>HM.NKEY
      vms>>VMS.vPage↑i = vPage
      test (vPage & MinDummyVP) eq MinDummyVP
         ifso if vPage eq EmptyVP then vms>>VMS.type↑i = vmiTypeEmpty
         ifnot
            [
            vms>>VMS.dirty↑i = hm>>HM.CLEAN eq 0
            vms>>VMS.type↑i = FindVMD(vPage)>>VMD.vmi>>VMI.type
            ]
      ]

   // Locked cell list
   // This will set the lock bit for every overlay page, but
   //  that will be fixed when we process the overlay descriptors
   let lc = LockedCells; while lc ne LastLockedCell do
      [
      vms>>VMS.locked↑(@(lc>>LC.addr) rshift 10) = true
      lc = lc + LCsize
      ]

   // Overlay Descriptors
   let od = FirstOD; while od ne EndOD+lOD do
      [
      if od>>OD.core ne 0 then
         [
         let base = od>>OD.core rshift 10
         let length = (od+lOD)>>OD.firstPn - od>>OD.firstPn
         for i = base to base+length-1 do
            [ 
            vms>>VMS.locked↑i = od>>OD.onstack ne 0  //see note on locks ↑
            vms>>VMS.ovNum↑i = (od-FirstOD)/lOD +1
            ]
         ]
      od = od + lOD
      ]

   // Snarfed buffers being used for job stacks
   for i = 0 to lenJobT-1 do if jobT>>JobT↑i ne 0 then
      vms>>VMS.jobType↑(jobT>>JobT↑i rshift 10) = jobT>>JobT↑i>>RSCtx.type+1

   // Snarf table
   for i = 0 to 63 do if snarfTable!i ne -1 then
      if snarfTable!i ne 0 then for j = 1 to snarfTable!i do
         vms>>VMS.type↑(i+j-1) = vmiTypeSnarf

   // Retained free pages (IFSAllocate, IFSFree) -- indicate as "empty"
   let freePage = freePageQ!0
   while freePage ne 0 do
      [ vms>>VMS.type↑(freePage rshift 10) = vmiTypeEmpty; freePage = freePage!0 ]

   // VMStats
   MoveBlock(lv vms>>VMS.stats, vmStats, lenVMStats)

   ExchangePorts(pbi)
   CompletePup(pbi, typeVMemSpyReply, pupOvBytes + size VMS/8)
      ]

while vmemSpySoc>>PupSoc.iQ.head ne 0 do
   ReleasePBI(Dequeue(lv vmemSpySoc>>PupSoc.iQ))
]