// 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𢋠) 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 LockPageVp(vp) = valof
[
if (vp𢋠) 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
]