-- RTTypesBasicImpl.mesa
-- Last Modified On June 27, 1983 2:20 pm by Paul Rovner
-- Last Edited by: Levin, September 20, 1983 3:34 pm

DIRECTORY
Basics USING[BITAND, BITSHIFT, LongNumber],
BrandXSymbolDefs USING[PreDefinedSEI],
BrandYSymbolDefs USING[PreDefinedSEI],
PrincOps USING[wordsPerPage],
RCMap USING[Index],
RCMapOps USING[Initialize],
RTFlags USING[takingStatistics],
RTSymbolDefs USING[SymbolIndex, nullSymbolIndex],
RTTypesBasicPrivate USING
[TypeDesc, TMapTiTd, PTypeDesc, FindSTI,
TypeStructure, UniqueTypeFinger, RMapTiTd,
STDesc, TMapStiStd, SymbolTableIndex, LOOPHOLEDTMapStiStd,
LOOPHOLEDRMapStiStd, InitialSTIRangeSize],
SafeStorage USING[TypeIndex, Type, nullType, anyType, lastPredefinedTypeIndex],
SafeStoragePrivate USING[GetPermanentDataPages, PrivateHeapZone, PermanentPageZone],
SSTraps USING[],
TimeStamp USING[Null],
TypeStrings USING[Code];

RTTypesBasicImpl: MONITOR -- protects data structures for runtime types
IMPORTS Basics, RCMapOps, RTTypesBasicPrivate, SafeStoragePrivate
EXPORTS RTTypesBasicPrivate, SafeStorage, SSTraps

= BEGIN OPEN bx: BrandXSymbolDefs, by: BrandYSymbolDefs, RTSymbolDefs,
RTTypesBasicPrivate, SafeStorage, SafeStoragePrivate;

-- Statistics

stats: RECORD[

Bump: PROC[p: POINTER TO INT, delta: INT ← 1] =

INLINE {IF RTFlags.takingStatistics THEN p^ ← p^+delta};

-- Constants --
InitialTiRangeSize: CARDINAL = 10000B; -- a power of 2, divisible by PageSize (for MapTiTd)
InitialUTFRangeSize: CARDINAL = 10000B; -- a power of 2, divisible by PageSize (for MapUTFTi)
InitialTsRangeSize: CARDINAL = 4000B; -- a power of 2, divisible by PageSize (for MapTsTdl)
rcMapBasePages: CARDINAL = 30;

-- Variables --
lastTypeIndex: TypeIndex ← lastPredefinedTypeIndex;
nullTD: TypeDesc ← [utf: [umid: TimeStamp.Null, seIndex: nullSymbolIndex], symbolAccess: [], myType: nullType, typeStructure: ""];
atomRecType: Type ← nullType;

MapTiTd: PUBLIC TMapTiTd; -- table: TypeIndex -> PTypeDesc
MapTsTdl: LONG DESCRIPTOR FOR ARRAY OF PTypeDesc;
-- hash map: TypeStructure -> PTypeDesc
MapUTFTi: LONG DESCRIPTOR FOR ARRAY OF TypeIndex;
-- hash map: UniqueTypeFinger -> TypeIndex

MapStiStd: PUBLIC TMapStiStd; -- EXTREMELY delicate initialization. WATCH OUT.

-- ERRORs
InvalidType: PUBLIC ERROR[type: Type] = CODE;
CantEstablishFinalization: PUBLIC ERROR [type: Type] = CODE;
NarrowFault: PUBLIC ERROR = CODE;
NarrowRefFault: PUBLIC ERROR[ref: REF ANY, targetType: Type] = CODE;
TooManyTypes: ERROR = CODE;


--PUBLIC procedures


EquivalentTypes: PUBLIC SAFE PROC[t1, t2: Type] RETURNS[BOOLEAN] =
TRUSTED { IF t1 = t2 THEN RETURN[TRUE];
t1 ← GetCanonicalType[t1]; t2 ← GetCanonicalType[t2];
RETURN[t1 = t2]};

-- BEWARE NOTE don't microcode this without changing InternalGetCanonicalReferentType
GetCanonicalType: PUBLIC ENTRY SAFE PROC[t: Type] RETURNS[Type] =
TRUSTED {ENABLE UNWIND => NULL; RETURN[DoGetCanonicalType[t]]};

NotifyAtomRecType: PUBLIC PROC[type: Type] = -- the Atom pkg is ready
{atomRecType ← type};

GetLastTypeIndex: PUBLIC PROC RETURNS[TypeIndex] = -- for use by CedarProbe
{RETURN[lastTypeIndex]};

-- this procedure value goes into SD
CheckForNarrowRefFault: PUBLIC PROC[ref: REF ANY, targetType: Type] RETURNS[REF ANY] = -- used by NARROW
{IF ref = NIL THEN RETURN[NIL] ELSE ERROR NarrowRefFault[ref: ref, targetType: targetType]};

GetMapTiTd: PUBLIC PROC RETURNS [LONG POINTER TO RMapTiTd] = {RETURN[MapTiTd]};

Enter: PUBLIC ENTRY PROC[inner: PROC] = {ENABLE UNWIND => NULL; inner[]};

AcquireTypeForLoader: PUBLIC ENTRY PROC
[utf: UniqueTypeFinger,
std: STDesc,
-- std identifies original source symbolStamp,
-- bcd and sgi for a symbol seg that contains
-- below sei (entry may be copied and relocated).
sei: SymbolIndex,
ts: TypeStructure,
rcmi: RCMap.Index,
canonicalize: BOOLEAN ← FALSE,
initializing: BOOL ← FALSE]
RETURNS[Type] =
{ ENABLE UNWIND => NULL;
ptd: PTypeDesc;
IF canonicalize
THEN ptd ← FindCanonicalPTD[ts]
ELSE ptd ← FindPTD[utf, ts];
RETURN[IF ptd # NIL
THEN ptd.myType
ELSE MakeNewType[utf, std, sei, CopyString[ts], rcmi, canonicalize, initializing]]};

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

--PRIVATE procedures

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

CopyString: PROC[s: LONG STRING] RETURNS[ns: LONG STRING] =
{ ns ← LOOPHOLE[PrivateHeapZone.NEW[TEXT[s.length]]];
Bump[@stats.nNewTypes];
Bump[@stats.nTSWords, (s.length + 1)/2];
AppendString[to: ns, from: s]};

AppendString: PROC [to: LONG STRING, from: LONG STRING] = {
i, j, n: CARDINAL;
IF to = NIL OR from = NIL THEN RETURN;
IF from.length + to.length > to.maxlength THEN ERROR;
n ← MIN[from.length, LOOPHOLE[to.maxlength - to.length, CARDINAL]];
i ← to.length;
j ← 0;
WHILE j < n DO to[i] ← from[j]; i ← i + 1; j ← j + 1; ENDLOOP;
to.length ← i;
};

EqualStrings: PROC[s1, s2: LONG STRING] RETURNS [ans: BOOL ← TRUE] = {
IF s1 = NIL AND s2 = NIL THEN RETURN[TRUE];
IF s1 = NIL OR s2 = NIL OR s1.length # s2.length THEN RETURN[FALSE];
FOR i: CARDINAL IN [0..s1.length) DO IF s1[i] # s2[i] THEN RETURN[FALSE]; ENDLOOP;
};

MakeNewType: PUBLIC INTERNAL PROC[utf: UniqueTypeFinger,
std: STDesc,
sei: SymbolIndex,
ts: TypeStructure,
rcmx: RCMap.Index,
canonicalize: BOOLEAN ← FALSE,
initializing: BOOLEAN ← FALSE,
type: Type ← nullType]
RETURNS[Type] =
{ ptd: PTypeDesc;
sti: SymbolTableIndex;
IF type = nullType THEN type ← [NewTypeIndex[utf]];
sti ← IF (WITH sei SELECT FROM
t: SymbolIndex.x => LOOPHOLE[t.e, CARDINAL] IN bx.PreDefinedSEI,
t: SymbolIndex.y => LOOPHOLE[t.e, CARDINAL] IN by.PreDefinedSEI,
ENDCASE => ERROR)
AND MapStiStd[1] # NIL
THEN 1
ELSE FindSTI[std, initializing];
MapTiTd[type] ← ptd ← PrivateHeapZone.NEW
[TypeDesc ← [rcmx: rcmx,
utf: utf,
symbolAccess: [sti: sti, sei: sei],
myType: type,
typeStructure: ts]];
IF canonicalize
THEN {ptd.equivalentType ← type; EnterNewCanonicalType[ptd]};
RETURN[type]};

-- BEWARE NOTE don't microcode this without changing InternalGetCanonicalReferentType
DoGetCanonicalType: INTERNAL PROC[t: Type] RETURNS[Type] =
{ cptd, ptd: PTypeDesc;

IF t <= anyType THEN RETURN[t];
ptd ← MapTiTd[t];
IF ptd.equivalentType # nullType THEN RETURN[ptd.equivalentType];

-- here to "canonicalize" t
cptd ← FindCanonicalPTD[ptd.typeStructure];
IF cptd = NIL
THEN { ptd.equivalentType ← t;
EnterNewCanonicalType[ptd];
RETURN[t]}
ELSE { ptd.equivalentType ← cptd.equivalentType;
ptd.extension ← cptd.extension; -- there can't be one already
-- t would have been canonicalized
RETURN[ptd.equivalentType]}};


EnterNewCanonicalType: INTERNAL PROC[ptd: PTypeDesc] =
{ probe: CARDINAL = TsHash[ptd.typeStructure];
ptd.next ← MapTsTdl[probe];
MapTsTdl[probe] ← ptd};

-- here if utf is not yet registered
NewTypeIndex: INTERNAL PROC[utf: UniqueTypeFinger] RETURNS[typeIndex: TypeIndex] =
{ utfProbe: CARDINAL;
nLooks: CARDINAL ← 0;
lastTypeIndex ← (typeIndex ← lastTypeIndex + 1);
IF lastTypeIndex = InitialTiRangeSize OR lastTypeIndex = LAST[TypeIndex]
THEN ERROR TooManyTypes;

FOR utfProbe ← FirstUTFProbe[utf] , NextUTFProbe[utfProbe]
UNTIL MapUTFTi[utfProbe] = nullType DO
IF (nLooks ← nLooks + 1) > LENGTH[MapUTFTi] THEN
-- { double the size and chek
-- Get a new hash table.
-- rehash.
-- release old table.
-- try again
-- }
ERROR TooManyTypes; -- hash table is full
ENDLOOP;
MapUTFTi[utfProbe] ← typeIndex};

EstablishAtomRecUTF: INTERNAL PROC[utf: UniqueTypeFinger] =
{ utfProbe: CARDINAL;
nLooks: CARDINAL ← 0;

FOR utfProbe ← FirstUTFProbe[utf] , NextUTFProbe[utfProbe]
UNTIL MapUTFTi[utfProbe] = nullType DO
IF (nLooks ← nLooks + 1) > LENGTH[MapUTFTi] THEN
-- { double the size and chek
-- Get a new hash table.
-- rehash.
-- release old table.
-- try again
-- }
ERROR TooManyTypes; -- hash table is full
ENDLOOP;
MapUTFTi[utfProbe] ← atomRecType; MapTiTd[LOOPHOLE[atomRecType]].utf ← utf};

-- keep track of the canonical types. The representation is a hash map: TypeStructure -> PTypeDesc

FindCanonicalPTD: PUBLIC INTERNAL PROC[ts: TypeStructure]
RETURNS[ptd: PTypeDesc] =
{ IF IsAtomRecTS[ts]
THEN {IF atomRecType = nullType THEN ERROR; ptd ← MapTiTd[atomRecType]}
ELSE {ptd ← FindEQVType[ts]}};

FindEQVType: INTERNAL PROC[ts: TypeStructure] RETURNS[PTypeDesc] =
{ FOR candidate: PTypeDesc ← MapTsTdl[TsHash[ts]], candidate.next UNTIL candidate = NIL
DO IF EqualTS[ts, candidate.typeStructure] THEN RETURN[candidate] ENDLOOP;
RETURN[NIL]};


FindPTD: PUBLIC INTERNAL PROC[utf: UniqueTypeFinger, ts: TypeStructure ← NIL]
RETURNS[ptd: PTypeDesc] =
{ utfProbe: CARDINAL;
nLooks: CARDINAL ← 0;

FOR typeIndex: TypeIndex ← MapUTFTi[utfProbe ← FirstUTFProbe[utf]]
, MapUTFTi[utfProbe ← NextUTFProbe[utfProbe]]
UNTIL Type[typeIndex] = nullType DO
IF MapTiTd[typeIndex].utf = utf THEN RETURN[MapTiTd[typeIndex]];
IF (nLooks ← nLooks + 1) > LENGTH[MapUTFTi] THEN
-- { double the size and chek
-- Get a new hash table.
-- rehash.
-- release old table.
-- try again
-- }
ERROR TooManyTypes; -- hash table is full
ENDLOOP;
IF ts # NIL AND IsAtomRecTS[ts]
THEN {IF atomRecType = nullType THEN ERROR;
EstablishAtomRecUTF[utf];
RETURN[MapTiTd[atomRecType]]}
ELSE RETURN[NIL]}; -- end FindPTD

-- stolen from TexHash.mesa
TsHash: INTERNAL PROC[ts: TypeStructure] RETURNS[CARDINAL] = INLINE
{ acc: CARDINAL ← 0;
FOR i: CARDINAL IN [0..MIN[7, ts.length])
DO acc ← 7*acc+LOOPHOLE[ts[i], CARDINAL] ENDLOOP;
RETURN[acc MOD InitialTsRangeSize]};

EqualTS: INTERNAL PROC[ts1, ts2: TypeStructure]
RETURNS[ans: BOOLEAN ← TRUE] = INLINE
{RETURN[EqualStrings[ts1, ts2]]};

IsAtomRecTS: INTERNAL PROC[ts: TypeStructure] RETURNS[BOOLEAN] = INLINE
{RETURN[ts.length = 1 AND ts[0] = LOOPHOLE[TypeStrings.Code[atomRec]]]};

FirstUTFProbe: INTERNAL PROC[utf: UniqueTypeFinger] RETURNS[CARDINAL] = INLINE
{RETURN
[Basics.BITAND[
Basics.BITSHIFT[LOOPHOLE[utf.umid.time, Basics.LongNumber].lowbits + LOOPHOLE[utf.seIndex, CARDINAL], 2],
LENGTH[MapUTFTi] - 1]]};

NextUTFProbe: INTERNAL PROC[probe: CARDINAL] RETURNS[CARDINAL] = INLINE
{RETURN[Basics.BITAND[probe + 1, LENGTH[MapUTFTi] - 1]]};


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



-- M O D U L E I N I T I A L I Z A T I O N S T A R T S H E R E

LOOPHOLE[MapStiStd, LOOPHOLEDTMapStiStd] -- until the sun comes up.
← PermanentPageZone.NEW[LOOPHOLEDRMapStiStd[InitialSTIRangeSize]];
FOR i: CARDINAL IN [0..InitialSTIRangeSize)
DO LOOPHOLE[MapStiStd, LOOPHOLEDTMapStiStd][i] ← NIL ENDLOOP;

MapTiTd ← LOOPHOLE[PermanentPageZone.NEW[RMapTiTd[InitialTiRangeSize]]];
FOR i: CARDINAL IN [0..InitialTiRangeSize) DO MapTiTd[i] ← NIL ENDLOOP;
MapTiTd[nullType] ← @nullTD;

MapUTFTi ←
DESCRIPTOR[GetPermanentDataPages
[InitialUTFRangeSize * SIZE[TypeIndex]/PrincOps.wordsPerPage],
InitialUTFRangeSize];
FOR i: CARDINAL IN [0..InitialUTFRangeSize) DO MapUTFTi[i] ← nullType; ENDLOOP;

MapTsTdl ←
DESCRIPTOR[GetPermanentDataPages
[InitialTsRangeSize * SIZE[PTypeDesc]/PrincOps.wordsPerPage],
InitialTsRangeSize];
FOR i: CARDINAL IN [0..InitialTsRangeSize) DO MapTsTdl[i] ← NIL ENDLOOP;

RCMapOps.Initialize[LOOPHOLE[GetPermanentDataPages[rcMapBasePages]],
rcMapBasePages];

END.