// VMemB.bcpl. D* virtual memory package
// Last modified May 25, 1983  10:58 AM by Bill van Melle
// Last modified March 14, 1983  5:31 PM by Bill van Melle
// Last modified February 4, 1983  10:33 PM by Bill van Melle
// Major pruning December 16, 1982  10:27 PM by Bill van Melle
// Last modified May 17, 1982  1:58 PM by Bill van Melle

	get "LispBcpl.decl"
	get "Stats.decl"
	get "VMem.decl"
	get "Streams.d"

external	// SUBRS
 [ PageFault		// (lvPtr)

   MOREVMEMFILE		// (filepage)
   WRITEMAPSUBR		// (vp rp flags)
   LISPFINISH		// () returns to Alto exec

		// other entries
   VirtualPage		// (RP) -> VP
   IGetBase		// (offset)
   IPutBase		// (offset, val)
   LookupPage		// (vp)
   GetPageInCore	// (VP, FilePage, NewPageFlg)
   RemapMemory		// () cleans up on exit
   WriteSwapBuf		// () writes any dirty page out to vmem
  ]

external [		// OS procedures
	CallSwat; Zero
	CreateDiskStream; PositionPage; FileLength; ReadBlock; Closes
			// Other procs used
	LispCleanup; LoadRam; Fault; MachineType

	BP; @IncMiscStats; VP; VP2; Bytes2; DisplayVMbit
	WriteStatsX; IndexedPageIO; SmallUnbox
	@BGetBase; @BPutBase; MkSmallPos; EqNIL; EmUnbox
			// Raid procs
	Ws; Wo; Wn; CRLF; RaidReset; PrintPtr; RAIDCode

			// Statics
	realPageTableSetup	// exported
	noFaultFlg; SwapBuf; SwapBufVp; SwapBufFileP; SwapBufDirty
	lvAbortFlag	// OS
	LispFmap; @RMSK
	@lvNIL; @lvKT; @MiscSTATSbase
	insideRaid; EmulatorSpace
	PupZoneStart; PupZoneLength; altoUcodeFp; uCodeLoaded


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

static
 [ @Bpt; @BptLast = 0; BptSize; @BufVp; @BufRP
   @RPoffset; LispFmap
   realPageTableSetup = false

   noFaultFlg = true			// if true, non-intrusive fault
   SwapBuf
   SwapBufVp = 0
   SwapBufFileP = 0
   SwapBufDirty = false
 ]


let PageFault(lvPtr, ac2) = valof		// page fault handler
 [
 let vp = VP(lvPtr)
 let flags = ReadFlags(vp)
 test (flags & VACANT) ne VACANT
  ifso RAIDCode("Fault on resident page", lvPtr, true)
  ifnot [
	let filep = LookupPage(vp)
	test filep
	   ifso test noFaultFlg
		   ifnot GetPageInCore(vp, filep, false)
		   ifso [
			if not insideRaid
			   then RAIDCode("Non-Raid fault inside Bcpl.  ^N to continue", lvPtr)
			if vp ne SwapBufVp
			   then ReadSwapBuf(vp, filep)
			if (@ac2)!2 gr Fault
			   then SwapBufDirty = true	// write fault
			ac2!4 = EmulatorSpace
				// adjust reference to point at core buffer
			ac2!5 = ((ac2!5) & RMSK) + SwapBuf
			]
	   ifnot InvalidAddr (lvPtr)
	]
 resultis lvPtr
 ]

and ReadSwapBuf(vp, filep) be
 [
 if SwapBufDirty then WriteSwapBuf()
 IndexedPageIO(LispFmap, filep, SwapBuf, 1, false)
 SwapBufVp = vp
 SwapBufFileP = filep
 SwapBufDirty = false
 ]

and WriteSwapBuf() be
 [
 if SwapBufDirty then IndexedPageIO(LispFmap, SwapBufFileP, SwapBuf, 1, true)
 SwapBufDirty = false
 ]

and InvalidAddr (lvPtr) be
   [
   if insideRaid
      then [ Ws ("Invalid address: ")
	     PrintPtr (lvPtr!0, lvPtr!1)
	     RaidReset()
	   ]
   RAIDCode("Invalid address", lvPtr, true)
   ] repeat

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

and GetPageInCore(VP, FilePage, NewPageFlg) be
 [

   let prev = SelectRealPage()
   let tn = prev>>BPT.NEXT
   let bp = BP(tn)

   prev>>BPT.NEXT = bp>>BPT.NEXT	// Move page to end of chain
   test BptLast ge 0
      ifso [			// during startup
	   BP(BptLast)>>BPT.NEXT = tn
	   BptLast = tn
	   ]
     ifnot [			// rest of the time access thru interfacepage
	   BP(IGetBase(IFPRPTLAST))>>BPT.NEXT = tn
	   IPutBase(IFPRPTLAST, tn)
	   ]
   bp>>BPT.NEXT = 0
   bp>>BPT.VP = VP			// allocate it to VP (flags are set 
   bp>>BPT.FWORD = FilePage		// during transfer by TransferPage)
					// note: sets LOCK as well
   TransferPage(VP, FilePage & (not LOCKbit), tn, false, NewPageFlg)
]

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.
 // never run UPDATECHAIN, just find an unlocked page
   last = Bpt
	[ let tn = last>>BPT.NEXT
	     unless tn break
	     let bp = BP(tn)
	     if not bp>>BPT.LOCK
	        then [ DisplacePage(tn, bp)
			resultis last ]
	     last = bp
	] repeat
   [ RAIDCode ("SelectRealPage failed", lvNIL) ] repeat
 ]

and DisplacePage(tn, bp) be		// Replace a resident page
 [ FlushBuf(tn, true)			// cannot fault!
   ClearEntry(tn, bp)
 ]

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

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

 test wflag & BP(rpn)>>BPT.LOCK
  ifso	RAIDCode("Trying to write locked page from Bcpl", MkSmallPos(rpn))
  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.

	@lvAbortFlag = @lvAbortFlag + 1		// disallow shift-swat in here
	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
	@lvAbortFlag = @lvAbortFlag - 1
	]

   SetFlags(vpn, rpn+RPoffset, newflags)	// reset flags

//   UPCTrace(uPCTraceAddr)			// reenable any uPC stats
   @curs = not @curs			// restore cursor

 ]

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 LockPageVp(vp) = valof
 [
   if (vp&#140000) ne 0 then resultis InvalidVP(vp)
   let pmpE = BGetBase(PMTspace, PMTbase + vp<<PVP.key1)
   if pmpE eq -1 then resultis InvalidVP(vp)

   let fp = BGetBase(PAGEMAPspace, PAGEMAPbase + pmpE + vp<<PVP.key2)
   if fp gr 0
     then [		// not locked yet
	  fp = fp % LOCKbit
	  BPutBase(PAGEMAPspace, PAGEMAPbase + pmpE + vp<<PVP.key2, fp)
	  test (ReadFlags(vp) & VACANT) eq VACANT
	     ifso GetPageInCore(vp, fp, false)
	    ifnot	// page is in core, just mark it locked
		BP(ReadRP(vp)-RPoffset)>>BPT.LOCK = true
	  ]
 ]

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

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

and InvalidVP(vp) be 
   [
   if insideRaid
      then [ Ws ("Invalid VP: ")
	     Wo(vp, true)
	     RaidReset()
	   ]
   RAIDCode("Invalid VP", MkSmallPos(vp))
   ] repeat

and LISPFINISH() be 
  [
  LispCleanup()
  if altoUcodeFp & uCodeLoaded
     then [		// reload alto microcode
	let s = CreateDiskStream(altoUcodeFp, ksTypeReadOnly, wordItem)
	altoUcodeFp = 0
	unless s do finish
	let sl = (FileLength(s) + 1) rshift 1 - WordsPerPage
					// length of LoadRam buffer we need
	let buffer = ((PupZoneStart+PupZoneLength) + WordsPerPage-1) & not (WordsPerPage-1)
	PositionPage(s, 2)
	ReadBlock(s, buffer, sl)
	Closes(s)
	LoadRam((MachineType() eq Dolphin? buffer-1, buffer), 1)
	  ]
  finish
  ]

and RemapMemory() be
  [		// restore map to virgin state on exit
  unless realPageTableSetup do return
// I hope the emulator pages are ok, because we don't have a table for them

  let bp = Bpt+3
  let vp = VP2((EmulatorSpace eq 0? 1, 0), 0)	// first non-emulator page
  let rp = RPoffset+1
  for i = 1 to BptSize-1
    do	[
	if bp>>BPT.STATE ne UNAVAIL
	   then [			// good page
		let thisvp = bp>>BPT.STATE eq EMPTY? 0, bp>>BPT.VP
		if thisvp ge vp
		   then [		// Unmap the page first
			SetFlags(thisvp, 0, VACANT)
			]
		SetFlags(vp, rp, 0)	// map this vp into this page
		vp = vp+1
		]
	bp = bp+3
	rp = rp+1
	]
  ]

and WRITEMAPSUBR (vp, rp, flags) = valof
  [
  SetFlags (SmallUnbox(vp), SmallUnbox(rp), SmallUnbox(flags))
  resultis vp
  ]

and MOREVMEMFILE (filepage) = valof
  [
  let buf = vec WordsPerPage
  IndexedPageIO (LispFmap, SmallUnbox(filepage), buf, 1, 1)
  resultis filepage
  ]