-- ZoneCleanupImpl.Mesa
-- last edited February 6, 1981 9:13 AM by Willie-Sue Haugeland
-- last edit by Russ Atkinson, 17-Jul-81 14:12:24
-- last edited May 17, 1983 2:47 pm by Paul Rovner
-- Last Edited by: Levin, August 8, 1983 5:42 pm

DIRECTORY
Basics USING[LongNumber],
PrincOpsUtils USING[ZERO, LowHalf],
RTFlags USING[checking, clearing],
RTQuanta USING[QuantumSizeMOD, LASTAddress, QuantumIndex, QuantumSize,
QuantumCount],
Runs USING[Run],
SafeStorage USING[], -- EXPORTs only
UnsafeStorage USING[], -- EXPORTs only
RTZones;

ZoneCleanupImpl: MONITOR -- protects zones
LOCKS zn.LOCK USING zn: PZone
IMPORTS PrincOpsUtils, RTQuanta, RTZones
EXPORTS SafeStorage, UnsafeStorage
= BEGIN
OPEN RTQuanta, RTZones;

checking: BOOLEAN = FALSE; -- RTFlags.checking;

-- Exported procedures (public)

TrimZone: PUBLIC SAFE PROC[zone: ZONE] =
TRUSTED { WITH zn: LOOPHOLE[zone, PZone] SELECT FROM
quantized => {TrimQuantizedZone[@zn]};
prefixed => {MergePrefixedZone[@zn]; TrimPrefixedZone[@zn]};
ENDCASE};

MergeUZone: PUBLIC PROC[zone: UNCOUNTED ZONE] =
{ WITH zn: LOOPHOLE[zone, LONG POINTER TO PZone]^ SELECT FROM
prefixed => MergePrefixedZone[@zn];
ENDCASE};

TrimUZone: PUBLIC PROC[zone: UNCOUNTED ZONE] =
{ WITH zn: LOOPHOLE[zone, LONG POINTER TO PZone]^ SELECT FROM
quantized => {TrimQuantizedZone[@zn]};
prefixed => {MergePrefixedZone[@zn]; TrimPrefixedZone[@zn]};
ENDCASE};

MergeAllPrefixedZones: PUBLIC SAFE PROC =
TRUSTED { maxZi: ZoneIndex = GetZiNext[] - 1;
FOR i: ZoneIndex IN [1..maxZi] DO
zn: Zone = MapZiZn[i];
IF zn # NIL AND zn.sr = prefixed THEN MergePrefixedZone[LOOPHOLE[zn]];
ENDLOOP};

TrimSystemZone: PUBLIC SAFE PROC =
TRUSTED { FOR i: ZoneIndex IN [1..GetZiNext[] - 1] DO
IF MapZiZn[i] # NIL THEN TrimZone[LOOPHOLE[MapZiZn[i]]]; ENDLOOP};

-- Internal procedures for quantum zones

EraseQuantizedZone: PROC[zn: QuantizedZone] = -- *** dummy for now
{NULL};

TrimQuantizedZone: ENTRY PROC[zn: PZone] =
BEGIN ENABLE UNWIND => NULL;
qzn: PQuantizedZone = LOOPHOLE[zn];
FOR i: CARDINAL IN [0..qzn.mAsz] DO -- for each subzone
sz: SubZone = @qzn.pAsz[i];
size: LONG CARDINAL = sz.size;
pSzFl: FreeList = @sz.fl;

NodeProc: TYPE = PROC[ ptr: LONG POINTER TO LONG UNSPECIFIED,
q: QuantumIndex, size: LONG CARDINAL,
unlinkProc: PROC];
MapFl: PROC[procNode: NodeProc] =
BEGIN
-- Apply procNode to each node on a free list.
flPrev: FreeList ← pSzFl;
fl: FreeList;
Unlink: PROC = { flPrev^ ← fl^; fl ← flPrev};

UNTIL (fl ← flPrev^) = NIL DO
procNode[fl, MapPtrQ[fl], size, Unlink];
flPrev ← fl;
ENDLOOP;
END;

-- Count the number of occupied words in each quantum as follows.
-- Quanta with only one free node so far are linked on flOne.
-- Quanta with more than one free node are linked on flMore, where
-- the first node in the quantum is a QCounter and its successor
-- is the link to the next such quantum's QCounter.
QCounter: TYPE = MACHINE DEPENDENT RECORD
[
empty: BOOLEAN ← FALSE, -- true iff this quantum is known empty
count: [0..LAST[CARDINAL]/2], -- so empty + count fits in 1 word.
-- limit should be QuantumSize. count of occupied words
link: INTEGER -- should be (-QuantumSize..QuantumSize)
-- self-relative link: points to a cell which contains a PQCounter
];
PQCounter: TYPE = LONG POINTER TO QCounter;
PPQCounter: TYPE = LONG POINTER TO PQCounter;
flOne: FreeList ← NIL;
flMore: PQCounter ← NIL;
FindOnOne: PROC[q: QuantumIndex] RETURNS[fl: FreeList] =
BEGIN -- always deletes from flOne if successful
flPrev: FreeList ← @flOne;
UNTIL (fl ← flPrev^) = NIL DO
IF MapPtrQ[fl] = q THEN
BEGIN
flPrev^ ← fl^;
RETURN[fl];
END;
flPrev ← fl;
ENDLOOP;
RETURN[NIL];
END;
FindOnMore: PROC[q: QuantumIndex] RETURNS[flNext: PPQCounter] =
BEGIN -- moves to head of flMore if successful
flPrev: PPQCounter ← @flMore;
pqc: PQCounter;
UNTIL (pqc ← flPrev^) = NIL DO
flNext ← LOOPHOLE[pqc+pqc.link];
IF MapPtrQ[pqc] = q THEN
BEGIN
IF pqc # flMore THEN
BEGIN
flPrev^ ← flNext^; -- delink here
flNext^ ← flMore; -- insert at head
flMore ← pqc;
END;
RETURN[flNext];
END;
flPrev ← flNext;
ENDLOOP;
RETURN[NIL];
END;

-- First pass, accumulate amount of occupied space in each quantum
AccumNode: NodeProc = -- binds ptr, q, size, unlinkProc
BEGIN
fl: FreeList;
qsize: CARDINAL =
QuantumSize - (IF q = zn.qFirst THEN RTZones.BaseOverhead ELSE 0);

IF size > qsize/2 THEN -- only one (free) node in this quantum
BEGIN
nq: QuantumCount = MapSizeNq[size];
unlinkProc[];
ReturnQuanta[zn, q, nq];
RETURN;
END;
IF FindOnMore[q] # NIL THEN -- found node is now head of flMore
BEGIN
flMore.count ← flMore.count - LOOPHOLE[size, Basics.LongNumber].lowbits;
RETURN;
END;
unlinkProc[];
IF (fl ← FindOnOne[q]) # NIL THEN
BEGIN
IF size > qsize/3 THEN -- only two (free) nodes in this quantum
BEGIN ReturnQuanta[zn, q, 1]; RETURN; END;
fl^ ← LOOPHOLE[flMore]; -- move node from flOne to flMore
flMore ← LOOPHOLE[ptr];
flMore^ ←
[count: QuantumSize-LOOPHOLE[size, Basics.LongNumber].lowbits*2,
link: PrincOpsUtils.LowHalf[fl]-PrincOpsUtils.LowHalf[ptr]];
RETURN;
END;
ptr^ ← flOne; -- first free node encountered in quantum
flOne ← ptr;
END;

-- Second pass, free vacant quanta
ReturnNode: NodeProc = -- binds ptr, q, size, unlinkProc
BEGIN
flNext: PPQCounter;
IF (flNext ← FindOnMore[q]) # NIL THEN -- moves found node to head of flMore
BEGIN
empty: BOOLEAN ← flMore.empty;
IF flMore.count < size THEN {empty ← flMore.empty ← TRUE}; -- quantum is returnable

IF empty THEN unlinkProc[]; -- remove node from the free list
flMore.count ← flMore.count+LOOPHOLE[size, Basics.LongNumber].lowbits;
IF flMore.count = QuantumSize-(size + size) THEN -- last visit to this quantum
BEGIN
fl: FreeList ← LOOPHOLE[flMore];
flMore ← flNext^; -- removes node from flMore
IF empty THEN ReturnQuanta[zn, q, 1] -- free the quantum
ELSE -- return the flMore entry to the freelist
BEGIN
LOOPHOLE[flNext, FreeList]^ ← ptr^;
ptr^ ← fl;
fl^ ← LOOPHOLE[flNext, FreeList];
END;
END;
END;
END;

-- Finally, the driver
IF SIZE[FreeList] < SIZE[QCounter] THEN ERROR; -- minimum free block size constraint

IF IsSubZoneVacant[sz] THEN LOOP;
MapFl[AccumNode];
MapFl[ReturnNode];
WHILE flMore # NIL DO -- return the flMore list to the free list
fl1: FreeList ← LOOPHOLE[flMore];
fl2: FreeList ← LOOPHOLE[flMore+flMore.link];
flMore ← LOOPHOLE[fl2^];
fl1^ ← fl2; fl2^ ← pSzFl^; pSzFl^ ← fl1;
ENDLOOP;
IF flOne # NIL THEN -- return flOne list to freelist
BEGIN
fl: FreeList ← flOne;
UNTIL fl^ = NIL DO fl ← fl^ ENDLOOP;
fl^ ← pSzFl^;
pSzFl^ ← flOne;
END;
ENDLOOP; -- for each subzone
IF qzn.qNext # 0 THEN {ReturnQuanta[zn, qzn.qNext, qzn.qLast - qzn.qNext]; qzn.qNext ← qzn.qLast ← 0};
END;

-- Internal procedures for heap zones

ErasePrefixedZone: PROC[zn: PPrefixedZone] =
{NULL}; -- *** dummy for now

-- merge adjacent free blocks by scanning the free list
MergePrefixedZone: ENTRY PROC[zn: PZone] =
{ ENABLE UNWIND => NULL;
pzn: PPrefixedZone = LOOPHOLE[zn];
pfnFirst: PFreeNode ← @pzn.fnd;
pfn: PFreeNode ← pfnFirst;
UNTIL (pfn ← pfn.pfnNext) = pfnFirst DO
pfnLength: LongNodeSize = NodeLength[pfn];
pfnEndpfn: PNode ← pfn + pfnLength;
IF LOOPHOLE[pfnEndpfn, LONG CARDINAL] > LASTAddress THEN LOOP;
IF MapPtrZf[LOOPHOLE[pfnEndpfn, LONG POINTER]] = [prefixed[zi: zn.zi]] THEN
 { WITH pfnEnd: pfnEndpfn SELECT FROM
  free => -- next guy is free, merge it with pfn
  { newLength: LongNodeSize = pfnLength + NodeLength[@pfnEnd];
IF checking THEN
   {IF pfn.pfnNext.pfnPrev # pfn
   OR pfn.pfnPrev.pfnNext # pfn
   OR pfnEnd.pfnNext.pfnPrev # @pfnEnd
   OR pfnEnd.pfnPrev.pfnNext # @pfnEnd
   OR pfnLength < MinBlockSize
   OR NodeLength[@pfnEnd] < MinBlockSize
THEN ERROR};
pfnEnd.pfnNext.pfnPrev ← pfnEnd.pfnPrev;
pfnEnd.pfnPrev.pfnNext ← pfnEnd.pfnNext;
IF RTFlags.clearing -- keep free objects clear
   THEN [] ← PrincOpsUtils.ZERO[@pfnEnd, SIZE[free NodeHeader]];
   pfn.SizeLo ← LOOPHOLE[newLength, MDRLongNodeSize].lnsLo;
   pfn.SizeHi ← LOOPHOLE[newLength, MDRLongNodeSize].lnsHi;

   IF checking THEN CheckFreeChain[pfn];

  pfn ← pfn.pfnPrev;
  };
  ENDCASE;
 };
ENDLOOP;
pzn.pfn ← pzn.fnd.pfnNext;
};

CheckFreeChain: PROC [head: PFreeNode] = {
p: PFreeNode ← head;
IF p.pfnPrev.pfnNext # p THEN ERROR;
DO
next: PFreeNode ← p.pfnNext;
IF next.pfnPrev # p THEN ERROR;
p ← next;
IF p = head THEN RETURN;
ENDLOOP;
};

EnumerateAllObjects: PROC[visit: PROC[REF]] = {
-- this proc visits all non-free objects in a prefixed zone
FOR zi: CARDINAL IN [0..MapZiZn.length)
DO
zone: PZone ← LOOPHOLE[MapZiZn[zi]];
IF zone = NIL THEN LOOP;
IF zone.linkage.tag # collectible THEN LOOP;
ObjectsInPrefixedZone[zone, visit];
ENDLOOP;
};

ObjectsInPrefixedZone: ENTRY PROC [zn: PZone, visit: PROC[REF]] = {
-- this proc visits all non-free objects in a prefixed zone
ENABLE UNWIND => NULL;
WITH z: zn SELECT FROM
prefixed =>
-- look at all of the objects, both allocated and freed
FOR r: Runs.Run ← z.runs, r.rnNext UNTIL r = NIL DO
lim: PNode = LOOPHOLE[LONG[r.iTo] * RTQuanta.QuantumSize]; -- iTo not included
ptr: PNode ← LOOPHOLE[LONG[r.iFrom] * RTQuanta.QuantumSize];
WHILE ptr # lim DO -- look at each object in the run
size: LONG CARDINAL = NodeLength[ptr];
ref: REF ← LOOPHOLE[ptr + sizeNd];

IF RTFlags.checking AND size = 0 THEN ERROR;

IF ptr.state # free THEN visit[ref];
IF RTFlags.checking AND size # NodeLength[ptr]
THEN ERROR; -- oops, something changed!
ptr ← ptr + size;
ENDLOOP
ENDLOOP;
ENDCASE => ERROR;
};

-- return all quanta lying entirely within a free block
TrimPrefixedZone: ENTRY PROC[zn: PZone] =
{ ENABLE UNWIND => NULL;
pzn: PPrefixedZone = LOOPHOLE[zn];
pfn: PFreeNode ← @pzn.fnd;
UNTIL (pfn ← pfn.pfnNext) = @pzn.fnd DO -- foreach free block
IF NodeLength[pfn] >= QuantumSize THEN
{ -- quick rejection if there can't be at least one wholly contained quantum
qFirst: QuantumIndex ← MapPtrQ[pfn+(QuantumSize-1)];
qNext: QuantumIndex ← MapPtrQ[pfn+NodeLength[pfn]];
IF qNext > qFirst THEN -- if there is at least one wholly contained quantum
{ n: CARDINAL =
QuantumSizeMOD[LOOPHOLE[pfn, LONG CARDINAL]];
-- nonsense because compiler can't know this MOD yields a short result
prefixLn: CARDINAL ← (IF n = 0 THEN 0 ELSE QuantumSize-n);
pfnEnd: PFreeNode = LOOPHOLE[pfn+NodeLength[pfn]]; -- not a free node
suffixLn: CARDINAL ←
QuantumSizeMOD[LOOPHOLE[pfnEnd, LONG CARDINAL]];
-- nonsense ditto
tpfn: PFreeNode;

-- Retain residual blocks before and after entire quanta
IF (prefixLn > 0) AND (prefixLn < MinBlockSize)
THEN {IF (qFirst ← qFirst + 1) = qNext THEN LOOP;
prefixLn ← prefixLn + QuantumSize};
IF (suffixLn > 0) AND (suffixLn < MinBlockSize)
THEN {IF (qNext ← qNext - 1) = qFirst THEN LOOP;
suffixLn ← suffixLn + QuantumSize};
-- forget it if fragments would be created

tpfn ← DelinkFreeNode[pfn];
IF prefixLn # 0 THEN AddBlock[pfn, prefixLn, @pzn.fnd];
IF suffixLn # 0 THEN AddBlock[pfnEnd-suffixLn, suffixLn, @pzn.fnd];

-- Finally, release the quanta
ReturnQuanta[zn, qFirst, qNext-qFirst];
pfn ← tpfn; -- prepare for next iteration (new blocks may or may not be processed)
}; -- if there is at least one wholly contained quantum
};
ENDLOOP;
pzn.pfn ← pzn.fnd.pfnNext;
};

DelinkFreeNode: PROC[pfn: PFreeNode] RETURNS[pfnPrev: PFreeNode] =
INLINE BEGIN
pfnNext: PFreeNode = pfn.pfnNext;
pfnNext.pfnPrev ← pfnPrev ← pfn.pfnPrev;
pfnPrev.pfnNext ← pfnNext;
END;

END.