[Ivy]<Trinity>SafeStorage>RTTypesBasicImpl.mesa!2

-- RTTypesBasicImpl.mesa
-- Last Modified On December 21, 1982 8:55 am by Paul Rovner

DIRECTORY
Environment USING[wordsPerPage],
Inline,
LongString USING[EqualStrings, AppendString],
RCMap USING[Index],
RCMapOps USING[Initialize],
RTBasic USING[TypeIndex],
RTOS USING[GetPermanentDataPages, PrivateHeapZone, PermanentPageZone],
RTSymbols USING[SymbolIndex, nullSymbolIndex],
RTTypesBasicPrivate USING[TypeDesc, TMapTiTd, PTypeDesc, FindSTI,
TypeStructure, UniqueTypeFinger, RMapTiTd,
STDesc, PreDefinedSEI, MapStiStd,
SymbolTableIndex],
RTTypesBasic USING[Type, nullType, anyType],
SafeStorage USING[], -- EXPORTS only
TimeStamp USING[Null],
TypeStrings USING[Code];

RTTypesBasicImpl: MONITOR -- protects data structures for runtime types
IMPORTS Inline, LongString, RCMapOps, RTOS, RTTypesBasicPrivate
EXPORTS RTTypesBasic, RTTypesBasicPrivate, SafeStorage
SHARES RTTypesBasic

= BEGIN OPEN RTBasic, RTSymbols, RTTypesBasic, RTTypesBasicPrivate;

-- 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 = 20;

-- Variables --
lastTypeIndex: TypeIndex ← 6;
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

-- 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] = {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]
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]]};

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

--PRIVATE procedures

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

CopyString: PROC[s: LONG STRING] RETURNS[ns: LONG STRING] =
{ ns ← LOOPHOLE[RTOS.PrivateHeapZone.NEW[TEXT[s.length]]];
LongString.AppendString[to: ns, from: s]};

MakeNewType: PUBLIC INTERNAL PROC[utf: UniqueTypeFinger,
std: STDesc,
sei: SymbolIndex,
ts: TypeStructure,
rcmx: RCMap.Index,
canonicalize: BOOLEAN ← FALSE,
type: Type ← nullType]
RETURNS[Type] =
{ ptd: PTypeDesc;
sti: SymbolTableIndex;
IF type = nullType THEN type ← [NewTypeIndex[utf]];
sti ← IF LOOPHOLE[sei, CARDINAL] IN PreDefinedSEI
AND MapStiStd[1] # NIL
THEN 1
ELSE FindSTI[std];
MapTiTd[type] ← ptd ← RTOS.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]};

-- 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[LongString.EqualStrings[ts1, ts2]]};

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

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

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

NextUTFProbe: INTERNAL PROC[probe: CARDINAL] RETURNS[CARDINAL] = INLINE
{RETURN[Inline.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

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

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

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

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

END.