-- RTTraceAndSweepImpl.mesa
-- last change by Russ Atkinson, 17-Jul-81 12:23:33
-- last change by Willie-Sue Haugeland, 31-Jul-81 13:40:47
-- last change by Paul Rovner, February 25, 1983 10:32 am

-- This module implements a trace-and-sweep garbage collector for
-- Cedar ("DoTraceAndSweepCollection"). It uses auxilliary storage for bit tables
-- and reference stacks. To allow subsequent incremental collection,
-- DoTraceAndSweepCollection restores reference counts to correct values.
-- No collectible storage is allocated while DoTraceAndSweepCollection
-- is active, nor are any REFs change in counted storage during
-- that time. Client processes that attempt to do so are suspended
-- until after DoTraceAndSweepCollection finishes.

DIRECTORY
Environment: TYPE USING [wordsPerPage],
Inline: TYPE USING [LowHalf, LongNumber],
Mopcodes: TYPE USING [zAND, zLIB],
PilotLoadStateOps: TYPE USING [InputLoadState, ReleaseLoadState],
PrincOps: TYPE USING
[CSegPrefix, GlobalFrame, GlobalFrameHandle, MainBodyIndex],
Process: TYPE USING [Yield],
ProcessOperations: TYPE USING [LongEnter, LongExit],
RCMap: TYPE USING [nullIndex],
RefCounts: TYPE USING [Enumerate],
RTBases: TYPE USING [BaseOverhead, baseRoot, GetQuanta, PutQuanta],
RTBasic: TYPE USING [Address, Pointer, nullType],
RTCommon: TYPE USING [ShortenLongCardinal],
RTFlags: TYPE USING [checking, clearing, takingStatistics],
RTLoader: TYPE USING [GetGFRCType],
RTMicrocode: TYPE USING [RTMOVESTATUS, LONGZERO],
RTOS: TYPE USING
[EnumerateGlobalFrames, MapRCFrameBodies, SnapshotTheFrameHeap, GetCurrent,
FrameCopySpaceTooSmall, AllocateFrameBodyBuffer],
RTQuanta: TYPE USING [QuantumIndex, QuantumSize, PtrToQtmIndex, LASTAddress,
PagesPerQuantum, QtmIndexToPtr],
RTRefCounts: TYPE USING [ClearRCTable, DecrementReferenceCount, nWordsReclaimed,
IncrementReferenceCount, GCState, gcStopped, gcRunning,
nObjectsReclaimed, frameBodyBufferPages, rcFinalize],
RTStorageOps: TYPE USING [OutOfOverflowTable],
RTTypesBasic: TYPE USING [Type, GetReferentType],
RTTypesBasicPrivate: TYPE USING [MapTiRcmx, MapRefs, NPackageRefs],
Runs: TYPE USING [Run],
Runtime: TYPE USING [CallDebugger],
RTZones: TYPE USING
[GetSzSize, GetSzZi, PZone, SubZone, PFreeNode, FromCollectibleZone,
ZoneFinger, MapQZf, MapPtrZf, mzVacant, PNode, MapSziSz, PPrefixedZone,
MapZiZn, InusePNode, NodeLength, MapPtrQ,
Zone, SubZoneArray, FreeList, sizeNd, ZoneIndex],
SafeStorage: TYPE USING [ReclaimCollectibleObjects];

RTTraceAndSweepImpl: MONITOR
IMPORTS Inline, PilotLoadStateOps, Process, ProcessOperations, RefCounts, RTBases, RTCommon,
RTLoader, RTMicrocode, RTOS, RTQuanta, RTRefCounts, RTStorageOps,
RTTypesBasic, RTTypesBasicPrivate, RTZones, Runtime, SafeStorage
EXPORTS RTRefCounts
= BEGIN OPEN Environment, RTZones, RTMicrocode;

-- Variables

nRetainedObjects: LONG CARDINAL ← 0;
-- number of objects retained because REFs appear onstack (valid if countingOn = TRUE)
rpa: ARRAY [0..maxNRPIndex] OF LONG POINTER ← ALL[NIL];
maxNRPIndex: CARDINAL = 20;
nextRpaIndex: CARDINAL ← 0;

traceAndSweepEnabled: BOOLEAN ← TRUE;
destructiveTestEnabled: BOOL ← FALSE;
-- destructiveTestEnabled TRUE => do a second TandS without the stack scan, then punt
findingCircularGarbage: BOOL ← FALSE;
-- findingCircularGarbage TRUE => remember stuff found; don't reclaim it
countingOn: BOOLEAN ← TRUE;
-- countingOn left TRUE after TandS => RC table reconstructed successfully

quantizedCellsInitiallyFreed: LONG CARDINAL;
quantizedObjectsInitiallyFreed: LONG CARDINAL ← 0;
refStackChain: RefStack ← NIL;
refStackFree: RefStack ← NIL;

-- interesting statistics
prefixedObjectsMarkedFree: LONG CARDINAL ← 0;
prefixedObjectsReclaimed: LONG CARDINAL ← 0;
prefixedObjectsKept: LONG CARDINAL ← 0;
quantizedObjectsReclaimed: LONG CARDINAL ← 0;
quantizedObjectsKept: LONG CARDINAL ← 0;
nWordsReclaimedByTandS: LONG CARDINAL ← 0;
nGlobalFrames: LONG CARDINAL ← 0;
nLocalFrames: LONG CARDINAL ← 0;
quantizedObjectsSeen: LONG CARDINAL ← 0;
prefixedObjectsSeen: LONG CARDINAL ← 0;

BankTableArray: TYPE = ARRAY [0..MaxBank] OF BankTablePtr;
bankTableArray: REF BankTableArray ← NEW[BankTableArray ← ALL[NIL]];

-- debugging aids
SuspectSeen: SIGNAL = CODE;
suspect: LONG POINTER TO UNSPECIFIED ← LOOPHOLE[LONG[-1]];

BadObjectStart: ERROR = CODE;

checkMarkRef: BOOLEAN ← FALSE;
checkTraceObject: BOOLEAN ← FALSE;

bugRefs: CARDINAL ← 0;
bugRefArray: ARRAY [0..8) OF ParsedRef
← ALL[ParsedRef[word: 1, prefixed: TRUE, pad: 0, bank: 0]];
BugRefFound: SIGNAL = CODE;
SignalBugRefFound: PROC = { SIGNAL BugRefFound};
CheckBugRef: PROC [pr: ParsedRef] = {
FOR i: CARDINAL IN [0..bugRefs) DO
npr: ParsedRef ← bugRefArray[i];
IF pr.word = npr.word AND pr.bank = npr.bank THEN
SignalBugRefFound[ ! UNWIND => CONTINUE ];
ENDLOOP};

-- TYPEs and constants
ParsedNil: ParsedRef = [word: 0, prefixed: FALSE, pad: 0, bank: 0];

BankTableSize: CARDINAL = 4096; -- words (2^bitsPerWord / bitsPerWord)
BankTablePages: CARDINAL = BankTableSize / wordsPerPage; -- 16
MaxBank: CARDINAL = LOOPHOLE[RTQuanta.LASTAddress/(LONG[LAST[CARDINAL]] + 1),
Inline.LongNumber].lowbits; --63

ParsedRef: TYPE = MACHINE DEPENDENT RECORD
[word (0): CARDINAL,
prefixed (1: 0..0): BOOLEAN,
pad (1: 1..7): [0..63],
bank (1: 8..15): [0..255]];

BankTable: TYPE = PACKED ARRAY CARDINAL OF BOOLEAN;
BankTablePtr: TYPE = LONG POINTER TO BankTable;
Pair: TYPE = MACHINE DEPENDENT RECORD [low, high: CARDINAL];
PhonyTable: TYPE = ARRAY INTEGER [0..BankTableSize) OF CARDINAL;
PhonyTablePtr: TYPE = LONG POINTER TO PhonyTable;
RefStackRep: TYPE = RECORD [next: RefStack,
size, max: CARDINAL,
refs: SEQUENCE COMPUTED CARDINAL OF ParsedRef];
RefStack: TYPE = LONG POINTER TO RefStackRep;

BadAddress: ERROR = CODE;

-- support for WhoPointsTo and FindCircularGarbage
suspectRef: LONG POINTER TO UNSPECIFIED ← NIL; -- a LOOPHOLE'd REF

APNodes: TYPE = ARRAY [0..maxNReferers) OF RTZones.PNode;
suspectReferers: REF APNodes ← NEW[APNodes ← ALL[NIL]];
maxNReferers: NAT = 10;
nSuspectReferers: NAT ← 0;

AIPNodes: TYPE = ARRAY [0..maxNInnerReferers) OF RTZones.PNode;
innerReferers: REF AIPNodes ← NEW[AIPNodes ← ALL[NIL]];
maxNInnerReferers: NAT = 50;
nInnerReferers: NAT ← 0;

gfhToSuspectRef: PrincOps.GlobalFrameHandle ← NIL;
suspectRefFoundInLocalFrame: BOOL ← FALSE;
circularStructureFound: BOOL ← FALSE;

-- PROCS

-- Look up the referer chain. Stop if a gfh found, or if foundInLocalFrame, or if a loop is found,
-- or if more than 1 referer is found, or if no referers are found (changed conserv scan)
-- pn = (ref - RTZones.sizeNd)
-- RTZones.sizeNd = 2 these days
WhoPointsTo: PROC [pn: RTZones.PNode, cycleLimit: NAT ← 20]
RETURNS[referers: REF APNodes,
gfh: PrincOps.GlobalFrameHandle,
foundInLocalFrame, foundInCircularStructure: BOOL,
cycles: NAT ← 0] = {
FOR i: NAT IN [0..maxNReferers) DO suspectReferers[i] ← NIL ENDLOOP;
suspectReferers[0] ← pn;
nSuspectReferers ← 1;

FOR i: NAT IN [0..maxNInnerReferers) DO innerReferers[i] ← NIL ENDLOOP;
nInnerReferers ← 0;

gfhToSuspectRef ← NIL;
suspectRefFoundInLocalFrame ← FALSE;
circularStructureFound ← FALSE;

UNTIL gfhToSuspectRef # NIL
OR circularStructureFound
OR suspectRefFoundInLocalFrame
OR nSuspectReferers > 1
OR nSuspectReferers = 0
OR cycles = cycleLimit
DO
suspectRef ← suspectReferers[0] + RTZones.sizeNd;
FOR i: NAT IN [0..maxNReferers) DO suspectReferers[i] ← NIL ENDLOOP;
nSuspectReferers ← 0;
SafeStorage.ReclaimCollectibleObjects[suspendMe: TRUE, traceAndSweep: TRUE];
cycles ← cycles + 1;
ENDLOOP;
suspectRef ← NIL;
RETURN[referers: suspectReferers,
gfh: gfhToSuspectRef,
foundInLocalFrame: suspectRefFoundInLocalFrame,
foundInCircularStructure: circularStructureFound,
cycles: cycles];
};

-- This guy first does a standard incremental collection. Then it goes thru the motions of a TandS, but does not reclaim any garbage. Instead, it leaves the marked bit set. NOTE that this works only if SSExtra.useSizeToZn is TRUE. BEWARE don't forget to clear marks later! XXX
FindCircularGarbage: PROC =
{SafeStorage.ReclaimCollectibleObjects[suspendMe: TRUE];
findingCircularGarbage ← TRUE;
SafeStorage.ReclaimCollectibleObjects[suspendMe: TRUE, traceAndSweep: TRUE];
findingCircularGarbage ← FALSE;
};

IncRC: PROC [ref: REF ANY] =
INLINE
{IF countingOn
THEN RTRefCounts.IncrementReferenceCount
[ref ! RTStorageOps.OutOfOverflowTable => {countingOn ← FALSE; CONTINUE}]};

DecRC: PROC [ref: REF ANY] =
INLINE
{IF countingOn
THEN RTRefCounts.DecrementReferenceCount
[ref ! RTStorageOps.OutOfOverflowTable => {countingOn ← FALSE; CONTINUE}]};

-- local space management

NewPages: PROC [pages: CARDINAL--always a multiple of PagesPerQuantum--]
RETURNS [LONG POINTER] = {
RETURN[RTQuanta.QtmIndexToPtr[RTBases.GetQuanta
[base: RTBases.baseRoot,
nQ: pages / RTQuanta.PagesPerQuantum].q]];
-- RETURN [RTOS.GetDataPagesFromNewSpace[pages]];
};

FreePages: PROC [ptr: LONG POINTER, pages: CARDINAL--ditto--] = {
RTBases.PutQuanta[base: RTBases.baseRoot,
q: RTQuanta.PtrToQtmIndex[ptr],
nQ: pages / RTQuanta.PagesPerQuantum];
-- RTOS.FreeableSpaceZone.FREE[@ptr];
};

IsTraceAndSweepEnabled: PUBLIC PROC RETURNS [BOOLEAN] = {
RETURN[traceAndSweepEnabled]};

StuffZi: PUBLIC ENTRY PROC[zi: ZoneIndex, zone: ZONE] =
{ENABLE UNWIND => NULL;
z: REF ANY ← LOOPHOLE[zone];
MapZiZn[zi] ← NARROW[z]};

SuspendClientRCActivity: PROC =
{-- set the microcode to trap on any RC activity in any process other than this one
RTRefCounts.GCState.GCStateBasic.collector ← LOOPHOLE[RTOS.GetCurrent[]];
RTRefCounts.GCState.GCStateBasic.reclaimState ← RTRefCounts.gcStopped;
[] ← RTMOVESTATUS[toMemory, 0];
};

ResumeClientRCActivity: PROC[countingOn: BOOL] =
{IF countingOn -- else reference counting will be disabled
THEN RTRefCounts.GCState.GCStateBasic.reclaimState ← RTRefCounts.gcRunning;

RTRefCounts.GCState.GCStateBasic.collector ← NIL;
[] ← RTMOVESTATUS[toMemory, 0];
};

ActuallyDoIt: INTERNAL PROC[ignoreStack: BOOL ← FALSE] =
{ RTRefCounts.ClearRCTable[];

-- set start bits for prefixed objects and clear quantized free lists
quantizedCellsInitiallyFreed ← quantizedObjectsInitiallyFreed ← 0;

FOR zi: CARDINAL IN [0..MapZiZn.length) DO
zone: Zone ← MapZiZn[zi];
IF zone = NIL THEN LOOP;
IF zone.linkage.tag # collectible THEN LOOP;
WITH z: zone SELECT FROM
quantized =>
{sza: SubZoneArray ← z.pAsz;
FOR i: CARDINAL IN [0..LENGTH[sza]) DO
size: CARDINAL = sza[i].size;
fl: FreeList ← sza[i].fl;
WHILE fl # NIL DO
next: FreeList ← fl^;
IF RTFlags.checking AND NOT ObjectStart[LOOPHOLE[fl]] THEN ERROR;
[] ← LONGZERO[fl, SIZE[FreeList]];
quantizedObjectsInitiallyFreed ← quantizedObjectsInitiallyFreed + 1;
quantizedCellsInitiallyFreed ← quantizedCellsInitiallyFreed + size;
fl ← next;
ENDLOOP;
sza[i].fl ← NIL;
ENDLOOP};
prefixed =>
-- parse the prefixed zone, set object (start) bit for non-free object
{InitPrefixedObject: PROC [pref: ParsedRef] = {SetObjectBit[ParsedRefToPointer[pref]]};
ObjectsInPrefixedZone[zone, InitPrefixedObject]};
ENDCASE => ERROR
ENDLOOP;

-- trace from all local and global frames in the world
IF RTFlags.takingStatistics THEN nGlobalFrames ← nLocalFrames ← 0;

IF NOT ignoreStack THEN RTOS.MapRCFrameBodies[TraceLocalFrame];

[] ← RTOS.EnumerateGlobalFrames[TraceGlobalFrame];

-- continue marking from the ref stack and from objects
UNTIL EmptyRefStack[] DO
TraceRefsInObject[PopRef[]]
ENDLOOP;

-- free the space for ref stacks
FreeRefStacks[];

-- free the objects

-- initialize consistency counters
IF RTFlags.takingStatistics
THEN
prefixedObjectsMarkedFree ←
prefixedObjectsSeen ←
prefixedObjectsKept ←
prefixedObjectsReclaimed ←
quantizedObjectsSeen ←
quantizedObjectsKept ←
quantizedObjectsReclaimed ← 0;

nWordsReclaimedByTandS ← 0;

FOR zi: CARDINAL IN [0..MapZiZn.length) DO
zone: Zone ← MapZiZn[zi];
IF zone = NIL THEN LOOP;
IF zone.linkage.tag # collectible THEN LOOP;
WITH z: zone SELECT FROM
quantized => ObjectsInQuantizedZone[zone, VisitOneObject];
prefixed => ObjectsInPrefixedZone [zone, VisitOneObject];
ENDCASE => ERROR
ENDLOOP;

RTRefCounts.nObjectsReclaimed ← RTRefCounts.nObjectsReclaimed
- quantizedObjectsInitiallyFreed;
RTRefCounts.nWordsReclaimed ← RTRefCounts.nWordsReclaimed - quantizedCellsInitiallyFreed;
nWordsReclaimedByTandS ← nWordsReclaimedByTandS - quantizedCellsInitiallyFreed;

-- check for consistency
IF RTFlags.takingStatistics AND RTFlags.checking THEN
{IF prefixedObjectsMarkedFree
+ prefixedObjectsReclaimed
+ prefixedObjectsKept
# prefixedObjectsSeen
OR quantizedObjectsKept
+ quantizedObjectsReclaimed
# quantizedObjectsSeen
THEN ERROR};

FreeAllObjectBits[];

-- at this point, each RC table entry with count = (RCFinalize-NPackageRefs[type]) was
-- retained because it was seen onstack.

nRetainedObjects ← 0;
nextRpaIndex ← 0;
IF countingOn
THEN {p: PROC[ref: REF ANY, count: NAT, markedAsOnStack: BOOL]
RETURNS[stop: BOOL ← FALSE] =
{IF count = RTRefCounts.rcFinalize - RTTypesBasicPrivate.NPackageRefs
[RTTypesBasic.GetReferentType[ref]]
THEN {rpa[nextRpaIndex] ← LOOPHOLE[ref];
IF nextRpaIndex < maxNRPIndex THEN nextRpaIndex ← nextRpaIndex + 1;
nRetainedObjects ← nRetainedObjects + 1}};
[] ← RefCounts.Enumerate[proc: p];
};
}; -- end ActuallyDoIt

-- this is really an INTERNAL procedure of the collector's monitor (RTRefCountsImpl)
DoTraceAndSweepCollection: PUBLIC ENTRY PROC =
{ ENABLE UNWIND => NULL;

-- acquire the lock on the runtime loader (REFs in GF's are counted)
[] ← PilotLoadStateOps.InputLoadState[];

-- Acquire all ZONE locks. New ZONE creation is not a problem because the first
-- ZONE lock acquired is for the system ZONE, and NewZone won't stuff MapZiZn
-- while the TandS is active.

FOR zi: CARDINAL IN [0..MapZiZn.length)
DO zone: Zone ← MapZiZn[zi];
IF zone = NIL THEN LOOP;
IF zone.linkage.tag # collectible THEN LOOP;
UNTIL ProcessOperations.LongEnter[@zone.LOCK]
DO Process.Yield[]; ENDLOOP;
ENDLOOP;

SuspendClientRCActivity[];

DO { RTOS.SnapshotTheFrameHeap[ ! RTOS.FrameCopySpaceTooSmall => GOTO expandFCS];
EXIT;
EXITS expandFCS =>
RTOS.AllocateFrameBodyBuffer[RTRefCounts.frameBodyBufferPages
← RTRefCounts.frameBodyBufferPages+1];
} ENDLOOP;
countingOn ← TRUE;
ActuallyDoIt[ignoreStack: FALSE];
IF destructiveTestEnabled
THEN {ActuallyDoIt[ignoreStack: TRUE];
Runtime.CallDebugger["destructive collection finished."]};
-- look at nWordsReclaimedByTandS

ResumeClientRCActivity[countingOn];

-- release all the ZONE locks
FOR zi: CARDINAL IN [0..MapZiZn.length)
DO zone: Zone ← MapZiZn[zi];
IF zone = NIL THEN LOOP;
ProcessOperations.LongExit[@zone.LOCK]
ENDLOOP;

-- release the loader's lock
PilotLoadStateOps.ReleaseLoadState[];

RETURN; -- exiting the collector's monitor will unwedge reference-counting clients
};

-- this is called once for each valid REF found in counted storage
-- (this includes reconstructing the RC for the object)
MarkRef: PROC [pref: ParsedRef] = INLINE {
ref: REF ANY = UnParseRef[pref];
IF Marked[pref] THEN {IncRC[ref]; RETURN};

-- here if this REF is valid and not seen before
-- finalization: get the type, the package count, and
-- establish the correct initial RC (+1!)
FOR i: CARDINAL IN [1..RTTypesBasicPrivate.NPackageRefs[RTTypesBasic.GetReferentType[ref]]]
DO DecRC[ref] ENDLOOP;
SetMark[pref];
IF checkMarkRef THEN CheckBugRef[pref];
IF NOT RefContaining[pref] THEN RETURN;
PushRef[pref]};

-- the following proc will clear the mark bit for a ref
-- and free the object if it was unmarked
VisitOneObject: PROC [pref: ParsedRef] = {
IF NOT ObjectStart[ParsedRefToPointer[pref]] THEN ERROR;
IF Marked[pref]
THEN {IF pref.prefixed
THEN {IF RTFlags.takingStatistics
THEN prefixedObjectsKept ← prefixedObjectsKept + 1;
IF NOT findingCircularGarbage THEN ClearMark[pref]}
ELSE IF RTFlags.takingStatistics
THEN quantizedObjectsKept ← quantizedObjectsKept + 1}
ELSE {IF findingCircularGarbage
THEN {IF RTFlags.takingStatistics
THEN prefixedObjectsKept ← prefixedObjectsKept + 1;
RETURN}
ELSE IF RTFlags.takingStatistics
THEN IF pref.prefixed
THEN prefixedObjectsReclaimed ← prefixedObjectsReclaimed + 1
ELSE quantizedObjectsReclaimed ← quantizedObjectsReclaimed + 1;
TAndSFreeObject[LOOPHOLE[UnParseRef[pref]]]};
};

-- *******this stuff copied and slightly altered from RTReclaimerImpl
TAndSFreeObject: PROC[ptr: RTBasic.Pointer] =
{mz: ZoneFinger = MapPtrZf[ptr];

IF RTFlags.checking THEN
{ IF ptr = NIL THEN ERROR;
IF NOT FromCollectibleZone[LOOPHOLE[ptr, REF ANY]]
THEN ERROR};

RTRefCounts.nObjectsReclaimed ← RTRefCounts.nObjectsReclaimed + 1;

WITH mz: mz SELECT FROM
sub => {sz: SubZone = MapSziSz[mz.szi];
size: CARDINAL ← sz.size;
RTRefCounts.nWordsReclaimed ← RTRefCounts.nWordsReclaimed + size;
nWordsReclaimedByTandS ← nWordsReclaimedByTandS + size;
IF RTFlags.clearing THEN [] ← LONGZERO[ptr, size];
TAndSFreeQuantizedNode[ptr, LOOPHOLE[MapZiZn[sz.zi]], sz]};

prefixed => {size: CARDINAL = RTCommon.ShortenLongCardinal
[NodeLength[LOOPHOLE[ptr-sizeNd, PNode]]];
IF RTFlags.checking AND size = 0 THEN ERROR;
RTRefCounts.nWordsReclaimed ← RTRefCounts.nWordsReclaimed + size;
nWordsReclaimedByTandS ← nWordsReclaimedByTandS + size;
IF RTFlags.clearing THEN [] ← LONGZERO[ptr, size-sizeNd];
TAndSFreePrefixedNode[ptr, LOOPHOLE[MapZiZn[mz.zi]]]};

ENDCASE => ERROR};


TAndSFreeQuantizedNode: PROC[ptr: RTBasic.Pointer, zn: PZone, sz: SubZone] =
{LOOPHOLE[ptr, FreeList]^ ← sz.fl;
sz.fl ← ptr;
IF RTFlags.takingStatistics THEN
{ zn.cellsInService ← zn.cellsInService - sz.size;
zn.objectsInService ← zn.objectsInService - 1}};

TAndSFreePrefixedNode: PROC[ptr: RTBasic.Pointer, zn: PZone] =
{ IF RTFlags.takingStatistics THEN
{ pn: PNode = LOOPHOLE[ptr, PNode] - sizeNd;
zn.cellsInService ← zn.cellsInService - NodeLength[pn];
zn.overheadCells ← zn.overheadCells - sizeNd;
zn.objectsInService ← zn.objectsInService - 1};
LinkHeapNode[ptr-sizeNd, @LOOPHOLE[zn, PPrefixedZone].fnd]};

-- NOTE copied in RTPrefAllocImpl
LinkHeapNode: PROC[pfn, pfnPrev: PFreeNode] =
{pfnNext: PFreeNode = pfnPrev.pfnNext;
pfn.body ← free[pfnPrev: pfnPrev, pfnNext: pfnNext];
pfnNext.pfnPrev ← pfn;
pfnPrev.pfnNext ← pfn};
-- *******end of stuff copied and slightly altered from RTReclaimerImpl

GlobalFrameSize: PROC [gf: PrincOps.GlobalFrameHandle] RETURNS [CARDINAL] = {
-- return the size in words of the given global frame
-- 0 is returned for frames not yet started
IF gf = NIL OR NOT gf.started THEN RETURN [0];
{cp: LONG POINTER TO PrincOps.CSegPrefix ← LOOPHOLE[gf.code];
pbody: LONG POINTER TO CARDINAL ←
LOOPHOLE[cp + CARDINAL[cp.entry[PrincOps.MainBodyIndex].initialpc]];
RETURN [(pbody - 1)^]
}};

TraceLocalFrame: PROC [pa: LONG POINTER TO RTBasic.Address, nWords: CARDINAL] = {
-- this procedure is used to mark refs in a local frame
-- RCs must be decremented on first encounter
IF RTFlags.takingStatistics THEN nLocalFrames ← nLocalFrames + 1;
IF nWords >= (SIZE[REF]) THEN
FOR i: CARDINAL IN [0..nWords - (SIZE[REF])] DO
addr: RTBasic.Address = (pa + i)^;
IF ObjectStart[LOOPHOLE[addr]] THEN -- if this REF is valid
{ref: REF ANY = LOOPHOLE[addr];
pref: ParsedRef ← ParseRef[ref];
IF suspectRef # NIL AND LOOPHOLE[ref, LONG POINTER] = suspectRef
THEN suspectRefFoundInLocalFrame ← TRUE;
IF Marked[pref] THEN LOOP;

-- here if this REF is valid and not seen before
-- finalization: get the type, the package count, and
-- establish the correct initial RC (0)
FOR i: CARDINAL IN [0..RTTypesBasicPrivate.NPackageRefs
[RTTypesBasic.GetReferentType[ref]]]
DO DecRC[ref] ENDLOOP;
SetMark[pref];
IF NOT RefContaining[pref] THEN LOOP;
PushRef[pref]};
ENDLOOP};

TraceGlobalFrame: PROC [gfh: PrincOps.GlobalFrameHandle] RETURNS [BOOLEAN] = {
-- this procedure is used to mark refs from a global frame
-- the algorithm is essentially the same as for regular objects
type: RTTypesBasic.Type = RTLoader.GetGFRCType[gfh.gfi];
procRef: PROC [ref: REF] = {
IF RTFlags.checking AND NOT ObjectStart[LOOPHOLE[ref]] THEN ERROR;
IF suspectRef # NIL AND LOOPHOLE[ref, LONG POINTER] = suspectRef
THEN gfhToSuspectRef ← gfh;
MarkRef[ParseRef[ref]];
};
IF type # RTBasic.nullType
THEN RTTypesBasicPrivate.MapRefs
[LONG[gfh], RTTypesBasicPrivate.MapTiRcmx[type], procRef];
RETURN[FALSE]};


-- size ← GlobalFrameSize[gf];
-- p: POINTER TO RTBasic.Address ← LOOPHOLE[gf];
-- IF RTFlags.takingStatistics THEN nGlobalFrames ← nGlobalFrames + 1;
-- IF size >= SIZE[REF] THEN
-- FOR i: CARDINAL IN [SIZE[PrincOps.GlobalFrame]..size - (SIZE[REF])] DO
-- addr: RTBasic.Address = (p + i)^;
-- IF ObjectStart[LOOPHOLE[addr]] THEN
-- MarkRef[ParseRef[LOOPHOLE[addr]]]
-- ENDLOOP;
-- RETURN [FALSE]};

TraceRefsInObject: PROC [pref: ParsedRef] = {
-- applies P to each reference in the indicated object (ref)
container: REF ANY = UnParseRef[pref];
type: RTTypesBasic.Type ← RTTypesBasic.GetReferentType[container];
refererPushed: BOOL ← FALSE;
procRef: PROC [ref: REF] = {
IF RTFlags.checking AND NOT ObjectStart[LOOPHOLE[ref]] THEN ERROR;
IF suspectRef # NIL
AND LOOPHOLE[ref, LONG POINTER] = suspectRef
AND NOT refererPushed
THEN {pn: RTZones.PNode = LOOPHOLE[container, RTZones.PNode] - RTZones.sizeNd;
refererPushed ← TRUE;
IF nSuspectReferers < maxNReferers
THEN {suspectReferers[nSuspectReferers] ← pn;
nSuspectReferers ← nSuspectReferers + 1};
FOR i: NAT IN [0..nInnerReferers)
DO IF pn = innerReferers[i] THEN {circularStructureFound ← TRUE; EXIT}
ENDLOOP;
IF NOT circularStructureFound AND nInnerReferers < maxNInnerReferers
THEN {innerReferers[nInnerReferers] ← pn;
nInnerReferers ← nInnerReferers + 1};
};
MarkRef[ParseRef[ref]];
};

IF checkTraceObject THEN CheckBugRef[pref];
RTTypesBasicPrivate.MapRefs
[LOOPHOLE[container], RTTypesBasicPrivate.MapTiRcmx[type], procRef]};

ObjectsInPrefixedZone: PROC [zone: Zone, visit: PROC [ParsedRef]] = {
-- this proc visits all non-free objects in a prefixed zone
WITH z: zone 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];
pr: ParsedRef ← LOOPHOLE[ptr + sizeNd];

IF RTFlags.checking AND size = 0 THEN ERROR;

IF RTFlags.takingStatistics THEN prefixedObjectsSeen ← prefixedObjectsSeen + 1;

IF pr.pad # 0
OR pr.prefixed
OR size < sizeNd
OR LOOPHOLE[pr, LONG CARDINAL] > LOOPHOLE[lim, LONG CARDINAL]
THEN ERROR;

pr.prefixed ← TRUE;
IF ptr.state = free
THEN {IF RTFlags.takingStatistics
THEN prefixedObjectsMarkedFree ← prefixedObjectsMarkedFree + 1}
ELSE visit[pr];
IF RTFlags.checking AND size # NodeLength[ptr]
THEN ERROR; -- oops, something changed!
ptr ← ptr + size;
ENDLOOP
ENDLOOP;
ENDCASE => ERROR};

ObjectsInQuantizedZone: PROC [zone: Zone, visit: PROC [ParsedRef]] = {
-- this proc visits all objects in a quantized zone
-- the visitation is in order of increasing address
FOR r: Runs.Run ← zone.runs, r.rnNext WHILE r # NIL DO
FOR qx: CARDINAL IN [r.iFrom..r.iTo) DO
mz: ZoneFinger = MapQZf[qx];
IF mz = mzVacant THEN LOOP; -- unused quantum
WITH mz: mz SELECT FROM
sub =>
{size: CARDINAL = GetSzSize[mz.szi];
rz: Zone = MapZiZn[GetSzZi[mz.szi]];
lc: LONG CARDINAL ← 0;
p: LONG POINTER ← LOOPHOLE[LONG[qx]*RTQuanta.QuantumSize];

IF rz # zone OR size > RTQuanta.QuantumSize THEN ERROR;

IF qx = rz.qFirst THEN lc ← RTBases.BaseOverhead;
DO -- for each object in the quantum
pr: ParsedRef ← LOOPHOLE[p+lc];
lc ← lc + size;
IF lc > RTQuanta.QuantumSize THEN EXIT;
IF RTFlags.takingStatistics THEN quantizedObjectsSeen ← quantizedObjectsSeen + 1;
visit[pr];
ENDLOOP;
};
ENDCASE => ERROR;
ENDLOOP;
ENDLOOP;
};

ParsedRefToPointer: PROC [p: ParsedRef] RETURNS [RTBasic.Pointer] = MACHINE CODE
{Mopcodes.zLIB, 377B; Mopcodes.zAND};

ParsedRefToPNode: PROC [p: ParsedRef] RETURNS [InusePNode] = INLINE {
IF p.prefixed THEN RETURN [LOOPHOLE[ParsedRefToPointer[p] - sizeNd]];
ERROR};

ObjectStart: PROC [p: RTBasic.Pointer] RETURNS [BOOLEAN] = INLINE {
-- returns TRUE if the pointer really refers to the start of an object
-- it is OK to hand this thing pure garbage!

-- A ref to someplace in a prefixed zone points at the start of
-- a non-free object if ObjectBit[ref] is TRUE. We assume that the
-- object start bits have been set for prefixed objects

-- A ref to someplace in a quantized zone points at the start of
-- an object if the ref has the correct modulus with respect to
-- the size of the objects in the appropriate sub-zone. This must
-- be adjusted for BaseOverhead if the quantum is the one indicated
-- by zone.qFirst.

IF p = NIL
OR (LOOPHOLE[p, Pair].low MOD 2 = 1)
OR (LOOPHOLE[p, Pair].high > MaxBank)
THEN RETURN [FALSE];

{qx: RTQuanta.QuantumIndex = RTQuanta.PtrToQtmIndex[p];
mz: ZoneFinger = MapQZf[qx];
IF mz = mzVacant THEN RETURN [FALSE];
WITH mz: mz SELECT FROM
sub => {sz: CARDINAL = GetSzSize[mz.szi];
rz: Zone = MapZiZn[GetSzZi[mz.szi]];
lc: CARDINAL ← CARDINAL[Inline.LowHalf[p]] MOD RTQuanta.QuantumSize;

IF rz = NIL THEN RETURN[FALSE];
IF RTFlags.checking AND rz.linkage.tag # collectible THEN ERROR;
IF qx = rz.qFirst THEN
{IF lc < RTBases.BaseOverhead THEN RETURN [FALSE];
lc ← lc - RTBases.BaseOverhead};
IF sz > RTQuanta.QuantumSize THEN ERROR; -- can't allow this!
RETURN [lc MOD sz = 0]};
prefixed => IF MapZiZn[mz.zi] = NIL
THEN RETURN[FALSE]
ELSE RETURN[ObjectBit[p]];
ENDCASE => ERROR}};

Marked: PROC [pref: ParsedRef] RETURNS [BOOLEAN] = INLINE {
-- determines whether ref has been seen
ptr: RTBasic.Pointer = ParsedRefToPointer[pref];
IF NOT pref.prefixed
THEN RETURN [ObjectBit[ptr]] -- for quantized zones, the ObjectBit is used as the mark!
ELSE RETURN [ParsedRefToPNode[pref].marked]};

SetMark: PROC [pref: ParsedRef] = INLINE {
-- marks object as being seen
ptr: RTBasic.Pointer = ParsedRefToPointer[pref];
IF NOT pref.prefixed
THEN SetObjectBit[ptr] -- for quantized zones, the ObjectBit is used as the mark!
ELSE ParsedRefToPNode[pref].marked ← TRUE};

ClearMark: PROC [pref: ParsedRef] = INLINE {
-- clears object mark to ground state
ptr: RTBasic.Pointer = ParsedRefToPointer[pref];
IF NOT pref.prefixed
THEN ClearObjectBit[ptr] -- for quantized zones, the ObjectBit is used as the mark!
ELSE ParsedRefToPNode[pref].marked ← FALSE};

-- One bit per address in virtual memory.
-- For prefixed zones, the "object" bit indicates that the object is allocated.
-- For quantized zones, it is used as the mark bit.
ObjectBit: PROC [ptr: RTBasic.Pointer] RETURNS [BOOLEAN] = INLINE {
-- returns TRUE iff object bit is set for the reference
bank: CARDINAL ← LOOPHOLE[ptr, Pair].high;
word: CARDINAL ← LOOPHOLE[ptr, Pair].low;
IF bank > MaxBank THEN RETURN [FALSE];
IF suspect = ptr THEN SIGNAL SuspectSeen;
{table: BankTablePtr ← bankTableArray[bank];
IF table = NIL THEN RETURN [FALSE];
RETURN [table[word]]}};

SetObjectBit: PROC [ptr: RTBasic.Pointer] = INLINE {
-- sets the object bit for the reference
bank: CARDINAL ← LOOPHOLE[ptr, Pair].high;
word: CARDINAL ← LOOPHOLE[ptr, Pair].low;
IF bank > MaxBank THEN ERROR BadObjectStart;
IF suspect = ptr THEN SIGNAL SuspectSeen;
{table: BankTablePtr ← bankTableArray[bank];
IF table = NIL THEN
-- create new bank table (and initialize it to ALL[FALSE] efficiently)
{table ← LOOPHOLE[NewPages[BankTablePages]];
bankTableArray[bank] ← table;
LOOPHOLE[table, PhonyTablePtr]^ ← ALL[0]};
table[word] ← TRUE}};

ClearObjectBit: PROC [ptr: RTBasic.Pointer] = INLINE {
-- clears the object bit for the reference
bank: CARDINAL ← LOOPHOLE[ptr, Pair].high;
word: CARDINAL ← LOOPHOLE[ptr, Pair].low;
IF bank > MaxBank THEN ERROR BadObjectStart;
IF suspect = ptr THEN SIGNAL SuspectSeen;
{table: BankTablePtr ← bankTableArray[bank];
IF table = NIL THEN ERROR BadAddress;
table[word] ← FALSE}};

FreeAllObjectBits: PROC = {
-- free all of the object bit tables
FOR bank: CARDINAL IN [0..MaxBank] DO
table: BankTablePtr ← bankTableArray[bank];
IF table = NIL THEN LOOP;
FreePages[table, BankTablePages];
bankTableArray[bank] ← NIL
ENDLOOP};

PushRef: PROC [pref: ParsedRef] = {
-- pushes ref to object onto the reference stack
stack: RefStack ← refStackChain;
IF stack = NIL OR stack.size = stack.max THEN
-- time to get a new stack node
{IF refStackFree = NIL
-- oh well, nothing comes for free
THEN {stack ← NewPages[RTQuanta.QuantumSize/wordsPerPage];
stack.next ← NIL;
stack.size ← 0;
stack.max ← (RTQuanta.QuantumSize - (SIZE[RefStackRep])) / (SIZE[ParsedRef])}
ELSE {stack ← refStackFree;
refStackFree ← stack.next};
stack.next ← refStackChain;
refStackChain ← stack};
stack[stack.size] ← pref;
stack.size ← stack.size + 1};

PopRef: PROC RETURNS [pref: ParsedRef] = {
-- pops ref to object from the reference stack
stack: RefStack ← refStackChain;
IF stack # NIL THEN
{size: CARDINAL ← stack.size;
IF size = 0 THEN
{refStackChain ← stack.next;
stack.next ← refStackFree;
refStackFree ← stack;
IF (stack ← refStackChain) = NIL THEN RETURN [ParsedNil];
IF (size ← stack.size) = 0 THEN ERROR};
size ← size - 1;
stack.size ← size;
RETURN [stack[size]]};
RETURN [ParsedNil]};

EmptyRefStack: PROC RETURNS [BOOLEAN] = INLINE {
-- tests reference stack for emptiness
RETURN [refStackChain = NIL]};

FreeRefStacks: PROC = {
IF refStackChain # NIL THEN ERROR; -- should never happen, but check anyway
WHILE refStackFree # NIL DO
stack: RefStack ← refStackFree.next;
FreePages[refStackFree, RTQuanta.QuantumSize/wordsPerPage];
refStackFree ← stack
ENDLOOP};

ParseRef: PROC [ref: REF ANY] RETURNS [ParsedRef] = {
-- parses reference into more efficient representation
IF LOOPHOLE[ref, Pair].high > MaxBank THEN RETURN [ParsedNil];
{pr: ParsedRef ← LOOPHOLE[ref];
mz: ZoneFinger = MapPtrZf[LOOPHOLE[ref]];
rz: Zone;
WITH mz: mz SELECT FROM
sub => rz ← MapZiZn[GetSzZi[mz.szi]];
prefixed => rz ← MapZiZn[mz.zi];
ENDCASE => ERROR;
IF rz.linkage.tag # collectible THEN RETURN [ParsedNil];
IF rz.sr = prefixed THEN pr.prefixed ← TRUE;
RETURN[pr]}};

UnParseRef: PROC [pref: ParsedRef] RETURNS [REF ANY] = INLINE {
-- returns user-style reference from parsed ref
RETURN [LOOPHOLE[ParsedRefToPointer[pref]]]};

RefContaining: PROC [pref: ParsedRef] RETURNS [BOOLEAN] = INLINE {
-- tests for object being ref-containing (assume that ObjectStart is TRUE)
IF pref = ParsedNil THEN RETURN [FALSE];
{type: RTTypesBasic.Type = RTTypesBasic.GetReferentType[UnParseRef[pref]];
RETURN [RTTypesBasicPrivate.MapTiRcmx[type] # RCMap.nullIndex]}};

END.