//
// VMEM - virtual memory package
// last edited September 15, 1977 3:10 PM
//
// Copyright Xerox Corporation 1979
get "vmem.d"
external // entry procedures
[ LockOnly; LockReloc; LockZero // (addr, new, flag) -> ok
// (from assembly code)
MAPTRAP // (vpage, wflag, hptr)
LockCell // (lvlock[, proc])
UnlockCell // (lvlock)
// for VMEMAUX
FindFreeBuf
defaultNoBufsProc
FlushBufs
FlushMapStats
DoLocks
]
external // entry statics
[ @HASHMAP; @HASHMAPSIZE; @HASHMAPMASK
MAPSTATBASE
@MapStatPtr
SOFTMAPFLAG
CheckBPTflag
@ReprobeInc
// for VMEMAUX
@HASHMAPSIZE2
@HASHMAP1
@HASHMAPTOP
EMPTYXX
NAXX
MapStatProc
NoBufsProc
@Bpt; @BptLast
LockedCells; EndLockedCells; LastLockedCell
]
external // procedures
[ // O.S.
MoveBlock; SetBlock; Zero
Timer
CallSwat
Usc
DoubleAdd
// ASMAP
REHASHMAP
// User-supplied
CleanupLocks // ()
DOPAGEIO // (VP, core, # of pages, write flag)
PageGroupBase // (VP) -> VP
PageGroupSize // (VP) -> # of pages & write group flag
PageGroupAlign // (VP) -> core alignment mask
PageType // (VP) -> new page flag
]
external // statics
[ // O.S.
@oneBits
]
static
[ HASHMAP
HASHMAPSIZE // MUST BE POWER OF 2
HASHMAPSIZE2
HASHMAPMASK
HASHMAP1
HASHMAPTOP
MAPSTATBASE
MapStatPtr
SOFTMAPFLAG = false
EMPTYXX // HASHX of empty buffers, lshift 8
NAXX // HASHX of unavailable buffers, lshift 8
MapStatProc // map statistics procedure
Bpt; BptLast
NoBufsProc
LockedCells; LastLockedCell; EndLockedCells
CheckBPTflag = false
ReprobeInc = RepInc
AnyDirty
LastTrapTime = 0
TSA = 0; TSA1 = 0
AgingInterval = 0
RefLockedCells = true
LockOnly // = FalsePredicate
LockZero // = TruePredicate
]
// PROCESS MAP TRAP, CALLED FROM ASSEMBLY CODE
let MAPTRAP(VPG, WFLAG, HPTR) be
[ CleanupLocks()
if FlushMapStats() then return // statistics buffer was full
if Usc(VPG, MinDummyVP) ge 0 then CallSwat("Illegal VP")
if @HPTR ne 0 then
[ // FIRST WRITE TO CLEAN PAGE
HPTR>>HM.CLEAN = 0
AnyDirty = true
return
]
let ttv = vec 1
ttv!1 = Timer(ttv)-LastTrapTime
ttv!0 = 0
DoubleAdd(lv TSA, ttv)
let ptype = PageType(VPG, WFLAG)
let NEWPAGEFLAG = selecton ptype into
[ case 1: false
case -1: true
default: CallSwat("Bad PageType")
]
let VPAGE = PageGroupBase(VPG)
let VNPGS = PageGroupSize(VPAGE)
let ALIGN = PageGroupAlign(VPAGE)
let WG = 0
if VNPGS ls 0 then // this is a write group
WG, VNPGS = WGROUPbit, -VNPGS
// Mark locked pages as referenced
if RefLockedCells then
for I = LockedCells by LCsize to LastLockedCell-LCsize do
unless (I>>LC.proc)(I>>LC.addr, 0, false) do
[ let hp = HASHMAP1+(Bpt+@(I>>LC.addr) rshift PS)>>BPT.HASHX*2
if (@hp & DUMMYbit) eq 0 then @hp = @hp & not NOTREFbit
]
// FLUSH Buffer
let tn = nil
[ tn = FindFreeBuf(VNPGS, ALIGN, 0)
if tn ne 0 break
NoBufsProc()
] repeat
FlushBufs(tn, VNPGS, -1)
// READ IN NEW PAGE
let CORE = tn lshift PS
test NEWPAGEFLAG
ifso Zero(CORE, VNPGS lshift PS)
ifnot DOPAGEIO(VPAGE, CORE, VNPGS, false)
// Reorder buffers
if (TSA ne 0) % (Usc(TSA1, AgingInterval) ge 0) then
[ TSA, TSA1 = 0, 0
UpdateChain()
]
ADDTOMAP(tn, VNPGS, VPAGE, (NEWPAGEFLAG % WFLAG? 0, CLEANbit)+WG)
CheckBPT()
LastTrapTime = Timer(ttv)
]
and defaultNoBufsProc() be
CallSwat("No free buffer(s)")
and FlushMapStats() = valof
[ if MAPSTATBASE eq 0 resultis false
let n = MapStatPtr-MAPSTATBASE
MapStatPtr = MAPSTATBASE
// If using the RAM, MapStatProc must reset the
// R register itself and return the old value
if MapStatProc ne 0 then
[ let r = MapStatProc(MAPSTATBASE, n)
unless SOFTMAPFLAG do n = r
]
resultis n eq HASHMAP-MAPSTATBASE
]
and getgroup(i, mask, d) = valof
[ while ((HASHMAP+(Bpt+i)>>BPT.HASHX*2)>>HM.FLAGWD & mask) ne 0 do
i = i+d
resultis i
]
and FindFreeBuf(nb, mask, wanted) = valof
[ let tn = @Bpt
let blk = vec BptSize
// blk!i eq 0 means page not reached yet
// blk!i gr 0 means buffer blk!i is first of available block
// blk!i ls 0 means buffer i begins av. block of length -blk!i
Zero(blk, BptSize)
while tn ne 0 do
[ let btn = nil
if DoLocks(tn lshift PS, 0, false) goto bot1
blk!tn = -1
btn = mergeblocks(tn, blk)
if ((-btn & mask)+blk!btn+nb le 0) & ((HASHMAP+(Bpt+btn)>>BPT.HASHX*2)>>HM.NFPG eq 0) then
[ let rtn = btn+(-btn & mask)
if (wanted eq 0) % ((wanted ge rtn) & (wanted ls btn-blk!btn)) resultis rtn
]
bot1: tn = Bpt!tn & NEXTmask
]
resultis 0
]
and mergeblocks(otn, blk) = valof
// Available blocks are of four types:
// closed (C), consisting of an integral number of single pages and complete page groups;
// head (H), consisting only of some initial pages of a page group;
// tail (T), consisting only of some final pages of a page group;
// interior (I), consisting only of some interior pages of a page group.
// The following table specifies whether a given pair of adjacent blocks
// may be merged (gives the type of the merged block),
// must be left separate (-),
// or is impossible (?):
// C H I T
//C C - ? ?
//H ? ? H C
//I ? ? I T
//T - - ? ?
// It is easy to distinguish block types on the basis of
// the group bits in their first and last pages:
// C has (~NF,~NL);
// H has (~NF+NL,NF+NL);
// T has (NF+NL,NF+~NL);
// I has (NF+NL,NF+NL).
// When we want to add a page to the set available as candidates for replacement,
// we first convert it into a one-page block of the appropriate type,
// and then do merging according to the table above.
// In fact, it is easiest to detect the cases where merging is forbidden (Tx or xH),
// and merge in all other cases.
[ let tn = otn
[ let bp = blk+tn
if @bp eq 0 then
[ bp = blk+otn
resultis (@bp ls 0? otn, @bp)
]
let tn0 = (@bp ls 0? tn, @bp)
[ let bp1 = bp+1
if @bp1 eq 0 goto down
let tp = Bpt+tn
if (HASHMAP1!((Bpt+tn0)>>BPT.HASHX*2)&NFPGbit) ne 0 then
if ((HASHMAP1!(tp>>BPT.HASHX*2))&NLPGbit) eq 0 then // Tx, can't merge
goto down
if (HASHMAP1!((tp-@bp1)>>BPT.HASHX*2)&NLPGbit) ne 0 then
if ((HASHMAP1!((tp+1)>>BPT.HASHX*2))&NFPGbit) eq 0 then // xH, can't merge
goto down
// OK to merge
let bp0 = blk+tn0
@bp0 = @bp0+@bp1 // add lengths
let lenm1 = -@bp0-1
bp0!lenm1 = tn0 // mark top
otn = tn0+lenm1 // move to top of block
tn0 = otn+1
]
down: tn = tn0-1
] repeat
]
and RemoveBufs(tn, NPGS) be
// Remove the affected buffers from the chain
[ let lasttn = tn+NPGS-1
let I, N = 0, NPGS
[ let ip = Bpt+I
I = ip>>BPT.NEXT
while (I ge tn) & (I le lasttn) do
[ I = (Bpt+I)>>BPT.NEXT
@ip = (@ip & not NEXTmask)+I
N = N-1
if N eq 0 return
]
] repeat
]
and UpdateChain() be
// Reorder the chain according to use
[ let I = @Bpt
@Bpt = 0
let head1 = 0
let chain0, chain1 = Bpt, lv head1
[ let ip = Bpt+I
let HP = HASHMAP1+(@ip)<<BPT.HASHX*2
test (@HP & NOTREFbit) eq 0
ifso // REFERENCED, PUT ON chain1
[ @HP = @HP+NOTREFbit
@chain1 = (@chain1 & not NEXTmask)+I // OK when chain1 = lv head1
chain1 = ip
]
ifnot // NOT REFERENCED, PUT ON chain0
[ @chain0 = (@chain0 & not NEXTmask)+I // OK even when chain0=Bpt
chain0 = ip
]
I = @ip & NEXTmask
] 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
]
and ADDTOMAP(tn, NPGS, VP, newbits) be
[ADM
// RESET THE PAGED-OUT ENTRY
if NPGS gr 1 then newbits = newbits+NLPGbit
(Bpt+BptLast)>>BPT.NEXT = tn
BptLast = tn+NPGS-1
let N = tn
while N ls BptLast do
[ Bpt!N = N+1
MakeMapEntry(VP, N, newbits)
newbits = newbits % NFPGbit
VP = VP+1
N = N+1
]
Bpt!N = 0
MakeMapEntry(VP, N, newbits & not NLPGbit)
]ADM
and MakeMapEntry(VP, tn, bits) be
[ let hp = REHASHMAP(VP)
let bp = Bpt+tn
test hp eq 0
ifso // page already in core as a side effect of some external call
@bp = (@bp & NEXTmask) + EMPTYXX
ifnot
[ hp>>HM.NKEY = not VP
hp>>HM.FLAGWD = (tn-VP) lshift 8 + bits
bp>>BPT.HASHX = (hp-HASHMAP) rshift 1
]
]
and corepage(hp) =
(hp>>HM.FLAGWD+(not hp>>HM.NKEY) lshift 8) rshift 8
and DeleteMapEntry(hp, dostat) be
[ if hp>>HM.DUMMY ne 0 return
let oldvp = not hp>>HM.NKEY
let i = corepage(hp)
let bp = Bpt+i
@bp = (@bp & NEXTmask) + EMPTYXX
hp>>HM.NKEY = 0
[ hp = hp+ReprobeInc
if (hp-HASHMAPTOP) ge 0 then hp = hp-HASHMAPSIZE
let key = not hp>>HM.NKEY
if key eq -1 break
hp>>HM.NKEY = 0
let hp1 = REHASHMAP(key)
hp1>>HM.NKEY = not key
if hp1 ne hp then
[ hp1>>HM.FLAGWD = hp>>HM.FLAGWD
(Bpt+corepage(hp1))>>BPT.HASHX = (hp1-HASHMAP) rshift 1
]
] repeat
if dostat then MapStatProc(i, -1, oldvp)
]
and FlushBufs(tn, N, empty) be
// Empty=0 means just mark clean,
// >0 means also remove from chain,
// <0 means mark empty
[ if empty then RemoveBufs(tn, N)
let l = getgroup(tn+N-1, NLPGbit, 1)
tn = getgroup(tn, NFPGbit, -1)
[ AnyDirty = false
let f = 0 // TN of first dirty buffer in sequence, or 0
let key = nil // VP of first dirty buffer (i.e. buffer f)
let lkey = nil // VP of last dirty buffer
let grouptn = nil // TN of first page of group
for i = tn to l do
[
try: let locked = DoLocks(i lshift PS, 0, empty)
if locked & empty then CallSwat("Can't flush locked page")
let HP = HASHMAP+(Bpt+i)>>BPT.HASHX*2
let k = not HP>>HM.NKEY
let flags = HP>>HM.FLAGWD
if (flags&NFPGbit) eq 0 then grouptn = i // Remember beginning of group
test ((flags&CLEANbit) eq 0) & ((f eq 0) % ((k eq lkey+1) & ((flags&NFPGbit) ne 0)))
ifso // first dirty buffer, or in sequence
[ if f eq 0 then // first one, check for a write group
test (flags&WGROUPbit) ne 0
ifso // write whole group (by dirtying the rest of it)
[ f = grouptn
key = k+f-i // but lkey = k still
for j = i+1 to getgroup(i, NLPGbit, 1) do
(HASHMAP+(Bpt+j)>>BPT.HASHX*2)>>HM.CLEAN = 0
]
ifnot // just this page
f, key = i, k
lkey = k
if not locked then HP>>HM.FLAGWD = flags+CLEANbit
]
ifnot // end of sequence
[ if f ne 0 then
[ flushout(key, f, i)
f = 0
goto try
]
]
if empty then DeleteMapEntry(HP, (empty ls 0? flags&CLEANbit, false))
]
if f ne 0 then flushout(key, f, l+1)
] repeatwhile AnyDirty
CheckBPT()
]
and flushout(key, f, lim) be
[ let lock = f lshift PS
LockCell(lv lock) // in case of recursive VMEM call
DOPAGEIO(key, lock, lim-f, true)
UnlockCell(lv lock)
]
and LockCell(lvLock, proc; numargs n) = valof
[ if (n ls 2) % (proc eq 0) then proc = LockOnly
UnlockCell(lvLock)
if LastLockedCell eq EndLockedCells then CallSwat("Lock list full")
LastLockedCell>>LC.addr, LastLockedCell>>LC.proc = lvLock, proc
LastLockedCell = LastLockedCell + LCsize
]
and UnlockCell(lvLock) = valof
[ for I = LockedCells by LCsize to LastLockedCell-LCsize do
if I>>LC.addr eq lvLock then
[ LastLockedCell = LastLockedCell - LCsize
MoveBlock(I, LastLockedCell, LCsize)
resultis true
]
resultis false
]
and DoLocks(addr, newpa, flag) = valof
[ let oldpa = addr & (not WM)
let I = LockedCells
LastLockedCell>>LC.addr = lv addr
LastLockedCell>>LC.proc = dlexit
[ if (@(I>>LC.addr) & (not WM)) eq oldpa then
[ let addr = I>>LC.addr // in case lock proc unlocks cell
let new = (newpa eq 0? 0, @addr+newpa-oldpa)
unless (I>>LC.proc)(addr, new, flag) resultis true
if flag then @addr = new
]
I = I+LCsize
] repeat
dlexit: resultis false
]
// and LockOnly(addr, new, flag) = false
and LockReloc(addr, new, flag) = new ne 0
// and LockZero(addr, new, flag) = true
//
// Checker for BPT
//
and CheckBPT() be
compileif false then // ***
[
unless CheckBPTflag return
for hp = HASHMAP by 2 to HASHMAPTOP-2 do
if hp>>HM.NKEY ne 0 then
if (Bpt+corepage(hp))>>BPT.HASHX*2 ne (hp-HASHMAP) then
CallSwat("BPT wrong")
for bp = Bpt+1 to Bpt+#377 do
[ let hp = HASHMAP+bp>>BPT.HASHX*2
if (hp>>HM.DUMMY eq 0) & (corepage(hp) ne (bp-Bpt)) then
CallSwat("BPT wrong")
]
]