TypesBasicImpl.mesa
Copyright © 1984, 1985 by Xerox Corporation. All rights reserved.
Russ Atkinson (RRA) October 29, 1985 11:25:28 am PST
DIRECTORY
AllocatorOps USING [permanentPageZone],
Basics USING [bytesPerWord, BITAND, BITSHIFT, LowHalf],
BrandXSymbolDefs USING [PreDefinedSEI],
BrandYSymbolDefs USING [PreDefinedSEI],
Checksum USING [ComputeChecksum],
RCMap USING [Index],
RCMapOps USING [Initialize],
RTSymbolDefs USING [SymbolIndex, nullSymbolIndex],
RTTypesBasicPrivate USING [FindSTI, InitialSTIRangeSize, LOOPHOLEDRMapStiStd, LOOPHOLEDTMapStiStd, PTypeDesc, RMapTiTd, STDesc, SymbolTableIndex, TMapStiStd, TMapTiTd, TypeDesc, UniqueTypeFinger],
SafeStorage USING [TypeIndex, Type, nullType, anyType, lastPredefinedTypeIndex],
StorageTraps USING [],
TimeStamp USING [Null],
TypeHash USING [TypeKey, nullKey, WordPerKey],
TypeStrings USING [Code, TypeString],
UnsafeStorage USING [GetSystemUZone],
VM USING [AddressForPageNumber, Allocate];
TypesBasicImpl:
MONITOR
IMPORTS AllocatorOps, Basics, Checksum, RTTypesBasicPrivate, RCMapOps, UnsafeStorage, VM
EXPORTS RTTypesBasicPrivate, SafeStorage, StorageTraps, TypeHash
= BEGIN OPEN bx: BrandXSymbolDefs, by: BrandYSymbolDefs, RTSymbolDefs, RTTypesBasicPrivate, RTTypesBasicPrivate, RTTypesBasicPrivate, SafeStorage, TypeHash, TypeStrings;
Types
TypeKey:
TYPE = TypeHash.TypeKey;
nullKey: TypeKey = TypeHash.nullKey;
KeyPtr: TYPE = LONG POINTER TO TypeKey;
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
uz: UNCOUNTED ZONE ← UnsafeStorage.GetSystemUZone[];
lastTypeIndex: TypeIndex ← lastPredefinedTypeIndex;
nullTD: TypeDesc ← [utf: [umid: TimeStamp.Null, seIndex: nullSymbolIndex], symbolAccess: [], myType: nullType, typekey: nullKey];
atomRecType: Type ← nullType;
atomRecString: TypeString ← NIL;
atomRecKey: TypeKey;
TypeMap stuff
MapTiTd: PUBLIC TMapTiTd; -- table: TypeIndex -> PTypeDesc
TMapTsTdl: TYPE = RECORD[SEQUENCE length: CARDINAL OF PTypeDesc];
MapTsTdl:
LONG
POINTER
TO TMapTsTdl;
hash map: TypeStructure -> PTypeDesc
TMapUTFTi: TYPE = RECORD[SEQUENCE length: CARDINAL OF TypeIndex];
MapUTFTi:
LONG
POINTER
TO TMapUTFTi;
hash map: UniqueTypeFinger -> TypeIndex
MapStiStd: PUBLIC TMapStiStd; -- EXTREMELY delicate initialization. WATCH OUT.
ERRORs
InvalidType: 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 [
BOOL] =
TRUSTED {
IF t1 = t2 THEN RETURN [TRUE];
RETURN [GetCanonicalType[t1] = GetCanonicalType[t2]];
};
GetCanonicalType:
PUBLIC
ENTRY
SAFE
PROC [t: Type]
RETURNS [Type] =
TRUSTED {
BEWARE NOTE don't microcode this without changing InternalGetCanonicalReferentType
ENABLE UNWIND => NULL;
RETURN [DoGetCanonicalType[t]];
};
The Atom pkg is ready
NotifyAtomRecType: PUBLIC PROC [type: Type] = { atomRecType ← type};
Use by CedarProbe
GetLastTypeIndex: PUBLIC PROC RETURNS [ans: TypeIndex ← lastTypeIndex] = {};
CheckForNarrowRefFault:
PUBLIC
PROC [ref:
REF, targetType: Type]
RETURNS [
REF ←
NIL] = {
This procedure value goes into SD and used by NARROW
IF ref # NIL THEN ERROR NarrowRefFault[ref: ref, targetType: targetType];
};
GetMapTiTd: PUBLIC PROC RETURNS [ans: LONG POINTER TO RMapTiTd ← MapTiTd] = {};
Enter: PUBLIC ENTRY PROC [inner: PROC] = { ENABLE UNWIND => NULL; inner[]; };
AcquireTypeForLoader:
PUBLIC
ENTRY
PROC [
utf: UniqueTypeFinger,
std: STDesc,
sei: SymbolIndex,
ts: TypeString,
rcmi: RCMap.Index,
canonicalize:
BOOL ←
FALSE,
initializing:
BOOL ←
FALSE]
RETURNS [Type] = {
std identifies original source symbolStamp, bcd and sgi for a symbol seg that contains below sei (entry may be copied and relocated).
ENABLE UNWIND => NULL;
ptd: PTypeDesc;
IF canonicalize THEN ptd ← FindCanonicalPTD[ts] ELSE ptd ← FindPTD[utf, ts];
IF ptd # NIL THEN RETURN [ptd.myType];
RETURN [MakeNewType[utf, std, sei, ts, rcmi, canonicalize, initializing]];
};
FindCanonicalPTD:
PUBLIC
INTERNAL
PROC [ts: TypeString]
RETURNS [ptd: PTypeDesc] = {
tk: TypeKey = TypeStrHash[ts];
IF EqualKey[tk, nullKey] THEN ERROR;
ptd ← FindCanonicalPTDFromKey[tk];
};
***********************************
PRIVATE procedures
***********************************
MakeNewType:
PUBLIC
INTERNAL
PROC [utf: UniqueTypeFinger, std: STDesc, sei: SymbolIndex, ts: TypeString, rcmx: RCMap.Index, canonicalize:
BOOL ←
FALSE, initializing:
BOOL ←
FALSE, type: Type ← nullType]
RETURNS [Type] = {
ptd: PTypeDesc;
tk: TypeKey = TypeStrHash[ts];
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 ← uz.NEW [TypeDesc ← [rcmx: rcmx,
equivalentType: nullType,
utf: utf,
symbolAccess: [sti: sti, sei: sei],
myType: type,
typekey: tk] ];
IF canonicalize
THEN {
ptd.equivalentType ← type;
EnterNewCanonicalType[ptd]}
ELSE ptd.equivalentType ← DoGetCanonicalType[type];
RETURN [type];
};
DoGetCanonicalType:
INTERNAL
PROC [t: Type]
RETURNS [Type] = {
BEWARE NOTE don't microcode this without changing InternalGetCanonicalReferentType
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 ← FindCanonicalPTDFromKey[ptd.typekey];
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 = ptd.typekey[0] MOD InitialTsRangeSize;
ptd.next ← MapTsTdl[probe];
MapTsTdl[probe] ← ptd;
NewTypeIndex:
INTERNAL
PROC [utf: UniqueTypeFinger]
RETURNS [typeIndex: TypeIndex] = {
here if utf is not yet registered
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) > MapUTFTi.length THEN ERROR TooManyTypes;
It would be nice to double the size and chek; get a new hash table; rehash; release old table and try again.
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) > MapUTFTi.length
THEN
ERROR TooManyTypes;
Someday we may extend the table instead of producing an error.
ENDLOOP;
MapUTFTi[utfProbe] ← atomRecType; MapTiTd[LOOPHOLE[atomRecType]].utf ← utf;
};
keep track of the canonical types. The representation is a hash map: TypeStructure -> PTypeDesc
FindCanonicalPTDFromKey:
INTERNAL
PROC [tk: TypeKey]
RETURNS [ptd: PTypeDesc] = {
IF tk = atomRecKey
THEN {
IF atomRecType = nullType THEN ERROR;
ptd ← MapTiTd[atomRecType]}
ELSE ptd ← FindEQVTypeFromKey[tk];
};
FindEQVTypeFromKey:
INTERNAL
PROC [tk: TypeKey]
RETURNS [PTypeDesc] = {
start: CARDINAL ← tk[0] MOD InitialTsRangeSize;
FOR candidate: PTypeDesc ← MapTsTdl[start], candidate.next
UNTIL candidate =
NIL
DO
IF EqualKey[tk, candidate.typekey] THEN RETURN [candidate];
ENDLOOP;
RETURN [NIL];
FindPTD:
PUBLIC
INTERNAL
PROC [utf: UniqueTypeFinger, ts: TypeString ←
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) > MapUTFTi.length THEN ERROR TooManyTypes;
It would be nice to double the size and chek; get a new hash table; rehash; release old table and try again.
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
IsAtomRecTS:
INTERNAL
PROC [ts: TypeString]
RETURNS [
BOOL] = {
RETURN [ts.length = 1 AND ts[0] = LOOPHOLE[TypeStrings.Code[atomRec]]];
};
EqualKey:
PROC [key1, key2: TypeKey]
RETURNS [ans:
BOOL ←
TRUE] = {
FOR i:
CARDINAL
IN [0..WordPerKey)
DO
IF key1[i] # key2[i] THEN RETURN [FALSE];
ENDLOOP;
};
FirstUTFProbe:
INTERNAL
PROC [utf: UniqueTypeFinger]
RETURNS [
CARDINAL] =
INLINE {
RETURN [Basics.
BITAND[
Basics.BITSHIFT[Basics.LowHalf[utf.umid.time] + LOOPHOLE[utf.seIndex, CARDINAL], 2],
MapUTFTi.length-1]];
NextUTFProbe:
INTERNAL
PROC [probe:
CARDINAL]
RETURNS [
CARDINAL] =
INLINE {
RETURN [Basics.BITAND[probe + 1, MapUTFTi.length-1]];
};
Type Hashing (formerly in TypeHashImpl)
KeyAsChars:
TYPE =
PACKED ARRAY [0 .. CharsPerKey)
OF
CHAR;
WordsPerKey: CARDINAL = SIZE[TypeKey];
CharsPerKey: CARDINAL = Basics.bytesPerWord*WordsPerKey;
KeyAsCharsPtr: TYPE = LONG POINTER TO KeyAsChars;
DoubleKey: TYPE = RECORD [key1: TypeKey, key2: TypeKey];
EndBytes: TYPE = PACKED ARRAY [0..Basics.bytesPerWord) OF CHAR;
EndBytesPtr: TYPE = LONG POINTER TO EndBytes;
TypeStrHash:
PUBLIC
PROC [ts: TypeString]
RETURNS [key: TypeKey ← nullKey] = {
TypeStrings is of type LONG STRING.
chars: CARDINAL ← ts.length;
ptr: LONG POINTER TO CARDINAL ← LOOPHOLE[ts+SIZE[StringBody]];
double: DoubleKey ← [nullKey, nullKey];
pos: CARDINAL ← 0;
double.key1[0] ← chars+1;
WHILE chars >= Basics.bytesPerWord
DO
mod: [0..WordsPerKey) ← pos MOD WordsPerKey;
double.key2[mod] ← (ptr+pos)^;
pos ← pos + SIZE[CARDINAL];
double.key1[mod] ← Checksum.ComputeChecksum[pos, WordsPerKey+1, @double.key1[mod]];
chars ← chars - Basics.bytesPerWord;
ENDLOOP;
IF chars # 0
THEN {
endBytesPtr: EndBytesPtr ← LOOPHOLE[ptr+pos];
endBytes: EndBytes ← ALL[0C];
mod: [0..WordsPerKey) ← pos MOD WordsPerKey;
FOR i:
NAT
IN [0..chars)
DO
endBytes[i] ← endBytesPtr[i];
ENDLOOP;
double.key2[mod] ← LOOPHOLE[endBytes];
double.key1[mod] ←
Checksum.ComputeChecksum[pos+1, WordsPerKey+1, @double+(pos MOD WordsPerKey)];
};
key ← double.key1;
IF key[0] = 0
AND key[1] = 0
AND key[2] = 0
AND key[3] = 0
THEN {
Don't ever return a null type key!
key[0] ← chars+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.
← AllocatorOps.permanentPageZone.NEW[LOOPHOLEDRMapStiStd[InitialSTIRangeSize]];
FOR i:
CARDINAL
IN [0..InitialSTIRangeSize)
DO
LOOPHOLE[MapStiStd, LOOPHOLEDTMapStiStd][i] ← NIL;
ENDLOOP;
MapTiTd ← LOOPHOLE[AllocatorOps.permanentPageZone.NEW[RMapTiTd[InitialTiRangeSize]]];
FOR i: CARDINAL IN [0..InitialTiRangeSize) DO MapTiTd[i] ← NIL ENDLOOP;
MapTiTd[nullType] ← @nullTD;
atomRecString ← LOOPHOLE[AllocatorOps.permanentPageZone.NEW[TEXT[1]]];
atomRecString.length ← 1;
atomRecString[0] ← LOOPHOLE[TypeStrings.Code[atomRec]];
atomRecKey ← TypeStrHash[atomRecString];
MapUTFTi ←
LOOPHOLE[AllocatorOps.permanentPageZone.NEW[TMapUTFTi[InitialUTFRangeSize]]];
FOR i: CARDINAL IN [0..InitialUTFRangeSize) DO MapUTFTi[i] ← nullType ENDLOOP;
MapTsTdl ← LOOPHOLE[AllocatorOps.permanentPageZone.NEW[TMapTsTdl[InitialTsRangeSize]]];
FOR i: CARDINAL IN [0..InitialTsRangeSize) DO MapTsTdl[i] ← NIL ENDLOOP;
RCMapOps.Initialize
[
LOOPHOLE
[VM.AddressForPageNumber[VM.Allocate[count: rcMapBasePages, in64K: TRUE].page]],
rcMapBasePages
];
END.
CHANGE
LOG
Changed by Koo on June 28, 1984 3:45:57 pm PDT:
Changes are done throughout to reflect the change of the definition of TypeDesc in RTTypesBasicPrivate. One significant change is when canonicalization is performed; now it is done when a new type is entered into MapTiTd.