-- RTPrefAllocImpl.Mesa
-- last edited On August 30, 1982 10:34 am by Willie-Sue Haugeland
-- last edited On March 7, 1983 8:59 am by Paul Rovner

DIRECTORY
Inline USING[LowHalf, BITAND], -- for debugging
Environment USING[wordsPerPage],
PrincOps USING[StateVector],
RCMap USING[nullIndex],
RTBases USING[GetSubspaceQuanta],
RTBasic USING[Pointer, nullType, TypeIndex],
RTCommon USING[RepAddrPtr, ShortenLongCardinal],
RTFlags USING[checking, clearing, takingStatistics, useMicrocode],
RTMicrocode USING[ALLOCATEHEAPNODE, LONGZERO],
RTOS USING[MyLocalFrame],
RTQuanta USING[LASTAddress, QuantumSizeMULT, PagesPerQuantum, QuantumCount,
QuantumIndex],
RTRefCounts USING[CreateRef, GCMicrocodeExists, AllocatorTrapStatsRec],
RTStorageAccounting USING[ConsiderCollection, nObjectsCreated, AllocatorCallbackProcForSpy],
RTStorageOps USING[FreeCollectibleObject],
RTTypesBasic USING[Type, InvalidType],
RTTypesBasicPrivate USING[NPackageRefs, MapTiRcmx],
Runs USING[AddInterval],
Runtime USING[CallDebugger],
SafeStorage USING[MemoryExhausted, InvalidSize, GetSystemZone],
SafeStorageExtras USING[permanentZone],
Space USING[Handle, GetHandle, Unmap, Create, Map, PageFromLongPointer, defaultWindow],
SSExtra USING[SizeToZn, maxSizeToZnIndex, useSizeToZn, mediumSizedZone],
-- XXX
UnsafeStorage USING[],
TrapSupport USING[BumpPC, GetTrapParam],
RTZones;

RTPrefAllocImpl: MONITOR -- protects zones
LOCKS zn.LOCK USING zn: PZone
IMPORTS RTBases, RTCommon, RTMicrocode, RTOS, RTQuanta, RTRefCounts,
RTStorageAccounting, RTStorageOps,
RTTypesBasic, RTTypesBasicPrivate, Runs, Runtime, SafeStorage, SafeStorageExtras, Space,
SSExtra, TrapSupport, RTZones

EXPORTS RTRefCounts, RTZones, RTStorageOps, SSExtra
SHARES RTBasic
= BEGIN
OPEN RTBasic, RTMicrocode, RTRefCounts, RTStorageOps, RTTypesBasic, RTTypesBasicPrivate,
SafeStorage, RTZones, RTQuanta;

-- Signals
SuspectPtrSeen: SIGNAL[suspectPtr: Pointer] = CODE; -- hook for debugging
InvalidZone: ERROR[zone: ZONE] = CODE;
SizeTooBig: SIGNAL[size: CARDINAL] = CODE;

-- Global variables and constants

useAllocUCode: BOOLEAN ← RTFlags.useMicrocode AND NOT SSExtra.useSizeToZn; -- XXX
useFreeUCode: BOOLEAN ← RTFlags.useMicrocode;
checking: BOOLEAN = RTFlags.checking;
clearing: BOOLEAN = RTFlags.clearing;
traceAndMarkEnabled: BOOLEAN = FALSE; --NOTE
takingStatistics: BOOLEAN = RTFlags.takingStatistics;
-- "= FALSE" suppresses compilation of statistics code

suspectPtr: Pointer ← NIL; -- for debugging

-- Statistics
Count: TYPE = LONG CARDINAL;
Bump: PROC[p: POINTER TO Count, delta: Count ← 1] = INLINE
BEGIN IF takingStatistics THEN p^ ← p^+delta END;
AllocStatsRec: TYPE = RECORD
[ nAllocateHeapNodeTraps: Count ← 0,
nExpandPrefixedZone: Count ← 0
];
Stats: AllocStatsRec ← []; -- the one and only

PrefixedAllocatorTrapStats: PUBLIC RTRefCounts.AllocatorTrapStatsRec ← [];

-- PUBLIC procedures (i.e. exported)

-- The result will point to the beginning of a subspace (a page boundary)
-- zone must be a prefixed ZONE
-- type must not be RC
-- Pages will all be from the same space
NewCollectibleSubspace: PUBLIC PROC[nPages: CARDINAL, type: Type, zone: ZONE ← NIL]
RETURNS[REF ANY] =
{ IF zone = NIL THEN zone ← zoneSystem;
IF MapTiRcmx[LOOPHOLE[type]] # RCMap.nullIndex
THEN ERROR RTTypesBasic.InvalidType[type];
WITH zn: LOOPHOLE[zone, Zone] SELECT FROM
quantized => ERROR InvalidZone[zone];
prefixed =>
{ size: CARDINAL = nPages*Environment.wordsPerPage + sizeNd;
nQ: QuantumCount ← MapSizeNq[size];
ptr: Pointer ←
ExtendZoneWithSubspace[LOOPHOLE[zone, PPrefixedZone],
size,
nPages,
type,
nQ,
RTBases.GetSubspaceQuanta[nQ]];
IF checking
THEN {IF LOOPHOLE[ptr, LONG CARDINAL] MOD Environment.wordsPerPage # 0
THEN ERROR;
IF ptr = suspectPtr THEN SIGNAL SuspectPtrSeen[suspectPtr]};
IF takingStatistics THEN
{ zn.cellsInService ← zn.cellsInService + size;
zn.overheadCells ← zn.overheadCells + sizeNd;
zn.objectsInService ← zn.objectsInService + 1};

-- TandS: CreateRef OK outside the monitor if it is idempotent and new storage has been cleared

CreateRef[NPackageRefs[type], LOOPHOLE[ptr, REF ANY]];
RTStorageAccounting.nObjectsCreated ← RTStorageAccounting.nObjectsCreated + 1;
IF FALSE --checking
THEN FOR i: CARDINAL IN [0..size)
DO IF (LOOPHOLE[ptr, LONG POINTER TO CARDINAL] + i)^ # 0
THEN ERROR
ENDLOOP;
RTStorageAccounting.ConsiderCollection[size, size];
RETURN[LOOPHOLE[ptr, REF ANY]]};
ENDCASE => ERROR};

ExtendZoneWithSubspace: ENTRY PROC[zn: PPrefixedZone,
size, nPages: CARDINAL,
type: Type,
nQ: QuantumCount,
qNew: QuantumIndex]
RETURNS[ptr: Pointer] =
{ ENABLE UNWIND => NULL;
nPrefixPages: CARDINAL;
fragSize: CARDINAL;
fragSpace, space: Space.Handle;

fragSize ← RTCommon.ShortenLongCardinal[QuantumSizeMULT[nQ] - size];
nPrefixPages ← nQ * PagesPerQuantum - nPages;
ptr ← RTCommon.RepAddrPtr[QuantumSizeMULT[qNew]]; -- ptr to prefix fragment
FOR q: QuantumIndex IN [qNew..qNew + nQ) DO MapQZf[q] ← [prefixed[zn.zi]]; ENDLOOP;
Runs.AddInterval[@zn.runs, qNew, nQ];

space ← Space.GetHandle[Space.PageFromLongPointer[ptr]];
Space.Unmap[space];
fragSpace ← Space.Create[size: nPrefixPages, parent: space, base: 0];
[] ← Space.Create[size: nPages, parent: space, base: nPrefixPages];
Space.Map[fragSpace, Space.defaultWindow];
AddBlock[ptr, fragSize, zn.pfn];
IF clearing THEN [] ← LONGZERO[ptr + fragSize + sizeNd, size - sizeNd];
ptr ← MakeInuseHeapNode[ptr + fragSize, size, type] + sizeNd;
};

NewPrefixedObject: PUBLIC PROC[self: PrefixedZone, size: CARDINAL, type: Type]
RETURNS[ref: REF ANY] =
{ triedAgain: BOOLEAN ← FALSE;

IF RTStorageAccounting.AllocatorCallbackProcForSpy # 0
THEN LOOPHOLE[RTStorageAccounting.AllocatorCallbackProcForSpy, PROC[CARDINAL]][size];

ref ← LOOPHOLE[CreatePrefixedObject[self, size, type]];

-- TandS: CreateRef OK outside the monitor if it is idempotent and new storage has been cleared
CreateRef[NPackageRefs[type], ref];
RTStorageAccounting.nObjectsCreated ← RTStorageAccounting.nObjectsCreated + 1;
IF FALSE --checking
THEN FOR i: CARDINAL IN [0..size)
DO IF (LOOPHOLE[ref, LONG POINTER TO CARDINAL] + i)^ # 0
THEN ERROR
ENDLOOP;

RTStorageAccounting.ConsiderCollection
[size, NodeLength[LOOPHOLE[ref, PNode] - sizeNd]]};

FreePrefixedObject: PUBLIC PROC[self: PrefixedZone, object: REF ANY] =
{FreeCollectibleObject[object]};

NewPrefixedHeapObject: PUBLIC PROC[self: LONG POINTER TO PPrefixedZone, size: CARDINAL]
RETURNS[ptr: LONG POINTER] =
{ triedAgain: BOOLEAN ← FALSE;
ptr ← INLCreatePrefixedUObject[size, self^
! MemoryExhausted => IF NOT triedAgain THEN {triedAgain ← TRUE;RETRY}]};

-- used by ExtendZone
AddBlock: PUBLIC PROC[ptr: Pointer, size: LongNodeSize, pfnPrev: PFreeNode] =
{IF clearing
THEN {WHILE size > LAST[CARDINAL]
DO [] ← LONGZERO[ptr, LAST[CARDINAL]];
size ← size - LAST[CARDINAL];
ENDLOOP;
[] ← LONGZERO[ptr, Inline.LowHalf[size]]};
LinkHeapNode[MakeFreeHeapNode[ptr, size], pfnPrev];
};


-- *** The Prefixed Object Allocator
--********************************************************************************
-- called when the microcode can't handle the allocation
CreatePrefixedObjectTrap: PUBLIC PROC[zn: PPrefixedZone, size: CARDINAL, type: Type]
RETURNS[ptr: Pointer] =
{ state: PrincOps.StateVector;
param: CARDINAL;
state← STATE; -- incantation
param← IF RTRefCounts.GCMicrocodeExists THEN TrapSupport.GetTrapParam[] ELSE 0;

IF param < 2 OR param > 4 THEN useAllocUCode ← FALSE;

IF state.stkptr # 0 THEN Runtime.CallDebugger["CreatePrefixedObjectTrap: stack not empty"];
ptr ← InternalCreatePrefixedObject[zn, size, type];

IF takingStatistics
THEN
SELECT param FROM
0 => Bump[@PrefixedAllocatorTrapStats.NoUCodeTraps];
1 => Bump[@PrefixedAllocatorTrapStats.OldUCodeTraps];
2 => Bump[@PrefixedAllocatorTrapStats.ZoneLockedTraps];
3 => Bump[@PrefixedAllocatorTrapStats.NoBlockFoundTraps];
4 => Bump[@PrefixedAllocatorTrapStats.LongFreeListTraps];
ENDCASE => Bump[@PrefixedAllocatorTrapStats.UnKnownTraps];

TrapSupport.BumpPC[2];
state.dest← LOOPHOLE[RTOS.MyLocalFrame[]];
TRANSFER WITH state; -- incantation
};

AllocateHeapNodeSDTrap: PUBLIC PROC[zn: PPrefixedZone, size: CARDINAL, type: Type]
RETURNS[ptr: Pointer] =
{RETURN[InternalCreatePrefixedObject[zn, size, type]]};

InternalCreatePrefixedObject: PROC[zn: PPrefixedZone, size: CARDINAL, type: Type]
RETURNS[ptr: Pointer] =
{ triedAgain: BOOLEAN;
size ← Inline.BITAND[size+1, 177776B]; -- make even

triedAgain ← FALSE;
WHILE (ptr ← AllocateHeapNode[zn, size, type]) = NIL DO
WITH zn.linkage SELECT FROM
collectible =>
LOOPHOLE[zn.linkage, collectible ZoneLinkage].fullProc[LOOPHOLE[zn], size
! MemoryExhausted => -- try once more in case merger made a big enough block
IF NOT triedAgain THEN {triedAgain ← TRUE; LOOP}
];
heap =>
LOOPHOLE[zn.linkage, heap ZoneLinkage].fullProc[LOOPHOLE[LONG[@zn]], size];
ENDCASE => ERROR;
ENDLOOP};

--****************************************************************************

-- XXX arg is the requested size, not including overhead
QuantizedSize: PUBLIC PROC[size: CARDINAL] RETURNS[CARDINAL] =
{RETURN[INLQuantizedSize[size]]};

-- XXX arg is the requested size, not including overhead. See MapSizeToZn.
INLQuantizedSize: PROC[size: CARDINAL] RETURNS[CARDINAL] =
INLINE
{IF size < SIZE[free NodeHeader]-sizeNd THEN size ← SIZE[free NodeHeader]-sizeNd;
size ← SELECT size FROM
<20B => size,
<40B => ((size-1)/4B + 1)*4B,
<100B => ((size-1)/10B + 1)*10B,
<200B => ((size-1)/20B + 1)*20B,
<400B => ((size-1)/40B + 1)*40B,
<1000B => ((size-1)/100B + 1)*100B,
<2000B => ((size-1)/200B + 1)*200B,
<4000B => ((size-1)/400B + 1)*400B,
ENDCASE => size;
RETURN[size];
};

CreatePrefixedObject: PROC[zn: PrefixedZone, size: CARDINAL, type: Type]
RETURNS[ptr: Pointer] =
INLINE
{ IF checking AND size > MaxClientBlockSize THEN SIGNAL SizeTooBig[size];
size ← Inline.BITAND[size+1, 177776B]; -- make even
IF SSExtra.useSizeToZn
AND SSExtra.SizeToZn # NIL
AND zn # LOOPHOLE[SafeStorageExtras.permanentZone, PrefixedZone]
-- XXX
THEN {size ← INLQuantizedSize[size];
zn ← MapSizeToZn[size];
};

IF useAllocUCode
THEN ptr ← ALLOCATEHEAPNODE[LOOPHOLE[zn], size, type]
ELSE
{ triedAgain: BOOLEAN ← FALSE;
WHILE (ptr ← AllocateHeapNode[LOOPHOLE[zn], size, type]) = NIL
DO LOOPHOLE[zn.linkage, collectible ZoneLinkage].fullProc[LOOPHOLE[zn], size
! MemoryExhausted => -- try once more in case merger made a big enough block
IF NOT triedAgain THEN {triedAgain ← TRUE; LOOP}];
ENDLOOP};
IF checking THEN IF ptr = suspectPtr THEN SIGNAL SuspectPtrSeen[suspectPtr]};

-- XXX
MapSizeToZn: PROC[size: CARDINAL] RETURNS[zn: PrefixedZone] =
INLINE
{ RETURN[IF size <= SSExtra.maxSizeToZnIndex
THEN LOOPHOLE[SSExtra.SizeToZn[size]]
ELSE IF size >= 4000B -- large buffers, e.g. for Tioga
THEN LOOPHOLE[SSExtra.mediumSizedZone]
ELSE LOOPHOLE[SafeStorage.GetSystemZone[]]
];
};

CreatePrefixedTypedUObject: PUBLIC PROC[type: Type, size: CARDINAL, zn: PPrefixedZone]
RETURNS[ptr: Pointer] =
{ size ← Inline.BITAND[size+1, 177776B]; -- make even
IF useAllocUCode
THEN ptr ← ALLOCATEHEAPNODE[LOOPHOLE[zn], size, type]
ELSE
WHILE (ptr ← AllocateHeapNode[zn, size, type]) = NIL DO
LOOPHOLE[zn.linkage, heap ZoneLinkage].fullProc[LOOPHOLE[LONG[@zn]], size];
ENDLOOP;
IF checking THEN IF ptr = suspectPtr THEN SIGNAL SuspectPtrSeen[suspectPtr]};

CreatePrefixedUObject: PUBLIC PROC[size: CARDINAL, zn: PPrefixedZone]
RETURNS[ptr: Pointer] = {RETURN[INLCreatePrefixedUObject[size, zn]]};

INLCreatePrefixedUObject: PROC[size: CARDINAL, zn: PPrefixedZone]
RETURNS[ptr: Pointer] =
INLINE
{ size ← Inline.BITAND[size+1, 177776B]; -- make even
IF useAllocUCode
THEN ptr ← ALLOCATEHEAPNODE[LOOPHOLE[zn], size, nullType]
ELSE
WHILE (ptr ← AllocateHeapNode[zn, size, nullType]) = NIL DO
LOOPHOLE[zn.linkage, heap ZoneLinkage].fullProc[LOOPHOLE[LONG[@zn]], size];
ENDLOOP;
IF checking THEN IF ptr = suspectPtr THEN SIGNAL SuspectPtrSeen[suspectPtr]};

AllocateHeapNode: ENTRY PROC[zn: PZone, s: CARDINAL, type: Type] RETURNS[Pointer] =
BEGIN ENABLE UNWIND => NULL;
size: CARDINAL =
(IF s < SIZE[free NodeHeader]-sizeNd
THEN SIZE[free NodeHeader]
ELSE IF s > (LAST[CARDINAL]-sizeNd) THEN ERROR InvalidSize[s]
ELSE (s+sizeNd));
pfnFirst: PFreeNode ← LOOPHOLE[zn, PPrefixedZone].pfn;
pfn: PFreeNode ← pfnFirst;
length, excess: LongNodeSize;
pType: TypeIndex;
ppzn: PPrefixedZone = LOOPHOLE[zn];

DO
pfnEndpfn: PNode;
IF (length ← NodeLength[pfn]) >= size THEN EXIT;
IF checking AND length = 0 AND pfn # @ppzn.fnd THEN ERROR;

pfnEndpfn ← pfn + length;
IF length > 0 -- 0 indicates the dummy free node header in the zone.
AND LOOPHOLE[pfnEndpfn, LONG CARDINAL] <= LASTAddress
AND MapPtrZf[pfnEndpfn] = [prefixed[zi: zn.zi]]
THEN WITH pfnEnd: pfnEndpfn SELECT FROM
free => -- next guy is free, merge it with pfn
{ newLength: LongNodeSize = length + NodeLength[pfnEndpfn];
IF checking THEN
{IF pfn.pfnNext.pfnPrev # pfn
OR pfn.pfnPrev.pfnNext # pfn
OR pfnEnd.pfnNext.pfnPrev # @pfnEnd
OR pfnEnd.pfnPrev.pfnNext # @pfnEnd
OR length < MinBlockSize
OR NodeLength[@pfnEnd] < MinBlockSize
THEN ERROR};
pfnEnd.pfnNext.pfnPrev ← pfnEnd.pfnPrev;
pfnEnd.pfnPrev.pfnNext ← pfnEnd.pfnNext;
IF @pfnEnd = pfnFirst THEN pfnFirst ← pfn.pfnPrev;
IF RTFlags.clearing -- keep free objects clear
THEN [] ← LONGZERO[pfnEndpfn, SIZE[free NodeHeader]];
pfn.SizeLo ← LOOPHOLE[newLength, MDRLongNodeSize].lnsLo;
pfn.SizeHi ← LOOPHOLE[newLength, MDRLongNodeSize].lnsHi;
ppzn.pfn ← pfn; -- update like ucode does
LOOP};
ENDCASE;
pfn ← pfn.pfnNext;
ppzn.pfn ← pfn; -- update like ucode does
IF pfn = pfnFirst THEN RETURN[NIL] -- no free block large enough
ENDLOOP;

-- Found a large enough free block
pType ← LOOPHOLE[type];
IF checking AND Inline.BITAND[Inline.LowHalf[length], 1] # 0 THEN ERROR; -- debugging
IF (excess ← length-size) >= (IF SSExtra.useSizeToZn THEN size ELSE (4 * MinBlockSize))
-- XXX
THEN -- split the block
{pfn.SizeLo← LOOPHOLE[excess, MDRLongNodeSize].lnsLo;
pfn.SizeHi← LOOPHOLE[excess, MDRLongNodeSize].lnsHi;
pfn← LOOPHOLE[pfn + excess];
LOOPHOLE[pfn, PNode]^← [SizeLo: size, body: inuse[type: pType]]}
ELSE -- remove block from free list without splitting it
{pfn.pfnNext.pfnPrev ← pfn.pfnPrev;
ppzn.pfn ← pfn.pfnPrev.pfnNext ← pfn.pfnNext;
pfn.pfnNext ← pfn.pfnPrev ← NIL;
LOOPHOLE[pfn, PNode].body ← inuse[type: pType]};
RETURN[pfn + sizeNd];
END;

MakeFreeHeapNode: PROC[pnp: PNode, size: LongNodeSize] RETURNS[PFreeNode] =
INLINE
{ LOOPHOLE[pnp, PFreeNode]^←
[ SizeLo: LOOPHOLE[size, MDRLongNodeSize].lnsLo,
body: free[SizeHi: LOOPHOLE[size, MDRLongNodeSize].lnsHi,
pfnPrev: NIL, pfnNext: NIL]
];
RETURN[LOOPHOLE[pnp]]};

MakeInuseHeapNode: PROC[pnp: PNode, size: LongNodeSize, type: Type] RETURNS[PNode] =
INLINE
{ pnp^ ← [ SizeLo: LOOPHOLE[size, MDRLongNodeSize].lnsLo,
body: inuse[type: LOOPHOLE[type]]];
RETURN[LOOPHOLE[pnp]]};


-- *** The Prefixed Object Allocator (end)


-- NOTE copied in RTTraceAndSweepImpl, RTReclaimerImpl
LinkHeapNode: PROC[pfn, pfnPrev: PFreeNode] =
INLINE BEGIN
pfnNext: PFreeNode = pfnPrev.pfnNext;
IF checking THEN IF LOOPHOLE[pfn, Pointer] = suspectPtr THEN SIGNAL SuspectPtrSeen[suspectPtr];
pfn.body ← free[pfnPrev: pfnPrev, pfnNext: pfnNext];
pfnNext.pfnPrev ← pfn;
pfnPrev.pfnNext ← pfn;
END;


-- START HERE

useAllocUCode ← useAllocUCode AND RTRefCounts.GCMicrocodeExists;
useFreeUCode ← useFreeUCode AND RTRefCounts.GCMicrocodeExists;

END.