
<<CedarExporterImpl.mesa>>
<<exports a newly loaded bcd to the current set of interface records.>>
<<Last edited by: John Maxwell on: February 22, 1983 2:49 pm>>
<<Last Edited by: Levin, August 9, 1983 11:47 am>>
<<Last Edited by: Birrell, July 7, 1983 2:07 pm>>
<<Last edited by: Paul Rovner on: November 16, 1983 3:26 pm>>
<<Last edited by: Satterthwaite, August 20, 1985 10:04:01 am PDT>>
<<>>
DIRECTORY
Atom USING [GetPName, GetProp, PutProp, MakeAtom, FindAtom],
BcdDefs USING [
EVIndex, EVNull, EXPIndex, FTSelf, Link, MTIndex, MTRecord, NullVersion, TYPRecord, VarLimit, VersionStamp, BcdBase, EXPHandle, 
MTHandle, NameString, ModuleIndex],
BcdOps USING [ProcessExports, ProcessModules],
IO USING [PutR, int],
Loader USING [Error],
LoaderOps USING [Pending, IR, GetPendingList, IsNullLink, SetPendingList, PendingModule, OpenLinkSpace, WriteLink, CloseLinkSpace, 
pendingModules, IRRecord],
LoadState USING [local, Release, ConfigID, Acquire, EnumerateConfigs, ModuleInfo, ConfigInfo, BuildProcDescUsingModule],
PrincOps USING [ControlLink, GlobalFrameHandle, NullLink],
Rope USING [Cat, ROPE, Text, Length, InlineFetch, FromProc],
SafeStorage USING [GetPermanentZone],
Table USING [Base];


CedarExporterImpl: PROGRAM
IMPORTS 
Atom, BcdOps, IO, Loader, LoaderOps, LoadState, Rope, SafeStorage
EXPORTS LoaderOps =

BEGIN 
OPEN BcdDefs, LoaderOps, Rope;  

<<********************************************************************>>
<<Export: exports procedure descriptors, variables, and types to the appropriate interfaces.  >>
<<Checks to see if anybody is waiting for the new entry.  Sorts pending entries by frame and >>
<<assigns them all at once at the end.  Modules are only exported if there is somebody >>
<<waiting for one.  >>
<<********************************************************************>>

Export: PUBLIC PROC[config: LoadState.ConfigID] =
BEGIN
bcd: BcdBase = LoadState.local.ConfigInfo[config].bcd;
name: ROPE;
toBeProcessed: LIST OF Pending;
ftb: Table.Base = LOOPHOLE[bcd + bcd.ftOffset];
ssb: BcdDefs.NameString = LOOPHOLE[bcd + bcd.ssOffset];

ExportInterface: PROC[exph: EXPHandle, expi: EXPIndex] 
RETURNS[stop: BOOL _ FALSE] =
BEGIN
interface: IR;
atom: ATOM;
pending: LIST OF Pending;
i: NAT _ 0;
p: SAFE PROC RETURNS[c: CHAR] = TRUSTED{
c _ ssb.string.text[exph.name+i];
i _ i + 1;
};

<<get the name of the interface>>
name _ Rope.FromProc[ssb.size[exph.name], p];
<<>>
<<get the interface record >>
atom _ Atom.MakeAtom[name];
interface _ GetIR[atom, ftb[exph.file].version, exph.size].interface;
<<export to the interface>>
FOR i: NAT IN [0..exph.size) DO
IF IsNullLink[exph.links[i]] THEN LOOP;
<<export the item to the interface>>
SELECT exph.links[i].vtag FROM
var => {
frame: PrincOps.GlobalFrameHandle;
[interface[i], frame] _ FindVariableLink[config, exph.links[i].gfi, exph.links[i]];
IF frame # NIL THEN SaveFrame[interface, i, frame];
};
proc0, proc1 =>
interface[i] _ LoadState.local.BuildProcDescUsingModule[config, exph.links[i].gfi, exph.links[i].ep];
type => interface[i] _ CheckType[bcd, exph.links[i], LOOPHOLE[interface[i]], i, name];
ENDCASE => ERROR;
ENDLOOP;
<<put the resolved pending items on the toBeProcessed list>>
pending _ GetPendingList[atom];
IF pending # NIL THEN {
[toBeProcessed, pending] _ SaveResolvedEntries[toBeProcessed, pending, interface];
SetPendingList[atom, pending]};
END;

<<START Export HERE>>
[] _ BcdOps.ProcessExports[bcd, ExportInterface];
IF toBeProcessed # NIL THEN ProcessPendingEntries[toBeProcessed];
IF pendingModules # NIL THEN ExportModules[bcd, config];
END;

ExportModules: PROC[bcd: BcdBase, config: LoadState.ConfigID] =
BEGIN -- check to see if this bcd has a module that someone is waiting for.
link: UNSPECIFIED;
list, lastPending: LIST OF PendingModule;
ftb: Table.Base = LOOPHOLE[bcd + bcd.ftOffset];
ssb: BcdDefs.NameString = LOOPHOLE[bcd + bcd.ssOffset];
Export: PROC[mth: MTHandle, mti: MTIndex] RETURNS[stop: BOOLEAN _ FALSE] =
BEGIN
found: BOOLEAN;
FOR list _ pendingModules, list.rest WHILE list # NIL DO
IF mth.file = BcdDefs.FTSelf
THEN IF list.first.version # bcd.version THEN LOOP ELSE NULL 
ELSE IF list.first.version # ftb[mth.file].version THEN LOOP;
found _ TRUE;
IF Rope.Length[list.first.name] # ssb.size[mth.name] THEN LOOP;
FOR i: NAT IN NAT[0..Rope.Length[list.first.name]) DO
IF Rope.InlineFetch[list.first.name, i] # ssb.string.text[mth.name+i] THEN {found _ FALSE; EXIT};
ENDLOOP;
IF ~found THEN LOOP;
<<we have a match!!!  Fill in the link.>>
link _ LoadState.local.ModuleInfo[config, mth.gfi].gfh;
OpenLinkSpace[list.first.frame, list.first.mth, list.first.bcd];
WriteLink[list.first.index, link];
CloseLinkSpace[list.first.frame];
<<nullify the entry (will be removed later)>>
list.first.frame _ NIL;
ENDLOOP;
END;

<<START ExportModules HERE>>
[] _ BcdOps.ProcessModules[bcd, Export];
<<remove completed modules>>
FOR list _ pendingModules, list.rest WHILE list # NIL DO
IF list.first.frame # NIL THEN {lastPending _ list; LOOP};
IF lastPending = NIL
THEN pendingModules _ list.rest
ELSE lastPending.rest _ list.rest;
ENDLOOP;
END;

SaveResolvedEntries: PROC[process, pending: LIST OF Pending, interface: IR]
RETURNS[newProcess, newPending: LIST OF Pending] =
BEGIN -- move resolved pending items to the 'toBeProcessed' list.
<<the link slot is redefined to be the new interface element.>>
index: NAT;
next, lastPending: LIST OF Pending;
newProcess _ process;
newPending _ pending;
<<this is convoluted!>>
FOR pending _ pending, next WHILE pending # NIL DO
next _ pending.rest; -- 'rest' may be changed
index _ LOOPHOLE[pending.first.link];
IF IsNullLink[interface[index]] THEN {lastPending _ pending; LOOP};
pending.first.link _ interface[index]; -- redefines 'link'
<<remove resolved entry from pending list>>
IF lastPending # NIL
THEN lastPending.rest _ next
ELSE newPending _ next;
<<add the entry to the processed list, SORTED BY FRAME>>
<<does it go before the first element the processed list?>>
IF newProcess = NIL OR 
LOOPHOLE[pending.first.frame, CARDINAL] < 
LOOPHOLE[newProcess.first.frame, CARDINAL] THEN {
pending.rest _ newProcess;
newProcess _ pending; 
LOOP};
<<put it where it belongs>>
FOR process _ newProcess, process.rest DO
IF process.rest = NIL OR 
LOOPHOLE[pending.first.frame, CARDINAL] < 
LOOPHOLE[process.rest.first.frame, CARDINAL] THEN {
pending.rest _ process.rest;
process.rest _ pending;
EXIT}; 
ENDLOOP;
ENDLOOP;
END;

ProcessPendingEntries: PROC[list: LIST OF Pending] =
BEGIN
frame: PrincOps.GlobalFrameHandle _ NIL;
<<process all of the resolved pending items>>
FOR list _ list, list.rest WHILE list # NIL DO
IF list.first.frame # frame THEN {
frame _ list.first.frame;
OpenLinkSpace[list.first.frame, list.first.mth, list.first.bcd];
};
WriteLink[list.first.index, list.first.link];
IF list.rest = NIL OR list.rest.first.frame # frame THEN CloseLinkSpace[frame];
ENDLOOP;  
END;

<<>>
<<********************************************************************>>
<<CheckType: Concrete types are represented in the IR as an index into the sequence>>
<<'types'.  We want to check that there is at most one concrete type for each opaque type. >>
<<Someday we will use an RTTypes.Type to represent the type.  Currently exported types >>
<<are ignored by the importing module.>>
<<********************************************************************>>

typeIndex: NAT _ 0; 
types: ExportedTypes _ NEW[ExportedTypesSequence[100]];
ExportedTypes: TYPE = REF ExportedTypesSequence;
ExportedTypesSequence: TYPE = RECORD[s: SEQUENCE size: NAT OF BcdDefs.TYPRecord];

CheckType: PROC[bcd: BcdBase, new, old: BcdDefs.Link, i: NAT, name: ROPE] 
RETURNS[PrincOps.ControlLink] =
BEGIN -- compare the old type with the one we want to export. 
oldIndex: NAT = LOOPHOLE[old.typeID];
typb: Table.Base = LOOPHOLE[bcd + bcd.typOffset];
IF oldIndex = 0 THEN { -- first time exported.
<<look for an existing entry>>
FOR i: NAT IN [1..typeIndex) DO
IF types[i] # typb[new.typeID] THEN LOOP;
old _ [type[typeID: LOOPHOLE[i], type: new.type, proc: new.proc]];
RETURN[LOOPHOLE[old]];
ENDLOOP;
<<create a new entry>>
typeIndex _ typeIndex + 1;
IF typeIndex >= types.size THEN { -- allocate a large one
larger: ExportedTypes _ NEW[ExportedTypesSequence[types.size + 100]];
FOR i: NAT IN [0..types.size) DO
larger[i] _ types[i];
ENDLOOP;
types _ larger};
types[typeIndex] _ typb[new.typeID];
old _ [type[typeID: LOOPHOLE[typeIndex], type: new.type, proc: new.proc]];
RETURN[LOOPHOLE[old]]};
<<raise an error if there is a type clash>>
IF types[oldIndex] # typb[new.typeID] THEN {
typeError: ROPE
_ Cat[
"Exported Type Clash for interface ",
name,
", item # ",
IO.PutR[IO.int[i]]
];
ERROR Loader.Error[versionMismatch, typeError]};
RETURN[LOOPHOLE[old]];
END;

<<>>
<<********************************************************************>>
<<utility procedures>>
<<********************************************************************>>

FindVariableLink: PUBLIC PROC[
config: LoadState.ConfigID, mx: BcdDefs.ModuleIndex, mthLink: BcdDefs.Link]
RETURNS [link: PrincOps.ControlLink, frame: PrincOps.GlobalFrameHandle] =
BEGIN
bcd: BcdBase = LoadState.local.ConfigInfo[config].bcd;
ep: CARDINAL;
evi: EVIndex;
evb: Table.Base;
mth: MTHandle;
[mth, ep] _ FindModule[bcd, mthLink.vgfi];
IF mth = NIL THEN RETURN[PrincOps.NullLink, NIL];
evb _ LOOPHOLE[bcd + bcd.evOffset, Table.Base];
frame _ LoadState.local.ModuleInfo[config, mx].gfh;
IF (ep _ ep + mthLink.var) = 0 THEN RETURN[LOOPHOLE[frame], NIL];  
<<an imported program>>
IF (evi _ mth.variables) = EVNull THEN RETURN[PrincOps.NullLink, NIL];
RETURN[LOOPHOLE[frame + evb[evi].offsets[ep]], frame];  
<<a pointer to the variable in the frame>>
END;  -- end FindVariableLink

FindModule: PROC[bcd: BcdBase, gfi: BcdDefs.ModuleIndex] 
RETURNS[mth: MTHandle, ep: CARDINAL] =
BEGIN -- expansion of BcdOps.ProcessModules[bcd, FindModule]
mti: MTIndex;
mtb: Table.Base = LOOPHOLE[bcd + bcd.mtOffset];
i: CARDINAL;
mti _ FIRST[MTIndex];
FOR i IN [0..bcd.nModules) DO
mth _ @mtb[mti];
<<~~~~~~~~~~~~~~~~~~~~~~~~>>
IF gfi IN [mth.gfi..mth.gfi+mth.ngfi) THEN
RETURN[mth, VarLimit*(gfi - mth.gfi)];
<<~~~~~~~~~~~~~~~~~~~~~~~~>>
mti _ mti + (WITH m: mtb[mti] SELECT FROM
direct => SIZE[MTRecord[direct]] + m.length*SIZE[Link],
indirect => SIZE[MTRecord[indirect]],
multiple => SIZE[MTRecord[multiple]],
ENDCASE => ERROR)
ENDLOOP;
RETURN[NIL, 0];
END;

<<>>
<<********************************************************************>>
<<a cache of frames for exported varables>>
<<********************************************************************>>

frameIndex: NAT _ 0;
frames: ExportedVariables _ NEW[ExportedVariablesSequence[500]];
ExportedVariables: TYPE = REF ExportedVariablesSequence;
ExportedVariablesSequence: TYPE = RECORD[s: SEQUENCE size: NAT OF VariableRecord];
VariableRecord: TYPE = RECORD[
interface: IR, 
index: CARDINAL, 
frame: PrincOps.GlobalFrameHandle];

SaveFrame: PROC[interface: IR, index: CARDINAL, frame: PrincOps.GlobalFrameHandle] =
BEGIN
IF frame = NIL THEN RETURN;
IF frameIndex >= frames.size THEN { -- allocate a larger one
larger: ExportedVariables _ NEW[ExportedVariablesSequence[frames.size + 100]];
FOR i: NAT IN [0..frames.size) DO
larger[i].interface _ frames[i].interface;
larger[i].index _ frames[i].index;
larger[i].frame _ frames[i].frame;
ENDLOOP;
frames _ larger};
frames[frameIndex] _ [interface, index, frame];
frameIndex _ frameIndex + 1;
END;

GetFrame: PUBLIC PROC[interface: IR, index: CARDINAL] 
RETURNS[PrincOps.GlobalFrameHandle] =
BEGIN
FOR i: CARDINAL DECREASING IN [0..frameIndex) DO -- decreasing to catch last export
IF frames[i].interface # interface THEN LOOP;
IF frames[i].index # index THEN LOOP;
RETURN[frames[i].frame];
ENDLOOP;
RETURN[NIL];
END;

<<>>
<<********************************************************************>>
<<manipulating interface records>>
<<********************************************************************>>

Zone: ZONE _ SafeStorage.GetPermanentZone[];

GetIR: PUBLIC PROCEDURE[
atom: ATOM, 
version: BcdDefs.VersionStamp, 
length: CARDINAL] -- in case a new one must be created
RETURNS[name: ATOM, interface: IR, versionStamp: BcdDefs.VersionStamp] =
BEGIN
old: REF BcdDefs.VersionStamp;
IF atom = NIL THEN atom _ FindAtom[version];
IF atom = NIL THEN RETURN[NIL, NIL, NullVersion];
IF version # NullVersion THEN
IF (old _ NARROW[Atom.GetProp[atom, $version]]) = NIL
THEN {-- create a new one
old _ Zone.NEW[VersionStamp _ version]; 
Atom.PutProp[atom, $version, old];
}
ELSE -- check version mismatch 
IF version # old^ THEN Loader.Error[versionMismatch, Atom.GetPName[atom]];
interface _ NARROW[Atom.GetProp[atom, $IR]];
IF length = 0 THEN 
RETURN[atom, interface, IF old = NIL THEN NullVersion ELSE old^];
IF interface = NIL THEN {
interface _ Zone.NEW[IRRecord[length]];
Atom.PutProp[atom, $IR, interface]};
RETURN[atom, interface, IF old = NIL THEN NullVersion ELSE old^];
END;

FindAtom: PROCEDURE[version: BcdDefs.VersionStamp] RETURNS[atom: ATOM] =
BEGIN
CheckVersion: SAFE PROC[atom: ATOM] RETURNS[stop: BOOL] = TRUSTED {
old: REF BcdDefs.VersionStamp;
old _ NARROW[Atom.GetProp[atom, $version]];
IF old = NIL THEN RETURN[stop: FALSE];
RETURN[stop: old^ = version]};
IF version = BcdDefs.NullVersion THEN RETURN[NIL];
atom _ Atom.FindAtom[CheckVersion];
END;

Initialize: PROC =
BEGIN
ENABLE UNWIND => {LoadState.local.Release[]};
proc: PROC [config: LoadState.ConfigID] RETURNS [stop: BOOL _ FALSE] = {Export[config]};
LoadState.local.Acquire[exclusive];
[] _ LoadState.local.EnumerateConfigs[oldestFirst, proc];
LoadState.local.Release[];
END;


--Initialize[];

END . . .

