-- RTAllocatorImpl.Mesa
-- Contains a small number of basic allocator procedures plus the quantized allocator

-- last edited On August 30, 1982 10:33 am by Willie-Sue Haugeland
-- last edited On October 19, 1982 11:06 am by Paul Rovner

DIRECTORY
Inline USING[BITAND],
PrincOps USING[StateVector],
RTBases USING[BaseOverhead],
RTBasic USING[Pointer],
RTCommon USING[RepAddrPtr],
RTFlags USING[checking, clearing, takingStatistics, useMicrocode],
RTOS USING[MyLocalFrame],
RTQuanta USING[QuantumSizeMULT, QuantumIndex, QuantumSize],
RTMicrocode USING[ALLOCATEQUANTIZEDNODE, LONGZERO],
RTRefCounts USING[CreateRef, GCMicrocodeExists, AllocatorTrapStatsRec],
RTStorageAccounting USING[nObjectsCreated, ConsiderCollection],
RTStorageOps USING[FreeCollectibleObject],
RTTypesBasic USING[Type, nullType],
RTTypesBasicPrivate USING[NPackageRefs],
Runtime USING[CallDebugger],
SafeStorage USING[MemoryExhausted, InvalidSize],
TrapSupport USING[BumpPC, GetTrapParam],
UnsafeStorage USING[GetSystemUZone],
RTZones;

RTAllocatorImpl: MONITOR -- protects zones
LOCKS zn.LOCK USING zn: PZone
IMPORTS Inline, RTCommon, RTMicrocode, RTOS, RTQuanta, RTRefCounts,
RTStorageAccounting, RTStorageOps, RTTypesBasicPrivate, Runtime, SafeStorage,
TrapSupport, UnsafeStorage, RTZones

EXPORTS RTRefCounts, RTStorageAccounting, RTStorageOps, UnsafeStorage, RTZones
= BEGIN
OPEN RTMicrocode, RTQuanta, RTRefCounts, RTStorageOps, RTTypesBasic, RTTypesBasicPrivate,
SafeStorage, UnsafeStorage, RTZones;

-- Types
Pointer: TYPE = RTBasic.Pointer;
InsertionOp: TYPE = {normal, rehashing}; -- for arg to MapZnTdSizeSz

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

-- Global variables and constants

useAllocUCode: BOOLEAN ← RTFlags.useMicrocode;
checking: BOOLEAN = RTFlags.checking;
clearing: BOOLEAN = RTFlags.clearing;
takingStatistics: BOOLEAN = RTFlags.takingStatistics;
-- "= FALSE" suppresses compilation of statistics code
suspectPtr: Pointer ← NIL; -- for debugging

AllocatorCallbackProcForSpy: PUBLIC UNSPECIFIED ← 0;

-- Statistics
Count: TYPE = LONG CARDINAL;
Bump: PROC[p: POINTER TO Count, delta: Count ← 1] = INLINE
BEGIN IF takingStatistics THEN p^ ← p^+delta END;

QuantizedAllocatorTrapStats: PUBLIC RTRefCounts.AllocatorTrapStatsRec ← [];

-- PUBLIC procedures (i.e. exported)

NewObject: PUBLIC PROC[type: Type, size: CARDINAL, zone: ZONE ← NIL]
RETURNS[REF ANY] =
{ IF zone = NIL THEN zone ← zoneSystem;
WITH zn: LOOPHOLE[zone, Zone] SELECT FROM
quantized => RETURN[NewQuantizedObject[size: size, self: @zn, type: type]];
prefixed => RETURN[NewPrefixedObject[size: size, self: @zn, type: type]];
ENDCASE => ERROR};

NewQuantizedObject: PUBLIC PROC[self: QuantizedZone, size: CARDINAL, type: Type]
RETURNS[ref: REF ANY] =
{ IF size < SIZE[FreeList]
THEN size ← SIZE[FreeList]
ELSE size ← Inline.BITAND[size+1, 177776B]; -- size even => refs even

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

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

-- TandS: CreateRef OK outside the monitor if it is idempotent and new storage has been cleared
CreateRef[NPackageRefs[type], ref]; -- establish initial refCount of 0
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--no overhead--]};

FreeQuantizedObject: PUBLIC PROC[self: QuantizedZone, object: REF ANY] =
{FreeCollectibleObject[object]};

NewUObject: PUBLIC PROC -- used when NEW won't do, e.g for type-carrying heap objects
[size: CARDINAL,
zone: UNCOUNTED ZONE,
type: Type ← nullType] RETURNS[ptr: LONG POINTER] =
{ WITH zn: LOOPHOLE[zone, LONG POINTER TO PZone]^ SELECT FROM
quantized =>
{ IF size < SIZE[FreeList]
THEN size ← SIZE[FreeList]
ELSE size← Inline.BITAND[size+1, 177776B]; -- size even => refs even
RETURN[CreateQuantizedObject[zn: @zn, size: size, type: type]]};
prefixed =>
{ triedAgain: BOOLEAN ← FALSE;
IF LOOPHOLE[zn.linkage, heap ZoneLinkage].typeRepresentation THEN
ptr ← CreatePrefixedTypedUObject[type, size, @zn
! MemoryExhausted => IF NOT triedAgain THEN {triedAgain ← TRUE;RETRY}]
ELSE
ptr ← CreatePrefixedUObject[size, @zn
! MemoryExhausted => IF NOT triedAgain THEN
{triedAgain ← TRUE;RETRY}]};
ENDCASE => ERROR};

NewQuantizedHeapObject: PUBLIC PROC[self: LONG POINTER TO PQuantizedZone, size: CARDINAL]
RETURNS[LONG POINTER] =
{IF size < SIZE[FreeList]
THEN size ← SIZE[FreeList]
ELSE size← Inline.BITAND[size+1, 177776B]; -- size even => refs even;
RETURN[CreateUQuantizedObject[size, self^]]};

-- ********** special speedy interface for Doug Wyatt
-- NewQuantumNode: PUBLIC PROC[size: CARDINAL, zone: Zone] RETURNS[ptr: Pointer] =
-- { RETURN[CreateQuantizedObject[size, zone]]};
-- { sz: SubZone = MapZnTdSizeSz[LOOPHOLE[zone, QuantumZone], size];
-- WHILE (ptr ← sz.fl) = NIL DO
-- IF NOT AddQuantum[LOOPHOLE[zone, QuantumZone], sz, size] THEN
-- LOOPHOLE[zone, QuantumZone].fullProc[zone, size];
-- ENDLOOP;
-- sz.fl ← LOOPHOLE[ptr, FreeList]^;
-- };

-- FreeQuantumNode: PUBLIC PROC[ptr: Pointer] =
-- { sz: SubZone = MapSziSz[LOOPHOLE[MapPtrZf[ptr], sub MyZone].szi];
-- LOOPHOLE[ptr, FreeList]^ ← sz.fl;
-- sz.fl ← ptr;
-- IF takingStatistics THEN
-- { zn: Zone = MapZiZn[sz.zi];
-- zn.cellsInService ← zn.cellsInService - sz.size;
-- zn.objectsInService ← zn.objectsInService - 1;
-- };
-- };
-- ********** special speedy interface for Doug Wyatt (end)

-- *** The Quantum Object Allocator
-- this procedure gets called when the microcode can't do it
CreateQuantizedObjectTrap: PUBLIC PROC[zn: PQuantizedZone, size: CARDINAL, type: Type]
RETURNS[ptr: Pointer] =
{ state: PrincOps.StateVector;
param: CARDINAL;
state ← STATE; -- incantation

param ← IF useAllocUCode THEN TrapSupport.GetTrapParam[] ELSE 0;

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

IF state.stkptr # 0 THEN Runtime.CallDebugger["CreateQuantizedObjectTrap: stack not empty"];

ptr ← DoCreateQuantizedObject[zn, size, type];

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

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

AllocateQuantizedNodeSDTrap: PUBLIC PROC[zn: PQuantizedZone, size: CARDINAL, type: Type]
RETURNS[ptr: Pointer] = {RETURN[DoCreateQuantizedObject[zn, size, type]]};

-- PRIVATE procedures (i.e. local to this module)

-- OBJECT ALLOCATION
-- *** The Quantum Object Allocator
CreateQuantizedObject: PROC[zn: PQuantizedZone, size: CARDINAL, type: Type ← nullType]
RETURNS[ptr: Pointer] =
INLINE BEGIN
IF useAllocUCode
THEN RETURN[ALLOCATEQUANTIZEDNODE[zn, size, type]]
ELSE RETURN[DoCreateQuantizedObject[zn, size, type]];
END;

DoCreateQuantizedObject: PROC[zn: PQuantizedZone, size: CARDINAL, type: Type ← nullType]
RETURNS[ptr: Pointer] =
INLINE BEGIN
DO
{ WHILE (ptr ← AllocateQuantizedNode[zn, size, type ! NeedASZ => GOTO needASZ]) = NIL DO
WITH zn.linkage SELECT FROM
collectible => fullProc[LOOPHOLE[zn], size];
heap => fullProc[LOOPHOLE[LONG[@zn]], size];
ENDCASE => ERROR;
ENDLOOP;
IF checking THEN IF ptr = suspectPtr THEN SIGNAL SuspectPtrSeen[suspectPtr];
RETURN[ptr];
EXITS
needASZ => --the stack is unwound, and the monitor lock is released
{ newnAsz: CARDINAL = (zn.mAsz*2+1)+1;
newASZ: SubZoneArray ←
DESCRIPTOR[NewUObject[SIZE[SubZoneRec]*newnAsz, GetSystemUZone[]], newnAsz];
p: LONG POINTER ← BASE[ExpandASZ[zn, newASZ, newnAsz]--enter the zone's monitor--];
GetSystemUZone[].FREE[@p];
};
};
ENDLOOP;
END;

CreateUQuantizedObject: PROC[size: CARDINAL, zn: PQuantizedZone] RETURNS[ptr: Pointer] =
INLINE BEGIN
DO
BEGIN
WHILE (ptr ← AllocateUQuantizedNode[zn, size ! NeedASZ => GOTO needASZ]) = NIL DO
LOOPHOLE[zn.linkage, heap ZoneLinkage].fullProc[LOOPHOLE[LONG[@zn]], size];
ENDLOOP;
IF checking THEN IF ptr = suspectPtr THEN SIGNAL SuspectPtrSeen[suspectPtr];
RETURN[ptr];
EXITS
needASZ => --the stack is unwound, and the monitor lock is released
{ newnAsz: CARDINAL = (zn.mAsz*2+1)+1;
newASZ: SubZoneArray ←
DESCRIPTOR[NewUObject[SIZE[SubZoneRec]*newnAsz, GetSystemUZone[]], newnAsz];
p: LONG POINTER ← BASE[ExpandASZ[zn, newASZ, newnAsz]--enter the zone's monitor--];
GetSystemUZone[].FREE[@p];
};
END;
ENDLOOP;
END;

AllocateQuantizedNode: ENTRY PROC[zn: PZone, size: CARDINAL, type: Type ← nullType]
RETURNS[ptr: Pointer] =
{ ENABLE UNWIND => NULL;
sz: SubZone ← MapZnTdSizeSz[LOOPHOLE[zn], size, type];
IF sz.fl = NIL THEN IF NOT AddQuantum[LOOPHOLE[zn], sz, size] THEN RETURN[NIL];
ptr ← sz.fl;
sz.fl ← LOOPHOLE[ptr, FreeList]^;
IF clearing THEN [] ← LONGZERO[ptr, SIZE[FreeList]]; -- the rest of the object should be clear
IF takingStatistics THEN
{ zn.cellsInService ← zn.cellsInService + size;
zn.objectsInService ← zn.objectsInService + 1}};

AllocateUQuantizedNode: ENTRY PROC[zn: PZone, size: CARDINAL]
RETURNS[ptr: Pointer] =
{ ENABLE UNWIND => NULL;
sz: SubZone ← MapZnSizeSz[LOOPHOLE[zn], size];
IF sz.fl = NIL THEN IF NOT AddQuantum[LOOPHOLE[zn], sz, size] THEN RETURN[NIL];
ptr ← sz.fl;
sz.fl ← LOOPHOLE[ptr, FreeList]^;
IF takingStatistics THEN
{ zn.cellsInService ← zn.cellsInService + size;
zn.objectsInService ← zn.objectsInService + 1}};

AddQuantum: INTERNAL PROC
[zn: PQuantizedZone, sz: SubZone, size: CARDINAL] RETURNS[ok: BOOLEAN] =
{ q: QuantumIndex = zn.qNext;
i: QuantumIndex;
overhead: CARDINAL;
base: Pointer;
pFl: LONG POINTER TO FreeList;
IF q = 0 THEN RETURN[FALSE]; -- no quanta left to allocate
IF size + RTBases.BaseOverhead > QuantumSize THEN ERROR SafeStorage.InvalidSize[size];
overhead ← IF q = zn.qFirst THEN RTBases.BaseOverhead ELSE 0;
-- omit overhead at low end of base
IF CARDINAL[q+1] > CARDINAL[zn.qLast] THEN RETURN[FALSE]; -- no quanta left to allocate
zn.qNext ← q + 1;
IF zn.qNext = zn.qLast THEN zn.qNext ← zn.qLast ← 0;
base ← RTCommon.RepAddrPtr[QuantumSizeMULT[q] + overhead];
pFl ← base + ((QuantumSize - overhead)/size - 1) * size;
IF clearing THEN [] ← LONGZERO[base, QuantumSize - overhead];
DO
pFl^ ← sz.fl;
sz.fl ← pFl;
IF pFl = base THEN EXIT;
pFl ← pFl - size;
ENDLOOP;
FOR i IN [q..q + 1) DO MapQZf[i] ← [sub[sz.szi]]; ENDLOOP;
RETURN[TRUE]};

-- GetSZFast: PROC
-- [zn: QuantumZone, size: CARDINAL]
-- RETURNS[sz: SubZone] =
-- INLINE BEGIN
-- asz: SubZoneArray = zn.pAsz;
-- mAsz: CARDINAL = zn.mAsz;
-- i: CARDINAL ← Inline.BITAND[size, mAsz];
-- UNTIL IsSubZoneVacant[sz ← @asz[i]] DO
-- IF sz.size = size THEN RETURN;
-- i ← (IF i = 0 THEN mAsz ELSE i-1);
-- ENDLOOP;
-- IF zn.nAsz < zn.mAsz THEN
-- BEGIN
-- szi: SubZoneIndex = AllocateSzi[];
-- sz^ ← [szi: szi, type: nullType, size: size, zi: zn.zi];
-- MapSziSz[szi] ← sz;
-- zn.nAsz ← zn.nAsz+1;
-- RETURN;
-- END;
-- zn.mAsz ← mAsz*2+1;
-- AllocateAszForQzn[zn];
-- FOR i IN [0..mAsz] DO
-- IF NOT IsSubZoneVacant[@asz[i]] THEN
-- BEGIN
-- sz ← MapZnTdSizeSz[zn, asz[i].size, asz[i].type, rehashing];
-- sz^ ← asz[i];
-- MapSziSz[sz.szi] ← sz;
-- END;
-- ENDLOOP;
-- FreeHeapArray[asz];
-- RETURN[MapZnTdSizeSz[zn, size]];
-- END;

MapZnSizeSz: INTERNAL PROC[zn: PQuantizedZone, size: CARDINAL, insert: InsertionOp ← normal]
RETURNS[sz: SubZone] =
INLINE BEGIN
mAsz: CARDINAL = zn.mAsz;
asz: SubZoneArray = zn.pAsz;
i: CARDINAL ← Inline.BITAND[size, mAsz]; -- hash code
UNTIL IsSubZoneVacant[sz ← @asz[i]] DO -- table can not get full, so this must terminate
IF sz.size = size THEN RETURN;
i ← (IF i = 0 THEN mAsz ELSE i-1);
ENDLOOP;
IF zn.nAsz < zn.mAsz THEN -- not full yet
BEGIN
szi: SubZoneIndex = (IF insert = normal THEN AllocateSzi[] ELSE 0);
sz^ ← [szi: szi, type: nullType, size: size, zi: zn.zi];
IF szi # 0 THEN MapSziSz[szi] ← sz;
zn.nAsz ← zn.nAsz+1;
RETURN;
END
ELSE ERROR NeedASZ;
END;

MapZnTdSizeSz: INTERNAL PROC
[zn: PQuantizedZone, size: CARDINAL, type: Type ← nullType, insert: InsertionOp ← normal]
RETURNS[sz: SubZone] =
INLINE BEGIN
mAsz: CARDINAL = zn.mAsz;
asz: SubZoneArray = zn.pAsz;
i: CARDINAL ← Inline.BITAND[size, mAsz]; -- hash code
UNTIL IsSubZoneVacant[sz ← @asz[i]] DO -- table can not get full, so this must terminate
IF sz.type = type AND sz.size = size THEN RETURN;
i ← (IF i = 0 THEN mAsz ELSE i-1);
ENDLOOP;
IF zn.nAsz < zn.mAsz THEN -- not full yet
BEGIN
szi: SubZoneIndex = (IF insert = normal THEN AllocateSzi[] ELSE 0);
sz^ ← [szi: szi, type: type, size: size, zi: zn.zi];
IF szi # 0 THEN MapSziSz[szi] ← sz;
zn.nAsz ← zn.nAsz+1;
RETURN;
END
ELSE ERROR NeedASZ;
END;

ExpandASZ: ENTRY PROC[zn: PZone, newASZ: SubZoneArray, newnAsz: CARDINAL]
RETURNS[SubZoneArray] =
-- Expand the hash table of subzones for this QuantizedZone
BEGIN ENABLE UNWIND => NULL;
qzn: PQuantizedZone = LOOPHOLE[zn];
mAsz: CARDINAL ← qzn.mAsz;
oldAsz: SubZoneArray ← qzn.pAsz;

IF newnAsz < (mAsz*2+1)+1 THEN RETURN[newASZ]; -- it may have been expanded already
qzn.mAsz ← mAsz*2+1;
FOR j: CARDINAL IN [0..newnAsz) DO
newASZ[j] ← [type: nullType, szi: sziVacant, zi: qzn.zi, fl: NIL, size: 0];
ENDLOOP;
qzn.nAsz ← 0;
qzn.pAsz ← newASZ;

FOR i: CARDINAL IN [0..mAsz] DO -- copy entries from old hash table
IF NOT IsSubZoneVacant[@oldAsz[i]] THEN
{ sz: SubZone ← MapZnTdSizeSz[qzn, oldAsz[i].size, oldAsz[i].type, rehashing ! ANY => ERROR];
sz^ ← oldAsz[i];
MapSziSz[sz.szi] ← sz};
ENDLOOP;
RETURN[oldAsz]; -- for reclamation
END;
-- *** The Quantum Object Allocator (end)

-- start code, for debugging microcode under Pilot

useAllocUCode ← useAllocUCode AND RTRefCounts.GCMicrocodeExists;

END.