
<<SMLDriverImpl.mesa>>
<<Copyright  1985 by Xerox Corporation.  All rights reserved.>>
<<last edit by Satterthwaite, May 26, 1986 1:44:43 pm PDT>>

DIRECTORY
Atom: TYPE USING [GetProp, PutProp],
BasicTime: TYPE USING [GMT, nullGMT, Now, Period],
BcdDefs: TYPE USING [
Base, BcdBase, EXPHandle, EXPIndex, FTHandle, IMPHandle, IMPIndex, Link,
MTHandle, MTIndex, ProcLimit],
BcdOps: TYPE USING [ProcessExports, ProcessImports, ProcessModules],
IO: TYPE USING [atom, card, PutF, rope, STREAM],
Loader: TYPE USING [Error, Start],
LoaderOps: TYPE USING [
AssignControlModules, CloseLinkSpace, CreateGlobalFrames, FrameList,
GetIR, GetModuleLink, GetPendingList, IR, IthLink, LinkSegmentLength, OpenLinkSpace,
PendingList, ReadLink, SetPendingList, WriteLink],
LoaderOpsExtras: TYPE USING [
AcquireFileProc, AssignCode, ProcessPendingEntries, SaveResolvedEntries, UpdateCode],
LoadState: TYPE USING [
Acquire, ConfigID, local, ModuleIndex, ModuleToGlobalFrame, NewConfig,
nullConfig, Release, SetType],
PrincOps: TYPE USING [
ControlLink, ControlModule, GlobalFrameHandle,
NullControl, NullLink, UnboundLink],
Rope: TYPE USING [ROPE],
SafeStorage: TYPE USING [Type],
SafeStorageOps: TYPE USING [AcquireTypesAndLiterals],
SMFI: TYPE USING [BcdFileInfo, SrcFileInfo],
SMLoad: TYPE USING [
AllocateIR, BuildInterface, BuildFramePtrInterface,
ImportMap, ImportMapSeq, IR, IRSeq, IRSeqRecord, LoadInfo, LoadInfoRecord,
RelocateLink],
SMLDriver: TYPE USING [LoadMod, LoadModRecord],
SMModelBcd: TYPE USING [Bcd, Base, BuildBcd, ReplaceComponent, RopeFromNS],
SMProj: TYPE USING [Available, Fill, Find, Proj, Read],
SMTree: TYPE Tree USING [
ApplOp, BindOp, Handle, Id, Link, Name, NodeName, null, nullName],
SMTreeOps: TYPE TreeOps USING [
GetExt, GetName, GetNode, NSons, NthSon, OpName, PutExt, Scan, ScanSons, TM],
SMVal: TYPE USING [
Binding, BtoD, BtoG, GetExtFromParse, IdName, IdType, OuterBody, PutExtInParse,
ValOf, ValOfNthSon, VisitNodes],
TimeStamp: TYPE USING [Stamp, Null],
VM: TYPE USING [AddressForPageNumber, Interval];

SMLDriverImpl: CEDAR PROGRAM
IMPORTS
Atom, BasicTime, BcdOps, IO, Loader, LoaderOps, LoaderOpsExtras, LoadState,
SafeStorageOps, SMLoad, SMModelBcd, SMProj, SMTreeOps, SMVal, VM
EXPORTS SMLDriver SHARES LoaderOps ~ {
OPEN Tree~~SMTree, TreeOps~~SMTreeOps;

LS: TYPE~REF LoaderState;
LoaderState: PUBLIC TYPE~RECORD[    -- state information for the modeller's loader
z: ZONE_,
tm: TreeOps.TM_,
out: IO.STREAM_,
modelBcd: SMModelBcd.Bcd_NIL,
config: LoadState.ConfigID_LoadState.nullConfig,
frameList: LoaderOps.FrameList_NIL,
cm: PrincOps.ControlModule_PrincOps.NullControl,
modelActuals: SMLoad.IRSeq_NIL,
started: BOOL_FALSE];


Create: PUBLIC PROC[z: ZONE, tm: TreeOps.TM, out: IO.STREAM]
RETURNS[LS] ~ {
RETURN[z.NEW[LoaderState _ [z~z, tm~tm, out~out]]]};


<<loading modules>>

Loaded: PUBLIC PROC[ls: LS] RETURNS[BOOL] ~ {
RETURN[ls ~= NIL AND ls.config # LoadState.nullConfig]};


LoadAndBind: PUBLIC PROC[ls: LS, root: Tree.Link, wDir: Rope.ROPE, replace: BOOL]
RETURNS[errors: BOOL _ FALSE] ~ {
startTime: BasicTime.GMT ~ BasicTime.Now[];
nBcds: NAT _ 0;
formals, body: Tree.Link;
[formals, body] _ SMVal.OuterBody[root];
<<unload any bcds that might be around from the last invocation>>
IF Loaded[ls] THEN DeleteLoadStateEntry[ls, replace];
IF ~replace THEN {
<<read the component bcds and build a composite one to simulate a config>>

LoadBcds: PROC[
root: Tree.Link,
ProcessComponent: PROC[BcdDefs.BcdBase, Rope.ROPE]
  RETURNS[LoadState.ModuleIndex]
] ~ {

ForEachApply: PROC[node, parent: Tree.Link] ~ {
IF TreeOps.OpName[node] IN Tree.ApplOp THEN {
<<this is interesting if either an Apply of a source file whose bcd is valid>>
<<or an fiBcd for a .bcd mentioned directly in the model>>
bcd: SMProj.Proj _ NIL;
WITH SMVal.ValOfNthSon[node, 1] SELECT FROM
subNode: Tree.Handle =>
IF TreeOps.OpName[subNode] IN Tree.ApplOp THEN
bcd _ NARROW[TreeOps.GetExt[subNode]];
fiBcd: SMFI.BcdFileInfo => {    -- temporary (inefficient)
bcd _ SMProj.Find[fiBcd.stamp];
IF ~bcd.Available THEN bcd.Fill[fiBcd.fName, wDir, FALSE]};
ENDCASE;
IF bcd # NIL AND ~bcd.interface THEN {
loadMod: SMLDriver.LoadMod _ NARROW[SMVal.GetExtFromParse[node]];
IF loadMod = NIL THEN loadMod _ (ls.z).NEW[SMLDriver.LoadModRecord _ []];
loadMod.proj _ bcd;
IF ~bcd.Available THEN
ls.out.PutF["Error - can't load %g (bcd not available)\n", IO.rope[bcd.localName]]
ELSE IF loadMod.loadInfo = NIL THEN {
<<note that ls.config can't be allocated yet; see export processor>>
loadInfo: SMLoad.LoadInfo ~ (ls.z).NEW[SMLoad.LoadInfoRecord _ [
config~LoadState.nullConfig]];
loadMod.loadInfo _ loadInfo;
[loadInfo.bcdSpace, loadInfo.bcd] _ bcd.Read;
loadInfo.moduleIndex _ ProcessComponent[loadInfo.bcd, bcd.localName];
loadInfo.nModules _ 1;    -- **** a fudge for now
nBcds _ nBcds + 1}
ELSE ERROR;
SMVal.PutExtInParse[node, loadMod]};
};
};

SMVal.VisitNodes[ls.tm, root, ForEachApply]};

ls.modelBcd _ SMModelBcd.BuildBcd[
"&model", BasicTime.nullGMT, body, LoadBcds, ls.modelBcd]
};

TRUSTED {LoadState.local.Acquire[$exclusive];    -- locks load state
{
ENABLE {
UNWIND => NULL;
ANY => LoadState.local.Release[commit~FALSE]};

AcquireFile: LoaderOpsExtras.AcquireFileProc ~ {
bcd: SMProj.Proj ~ SMProj.Find[version];
IF ~bcd.Available THEN bcd.Fill[name, wDir, FALSE];
RETURN[bcd.file]};

IF ~replace THEN {
ls.config _ LoadState.local.NewConfig[ls.modelBcd.Base, NIL];
ls.frameList _ LoaderOps.CreateGlobalFrames[ls.config, FALSE].fl;
LoaderOpsExtras.AssignCode[ls.config, AcquireFile];
ls.cm _ LoaderOps.AssignControlModules[ls.config];
InputActuals[ls, formals];
CollectExports[ls, body]}
ELSE {

ForEachApply: PROC[node, parent: Tree.Link] ~ CHECKED {
IF TreeOps.OpName[node] IN Tree.ApplOp THEN {
<<this is interesting if either an Apply of a source file whose bcd is valid>>
<<or an fiBcd for a .bcd mentioned directly in the model>>
bcd: SMProj.Proj _ NIL;
WITH SMVal.ValOfNthSon[node, 1] SELECT FROM
subNode: Tree.Handle =>
IF TreeOps.OpName[subNode] IN Tree.ApplOp THEN
bcd _ NARROW[TreeOps.GetExt[subNode]];
fiBcd: SMFI.BcdFileInfo => {    -- temporary (inefficient)
bcd _ SMProj.Find[fiBcd.stamp];
IF ~bcd.Available THEN bcd.Fill[fiBcd.fName, wDir, FALSE]};
ENDCASE;
IF bcd # NIL AND ~bcd.interface THEN {
loadMod: SMLDriver.LoadMod ~ NARROW[SMVal.GetExtFromParse[node]];
loadInfo: SMLoad.LoadInfo ~ loadMod.loadInfo;
IF loadMod.mustReplace THEN {
[loadInfo.bcdSpace, loadInfo.bcd] _ bcd.Read;
(ls.modelBcd).ReplaceComponent[loadInfo.moduleIndex, loadInfo.bcd, bcd.localName];
TRUSTED {
LoaderOpsExtras.UpdateCode[
loadInfo.config, loadInfo.moduleIndex, BaseAddress[loadInfo.bcdSpace],
AcquireFile, bcd.file]
};
nBcds _ nBcds + 1;
SetUpExports[ls, loadInfo];
loadInfo.rtStarted _ FALSE;
loadMod.mustReplace _ FALSE}
ELSE ClearImports[loadInfo];
<<discard old binding information (compiler allows this to change)>>
loadInfo.imports _ NIL;
loadInfo.linksResolved _ FALSE}
};
};

SMVal.VisitNodes[ls.tm, body, ForEachApply]};
ProcessPlusAndThen[ls, body];
ResolveImports[ls, body];
ProcessCedarBcds[ls, body];
ExportToLoadState[ls, body];
};        -- end ENABLE
LoadState.local.Release[commit~TRUE]};    -- end TRUSTED
IF nBcds = 0 THEN ls.out.PutF["Nothing was loaded.\n\n"]
ELSE {
ls.out.PutF["%d modules loaded\n", IO.card[nBcds]];
ls.out.PutF[
"Total time to load: %d seconds.\n\n", IO.card[startTime.Period[BasicTime.Now[]]]]};
};


<<internal procedures>>

BaseAddress: PROC[interval: VM.Interval] RETURNS[BcdDefs.BcdBase] ~ TRUSTED {
RETURN[VM.AddressForPageNumber[interval.page]]};


DeleteLoadStateEntry: PROC[ls: LS, replace: BOOL] ~ {
<<currently, there is no way to release a load state entry or its data structures>>
IF ~replace THEN ls.config _ LoadState.nullConfig};


<<fill in exported interface records from the bcd>>

CollectExports: PROC[ls: LS, root: Tree.Link] ~ {

ForEachApply: PROC[node, parent: Tree.Link] ~ {
IF TreeOps.OpName[node] IN Tree.ApplOp THEN
WITH SMVal.GetExtFromParse[node] SELECT FROM
loadMod: SMLDriver.LoadMod => {
loadInfo: SMLoad.LoadInfo ~ loadMod.loadInfo;
IF loadInfo.exports = NIL THEN SetUpExports[ls, loadInfo]}
ENDCASE => NULL;
};

SMVal.VisitNodes[ls.tm, root, ForEachApply]};

SetUpExports: PROC[ls: LS, loadInfo: SMLoad.LoadInfo] ~ TRUSTED {
bcd: BcdDefs.BcdBase ~ loadInfo.bcd;
n: NAT _ 1;

ForEachExport: PROC[eth: BcdDefs.EXPHandle, eti: BcdDefs.EXPIndex]
RETURNS[stop: BOOL_FALSE] ~ CHECKED {
ir: SMLoad.IR ~ SMLoad.BuildInterface[loadInfo, eth];
loadInfo.exports[n] _ ir;
n _ n+1};

loadInfo.config _ ls.config;
loadInfo.exports _ (ls.z).NEW[SMLoad.IRSeqRecord[bcd.nExports+1]];
IF bcd.nModules = 1 THEN
<<build interface record for a compiler produced module>>
loadInfo.exports[0] _ SMLoad.BuildFramePtrInterface[loadInfo];
[] _ BcdOps.ProcessExports[bcd, ForEachExport]};


<<merge exported records for import>>

ProcessPlusAndThen: PROC[ls: LS, root: Tree.Link] ~ {
<<load state should not be locked>>

Eval: PROC[t: Tree.Link] RETURNS[SMLoad.IR] ~ {
SELECT TreeOps.OpName[t] FROM
IN Tree.ApplOp => {
<<this is a coercion not made explicit by the evaluator; simply use the first export>>
loadMod: SMLDriver.LoadMod ~ NARROW[SMVal.GetExtFromParse[t]];
IF loadMod # NIL THEN {
loadInfo: SMLoad.LoadInfo ~ loadMod.loadInfo;
RETURN[loadInfo.exports[1]]}    -- check size before allowing coercion?
ELSE RETURN[NIL]};
$subscript, $then, $union =>
WITH TreeOps.GetExt[t] SELECT FROM
ir: SMLoad.IR => RETURN[ir];
ENDCASE => {
ApplyOp[TreeOps.GetNode[t]];  RETURN[NARROW[TreeOps.GetExt[t]]]};
$nil => RETURN[NIL];
ENDCASE => RETURN[NIL]        -- ERROR?
};

ApplyOp: PROC[node: Tree.Link] ~ {
SELECT TreeOps.OpName[node] FROM
$union, $then => {
left: SMLoad.IR ~ Eval[SMVal.ValOfNthSon[node, 1]];
right: SMLoad.IR ~ Eval[SMVal.ValOfNthSon[node, 2]];
TreeOps.PutExt[node, BinaryOp[left, right, TreeOps.OpName[node]]]};    -- ****
$subscript => {
gb: Tree.Link ~ TreeOps.NthSon[node, 1];
selector: Tree.Name ~ TreeOps.GetName[TreeOps.NthSon[node, 2]];
left: Tree.Link ~ SMVal.ValOf[gb];
SELECT TreeOps.OpName[left] FROM
IN Tree.ApplOp => {
typeName: Tree.Name ~ IndexToType[gb, selector];
desiredName: Tree.Name ~
(IF typeName # Tree.nullName THEN typeName ELSE selector);
WITH SMVal.GetExtFromParse[left] SELECT FROM
loadMod: SMLDriver.LoadMod => {
exports: SMLoad.IRSeq ~ loadMod.loadInfo.exports;
FOR i: NAT IN [0 .. exports.size) DO
IF exports[i] # NIL AND exports[i].name = desiredName THEN
GOTO found;
REPEAT
found => TreeOps.PutExt[node, exports[i]];    -- ****
FINISHED =>
IF typeName # $CONTROL THEN
ls.out.PutF["Error - %g is not exported by %g.\n",
IO.atom[selector], IO.rope[loadMod.proj.localName]];
ENDLOOP;
};
ENDCASE => NULL;
};
ENDCASE => NULL;
};
ENDCASE => NULL;
};

BinaryOp: PROC[left, right: SMLoad.IR, mode: Tree.NodeName]
RETURNS[result: SMLoad.IR] ~ {
IF left = NIL THEN RETURN[right];
IF right = NIL THEN RETURN[left];
IF left.size # right.size OR left.stamp ~= right.stamp THEN {
<<a TYPE CHECK>>
ls.out.PutF["Interface mismatch between %g and %g.\n",
IO.atom[left.name], IO.atom[right.name]];
RETURN[left]};
result _ SMLoad.AllocateIR[left.stamp, left.name, left.size];
FOR i: NAT IN [0 .. left.size) DO
SELECT mode FROM
$then =>
result[i] _ (IF EmptyLink[left[i].link] THEN right[i] ELSE left[i]);
$union => {    -- +
IF ~EmptyLink[left[i].link] AND ~EmptyLink[right[i].link] THEN
ls.out.PutF["Multiple exports of item %d in interface %g.\n",
IO.card[i], IO.atom[left.name]];
result[i] _ (IF EmptyLink[left[i].link] THEN right[i] ELSE left[i])};
ENDCASE => ERROR;        -- other operators not yet implemented
ENDLOOP;
};

ForEachNode: PROC[node, parent: Tree.Link] ~ {
SELECT TreeOps.OpName[node] FROM
$union, $then, $subscript =>
WITH TreeOps.GetExt[node] SELECT FROM
ir: SMLoad.IR => NULL;
ENDCASE => ApplyOp[node];
ENDCASE => NULL;
};

SMVal.VisitNodes[ls.tm, root, ForEachNode]};

IndexToType: PROC[gb: Tree.Link, index: Tree.Name]
RETURNS[typeName: Tree.Name _ Tree.nullName] ~ {
WITH gb SELECT FROM
id: Tree.Id => {
d: Tree.Link ~ SMVal.IdType[id];

FindIndexType: TreeOps.Scan ~ {
elemName: Tree.Name ~ TreeOps.GetName[TreeOps.NthSon[t, 1]];
IF elemName = index THEN {
type: Tree.Link ~ TreeOps.NthSon[t, 2];
WITH type SELECT FROM
typeId: Tree.Id => typeName _ SMVal.IdName[typeId];
ENDCASE =>    -- temporary
IF TreeOps.OpName[type] = $control THEN typeName _ $CONTROL
ELSE NULL;    -- for now
};
};

IF TreeOps.OpName[d] # $decl THEN ERROR;
TreeOps.ScanSons[d, FindIndexType]};
ENDCASE => NULL;    -- for now
};


EmptyLink: PROC[link: PrincOps.ControlLink] RETURNS[BOOL] ~ {
RETURN[link = PrincOps.UnboundLink OR link = PrincOps.NullLink]};


<<fill in links>>

InputActuals: PROC[ls: LS, formals: Tree.Link] ~ {
<<called with the load state locked>>
n: NAT ~ TreeOps.NSons[formals];
IF n = 0 THEN ls.modelActuals _ NIL
ELSE {
ls.modelActuals _ (ls.z).NEW[SMLoad.IRSeqRecord[n+1]];
ls.modelActuals[0] _ NIL;        -- not used
FOR i: NAT IN [1 .. n] DO
id: Tree.Id ~ NARROW[TreeOps.GetExt[TreeOps.NthSon[formals, i]]];
type: Tree.Link ~ SMVal.IdType[id];
stamp: TimeStamp.Stamp _ TimeStamp.Null;
<<examine first son, it is either an apply for a mesa or fiBcd for a bcd in the model>>
WITH SMVal.ValOf[type] SELECT FROM
node: Tree.Handle =>
WITH SMVal.ValOfNthSon[SMVal.ValOf[node], 1] SELECT FROM
fiSrc: SMFI.SrcFileInfo =>
stamp _ NARROW[TreeOps.GetExt[node], SMProj.Proj].stamp;
subNode: Tree.Handle =>
IF TreeOps.OpName[subNode] IN Tree.ApplOp THEN
stamp _ NARROW[TreeOps.GetExt[subNode], SMProj.Proj].stamp;
fiBcd: SMFI.BcdFileInfo => stamp _ fiBcd.stamp;
ENDCASE;
fiBcd: SMFI.BcdFileInfo => stamp _ fiBcd.stamp;
ENDCASE;
IF stamp # TimeStamp.Null THEN {
ls.modelActuals[i] _ GetInterface[ls, stamp];
IF ls.modelActuals[i] = NIL THEN {
typeName: Tree.Name ~ SMVal.IdName[
WITH type SELECT FROM typeId: Tree.Id => typeId, ENDCASE => id];
ls.modelActuals[i] _ LookupFrame[ls, typeName, stamp]}
}
ENDLOOP;
};
};

GetInterface: PROC[ls: LS, bcdVersion: TimeStamp.Stamp] RETURNS[ir: SMLoad.IR] ~ {
<<called with LoadState locked>>
linkerIR:  LoaderOps.IR;
name: ATOM;
TRUSTED {
[interface~linkerIR, name~name] _ LoaderOps.GetIR[version: bcdVersion
! Loader.Error => {
IF type = $versionMismatch THEN {
ls.out.PutF["Error - version mismatch on %g\n", IO.rope[message]];
GOTO fail};
REJECT}        -- else let it propagate
];
EXITS
fail => linkerIR _ NIL;
};
IF linkerIR = NIL THEN {
<<this is one of>>
<<1) an imported module from the loadstate (done lazily: see LookupFrame)>>
<<2) an imported interface that is all inlines>>
<<3) an imported interface that has not been exported to the load state (error)>>
ir _ NIL}
ELSE {
ir _ SMLoad.AllocateIR[bcdVersion, name, linkerIR.size];
FOR i: NAT IN [0..ir.size) DO ir[i] _ [linkerIR[i]] ENDLOOP};
RETURN};


ResolveImports: PROC[ls: LS, root: Tree.Link] ~ {

ForEachApply: PROC[node, parent: Tree.Link] ~ {
IF TreeOps.OpName[node] IN Tree.ApplOp THEN
WITH SMVal.GetExtFromParse[node] SELECT FROM
loadMod: SMLDriver.LoadMod =>
IF ~loadMod.loadInfo.linksResolved THEN {
rand: Tree.Link ~ SMVal.ValOfNthSon[node, 2];
args: Tree.Link ~ (IF SMVal.Binding[rand] THEN SMVal.BtoG[rand] ELSE rand);
FillInImports[loadMod, args]};
ENDCASE => NULL;
};

FillInImports: PROC[loadMod: SMLDriver.LoadMod, args: Tree.Link] ~ TRUSTED {
loadInfo: SMLoad.LoadInfo ~ loadMod.loadInfo;
bcd: BcdDefs.BcdBase ~ loadInfo.bcd;
firstDummy: NAT ~ bcd.firstdummy;
importMap: SMLoad.ImportMap ~
(ls.z).NEW[SMLoad.ImportMapSeq[bcd.nDummies] _ [bias~firstDummy, map~]];
import: NAT _ 1;

ForEachImport: PROC[ith: BcdDefs.IMPHandle, iti: BcdDefs.IMPIndex]
RETURNS[stop: BOOL_FALSE] ~ TRUSTED {
fth: BcdDefs.FTHandle ~ @LOOPHOLE[bcd + bcd.ftOffset, BcdDefs.Base][ith.file];
FOR i: NAT IN [0 .. ith.ngfi) DO
importMap[(ith.gfi-firstDummy)+i] _ [index~import, whichOne~i];
ENDLOOP;
loadInfo.imports[import] _ (IF import > TreeOps.NSons[args] THEN
HiddenImport[ls, args, fth.version] ELSE LookupInterface[ls, args, import]);
IF FALSE AND loadInfo.imports[import] = NIL THEN {
<<would get spurious warnings for NIL implementations>>
sym: Rope.ROPE ~ SMModelBcd.RopeFromNS[bcd, ith.name];
ls.out.PutF["Warning - cannot find exporter of %g anywhere.\n", IO.rope[sym]]};
import _ import + 1};

moduleBase: LoadState.ModuleIndex ~ loadInfo.moduleIndex;

ForEachModule: PROC[mth: BcdDefs.MTHandle, mti: BcdDefs.MTIndex]
RETURNS[stop: BOOL_FALSE] ~ TRUSTED {
resolved: BOOL _ TRUE;
frame: PrincOps.GlobalFrameHandle ~
LoadState.local.ModuleToGlobalFrame[loadInfo.config, moduleBase + (mth.gfi-1)];
LoaderOps.OpenLinkSpace[frame, mth, bcd];
FOR i: CARDINAL IN [0..LoaderOps.LinkSegmentLength[mth, bcd]) DO
bound: BOOL;
link: PrincOps.ControlLink;
[link, bound] _ NewLink[
bcdLink~LoaderOps.IthLink[mth, i, bcd],
oldLink~LoaderOps.ReadLink[offset~i],
loadInfo~loadMod.loadInfo, importMap~importMap];
IF bound THEN LoaderOps.WriteLink[offset~i, link~link]
ELSE resolved _ FALSE;
ENDLOOP;
LoaderOps.CloseLinkSpace[frame];
IF ~resolved THEN loadInfo.linksResolved _ FALSE};

IF bcd.nImports = 0 THEN RETURN;    -- no imports
loadInfo.imports _ (ls.z).NEW[SMLoad.IRSeqRecord[bcd.nImports+1]];
loadInfo.imports[0] _ NIL;    -- not used
[] _ BcdOps.ProcessImports[bcd, ForEachImport];
loadInfo.linksResolved _ TRUE;
[] _ BcdOps.ProcessModules[bcd, ForEachModule]};

SMVal.VisitNodes[ls.tm, root, ForEachApply]};


ClearImports: PROC[loadInfo: SMLoad.LoadInfo] ~ TRUSTED {
bcd: BcdDefs.BcdBase ~ loadInfo.bcd;
moduleBase: LoadState.ModuleIndex ~ loadInfo.moduleIndex;

ForEachModule: PROC[mth: BcdDefs.MTHandle, mti: BcdDefs.MTIndex]
RETURNS[stop: BOOL_FALSE] ~ TRUSTED {
frame: PrincOps.GlobalFrameHandle ~
LoadState.local.ModuleToGlobalFrame[loadInfo.config, moduleBase + (mth.gfi-1)];
LoaderOps.OpenLinkSpace[frame, mth, bcd];
FOR i: CARDINAL IN [0..LoaderOps.LinkSegmentLength[mth, bcd]) DO
LoaderOps.WriteLink[offset~i, link~PrincOps.NullLink];
ENDLOOP;
LoaderOps.CloseLinkSpace[frame]};

IF bcd.nImports = 0 THEN RETURN;    -- no imports
loadInfo.imports _ NIL;
loadInfo.linksResolved _ FALSE;
[] _ BcdOps.ProcessModules[bcd, ForEachModule]};


PossibleCoercion: PROC[t: Tree.Link] RETURNS[SMLoad.IR] ~ {
SELECT TreeOps.OpName[t] FROM
IN Tree.ApplOp => {
<<this is a coercion not made explicit by the evaluator; simply use the first export>>
loadMod: SMLDriver.LoadMod ~ NARROW[SMVal.GetExtFromParse[t]];
loadInfo: SMLoad.LoadInfo ~ loadMod.loadInfo;
RETURN[loadInfo.exports[1]]};    -- check size before allowing coercion?
$subscript, $then, $union =>
RETURN[NARROW[TreeOps.GetExt[t]]];
$nil => RETURN[NIL];
ENDCASE => RETURN[NIL]        -- ERROR?
};


LookupInterface: PROC[ls: LS, args: Tree.Link, import: NAT] RETURNS[SMLoad.IR] ~ {

LookupOutside: PROC[id: Tree.Id] RETURNS[ir: SMLoad.IR] ~ {
ir _ ls.modelActuals[id.p];    -- id must be a formal
IF ir = NIL THEN
ls.out.PutF["Can't import %g from loadstate.\n", IO.atom[SMVal.IdName[id]]];
RETURN};

RETURN [WITH SMVal.ValOfNthSon[args, import] SELECT FROM
node: Tree.Handle => PossibleCoercion[node],
id: Tree.Id => LookupOutside[id],
ENDCASE => ERROR]
};

HiddenImport: PROC[ls: LS, args: Tree.Link, version: TimeStamp.Stamp]
RETURNS[ir: SMLoad.IR _ NIL] ~ {

CheckArg: TreeOps.Scan ~ {
v: Tree.Link ~ SMVal.ValOf[t];
SELECT TreeOps.OpName[v] FROM
IN Tree.ApplOp => {

CheckImport: TreeOps.Scan ~ {
WITH SMVal.ValOf[t] SELECT FROM
node: Tree.Handle => {
argIr: SMLoad.IR ~ PossibleCoercion[node];
IF argIr ~= NIL AND argIr.stamp = version THEN {
IF ir ~= NIL AND ir ~= argIr THEN
ls.out.PutF["Ambiguous implicit import of %g\n", IO.atom[ir.name]];
ir _ argIr};
};
ENDCASE;
<<could be an export too?>>
};

TreeOps.ScanSons[SMVal.ValOfNthSon[v, 2], CheckImport]};
$subscript => CheckArg[TreeOps.NthSon[v, 1]];
$then, $union => {
CheckArg[TreeOps.NthSon[v, 1]];  CheckArg[TreeOps.NthSon[v, 2]]};
$nil => NULL;
ENDCASE;
};

TreeOps.ScanSons[args, CheckArg];
<<ir will be NIL here only if implicitly importing instance came from load state>>
IF ir = NIL THEN ir _ GetInterface[ls, version];
RETURN};


NewLink: PROC[
  bcdLink: BcdDefs.Link, oldLink: PrincOps.ControlLink,
  loadInfo: SMLoad.LoadInfo, importMap: SMLoad.ImportMap]
RETURNS[link: PrincOps.ControlLink, resolved: BOOL] ~ {

FindLink: PROC[bcdLink: BcdDefs.Link]
  RETURNS [link: PrincOps.ControlLink, resolved: BOOL] ~ TRUSTED {
bcdGfi: LoadState.ModuleIndex ~ (SELECT bcdLink.vtag FROM
$var => bcdLink.vgfi,
$proc0, $proc1 => bcdLink.gfi,
ENDCASE => ERROR);
IF bcdGfi < importMap.bias THEN {
link _ SMLoad.RelocateLink[loadInfo, bcdLink];
resolved _ ~EmptyLink[link]}
ELSE {
relGfi: NAT ~ bcdGfi - importMap.bias;
index: NAT ~ importMap[relGfi].index;
entryNo: CARDINAL ~ bcdLink.ep + (importMap[relGfi].whichOne*BcdDefs.ProcLimit);
ir: SMLoad.IR _ loadInfo.imports[index];
resolved _ (ir # NIL AND ~EmptyLink[ir[entryNo].link]);
IF resolved THEN link _ ir[entryNo].link
ELSE {-- ****  warning message here? --};
};
RETURN[link, resolved]};

RETURN (SELECT bcdLink.vtag FROM
$proc0, $proc1,
$var =>
IF EmptyLink[oldLink] THEN FindLink[bcdLink] ELSE [oldLink, TRUE],
ENDCASE => [LOOPHOLE[bcdLink.typeID], TRUE])
};


LookupFrame: PROC[ls: LS, name: Tree.Name, stamp: TimeStamp.Stamp]
  RETURNS[ir: SMLoad.IR _ NIL] ~ {
version: REF TimeStamp.Stamp ~ (ls.z).NEW[TimeStamp.Stamp _ stamp];
cLink: PrincOps.ControlLink;
Atom.PutProp[name, $version, version];
<<try for the imported module (expensive)>>
TRUSTED {cLink _ LoaderOps.GetModuleLink[atom~name]};
IF ~EmptyLink[cLink] THEN {
ir _ SMLoad.AllocateIR[stamp, name, 1];
ir[0] _ [link~cLink]};
RETURN};


ExportToLoadState: PROC[ls: LS, body: Tree.Link] ~ {
resolved: LoaderOps.PendingList _ NIL;

ForEachItem: PROC[t: Tree.Link] ~ {
ir: SMLoad.IR ~ PossibleCoercion[SMVal.ValOf[t]];
IF ir # NIL THEN {
name: ATOM ~ ir.name;
linkerIR: LoaderOps.IR _ NARROW[Atom.GetProp[name, $IR]];
IF linkerIR = NIL THEN TRUSTED {
linkerIR _ LoaderOps.GetIR[name, ir.stamp, ir.size].interface;
FOR i: NAT IN [0..ir.size) DO linkerIR[i] _ ir[i].link ENDLOOP}
ELSE IF ir.stamp # NARROW[Atom.GetProp[name, $version], REF TimeStamp.Stamp]^
THEN {
ls.out.PutF[
"Error - interface %g is already exported to the loadstate in a different version.\n",
IO.atom[name]];
linkerIR _ NIL}
ELSE TRUSTED {
FOR i: NAT IN [0..ir.size) DO
IF ~EmptyLink[ir[i].link] THEN linkerIR[i] _ ir[i].link;
ENDLOOP};
IF linkerIR # NIL THEN TRUSTED {
pending: LoaderOps.PendingList _ LoaderOps.GetPendingList[name];
IF pending # NIL THEN {
[resolved, pending] _
LoaderOpsExtras.SaveResolvedEntries[resolved, pending, linkerIR];
LoaderOps.SetPendingList[name, pending]};
};
};
};

SELECT TreeOps.OpName[body] FROM
$group => TreeOps.ScanSons[body, ForEachItem];
IN Tree.BindOp => {TreeOps.ScanSons[SMVal.BtoG[body], ForEachItem]};
$let => ExportToLoadState[ls, TreeOps.NthSon[body, 2]];
ENDCASE => ForEachItem[body];
IF resolved # NIL THEN TRUSTED {LoaderOpsExtras.ProcessPendingEntries[resolved]}};


ProcessCedarBcds: PROC[ls: LS, root: Tree.Link] ~ {

ForEachApply: PROC[node, parent: Tree.Link] ~ {
IF TreeOps.OpName[node] IN Tree.ApplOp THEN
WITH SMVal.GetExtFromParse[node] SELECT FROM
loadMod: SMLDriver.LoadMod => TRUSTED {
loadInfo: SMLoad.LoadInfo ~ loadMod.loadInfo;

ModuleToGFH: PROC[bcdGfi: LoadState.ModuleIndex]
RETURNS[PrincOps.GlobalFrameHandle] ~ TRUSTED {
RETURN[LoadState.local.ModuleToGlobalFrame[
loadInfo.config, loadInfo.moduleIndex + (bcdGfi-1)]]
};

SetType: PROC[
gfh: PrincOps.GlobalFrameHandle, type: SafeStorage.Type] ~ TRUSTED {
LoadState.local.SetType[gfh, type]};

IF loadInfo # NIL AND ~loadInfo.rtStarted THEN {
SafeStorageOps.AcquireTypesAndLiterals[loadInfo.bcd, ModuleToGFH, SetType];
loadInfo.rtStarted _ TRUE};
};
ENDCASE => NULL;
};

SMVal.VisitNodes[ls.tm, root, ForEachApply]};


<<feedback to/from the compiler (for module replacement)>>

LoadInfo: TYPE~SMLoad.LoadInfo;
LoadInfoRecord: PUBLIC TYPE~SMLoad.LoadInfoRecord;

LoadedModule: PUBLIC PROC[info: LoadInfo] RETURNS[BOOL] ~ {
RETURN[info # NIL AND info.nModules = 1]};


<<starting modules>>

StartNode: TYPE~RECORD[
cm: PrincOps.ControlModule,
frame: PrincOps.GlobalFrameHandle,
next: REF StartNode];

Started: PUBLIC PROC[ls: LS] RETURNS[BOOL] ~ {
RETURN[Loaded[ls] AND ls.started]};

StartAll: PUBLIC PROC[ls: LS, root: Tree.Link] ~ {
startHead, startTail: REF StartNode _ NIL;

Append: PROC[cm: PrincOps.ControlModule, frame: PrincOps.GlobalFrameHandle] ~ {
node: REF StartNode ~ (ls.z).NEW[StartNode _ [cm, frame, NIL]];
IF startHead = NIL THEN startHead _ node ELSE startTail.next _ node;
startTail _ node};

ForEachNode: PROC[node, parent: Tree.Link] ~ {
IF SMVal.Binding[node] THEN {
d: Tree.Link ~ SMVal.BtoD[node];
g: Tree.Link ~ SMVal.BtoG[node];
p: NAT _ 0;

CheckElem: TreeOps.Scan ~ {
p _ p+1;
IF TreeOps.OpName[SMVal.ValOfNthSon[t, 2]] = $control THEN
StartModule[TreeOps.GetName[TreeOps.NthSon[t, 1]], SMVal.ValOfNthSon[g, p]]
};

TreeOps.ScanSons[d, CheckElem]};
};

StartModule: PROC[name: Tree.Name, t: Tree.Link] ~ {
WITH t SELECT FROM
node: Tree.Handle =>
SELECT TreeOps.OpName[node] FROM
IN Tree.ApplOp =>
WITH SMVal.GetExtFromParse[node] SELECT FROM
loadMod: SMLDriver.LoadMod => TRUSTED {    -- *** not right for configs
LoadState.local.Acquire[$shared];
{
ENABLE {
UNWIND => NULL;  ANY => LoadState.local.Release[]};
loadInfo: SMLoad.LoadInfo ~ loadMod.loadInfo;
gfh: PrincOps.GlobalFrameHandle ~
LoadState.local.ModuleToGlobalFrame[loadInfo.config, loadInfo.moduleIndex];
gfh.global[0] _ LOOPHOLE[PrincOps.NullLink, WORD];
Append[cm~[frame[gfh]], frame~gfh];
};    -- end enable
LoadState.local.Release[];
ls.out.PutF["Starting %g\n", IO.atom[name]]};
ENDCASE;
$subscript => StartModule[name, SMVal.ValOfNthSon[node, 1]];
ENDCASE;
ENDCASE => NULL;
};

SMVal.VisitNodes[ls.tm, SMVal.OuterBody[root].body, ForEachNode];
StartProcedure[ls, startHead]};

StartProcedure: PROC[ls: LS, startHead: REF  StartNode] ~ {
<<this procedure can be forked (but currently isn't)>>
i: NAT _ 0;
ls.started _ TRUE;
TRUSTED {
ENABLE ABORTED => {GOTO aborted};
FOR l: REF  StartNode _ startHead, l.next UNTIL l = NIL DO
i _ i+1;
IF l.frame.started THEN
ls.out.PutF["Error - element %d of start list has already been started.\n", IO.card[i]]
ELSE Loader.Start[l.cm];
ENDLOOP;
EXITS
aborted => NULL
};
IF i = 0 THEN ls.out.PutF["Nothing was started.\n\n"]
<<ELSE ls.out.PutF["All %d modules have been started.\n\n", IO.card[i]]};>>
ELSE ls.out.PutF["\n"]};


<<unloading modules>>

Unload: PUBLIC PROC[ls: LS, root: Tree.Link, unloadTheBcd: BOOL] ~ {
<<****>>
<<detach the model config from the modeller (best possible for now)>>
ls.config _ LoadState.nullConfig;
ls.modelBcd _ NIL;
ls.started _ FALSE;  ls.modelActuals _ NIL};

}.
