-- RTPrefAllocImpl.Mesa
-- last edited On August 30, 1982 10:34 am by Willie-Sue Haugeland
-- last edited On June 27, 1983 2:47 pm by Paul Rovner
-- Last Edited by: Levin, August 8, 1983 5:28 pm

DIRECTORY
Basics USING[BITAND],
DebuggerSwap USING[CallDebugger],
PrincOps USING[StateVector],
PrincOpsUtils USING[ZERO, BITAND, MyLocalFrame],
RTFlags USING[checking, clearing, takingStatistics, useMicrocode],
RTMicrocode USING[ALLOCATEHEAPNODE],
RTQuanta USING[LASTAddress],
RTRefCounts USING[CreateRef, GCMicrocodeExists],
RTStorageAccounting USING[ConsiderCollection, nObjectsCreated],
RTTypesBasicPrivate USING[NumberPackageRefs, FreeCollectibleObject],
SafeStoragePrivate USING[],
SSTraps USING[],
SafeStorage USING
[GetCanonicalType, MemoryExhausted, GetSystemZone, nullType, TypeIndex,
Type, GetPermanentZone],
UnsafeStorage USING[],
TrapSupport USING[BumpPC, GetTrapParam],
RTZones;

RTPrefAllocImpl: MONITOR -- protects zones
LOCKS zn.LOCK USING zn: PZone
IMPORTS Basics, DebuggerSwap, PrincOpsUtils, RTMicrocode, RTQuanta, RTRefCounts,
RTStorageAccounting, RTTypesBasicPrivate, RTZones, SafeStorage,
TrapSupport

EXPORTS RTZones, SafeStoragePrivate, SSTraps, UnsafeStorage
= BEGIN
OPEN RTMicrocode, RTRefCounts, RTTypesBasicPrivate, RTZones, SafeStorage, SafeStoragePrivate;

-- Signals
SuspectPtrSeen: SIGNAL[suspectPtr: LONG 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 useSizeToZn; -- XXX
useFreeUCode: BOOLEAN ← RTFlags.useMicrocode;
checking: BOOLEAN = RTFlags.checking;
clearing: BOOLEAN = RTFlags.clearing;
traceAndMarkEnabled: BOOLEAN = FALSE; --NOTE
-- "= FALSE" suppresses compilation of statistics code

suspectPtr: LONG POINTER ← NIL; -- for debugging

permanentZone: ZONE ← GetPermanentZone[];

-- Statistics
Bump: PROC[p: POINTER TO INT, delta: INT ← 1] = INLINE
BEGIN IF RTFlags.takingStatistics THEN p^ ← p^+delta END;

stats: RECORD
[ nNewUObjectCalls: INT ← 0,
nNewUObjectWords: INT ← 0,
nCreatePrefixedUObjectCalls: INT ← 0,
nCreatePrefixedUObjectWords: INT ← 0
];

-- PUBLIC procedures (i.e. exported)

NewObject: PUBLIC PROC[type: Type, size: CARDINAL, zone: ZONE ← NIL]
RETURNS[REF ANY] =
{ IF zone = NIL THEN zone ← zoneSystem;
IF useSizeToZn THEN type ← GetCanonicalType[type]; -- XXX
RETURN[LOOPHOLE[LOOPHOLE[zone, Zone].new,
PROC[self: ZONE, size: CARDINAL, type: Type] RETURNS[REF ANY]
][self: zone, size: size, type: type]];
};

NewUObject: PUBLIC PROC -- used when NEW won't do, e.g for type-carrying heap objects
[size: CARDINAL,
zone: UNCOUNTED ZONE] RETURNS[ptr: LONG POINTER] =
{ Bump[@stats.nNewUObjectCalls];
Bump[@stats.nNewUObjectWords, size];
WITH zn: LOOPHOLE[zone, LONG POINTER TO PZone]^ SELECT FROM
quantized => ERROR;
prefixed =>
{ triedAgain: BOOLEAN ← FALSE;
IF LOOPHOLE[zn.linkage, heap ZoneLinkage].typeRepresentation THEN ERROR
ELSE
ptr ← CreatePrefixedUObject[size, @zn
! MemoryExhausted => IF NOT triedAgain THEN {triedAgain ← TRUE;RETRY}]};
ENDCASE => ERROR};

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]];
IF checking AND LOOPHOLE[ref, LONG CARDINAL] > RTQuanta.LASTAddress THEN ERROR;

-- TandS: CreateRef OK outside the monitor if it is idempotent and new storage has been cleared
CreateRef[NumberPackageRefs[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: LONG POINTER, size: LongNodeSize, pfnPrev: PFreeNode] =
{IF clearing
THEN {WHILE size > LAST[CARDINAL]
DO [] ← PrincOpsUtils.ZERO[ptr, LAST[CARDINAL]];
size ← size - LAST[CARDINAL];
ENDLOOP;
[] ← PrincOpsUtils.ZERO[ptr, size]};
IF checking AND LOOPHOLE[ptr, LONG CARDINAL] > RTQuanta.LASTAddress THEN ERROR;
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: LONG 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 DebuggerSwap.CallDebugger["CreatePrefixedObjectTrap: stack not empty"];
ptr ← InternalCreatePrefixedObject[zn, size, type];

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

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

InternalCreatePrefixedObject: PROC[zn: PPrefixedZone, size: CARDINAL, type: Type]
RETURNS[ptr: LONG POINTER] =
{ triedAgain: BOOLEAN;
size ← PrincOpsUtils.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: LONG POINTER] =
INLINE
{ IF checking AND size > MaxClientBlockSize THEN SIGNAL SizeTooBig[size];
size ← PrincOpsUtils.BITAND[size+1, 177776B]; -- make even
IF useSizeToZn
AND SizeToZn # NIL
AND zn # LOOPHOLE[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 <= maxSizeToZnIndex
THEN LOOPHOLE[SizeToZn[size]]
ELSE IF size >= 4000B -- large buffers, e.g. for Tioga
THEN LOOPHOLE[mediumSizedZone]
ELSE LOOPHOLE[SafeStorage.GetSystemZone[]]
];
};

CreatePrefixedTypedUObject: PUBLIC PROC[type: Type, size: CARDINAL, zn: PPrefixedZone]
RETURNS[ptr: LONG POINTER] =
{ size ← PrincOpsUtils.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: LONG POINTER] = {
RETURN[INLCreatePrefixedUObject[size, zn]];
};

INLCreatePrefixedUObject: PROC[size: CARDINAL, zn: PPrefixedZone]
RETURNS[ptr: LONG POINTER] =
INLINE
{ Bump[@stats.nCreatePrefixedUObjectCalls];
Bump[@stats.nCreatePrefixedUObjectWords, size];
size ← PrincOpsUtils.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[LONG 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
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] <= RTQuanta.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 [] ← PrincOpsUtils.ZERO[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 Basics.BITAND[length, 1] # 0 THEN ERROR; -- debugging
IF (excess ← length-size) >= (IF 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, LONG 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.