// 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𢋠) 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)𒿑
]
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𢋠) 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𒿑 ]
pLoc = IGetBase(IFPNActivePages) + (FirstVmemBlock-1)
IPutBase(IFPNActivePages, (pLoc + 1) - (FirstVmemBlock-1))
IPutBase(IFPNDirtyPages, IGetBase(IFPNDirtyPages) + 1)
BPutBase(PAGEMAPspace, px, #100000 + pLoc)
resultis pLoc𒿑
]
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))