// VMemB.bcpl. D* virtual memory package
// Last modified December 12, 1981  4:59 PM by Bill van Melle
// Last modified July 13, 1981  12:58 AM by Beau Sheil
// Last modified January 27, 1981  8:05 PM by Beau Sheil
// Phrase change November 23, 1980  5:53 PM by Beau Sheil
// Chord change November 20, 1980  1:16 AM by Beau Sheil

	get "LispBcpl.decl"
	get "Stats.decl"
	get "VMem.decl"

external	// SUBRS
 [ PageFault		// (lvPtr)
   NEWPAGE		// (lvX)
   RELEASEWORKINGSET	// ()
   LOCKPAGES		// (lvX, lvPageCount)
   LOGOUT0		// ()
   UNLOCKPAGES		// (lvX, lvPageCount)
		// other entry procedures
   VirtualPage		// (RP) -> VP
   UpdateChain		// () for \BACKGROUND
   BNewPage		// (vaHi, vaLo)
   MakeVmemRO		// ()
   FlushVM		// ()
   LockPages		// (vaHI, vaLo, nbrPages)
   UnlockPages		// (vaHI, vaLo, nbrPages)
   IGetBase		// (offset)
   IPutBase		// (offset, val)
   WRITEDIRTYPAGE	// (mindirty, evenifvalid)
   NPAGESBIT		// (flg) -> count of pages
  ]

external		// OS procedures
 [ CallSwat; Timer; ReadClock; Zero
			// Other procs used
   BP; @IncMiscStats; RAIDCode; UPCTrace; VP; VP2; DisplayVMbit; MovePage
   TimeSince; WriteStatsX; MiscStatsAdd1; IndexedPageIO; SmallUnbox
   @BGetBase; @BPutBase; @BSetBR; @RWrite; @RRead; GetFXP; MkSmallPos; EqNIL
			// Statics
   @uPCTraceAddr; EmuDiskVp; LispFmap; VMDisplay
   @lvNIL; @lvKT; @MiscSTATSbase

			// Other external VMem procs (from VmemA.asm)
   ReadFlags		// (VP) -> oldflags
   ReadRP		// (VP) -> RP
   SetFlags		// (VP, RP, flags)
 ]

structure PVP:			// paged virtual page number
 [ key1 bit 11			// first level key
   key2 bit  5			// second level key = log PMBLOCKSIZE
 ]

manifest
 [ PMTspaceVP = PMTspace lshift 8 + PMTbase rshift 8
   PAGEMAPvp = PAGEMAPspace lshift 8 + PAGEMAPbase rshift 8
 ]

static
 [ @Bpt; @BptLast = 0; BptSize; @BufVp; @BufRP
   @RPoffset; LispFmap; LogPagingFlag = false
   BufsSinceUpdate = 0
   UpdateCount = 100			// may want to set from Swat
   lastDirtyPage = 0			// state pointer for WRITEDIRTYPAGE
 ]

let PageFault(lvPtr) = valof		// page fault handler
   [
   let vp = VP(lvPtr)
   let flags = ReadFlags(vp)
   if (flags & VACANT) ne VACANT then CallSwat("Fault on resident page")
   let filep = LookupPage(vp)
   unless filep do RAIDCode("Invalid address", lvPtr)
   GetPageInCore(vp, filep, false)
   resultis lvPtr
   ]

and NEWPAGE(lvX) = valof [ BNewPage(lvX!0, lvX!1); resultis lvX ]

and RELEASEWORKINGSET() = valof
   [ 
   FlushVM()
   for i=0 to BptSize-1 do
     [ let bp = BP(i)
       if (bp>>BPT.STATE ls EMPTY) & (not bp>>BPT.LOCK) then ClearEntry(i, bp)
     ]
   resultis lvNIL
   ]

and LOCKPAGES(lvX, lvPageCount) = valof
   [
   LockPages(lvX!0, lvX!1, SmallUnbox(lvPageCount))
   resultis lvX
   ]

and LOGOUT0() be
   [
   FlushVM()
   finish			// Stats, etc. is turned off in LispFinish
   ]

and UNLOCKPAGES(lvX, lvPageCount) = valof
   [
   UnlockPages(lvX!0, lvX!1, SmallUnbox(lvPageCount))
   resultis lvX
   ]

and VirtualPage(RP) = BP(RP)>>BPT.VP

and GetPageInCore(VP, FilePage, NewPageFlg) be
 [ if (BufsSinceUpdate ge UpdateCount) then UpdateChain()
   BufsSinceUpdate = BufsSinceUpdate+1
// Update chain is done first both to speed up SelectRealPage and because
// the update would treat the newly allocated page as unreferenced!
   let prev = SelectRealPage()
   let tn = prev>>BPT.NEXT
   let bp = BP(tn)
   if tn eq lastDirtyPage
      then lastDirtyPage = bp>>BPT.NEXT	// fix WRITEDIRTYPAGE's pointer
   prev>>BPT.NEXT = bp>>BPT.NEXT	// Move page to end of chain
   BP(BptLast)>>BPT.NEXT = tn
   BptLast = tn
   bp>>BPT.NEXT = 0
   bp>>BPT.VP = VP			// allocate it to VP (flags are set 
   bp>>BPT.FWORD = FilePage		// during transfer by TransferPage)
   TransferPage(VP, FilePage, tn, false, NewPageFlg)
   if VMDisplay then DisplayVMbit(VP, true)
]

and SelectRealPage() = valof
// Selects a real page to be used as a paging buffer. Returns the
// PREVIOUS buffer so the selected buffer can be popped out in unit time!
 [ let last = Bpt
   [ let tn = last>>BPT.NEXT
     unless tn break
     let bp = BP(tn)
     if bp>>BPT.STATE eq EMPTY then resultis last
     if bp>>BPT.STATE eq UNAVAIL then CallSwat("UNAVAIL on chain")
     if not bp>>BPT.LOCK & ((ReadFlags(bp>>BPT.VP) & REFbit) eq 0)
        then [ DisplacePage(tn, bp); resultis last ]
     last = bp
   ] repeat
   // It is possible that all the pages are touched between UpdateChains.
   // If so, we clear the refbits with an UpdateChain and try again.
   UpdateChain()
   resultis SelectRealPage()
 ]

and DisplacePage(tn, bp) be		// Replace a resident page
 [ FlushBuf(tn, true)			// cannot fault!
   ClearEntry(tn, bp)
   if LogPagingFlag then WriteStatsX(evPageDisplace, 0, bp>>BPT.VP)
 ]

and ClearEntry(tn, bp) be		// Clears the map and bp
 [ let vp = bp>>BPT.VP
   if VMDisplay then DisplayVMbit(vp, false)
   SetFlags(vp, tn+RPoffset, VACANT)
   bp>>BPT.STATE = EMPTY
 ]

and UpdateChain() be			// Reorder the chain according to use
 [ let I = @Bpt
   @Bpt = 0
   let head1 = 0
   let nc0, nc1 = 0, 0
   let chain0, chain1 = Bpt, lv head1
    [ let ip = BP(I)
      let iVP = ip>>BPT.VP
      let flags = ip>>BPT.STATE eq EMPTY ? 0, ReadFlags(iVP)
      test (flags & REFbit) ne 0 % ip>>BPT.LOCK
      ifso	// REFERENCED or LOCKED, put on chain1
       [ nc1=nc1+1
         SetFlags(iVP, I+RPoffset, flags & (not REFbit))
         chain1>>BPT.NEXT = I		// OK even when chain1 = lv head1
         chain1 = ip
       ]
      ifnot	// NOT REFERENCED, put on chain0
       [ nc0=nc0+1
         chain0>>BPT.NEXT = I		// OK even when chain0=Bpt
         chain0 = ip
       ]
      I = ip>>BPT.NEXT
    ] repeatuntil I eq 0

// Link the chains.  @Bpt=head0 already
   chain1>>BPT.NEXT = 0
   chain0>>BPT.NEXT = head1
   BptLast = ((head1 eq 0? chain0, chain1)-Bpt)/lBPT
   BufsSinceUpdate = 0
   if LogPagingFlag then WriteStatsX(evUpdateChain, 2, lv nc0)
   lastDirtyPage = 0
 ]

and FlushBuf(i, updatekey) be		// write out if dirty
 [ let ip = BP(i)
   if ip>>BPT.STATE ls EMPTY do		// real page is occupied
      [ let ivp = ip>>BPT.VP
        let flags = ReadFlags(ivp)
        if ((flags&DIRTYbit) ne 0) then	// write out dirty page
              [ TransferPage(ivp, ip>>BPT.FILEP, i, true, false)
                if updatekey & (IGetBase(IFPKey) eq IFPValidKey)
                   then [		// mark vmem invalid
                        IPutBase(IFPKey, not IFPValidKey)
                        TransferPage(InterfacePageVP, FirstVmemBlock,
                                     ReadRP(InterfacePageVP)-RPoffset,
                                     true, false)
                        ]
              ]
      ]
 ]

and TransferPage(vpn, vmp, rpn, wflag, newpage) be
 [
   unless vmp do CallSwat("No file page")
   let v = vec 3			// space for two times
   let curs = wflag ? #450, #431	// hiword or loword
   let newflags = newpage ? DIRTYbit,
                            (wflag ? ReadFlags(vpn) & not DIRTYbit, 0)

   @curs = not @curs			// change cursor during disk action
   UPCTrace(0)				// disable any uPC stats
   ReadClock(v)				// read start time

   test wflag & BP(rpn)>>BPT.LOCK
   ifso 
   [
// Locked pages cannot be mapped into the emulator space as that leaves a
// "hole" where others like the display controller might trip. Hence we copy.
   MovePage(BufVp, vpn)
   IndexedPageIO(LispFmap, vmp, BufVp lshift 8, 1, true)
   ]
   ifnot
   [
// Map the real page into the space set aside in emulator space for a
// paging buffer. Because Dorado won't allow two virtual pages to share
// the same real page, we first mark ivp VACANT, then map it to the BufVp.
// After we zero, read or write it, we restore the buffer.

   SetFlags(vpn, rpn+RPoffset, VACANT)		// unmap virtual page
   SetFlags(BufVp, rpn+RPoffset, OCCUPIED)	// map real page onto buff
   test newpage 
     ifso  Zero(BufVp lshift 8, WordsPerPage)	// zero a new page
     ifnot IndexedPageIO(LispFmap, vmp, BufVp lshift 8, 1, wflag)
   SetFlags(BufVp, BufRP, OCCUPIED)		// map buf back
   ]

   SetFlags(vpn, rpn+RPoffset, newflags)	// reset flags
   MiscStatsAdd1(wflag ? MSpgeWrt, MSpgeFlt)	// count swaps
   IncMiscStats(MSswapTime, TimeSince(v))	// accumulate swap wait time
   UPCTrace(uPCTraceAddr)			// reenable any uPC stats
   @curs = not @curs				// restore cursor

   ReadClock(v+2)				// end time
   WriteStatsX((wflag ? evSwapWrite, evSwapRead), 4, v)
   if LogPagingFlag then WriteStatsX((wflag ? evPageWrite, evPageRead), 0, vpn)
 ]

and LookupPage(vp) = valof
 [		// Returns page in vmem file or 0 if the page does not exist
   if (vp&#140000) ne 0 then InvalidVP(vp)
   let pmpE = BGetBase(PMTspace, PMTbase + vp<<PVP.key1)
   if pmpE eq -1 then resultis 0
   let px = PAGEMAPbase + pmpE + vp<<PVP.key2
   resultis BGetBase(PAGEMAPspace, px)&#77777
 ]

and BNewPage(vaHi, vaLo) be BNewPageVp(VP2(vaHi, vaLo))

and BNewPageVp(Vp) be
 [
   if LogPagingFlag then WriteStatsX(evNewPage, 0, Vp)
   GetPageInCore(Vp, CreateNewPage(Vp), true)
 ]

and LockPages(vaHi, vaLo, nbrPages) be
 [
   let v = VP2(vaHi, vaLo)
   for i = 0 to nbrPages-1 do LockPageVp(v+i)
 ]

and LockPageVp(vp) be
 [
   if (ReadFlags(vp) & VACANT) eq VACANT	// is page already in core?
      then 
	[
   // Special case code to return vmem file address of pages which support 
   // page lookup. These pages are looked up here b/c they are always locked
   // before their first reference and this is a low frequency operation.

   // InterfacePage is known to be on FirstVmemBlock. Rest of page map
   // tables are at a fixed location wrt various interface page entries. 

	let fpage = vp eq InterfacePageVP ? FirstVmemBlock,
	              vp eq PAGEMAPvp ? IGetBase(IFPfilePnPMP0),
	                (vp & #177770) eq PMTspaceVP ? IGetBase(IFPfilePnPMT0)+(vp&7),
		               LookupPage(vp)
	unless fpage do return
	GetPageInCore(vp, fpage, false)
	]
   BP(ReadRP(vp)-RPoffset)>>BPT.LOCK = true
 ]

and UnlockPages(vaHi, vaLo, nbrPages) be
 [
   let v = VP2(vaHi, vaLo)
   for i = 0 to nbrPages-1 do BP(ReadRP(v+i)-RPoffset)>>BPT.LOCK = false
 ]

and CreateNewPage(vp) = valof
 [
   if (vp&#140000) ne 0 then InvalidVP(vp)

   let pmpE = BGetBase(PMTspace, PMTbase + vp<<PVP.key1)
   if pmpE eq -1 then   // No second level page map block (1st level entry)
      pmpE = CreateSecondLevelBlock(vp)

   let px = PAGEMAPbase + pmpE + vp<<PVP.key2
   let pLoc = BGetBase(PAGEMAPspace, px)
   if pLoc then [ RAIDCode("Page already exists", MkSmallPos(vp))
                  resultis pLoc&#77777 ]

   pLoc = IGetBase(IFPNActivePages) + (FirstVmemBlock-1)
   IPutBase(IFPNActivePages, (pLoc + 1) - (FirstVmemBlock-1))
   IPutBase(IFPNDirtyPages, IGetBase(IFPNDirtyPages) + 1)
   BPutBase(PAGEMAPspace, px, #100000 + pLoc)
   resultis pLoc&#77777
 ]

and CreateSecondLevelBlock(vp) = valof
   [ let NextPMAddr = IGetBase(IFPNxtPMAddr)	// Next avail 2nd level block
     if (NextPMAddr<<LoByte) eq 0 then		// new page map page
        [ BNewPage(PAGEMAPspace,PAGEMAPbase+NextPMAddr)
          LockPages(PAGEMAPspace,PAGEMAPbase+NextPMAddr, 1) ]
     BPutBase(PMTspace, PMTbase + vp<<PVP.key1, NextPMAddr) // set 1st level
     IPutBase(IFPNxtPMAddr, NextPMAddr + PMBLOCKSIZE)
     resultis NextPMAddr
   ]

and MakeVmemRO() be
   [
   FlushVM()
   BSetBR(PAGEMAPspace, PAGEMAPbase)
   for i = 0 to IGetBase(IFPNxtPMAddr)-1 do RWrite(i, RRead(i) & #77777)
   IPutBase(IFPNDirtyPages,1)
   ]

and FlushVM() = valof	// Flushes all pages back to the disk
  [			// only one pass as no pages are dirtied
    IPutBase(IFPCurrentFXP, GetFXP())	// Save FXP
    IPutBase(IFPKey, IFPValidKey)	// VMem will shortly be consistent
    MiscSTATSbase = 0			// stops any writes into MiscStats
    for i=0 to BptSize-1 do FlushBuf(i, false)
    MiscSTATSbase = MISCSTATSbase	// reenable MiscStats
    resultis lvNIL		// result NIL to distinguish from sysin
  ]

and WRITEDIRTYPAGE(mindirty, evenifvalid; numargs na) = valof
		// Write out a dirty page, if there are at least mindirty
		// of them left
  [			
  let valid = IGetBase(IFPKey) eq IFPValidKey
  if valid & (na ls 2 % EqNIL(evenifvalid))
     then resultis lvNIL
  test na ls 1 % EqNIL(mindirty)
     ifso mindirty = 1
     ifnot mindirty = SmallUnbox(mindirty)
  let bp = (lastDirtyPage ? BP(lastDirtyPage) , Bpt)
  let numdirty, firstdirty = 0, 0
  let pn = nil
    [	// search for a dirty page, preferably an unreferenced one
    pn = bp>>BPT.NEXT
    if pn eq 0
	then [  if lastDirtyPage ne 0
		   then [	// we didn't start from the top,
				// so we might have succeeded
			lastDirtyPage = 0
			resultis lvKT
			]
		if (numdirty ls mindirty) % (numdirty eq 0)
		   then [ lastDirtyPage = firstdirty
			  resultis lvNIL
			]
		pn = firstdirty
		break
	     ]
    bp = BP(pn)
    if bp>>BPT.STATE eq EMPTY
	then resultis lvNIL
    if not bp>>BPT.LOCK
	then [		// don't bother with locked pages?
		let flags = ReadFlags (bp>>BPT.VP)
		if (flags & DIRTYbit) ne 0
		   then test (flags & REFbit) eq 0
			   ifso break	// page dirty and not ref'd
			  ifnot [ 	// dirty but ref'd: note it
				if numdirty eq 0
				   then firstdirty = pn
				numdirty = numdirty+1
				]
	     ]
    ] repeat
			// fall thru with desired page pn
  FlushBuf (pn, valid)
  lastDirtyPage = pn	// keep a pointer so next search is shorter
  resultis lvKT
  ]

and NPAGESBIT (flg) = valof
  [		// count number of real pages that satisfy flg
		// 0: ref, 1: dirty, 2: locked
  let bp = Bpt
  let numpages = 0
  let pn = nil
  flg = SmallUnbox(flg)
  let mask = ((flg eq 0) ? REFbit, DIRTYbit)
    [
    pn = bp>>BPT.NEXT
    if pn eq 0
	then resultis MkSmallPos(numpages)
    bp = BP(pn)
    if bp>>BPT.STATE ne EMPTY & 
	(flg eq 2 ? bp>>BPT.LOCK, (ReadFlags (bp>>BPT.VP) & mask) ne 0)
	then numpages = numpages + 1
    ] repeat
  ]

and IGetBase(disp) = BGetBase(INTERFACEspace,INTERFACEbase+disp)

and IPutBase(disp,val) be BPutBase(INTERFACEspace,INTERFACEbase+disp,val)

and InvalidVP(vp) be RAIDCode("Invalid VP", MkSmallPos(vp))