-- Access to built-in Zones
GetHeapSystemZone: PUBLIC PROC RETURNS[UNCOUNTED ZONE] = {RETURN[zoneHeapSystem]};

GetSystemZone: PUBLIC SAFE PROC RETURNS[ZONE] = TRUSTED {RETURN[zoneSystem]};

GetPermanentZone: PUBLIC SAFE PROC RETURNS[ZONE] = TRUSTED {RETURN[permanentZone]};

GetSystemUZone: PUBLIC PROC RETURNS[UNCOUNTED ZONE] = {RETURN[zoneHeapSystem]};

NewZone: PROC[ initialSize: LONG CARDINAL --words-- ← 0] RETURNS[zone: ZONE] =
TRUSTED BEGIN
zi: ZoneIndex;
IF SizeToZn # NIL THEN RETURN[GetSystemZone[]];
zi ← AllocateZi[];
{pzn: PrefixedZone =
zoneSystem.NEW[prefixed ZoneRec ←
[ new: LOOPHOLE[NewPrefixedObject, UNSPECIFIED],
free: LOOPHOLE[FreePrefixedObject, UNSPECIFIED],
linkage: [collectible[fullProc: defaultZoneFullProc]],
zi: zi, freeLists: prefixed[], LOCK: ]];
InitPrefixedZone[LOOPHOLE[pzn, PPrefixedZone]];
zone ← LOOPHOLE[pzn];
MapZiZn[zi] ← LOOPHOLE[zone, Zone]; -- RTRefCounts.StuffZi[zi, zone]; the package ref
};
ExtendZone[zone, initialSize];
END;

NewUZone: PUBLIC PROC
[ initialSize: LONG CARDINAL --words-- ← 0] RETURNS[UNCOUNTED ZONE] =
BEGIN
ans: UNCOUNTED ZONE;
zi: ZoneIndex = AllocateZi[];
prz: PZone;
{ pzn: PPrefixedZone =
zoneHeapSystem.NEW[prefixed ZoneRec ←
[ new: LOOPHOLE[NewPrefixedHeapObject, UNSPECIFIED],
free: LOOPHOLE[FreePrefixedHeapObject, UNSPECIFIED],
linkage: [heap[fullProc: defaultUZoneFullProc]],
zi: zi, freeLists: prefixed[], LOCK: ]];
InitPrefixedZone[pzn];
prz ← pzn;
};
ans ← LOOPHOLE[zoneHeapSystem.NEW[PZone ← prz], UNCOUNTED ZONE];
ExtendUZone[ans, initialSize];
UZoneTracker.Register[ans];
RETURN[ans];
END;

FreeUZone: PUBLIC PROC[uz: UNCOUNTED ZONE] =
{ p: LONG POINTER TO PZone ← LOOPHOLE[uz];
prz: PZone ← p^;
UZoneTracker.UnRegister[uz];
FinalizeZone[prz];
zoneHeapSystem.FREE[@prz];
zoneHeapSystem.FREE[@p]};

GetCanonicalReferentTypeTrap: PUBLIC PROC[ref: REF ANY] RETURNS[type: Type] =
{ state: PrincOps.StateVector;
kludge: LONG CARDINAL;

state ← STATE; -- incantation
kludge← 0;
type← GetCanonicalType[InternalReferentType[LOOPHOLE[ref]]];
TrapSupport.BumpPC[2];
state.dest ← LOOPHOLE[PrincOpsUtils.MyLocalFrame[]];
TRANSFER WITH state -- incantation
};

GetCanonicalReferentTypeSDTrap: PUBLIC PROC[ref: REF ANY] RETURNS[type: Type] =
{RETURN[GetCanonicalType[InternalReferentType[LOOPHOLE[ref]]]]};

InternalReferentType: PROC[ptr: LONG POINTER] RETURNS[type: Type] =
BEGIN
mz: ZoneFinger;
IF ptr = NIL THEN RETURN[nullType];
mz ← MapPtrZf[ptr];
WITH mz: mz SELECT FROM
prefixed =>
{ IF checking THEN {
zn: Zone = MapZiZn[mz.zi];
IF mz.zi = 0 OR ((zn # NIL) AND (zn.sr # prefixed))
THEN ERROR
ELSE IF LOOPHOLE[(ptr - sizeNd), PNode].state = free
THEN ERROR ReferentOnFreeList[ptr];
};
RETURN[LOOPHOLE[LOOPHOLE[(ptr-sizeNd), InusePNode].type, Type]];
};
sub => ERROR;
ENDCASE => ERROR;
END;

IsReferentType: PUBLIC SAFE PROC[ref: REF ANY, type: Type] RETURNS[BOOLEAN] =
TRUSTED {RETURN[GetCanonicalType[type] = GetCanonicalReferentType[ref]]};

NarrowRef: PUBLIC SAFE PROC[ref: REF ANY, type: Type] RETURNS[REF ANY] =
TRUSTED {IF ref = NIL THEN RETURN[NIL]
ELSE IF GetCanonicalType[type] = GetCanonicalReferentType[ref]
THEN RETURN[ref]
ELSE ERROR NarrowRefFault[ref, type]};

GetCanonicalReferentType: PUBLIC SAFE PROC[ref: REF ANY] RETURNS[type: Type] =
TRUSTED { IF useCanonicalTypeMicroCode THEN RETURN[RTMicrocode.GETCANONICALREFERENTTYPE[ref]]
ELSE RETURN[GetCanonicalType[DoGetHeapReferentType[LOOPHOLE[ref]]]]};

GetReferentType: PUBLIC SAFE PROC[ref: REF ANY] RETURNS[type: Type] =
TRUSTED { RETURN[DoGetHeapReferentType[LOOPHOLE[ref]]]};

GetHeapReferentType: PUBLIC PROC[ptr: LONG POINTER] RETURNS[type: Type] =
{ RETURN[DoGetHeapReferentType[ptr]]};

DoGetHeapReferentType: PROC[ptr: LONG POINTER] RETURNS[type: Type] =
INLINE BEGIN
mz: ZoneFinger;
IF useCanonicalTypeMicroCode
THEN RETURN[RTMicrocode.GETCANONICALREFERENTTYPE[LOOPHOLE[ptr]]];
IF ptr = NIL THEN RETURN[nullType];
mz ← MapPtrZf[ptr];
WITH mz: mz SELECT FROM
prefixed =>
{ IF checking THEN {
zn: Zone = MapZiZn[mz.zi];
IF mz.zi = 0 OR ((zn # NIL) AND (zn.sr # prefixed))
THEN ERROR
ELSE IF LOOPHOLE[(ptr - sizeNd), PNode].state = free
THEN ERROR ReferentOnFreeList[ptr];
};
RETURN[LOOPHOLE[LOOPHOLE[(ptr-sizeNd), InusePNode].type, Type]]};
sub => ERROR;
ENDCASE => ERROR;
END;

SetZoneFullProc: PUBLIC SAFE PROC[zone: ZONE, proc: ZoneFullProc] RETURNS[oldProc: ZoneFullProc] =
TRUSTED {RETURN[DoSetZoneFullProc[LOOPHOLE[zone], proc]]};

DoSetZoneFullProc: ENTRY PROC[zn: PZone, proc: ZoneFullProc] RETURNS[oldProc: ZoneFullProc] =
{ENABLE UNWIND => NULL;
WITH zl: zn.linkage SELECT FROM
collectible => {oldProc ← zl.fullProc; zl.fullProc ← proc};
ENDCASE => ERROR};

ExtendZone: PUBLIC ZoneFullProc =
TRUSTED { nQ: QuantumCount = MapSizeNq[size];
zn: Zone = LOOPHOLE[zone];
qNew: QuantumIndex;
firstQuantum: BOOLEAN;
[qNew, firstQuantum] ← GetQuanta[nQ];
ExtendZoneWithQuanta[LOOPHOLE[zn], qNew, nQ, firstQuantum]};

SetUZoneFullProc: PUBLIC PROC[zone: UNCOUNTED ZONE, proc: UZoneFullProc]
RETURNS[oldProc: UZoneFullProc] =
{RETURN[DoSetUZoneFullProc[LOOPHOLE[zone, LONG POINTER TO PZone]^, proc]]};

DoSetUZoneFullProc: ENTRY PROC[zn: PZone, proc: UZoneFullProc] RETURNS[oldProc: UZoneFullProc] =
{ENABLE UNWIND => NULL;
WITH zl: zn.linkage SELECT FROM
heap => {oldProc ← zl.fullProc; zl.fullProc ← proc};
ENDCASE => ERROR};

ExtendUZone: PUBLIC UZoneFullProc =
{ nQ: QuantumCount = MapSizeNq[size];
zn: PZone = LOOPHOLE[zone, LONG POINTER TO PZone]^;
qNew: QuantumIndex;
firstQuantum: BOOLEAN;
[qNew, firstQuantum] ← GetQuanta[nQ];
ExtendZoneWithQuanta[zn, qNew, nQ, firstQuantum]};

ExtendZoneWithQuanta: ENTRY PROC
[zn: PZone, qNew: QuantumIndex, nQ: QuantumCount, firstQuantum: BOOLEAN] =
BEGIN ENABLE UNWIND => NULL;
IF firstQuantum THEN zn.qFirst ← qNew;
WITH zn: zn SELECT FROM
quantized => ERROR;
prefixed =>
{ overhead: CARDINAL = IF firstQuantum THEN BaseOverhead ELSE 0;
FOR q: QuantumIndex IN [qNew..qNew + nQ) DO MapQZf[q] ← [prefixed[zn.zi]]; ENDLOOP;
AddBlock[RTCommon.RepAddrPtr[QuantumSizeMULT[qNew] + overhead],
QuantumSizeMULT[nQ] - overhead,
zn.pfn --@zn.fnd--]};
ENDCASE => ERROR;
Runs.AddInterval[@zn.runs, qNew, nQ];
END;

-- Exported procedures (within GC only)

-- prefixedly an INTERNAL proccedure
ReturnQuanta: PUBLIC PROC[pzn: PZone, q: QuantumIndex, nQ: QuantumCount] =
{ FOR i: QuantumIndex IN [q..q + nQ) DO MapQZf[i] ← mzVacant; ENDLOOP;
Runs.DeleteInterval[@pzn.runs, q, nQ];
IF pzn.qFirst IN [q..CARDINAL[q + nQ]) THEN pzn.qFirst ← 0;
WITH zl: pzn.linkage SELECT FROM
collectible => PutQuanta[q, nQ];
heap => PutQuanta[q, nQ]
ENDCASE => ERROR};


-- PRIVATE procedures

InitPrefixedZone: PROC[zn: PPrefixedZone] = {zn.fnd.pfnNext ← zn.fnd.pfnPrev ← zn.pfn ← @zn.fnd};

ZoneResidueWords: PROC[zn: PZone] RETURNS[nWords: LONG CARDINAL ← 0] = {
IF zn.qFirst # 0 THEN nWords ← BaseOverhead;
WITH zn: zn SELECT FROM
quantized => ERROR;
ENDCASE;
RETURN[nWords]};

ZoneFreeWords: PROC[zn: PZone] RETURNS[LONG CARDINAL] =
{ nWords: LONG CARDINAL ← 0;
WITH zn: zn SELECT FROM
quantized => ERROR;
prefixed =>
{ pfn: PFreeNode ← zn.pfn;
DO
nWords ← nWords + NodeLength[pfn];
IF (pfn ← pfn.pfnNext) = zn.pfn THEN EXIT;
ENDLOOP};
ENDCASE => ERROR;
RETURN[nWords]};

ZoneFreeQuanta: PROC[zn: PZone] RETURNS[nQuanta: LONG CARDINAL] =
{RETURN[WITH zn: zn SELECT FROM
quantized => zn.qLast - zn.qNext,
prefixed => 0,
ENDCASE => ERROR]};

ZoneFreeObjects: PROC[zn: PZone] RETURNS[nObjects: LONG CARDINAL] =
{ nObjects ← 0;
WITH zn: zn SELECT FROM
quantized => ERROR;
prefixed =>
{ pfn: PFreeNode ← zn.pfn;
DO
nObjects ← nObjects + 1;
IF (pfn ← pfn.pfnNext) = zn.pfn THEN EXIT;
ENDLOOP};
ENDCASE => ERROR;
RETURN[nObjects]};

-- NOTE this is not an ENTRY proc!! It is meant to be called while debugging.
-- cellsInService includes overhead cells and 1 word for the type code in prefix objects
-- overheadCells is applicable for prefixed zones, residueCells for quantized zones
-- overheadCells is one word for small objects, 2 for big ones and does not include 1 word for
-- the type code in prefix objects
SummarizeZone: PUBLIC PROC[zn: PZone]
RETURNS[nQuanta, freeQuanta, objectsInService, overheadCells, freeObjects,
cellsInService, freeCells, residueCells: LONG CARDINAL] =
{ CountQuanta: PROC[iFrom, n: Runs.RunValue] ={ nQuanta ← nQuanta + n};

nQuanta ← 0;
Runs.MapIntervals[@zn.runs, CountQuanta];
freeQuanta ← ZoneFreeQuanta[zn];
objectsInService ← zn.objectsInService;
overheadCells ← zn.overheadCells;
freeObjects ← ZoneFreeObjects[zn];
cellsInService ← zn.cellsInService;
freeCells ← ZoneFreeWords[zn];
residueCells ← ZoneResidueWords[zn]};

IsZoneEmpty: PUBLIC SAFE PROC[zone: ZONE] RETURNS[BOOLEAN] =
TRUSTED {RETURN[DoIsZoneEmpty[LOOPHOLE[zone]]]};

DoIsZoneEmpty: ENTRY PROC[zn: PZone] RETURNS[BOOLEAN] =
BEGIN ENABLE UNWIND => NULL;
nq: CARDINAL ← 0;
CountQuanta: PROC[iFrom, n: Runs.RunValue] = {nq ← nq + n};

Runs.MapIntervals[@zn.runs, CountQuanta];
RETURN[(ZoneFreeWords[zn] + ZoneResidueWords[zn]) = QuantumSizeMULT[nq]];
END;

IsUZoneEmpty: PUBLIC PROC[zone: UNCOUNTED ZONE] RETURNS[BOOLEAN] =
{RETURN[DoIsZoneEmpty[LOOPHOLE[zone, LONG POINTER TO PZone]^]]};

-- ZoneFinalizerProcess: PROC[zfq: FinalizationQueue] =
-- { DO
-- zone: ZONE = LOOPHOLE[FQNext[zfq]];
-- TrimZone[zone];
-- IF IsZoneEmpty[zone] THEN FinalizeZone[LOOPHOLE[zone, PZone]];
-- ENDLOOP};

FinalizeZone: ENTRY PROC[zn: PZone] =
BEGIN ENABLE UNWIND => NULL;
FreeQRun: PROC[iFrom, n: CARDINAL] =
{ReturnQuanta[zn, iFrom, n]};
Runs.MapIntervals[@zn.runs, FreeQRun];
MapZiZn[zn.zi] ← NIL;
END;

Pair: TYPE = MACHINE DEPENDENT RECORD [low, high: CARDINAL];
MaxBank: CARDINAL = LASTAddress/(LONG[LAST[CARDINAL]] + 1); --63
ValidateRef: PUBLIC PROC [ref: REF ANY] = {
-- returns happily if the pointer refers to the start of an object

-- 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.

-- for a prefixed zone, gotta scan the run that contains the referenced object.

IF ref = NIL THEN RETURN; -- NIL is OK

IF (LOOPHOLE[ref, LONG CARDINAL] MOD 2 = 1)
OR (LOOPHOLE[ref, Pair].high > MaxBank)
THEN ERROR InvalidRef[ref];

{qx: QuantumIndex = PtrToQtmIndex[LOOPHOLE[ref, LONG POINTER]];
mz: ZoneFinger = MapQZf[qx];
IF mz = mzVacant THEN ERROR InvalidRef[ref]; -- not even in the quantum map
WITH mz: mz SELECT FROM
sub => ERROR;
prefixed => ValidatePrefixedRef[zn: LOOPHOLE[MapZiZn[mz.zi], PZone], ref: ref];
ENDCASE => ERROR}};

ValidatePrefixedRef: ENTRY PROC [zn: PZone, ref: REF ANY] =
{ ENABLE UNWIND => NULL;
ptr: LONG POINTER = LOOPHOLE[ref];
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] * QuantumSize]; -- iTo not included
pNode: PNode ← LOOPHOLE[LONG[r.iFrom] * QuantumSize];
IF LOOPHOLE[ptr, LONG CARDINAL] >= LOOPHOLE[pNode, LONG CARDINAL]
AND LOOPHOLE[ptr, LONG CARDINAL] < LOOPHOLE[lim, LONG CARDINAL]
THEN -- this is the run in which we should find the ref
{WHILE pNode # lim DO -- look at each object in the run
size: LONG CARDINAL = NodeLength[pNode];
IF pNode.state # free AND ptr = pNode + sizeNd THEN RETURN;
pNode ← pNode + size;
IF LOOPHOLE[ptr, LONG CARDINAL] < LOOPHOLE[pNode, LONG CARDINAL]
THEN ERROR InvalidRef[ref];
ENDLOOP;
ERROR};
ENDLOOP;
ERROR InvalidRef[ref]};
ENDCASE => ERROR};



-- MODULE INITIALIZATION ... this is extremely delicate

SetZiNext[3]; -- 0: zoneVacant, 1: zoneSystem, 2: zoneHeapSystem,

BEGIN
nQ: CARDINAL = LAST[QuantumIndex] - FIRST[QuantumIndex] + 1;
MapQZf ← LOOPHOLE[PermanentPageZone.NEW[RMapQZf[nQ]]];
FOR i: CARDINAL IN [0..nQ) DO MapQZf[i] ← mzVacant ENDLOOP;
RTRefCounts.StuffMapQZf[MapQZf];
END;
useCanonicalTypeMicroCode ← useCanonicalTypeMicroCode AND RTRefCounts.GCMicrocodeExists;

InitPrefixedZone[LOOPHOLE[znSystem, PPrefixedZone]];
InitPrefixedZone[LOOPHOLE[znHeapSystem, PPrefixedZone]];

-- ******Until the sun comes up*******
LOOPHOLE[zoneSystem, LONG POINTER] ← znSystem;
LOOPHOLE[zoneHeapSystem, LONG POINTER] ← @znHeapSystem;

LOOPHOLE[MapZiZn, LONG POINTER] ← PermanentPageZone.NEW[PMapZiZn[nZiMaxInit] ← [zones: NULL]];
FOR i: CARDINAL IN [0..nZiMaxInit) DO LOOPHOLE[MapZiZn, LONG POINTER TO PMapZiZn][i] ← 0 ENDLOOP;

LOOPHOLE[MapZiZn[rZnSystem.zi], LONG POINTER] ← znSystem;
RTRefCounts.StuffMapZiZn[LOOPHOLE[MapZiZn, LONG POINTER TO PMapZiZn]];
-- ******Until the sun comes up*******

LOOPHOLE[@PrincOps.SD[RTSD.sSystemZone], POINTER TO LONG POINTER]^
← LOOPHOLE[zoneSystem, LONG POINTER];
NotifyAllocatorReady[]; -- the allocator is now useable

{ oldZs: PrefixedZone = LOOPHOLE[zoneSystem];
zs: PrefixedZone =
NEW[prefixed ZoneRec ←
[ new: oldZs.new,
free: oldZs.free,
zi: oldZs.zi,
linkage: [collectible[fullProc: ExtendZone]],
qFirst: oldZs.qFirst,
runs: oldZs.runs,
cellsInService: oldZs.cellsInService,
objectsInService: oldZs.objectsInService,
overheadCells: oldZs.overheadCells,
freeLists: prefixed[], LOCK: ]
];
InitPrefixedZone[LOOPHOLE[zs, PPrefixedZone]];

IF oldZs.fnd.pfnNext # @oldZs.fnd THEN
{ zs.fnd.pfnNext ← oldZs.fnd.pfnNext;
oldZs.fnd.pfnNext.pfnPrev ← @zs.fnd;
zs.fnd.pfnPrev ← oldZs.fnd.pfnPrev;
oldZs.fnd.pfnPrev.pfnNext ← @zs.fnd
};

LOOPHOLE[zoneSystem, LONG POINTER] ← NIL;
zoneSystem ← LOOPHOLE[zs]; -- NOTE stuff this in the SD!!
LOOPHOLE[@PrincOps.SD[RTSD.sSystemZone], POINTER TO LONG POINTER]^
← LOOPHOLE[zoneSystem, LONG POINTER];
};

{ mzizn: TMapZiZn = NEW[RMapZiZn[nZiMaxInit] ← [zones: NULL]];
p: LONG POINTER ← LOOPHOLE[MapZiZn];
FOR i: CARDINAL IN [0..nZiMaxInit) DO LOOPHOLE[mzizn, LONG POINTER TO PMapZiZn][i] ← 0 ENDLOOP;
LOOPHOLE[MapZiZn, LONG POINTER] ← NIL;
MapZiZn ← mzizn;
MapZiZn[LOOPHOLE[zoneSystem, Zone].zi] ← LOOPHOLE[zoneSystem, Zone];
-- FreeableSpaceZone.FREE[@p];
RTRefCounts.StuffMapZiZn[LOOPHOLE[MapZiZn, LONG POINTER TO PMapZiZn]];
};

IF useSizeToZn THEN
{stz: REF ARRAY [0..maxSizeToZnIndex] OF ZONE
= NEW[ARRAY [0..maxSizeToZnIndex] OF ZONE ← ALL[NIL]];
FOR i: [0..maxSizeToZnIndex/2] IN [0..maxSizeToZnIndex/2]
DO IF stz[QuantizedSize[i*2]] = NIL
THEN stz[QuantizedSize[i*2]] ← NewZone[];
ENDLOOP;
mediumSizedZone ← NewZone[initialSize: 100000B];
permanentZone ← NewZone[initialSize: 40000B];
SizeToZn ← stz; -- subsequent calls on the prefixed allocator for any ZONE will use this stuff
};

END.