-- SafeStorageOpsImpl.Mesa
 -- Last Modified On June 27, 1983 11:30 am by Paul Rovner

DIRECTORY
AllocatorOps USING[NewObject, Initialize],
AtomPrivate USING[UnsafeMakeAtom],
BasicLoadState USING
[ConfigID, ModuleToGlobalFrame, ConfigInfo, GlobalFrameToType, SetType,
EnumerateConfigs, GlobalFrameToModule, TypeCode],
BcdDefs USING
[VersionStamp, MTIndex, SGIndex, RFNull, RFIndex, TFNull, TFIndex, FTSelf,
BcdBase, MTHandle, ModuleIndex],
BcdOps USING[ProcessModules],
MPCodes USING[storageInitialized],
PrincOps USING[GlobalFrameHandle, wordsPerPage],
PrincOpsUtils USING[LongCOPY],
ProcessorFace USING[SetMP],
RCMap USING[Index, Base, invalidIndex],
RCMapOps USING[Include, MapMap, FindMapMapEntry],
RTBcd USING[AnyStamp, RTBase, StampList, TypeList, VersionID, TypeItem, RefLitItem],
RTSymbolDefs USING[nullXSymbolIndex],
RTTypesBasicPrivate USING [UniqueTypeFinger, BlessMapStiStd, AcquireTypeForLoader, NotifyAtomRecType],
SafeStorage USING[GetPermanentZone, Type, nullType, TypeIndex],
SafeStorageOps USING[],
Table USING[Base],
TimeStamp USING[Null, Stamp],
TypeStrings USING[Code, TypeString],
UnsafeStorage USING[GetSystemUZone];

SafeStorageOpsImpl: PROGRAM
IMPORTS AllocatorOps, AtomPrivate, BasicLoadState, BcdOps, PrincOpsUtils, ProcessorFace, RCMapOps, RTTypesBasicPrivate, SafeStorage, UnsafeStorage
EXPORTS SafeStorageOps

= BEGIN OPEN AtomPrivate, BcdDefs, RTBcd, SafeStorage;

RTBcdVersionMismatch: ERROR = CODE;

uz: UNCOUNTED ZONE = UnsafeStorage.GetSystemUZone[];

configID: BasicLoadState.ConfigID
= BasicLoadState.GlobalFrameToModule[LOOPHOLE[SafeStorageOpsImpl]].config;
bcd: BcdDefs.BcdBase = BasicLoadState.ConfigInfo[configID].bcd;

atomType: Type ← nullType; -- the concrete type code for ATOM referents

TypeTable: TYPE = RECORD[SEQUENCE length: NAT OF Type];

-- stuff used during CedarRuntime initialization
ptt: LONG POINTER TO TypeTable ← NIL;
rcMapMap: RCMapOps.MapMap ← NIL;
-- communication between AcquireBasicTypes and AcquireBasicLiterals

atomTypeChain: POINTER TO Type ← NIL; -- NOTE assume TypeTable entry in gf is 1 word
 -- this threads thru ATOM referent types in global frame type tables until atomType is known

GetGFRCType: PUBLIC PROC[gfh: PrincOps.GlobalFrameHandle] RETURNS[Type] =
{RETURN[LOOPHOLE[BasicLoadState.GlobalFrameToType[gfh], Type]]};

-- called by the Mesa runtime loader or the Cedar modeller after loading a bcd
 -- this initializes the type table and REF literal table in each new global frame.
AcquireTypesAndLiterals: PUBLIC PROC[
bcd: BcdDefs.BcdBase,
moduleToGFH: PROC[BcdDefs.ModuleIndex] RETURNS[PrincOps.GlobalFrameHandle],
setType: PROC[PrincOps.GlobalFrameHandle, SafeStorage.Type]] = {
-- fill in the master tables (types, collectible literals) for the BCD.
 -- Then, foreach MT entry, fix up its type table and collectible literal table
 -- in the corresponding GF.
 rtBase: RTBcd.RTBase;
rfBase, tfBase: Table.Base;
l: NAT;
ptrTypeTable: LONG POINTER TO TypeTable ← NIL;
RefLitTable: TYPE = RECORD[SEQUENCE length: NAT OF REF ANY];
rrlt: REF RefLitTable ← NIL;
rcmm: RCMapOps.MapMap ← NIL;

-- foreach module in this bcd...
 doModule: PROC[mth: BcdDefs.MTHandle, mti: BcdDefs.MTIndex]
RETURNS[stop: BOOLEAN ← FALSE] =
{ gfh: PrincOps.GlobalFrameHandle = moduleToGFH[mth.gfi];
WITH mth: mth SELECT FROM
multiple =>
{ IF mth.refLiterals # RFNull
THEN {rl: RFIndex = mth.refLiterals;
gfRefLiteralTable: LONG POINTER ← LONG[gfh+rfBase[rl].offset];
FOR i: NAT IN [0..rfBase[rl].length)
DO LOOPHOLE[gfRefLiteralTable+i*SIZE[REF ANY],
REF REF ANY]^ ← rrlt[rfBase[rl].frag[i]]
--GFs are initially cleared to all NIL
 ENDLOOP};
IF mth.types # TFNull
THEN {t: TFIndex = mth.types;
pat: POINTER TO ARRAY [0..0) OF Type ← LOOPHOLE[gfh+tfBase[t].offset];
FOR i: NAT IN [0..tfBase[t].length)
DO pat[i] ← ptrTypeTable[tfBase[t].frag[i]]
ENDLOOP;
IF NOT mth.tableCompiled AND mth.frameRefs
THEN setType[gfh, LOOPHOLE[pat[mth.frameType]]];
--fill in gftype in gftshadow--
};
};
ENDCASE};

-- START AcquireTypesAndLiterals HERE
 IF (NOT bcd.extended) OR (bcd.rtPages.pages = 0) THEN RETURN;
-- old-style bcd or empty rtBase
 IF atomType = nullType THEN ERROR; -- better have done AcquireBasicTypes by now
 rtBase ← LOOPHOLE[bcd + bcd.rtPages.relPageBase*PrincOps.wordsPerPage];
IF rtBase.versionIdent # RTBcd.VersionID THEN ERROR RTBcdVersionMismatch;
rfBase ← LOOPHOLE[bcd + bcd.rfOffset];
tfBase ← LOOPHOLE[bcd + bcd.tfOffset];

--now merge the BCD's RCMap base into the rcMapBase that is maintained by RT.
-- construct rcmm: (BCD rcmapx -> RT rcmapx)
 IF rtBase.rcMapLength # 0
THEN rcmm ← RCMapOps.Include[LOOPHOLE[@rtBase[rtBase.rcMapBase]],
rtBase.rcMapLength,
uz];

ptrTypeTable ← AcquireTypes[bcd, rcmm];

l ← rtBase[rtBase.refLitTable].length;
IF l # 0
THEN {rrlt ← NEW[RefLitTable[l]]; -- collectible!!
 FOR i: NAT IN [0..l)
DO
rli: RefLitItem = rtBase[rtBase.refLitTable][i];
p: LONG POINTER ← (@rtBase[rtBase.litBase]) + rli.offset;
IF rli.length = 0 THEN {rrlt[i] ← NIL; LOOP};
IF ptrTypeTable[rli.referentType] = atomType
THEN rrlt[i] ← UnsafeMakeAtom[LOOPHOLE[p]]
ELSE {rrlt[i] ← AllocatorOps.NewObject[type: ptrTypeTable[rli.referentType],
size: rli.length,
zone: GetPermanentZone[]];
PrincOpsUtils.LongCOPY[from: p, to: LOOPHOLE[rrlt[i]], nwords: rli.length]};
ENDLOOP};

[] ← BcdOps.ProcessModules[bcd, doModule];

IF ptrTypeTable # NIL THEN uz.FREE[@ptrTypeTable];
IF rcmm # NIL THEN uz.FREE[@rcmm];
}; -- end AcquireTypesAndLiterals

CopyTypesAndLiterals: PUBLIC PROC [
bcd: BcdDefs.BcdBase, mi: BcdDefs.ModuleIndex, old, new: PrincOps.GlobalFrameHandle] = {
IF bcd.extended AND bcd.rtPages.pages # 0 THEN { -- this bcd has an RTBcd
rtBase: RTBcd.RTBase = LOOPHOLE[bcd + bcd.rtPages.relPageBase*PrincOps.wordsPerPage];
rfBase: Table.Base = LOOPHOLE[bcd + bcd.rfOffset];
tfBase: Table.Base = LOOPHOLE[bcd + bcd.tfOffset];
findMTH: PROC[mth: BcdDefs.MTHandle, mti: BcdDefs.MTIndex]
RETURNS[stop: BOOLEAN ← FALSE] = {
IF mi IN [mth.gfi .. mth.gfi + mth.ngfi) -- this is the mth for the old global frame
THEN {
WITH mth: mth SELECT FROM
multiple => {
IF mth.refLiterals # BcdDefs.RFNull
THEN {
rl: BcdDefs.RFIndex = mth.refLiterals;
gfRefLiteralTable: LONG POINTER ← LONG[new+rfBase[rl].offset];
oldGFRefLiteralTable: LONG POINTER ← LONG[old+rfBase[rl].offset];
FOR i: NAT IN [0..rfBase[rl].length)
DO
LOOPHOLE[gfRefLiteralTable+i*SIZE[REF ANY], REF REF ANY]^
← LOOPHOLE[oldGFRefLiteralTable+i*SIZE[REF ANY], REF REF ANY]^;
GFs are initially cleared to all NIL
ENDLOOP;
};
IF mth.types # BcdDefs.TFNull
THEN {
t: BcdDefs.TFIndex = mth.types;
newPAT: POINTER TO ARRAY [0..0) OF SafeStorage.Type
← LOOPHOLE[new+tfBase[t].offset];
oldPAT: POINTER TO ARRAY [0..0) OF SafeStorage.Type
← LOOPHOLE[old+tfBase[t].offset];
PrincOpsUtils.LongCOPY[
from: oldPAT,
nwords: tfBase[t].length * SIZE[SafeStorage.Type],
to: newPAT
];
};
}; -- end multiple =>
ENDCASE;
stop ← TRUE;
}; -- end IF mi IN [mth.gfi .. mth.gfi + mth.ngfi)
}; -- end findMTH
IF rtBase.versionIdent # RTBcd.VersionID THEN ERROR;
IF BcdOps.ProcessModules[bcd, findMTH].mth = NIL THEN ERROR;
}; -- end IF bcd.extended AND bcd.rtPages.pages # 0
};
-- Whiz thru THIS config in the loadstate, acquiring Types.
 -- This config includes SafeStoragePackage.bcd.
AcquireBasicTypes: PROC =
{rtBase: RTBcd.RTBase; -- base of RTBcd
 tfBase: Table.Base; -- type table part of the RTBcd

-- foreach module in this bcd...
 doModule: PROC[mth: BcdDefs.MTHandle, mti: BcdDefs.MTIndex]
RETURNS[stop: BOOLEAN ← FALSE] =
{ gfh: PrincOps.GlobalFrameHandle = BasicLoadState.ModuleToGlobalFrame[configID, mth.gfi];
IF mth = NIL THEN ERROR;
WITH mth: mth SELECT FROM
multiple =>
IF mth.types # TFNull
THEN {t: TFIndex = mth.types;
pat: POINTER TO ARRAY [0..0) OF Type ← LOOPHOLE[gfh+tfBase[t].offset];
FOR i: NAT IN [0..tfBase[t].length)
DO IF ptt[tfBase[t].frag[i]] = LAST[TypeIndex]
-- special case for ATOMs ... link this into atomTypeChain.
 THEN {pat[i] ← LOOPHOLE[atomTypeChain]; atomTypeChain ← @pat[i]}
ELSE pat[i] ← ptt[tfBase[t].frag[i]];
ENDLOOP;
IF NOT mth.tableCompiled AND mth.frameRefs
THEN BasicLoadState.SetType[gfh, LOOPHOLE[pat[mth.frameType]]];
--fill in gftype in gftshadow--
};
ENDCASE};

IF (NOT bcd.extended) OR (bcd.rtPages.pages = 0) THEN ERROR;
-- this bcd (SafeStoragePackage and friends) better have somethin' to say
 rtBase ← LOOPHOLE[bcd + bcd.rtPages.relPageBase*PrincOps.wordsPerPage];
IF rtBase.versionIdent # RTBcd.VersionID THEN ERROR RTBcdVersionMismatch;
tfBase ← LOOPHOLE[bcd + bcd.tfOffset];
IF rtBase.rcMapLength = 0 THEN ERROR;
-- this bcd (SafeStoragePackage and friends) better have somethin' to say

-- now merge the BCD's RCMap base into the rcMapBase that is maintained by CedarRuntime.
-- construct rcMapMap: (BCD rcmapx -> CedarRuntime rcmapx)
 rcMapMap ← RCMapOps.Include[LOOPHOLE[@rtBase[rtBase.rcMapBase]],
rtBase.rcMapLength,
uz];
ptt ← AcquireTypes[bcd, rcMapMap, TRUE];
[] ← BcdOps.ProcessModules[bcd, doModule];
 }; -- end AcquireBasicTypes

AcquireTypes: PROC
[bcd: BcdDefs.BcdBase, rcMapMap: RCMapOps.MapMap, initializing: BOOLEAN ← FALSE]
RETURNS[ptt: LONG POINTER TO TypeTable ← NIL] =
{ rtBase: RTBcd.RTBase = LOOPHOLE[bcd + bcd.rtPages.relPageBase*PrincOps.wordsPerPage];
typeTable: RTBase RELATIVE POINTER TO TypeList ← rtBase.typeTable;
l: NAT ← rtBase[typeTable].length;

IF l # 0
THEN { ptt ← uz.NEW[TypeTable[l]];
FOR i: NAT IN [0..l)
DO
rcmi: RCMap.Index;
ti: TypeItem = rtBase[typeTable][i];
st: RTBase RELATIVE POINTER TO StampList = rtBase.stampTable;
utf: RTTypesBasicPrivate.UniqueTypeFinger
← [(IF ti.ut.version = AnyStamp
THEN TimeStamp.Null
ELSE rtBase[st][ti.ut.version]),
[x[ti.ut.sei]]];
ts: TypeStrings.TypeString ← LOOPHOLE[@rtBase[rtBase.litBase] + ti.ct.index];

IF ti.sei = RTSymbolDefs.nullXSymbolIndex THEN {ptt[i] ← nullType; LOOP};
rcmi ← RCMapOps.FindMapMapEntry[rcMapMap, LOOPHOLE[ti.rcMap]];
IF rcmi = RCMap.invalidIndex THEN ERROR;
-- to solve the atom type bootstrapping problem.
 IF initializing AND IsAtomRecTS[ts]
THEN ptt[i] ← [LAST[TypeIndex]] -- special case for ATOMs
 ELSE {sgb: Table.Base = LOOPHOLE[bcd + bcd.sgOffset];
ftb: Table.Base = LOOPHOLE[bcd + bcd.ftOffset];
version: TimeStamp.Stamp;
IF sgb[ti.table].file = BcdDefs.FTSelf
THEN version ← bcd.version
ELSE version ← ftb[sgb[ti.table].file].version;
ptt[i] ← RTTypesBasicPrivate.AcquireTypeForLoader
[utf: utf,
std: [symbolsStamp: version,
bcd: bcd,
sgi: ti.table],
sei: [x[ti.sei]],
ts: ts,
rcmi: rcmi,
canonicalize: TRUE,
initializing: initializing]};
ENDLOOP}}; -- end AcquireTypes

-- Called AFTER the allocator and ATOM machinery have been initialized.
AcquireBasicLiterals: PUBLIC PROC[aType: Type] =
{rtBase: RTBcd.RTBase;
rfBase: Table.Base;
l: NAT;
RefLitTable: TYPE = RECORD[SEQUENCE length: NAT OF REF ANY];
rrlt: REF RefLitTable ← NIL;

-- foreach module found in the loadstate for this config...
 doModule: PROC[mth: BcdDefs.MTHandle, mti: BcdDefs.MTIndex]
RETURNS[stop: BOOLEAN ← FALSE] =
{ gfh: PrincOps.GlobalFrameHandle = BasicLoadState.ModuleToGlobalFrame[configID, mth.gfi];
IF mth = NIL THEN ERROR;
WITH mth: mth SELECT FROM
multiple =>
IF mth.refLiterals # RFNull
THEN {rl: RFIndex = mth.refLiterals;
gfRefLiteralTable: LONG POINTER ← LONG[gfh+rfBase[rl].offset];
FOR i: NAT IN [0..rfBase[rl].length)
DO LOOPHOLE[gfRefLiteralTable+i*SIZE[REF ANY],
REF REF ANY]^ ← rrlt[rfBase[rl].frag[i]]
--GFs are initially cleared to all NIL
 ENDLOOP};
ENDCASE};

-- START AcquireBasicLiterals here

-- first, fixup the atom type chain.
 atomType ← aType;
RTTypesBasicPrivate.NotifyAtomRecType[atomType];
UNTIL atomTypeChain = NIL
DO next: POINTER TO Type = LOOPHOLE[atomTypeChain^];
atomTypeChain^ ← atomType;
atomTypeChain ← next;
ENDLOOP;

-- next, finish initilizing MapStiStd
 RTTypesBasicPrivate.BlessMapStiStd[];

-- next, get the BCD that contains this module (and RT.bcd)
 rtBase ← LOOPHOLE[bcd + bcd.rtPages.relPageBase*PrincOps.wordsPerPage];
rfBase ← LOOPHOLE[bcd + bcd.rfOffset];

-- now construct rrlt if there are any REF literals or ATOM constants, and store
 -- such REFs in indicated global frames
 l ← rtBase[rtBase.refLitTable].length;
IF l # 0
THEN
{ rrlt ← NEW[RefLitTable[l]];
-- collectible!! Types have been acquired for SafeStorageOpsImpl by this time.

-- first acquire REF literals (the rope implementation, invoked by
-- UnsafeMakeAtom, needs 'em)
 FOR i: NAT IN [0..l)
DO
rli: RefLitItem = rtBase[rtBase.refLitTable][i];
p: LONG POINTER ← (@rtBase[rtBase.litBase]) + rli.offset;
IF rli.length = 0 THEN {rrlt[i] ← NIL; LOOP};
IF ptt[rli.referentType] = LAST[TypeIndex] -- special case for ATOMs
 THEN LOOP
ELSE {rrlt[i] ← AllocatorOps.NewObject[type: ptt[rli.referentType],
size: rli.length,
zone: GetPermanentZone[]];
PrincOpsUtils.LongCOPY[from: p, to: LOOPHOLE[rrlt[i]], nwords: rli.length]};
ENDLOOP;
[] ← BcdOps.ProcessModules[bcd, doModule];

-- now acquire ATOMs
 FOR i: NAT IN [0..l)
DO
rli: RefLitItem = rtBase[rtBase.refLitTable][i];
p: LONG POINTER ← (@rtBase[rtBase.litBase]) + rli.offset;
IF rli.length = 0 THEN {rrlt[i] ← NIL; LOOP};
IF ptt[rli.referentType] = LAST[TypeIndex] -- special case for ATOMs
 THEN rrlt[i] ← UnsafeMakeAtom[LOOPHOLE[p]]
-- UnsafeMakeAtom invokes the ROPE package, which uses REF literals
 -- (but no ATOM literals). The parts of RT.config have no ATOM
 -- literals
 ELSE LOOP;
ENDLOOP;
[] ← BcdOps.ProcessModules[bcd, doModule];
};

-- now cleanup after the work on this BCD
 IF ptt # NIL THEN uz.FREE[@ptt];
IF rcMapMap = NIL THEN ERROR;
uz.FREE[@rcMapMap];

-- and foreach config except this one in the basic loadstate invoke (vanilla)
 -- AcquireTypesAndLiterals.
 {p: PROC[otherConfigID: BasicLoadState.ConfigID] RETURNS [BOOL] = {
IF otherConfigID # configID THEN {
moduleToGFH: PROC[mx: BcdDefs.ModuleIndex]RETURNS[PrincOps.GlobalFrameHandle] ={
RETURN[BasicLoadState.ModuleToGlobalFrame[otherConfigID, mx]];
};
setType: PROC[gfh: PrincOps.GlobalFrameHandle, type: Type] = {
BasicLoadState.SetType[gfh, LOOPHOLE[type, BasicLoadState.TypeCode]];
};
AcquireTypesAndLiterals[
bcd: BasicLoadState.ConfigInfo[otherConfigID].bcd,
moduleToGFH: moduleToGFH,
setType: setType
];
};
RETURN[FALSE];
};
[] ← BasicLoadState.EnumerateConfigs[p];
};

-- now set the maintenance panel code to indicate that SafeStorage is ready for business
ProcessorFace.SetMP[MPCodes.storageInitialized];

}; -- end AcquireBasicLiterals

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


--START HERE
AcquireBasicTypes[];
AllocatorOps.Initialize[];
END.