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];
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[]]]]};
};
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];
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]}};