-- SMLDriverImpl.mesa
-- last edit by Schmidt, May 27, 1983 6:31 pm
-- last edit by Satterthwaite, August 15, 1983 11:51 am
-- procedures to load and start modules in a Model
 
-- links:
-- IF gfi > firstdummy, then gfi is index into Import table
--  and ep is index into the export record paired with that import.
--  Binding is simply to copy control link in the export record
--  into this link
--  IF gfi < firstdummy, then gfi in this link is an index into the config's
--  moduletable. Do not alter the ep

-- spaces:
-- assume there are n modules
-- there will be
-- 1 space in MDS for all the frames (and frame links)
-- 1 space in VM for the Fake Config Bcd for the load state
-- n ReadOnly spaces for Code
--  code and code links are in same space
-- n spaces for the Bcd headers
--  (deleted on UnLoad)

DIRECTORY
Atom: TYPE USING [MakeAtom, PutProp],
BcdDefs: TYPE USING [
Base, BCD, EPLimit, EXPIndex, EXPRecord, FTIndex, FTRecord, GFTIndex,
IMPIndex, IMPRecord, Link, MTIndex, MTRecord, NameRecord, VersionStamp],
BcdOps: TYPE USING [
BcdBase, EXPHandle, FTHandle, IMPHandle, MTHandle,
ProcessExports, ProcessImports, ProcessModules],
--CedarExporterImpl: TYPE USING [ProcessPendingEntries, SaveResolvedEntries],
CedarLinkerOps: TYPE USING [
FindVariableLink, GetIR, GetPendingList, IR, PendingList, SetPendingList],
CS: TYPE USING [RopeFromStamp],
Directory: TYPE USING [DeleteFile, Error],
File: TYPE USING [Capability],
IO: TYPE USING [atom, card, PutF, rope, STREAM, string, UserAborted],
List: TYPE USING [DReverse],
Loader: TYPE USING [Error],
LoaderPrivate: TYPE USING [FindMappedSpace, GetModuleLink],
PilotLoaderOps: TYPE USING [DestroyMap, IthLink, LinkSegmentLength, ReleaseFrames],
PilotLoadStateFormat: TYPE USING [ConfigIndex, NullConfig],
PilotLoadStateOps: TYPE USING [
ConfigIndex, GetMap, InputLoadState, Map, NullConfig, ReleaseLoadState,
ReleaseMap, RemoveConfig],
PrincOps: TYPE USING [
ControlLink, GFTIndex, GFTNull, GlobalFrameHandle, NullLink, UnboundLink],
Process: TYPE USING [Detach],
Rope: TYPE USING [Text],
RTLoader: TYPE USING [AcquireTypesAndLiterals],
Runtime: TYPE USING [ValidateGlobalFrame],
RuntimeInternal: TYPE USING [Codebase],
SMFakeBcd: TYPE USING [BuildFakeBcd],
SMFI: TYPE USING [BcdFileInfo],
SMLDriver: TYPE USING [],
SMLoad: TYPE USING [
AllocateIR, BuildFramePtrInterface, BuildInterface, CloseLinkSpace,
ConvertLink, FreeLoadInfo, GfiMap, InvalidFile, IR, IRSeq, IRSeqRecord,
LoadGlobalFrames, LoadIncremental, LoadInfo, NSToRope,
OpenLinkSpace, ReadLink, ReplaceResult, WriteLink],
SMProj: TYPE USING [Proj, Available, Fill, Find],
SMTree: TYPE Tree USING [
ApplOp, BindOp, Handle, Id, Link, Name, NodeName, null, nullName],
SMTreeOps: TYPE USING [
TM, GetExt, GetName, NSons, NthSon, OpName, PutExt, Scan, ScanSons],
SMVal: TYPE USING [
Binding, BtoD, BtoG, IdName, IdType, LoadMod, LoadModRecord,
GetExtFromParse, OuterBody, PutExtInParse, Select, ValOf, ValOfNthSon, VisitNodes],
Space: TYPE USING [
Delete, GetHandle, Handle, nullHandle, PageFromLongPointer, virtualMemory],
Time: TYPE USING [Current],
TimeStamp: TYPE USING [Null, Stamp];
   
SMLDriverImpl: PROGRAM
IMPORTS
Atom, BcdOps, --CedarExporterImpl,-- CedarLinkerOps, CS, Directory,
IO, List, Loader, LoaderPrivate, PilotLoaderOps, PilotLoadStateOps, Process,
RTLoader, Runtime, RuntimeInternal, SMFakeBcd, SMLoad, SMProj, SMTreeOps,
SMVal, Space, Time
EXPORTS SMLDriver
SHARES --CedarExporterImpl,-- CedarLinkerOps ~ {
OPEN Tree~~SMTree, TreeOps~~SMTreeOps;

-- no MDS usage!

LS: TYPE~REF LoaderState;
LoaderState: PUBLIC TYPE~RECORD[ -- state information for the modeller's loader
z: ZONE←,
tm: TreeOps.TM←,
out: IO.STREAM←,     -- for messages
fakeBcdSpace: Space.Handle←Space.nullHandle, -- the bcd space for a fake config
fakeBcdFileName: Rope.Text←NIL,   -- name of backing file
configIndex: PilotLoadStateFormat.ConfigIndex←PilotLoadStateFormat.NullConfig,
frameInterfaces: LIST OF REF FrameListRecord←NIL,
importedInterfaces: SMLoad.IRSeq←NIL,
started: BOOL�LSE];

FrameListRecord: TYPE~RECORD[
name: ATOM←NIL,
stamp: TimeStamp.Stamp←TimeStamp.Null,
ir: SMLoad.IR←NIL];


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


Loaded: PUBLIC SAFE PROC[ls: LS] RETURNS[BOOL] ~ CHECKED {
RETURN[ls ~= NIL AND ls.configIndex ~= PilotLoadStateFormat.NullConfig]};


LoadAndBind: PUBLIC SAFE PROC[ls: LS, root: Tree.Link, replace: BOOL]
RETURNS[errors: BOOL ← FALSE] ~ TRUSTED {
ENABLE UNWIND => {PilotLoadStateOps.ReleaseLoadState[]};
time: LONG CARDINAL ← Time.Current[];
nBcds: NAT;
formals, body: Tree.Link;
[formals, body] ← SMVal.OuterBody[root];
-- unload any bcds that may be around from the last invocation
-- regardless of "replacement", old config in load state is unloaded
IF Loaded[ls] THEN DeleteLoadStateEntry[ls, replace];
ls.configIndex ← PilotLoadStateOps.InputLoadState[]; -- locks the load state
--*** load state locked ***
-- this will acquire all the (explicit) imports from the load state
IF ~replace THEN InputActuals[ls, formals];
-- this will build all interface records
nBcds ← LoadBcds[ls, body ! SMLoad.InvalidFile => {GOTO fail}];
[ls.fakeBcdFileName, ls.fakeBcdSpace] ← -- releases the load state
 SMFakeBcd.BuildFakeBcd[ls.configIndex, body, ls.fakeBcdFileName, ls.fakeBcdSpace, ls.out];
--*** load state released ***
ProcessPlusAndThen[ls, body];
-- PutExportsInLoadState[g];
-- now fill in all the frame links
ResolveImports[ls, body]; -- may lock the load state while finding hidden imports
-- now call Cedar related procedures to finish the loading
ProcessCedarBcds[ls, body];
time ← Time.Current[] - time;
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[time]]};
EXITS
fail => NULL;
};
 
-- always frees the bcdbases stored in our structures
Unload: PUBLIC SAFE PROC[
 ls: LS, root: Tree.Link, unloadTheBcd: BOOL] ~ TRUSTED {
nunl: NAT ← 0;
 
-- traverses the value tree
ForEachApply: SAFE PROC[node, parent: Tree.Link] ~ TRUSTED {
IF TreeOps.OpName[node] IN Tree.ApplOp THEN
 WITH SMVal.GetExtFromParse[node] SELECT FROM
  loadMod: SMVal.LoadMod =>
  IF loadMod.loadInfo ~= NIL THEN {
  nunl ← nunl + 1;
  IF unloadTheBcd THEN {
  IF nunl = 1 THEN ls.out.PutF["Unloading modules.\n"];
  -- remember that a binder bcd loaded by
  -- the modeller will have only ONE mapped
  -- space for all its code
  FOR i: NAT IN [0 .. loadMod.loadInfo.size) DO
   prog: PROGRAM ← LOOPHOLE[loadMod.loadInfo[i].frame];
   space: Space.Handle;
   IF RuntimeInternal.Codebase[prog] ~= NIL THEN {
   space ← Space.GetHandle[
   Space.PageFromLongPointer[RuntimeInternal.Codebase[prog]]];
   IF space ~= Space.nullHandle AND space ~= Space.virtualMemory THEN
   Space.Delete[LoaderPrivate.FindMappedSpace[space]];
   };
   ENDLOOP;
  -- frees the global frames
  PilotLoaderOps.ReleaseFrames[
   loadMod.loadInfo.bcdBase, loadMod.loadInfo.frameList,
   loadMod.loadInfo.map];
  PilotLoaderOps.DestroyMap[loadMod.loadInfo.map]};
  -- frees the bcdBase space
  loadMod.loadInfo ← SMLoad.FreeLoadInfo[loadMod.loadInfo]};
  ENDCASE => NULL;
};

SMVal.VisitNodes[ls.tm, SMVal.OuterBody[root].body, ForEachApply];
IF unloadTheBcd THEN {
DeleteLoadStateEntry[ls, FALSE];
IF nunl > 0 THEN {
 ls.out.PutF["%d modules unloaded.\n", IO.card[nunl]];
 ls.out.PutF["All code spaces and frames have been freed.\nDO NOT TRY TO USE THEM.\n\n"];
 };
}
ELSE { -- detach the fake config from the modeller
ls.configIndex ← PilotLoadStateOps.NullConfig;
ls.fakeBcdSpace ← Space.nullHandle; ls.fakeBcdFileName ← NIL};
ls.started ← FALSE; ls.importedInterfaces ← NIL};
 
-- internal procedures
 
DeleteLoadStateEntry: PROC[ls: LS, replace: BOOL] ~ {
index: PilotLoadStateOps.ConfigIndex ← ls.configIndex;
IF index ~= PilotLoadStateOps.NullConfig THEN {
ENABLE UNWIND => {PilotLoadStateOps.ReleaseLoadState[]};
map: PilotLoadStateOps.Map;
ls.configIndex ← PilotLoadStateOps.NullConfig;
[] ← PilotLoadStateOps.InputLoadState[];
map ← PilotLoadStateOps.GetMap[index];
PilotLoadStateOps.RemoveConfig[map, index];
PilotLoadStateOps.ReleaseMap[map];
PilotLoadStateOps.ReleaseLoadState[]};
IF ~replace AND ls.fakeBcdSpace ~= Space.nullHandle THEN {
Space.Delete[ls.fakeBcdSpace];
ls.fakeBcdSpace ← Space.nullHandle;
Directory.DeleteFile[LOOPHOLE[ls.fakeBcdFileName] ! Directory.Error => {CONTINUE}];
ls.fakeBcdFileName ← NIL};
};

 
-- the load state is locked for the entire time
LoadBcds: PROC[ls: LS, root: Tree.Link] RETURNS [nBcds: NAT ← 0] ~ {
ENABLE UNWIND => {PilotLoadStateOps.ReleaseLoadState[]};
configGfi: PrincOps.GFTIndex ← 1;
 
ForEachApply: SAFE PROC[node, parent: Tree.Link] ~ TRUSTED {
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.localName, FALSE]}
  ENDCASE;
 IF bcd # NIL AND ~bcd.interface THEN {
  loadMod: SMVal.LoadMod ← NARROW[SMVal.GetExtFromParse[node]];
  IF loadMod = NIL THEN loadMod ← (ls.z).NEW[SMVal.LoadModRecord ← []];
  loadMod.proj ← bcd;
  IF ~bcd.Available THEN
  ls.out.PutF["Error - can't load %s (not on the disk)\n", IO.rope[bcd.localName]]
  ELSE IF loadMod.loadInfo = NIL THEN {
  nBcds ← nBcds + 1;
  [loadMod.loadInfo, configGfi] ←
  SMLoad.LoadGlobalFrames[bcd.capability, ls.configIndex, configGfi, ls.out
   ! SMLoad.InvalidFile => {
   ls.out.PutF["Error - invalid bcd %s\n", IO.rope[bcd.localName]];
   REJECT} -- not caught at this level
   ];
  SetUpExports[ls, loadMod]}
  ELSE IF loadMod.mustReplace THEN {
  replaceResult: SMLoad.ReplaceResult ~
  SMLoad.LoadIncremental[bcd.capability, loadMod.loadInfo, ls.out];
  IF replaceResult = $ok THEN {
  loadMod.mustReplace ← FALSE; nBcds ← nBcds + 1;
  SetUpExports[ls, loadMod]} -- gets any newly exported procs
  ELSE ls.out.PutF[
  SELECT replaceResult FROM
   $configNotReplaceable => "Load of %s failed, is a config.\n",
   $frameTooBig => "Load of %s failed, frame too big.\n",
   $ngfiTooBig => "Load of %s failed, # gfis too big.\n",
   $checkForMRFailed => "Load of %s failed, outstanding local frames(?).\n",
   ENDCASE => ERROR,
  IO.rope[bcd.localName]];
  };
  SMVal.PutExtInParse[node, loadMod]};
 };
};

SMVal.VisitNodes[ls.tm, root, ForEachApply]};
  
-- fill in exported interface records from the bcd

SetUpExports: PROC[ls: LS, loadMod: SMVal.LoadMod] ~ {
loadInfo: SMLoad.LoadInfo ~ loadMod.loadInfo;
n: NAT ← 1;
  
ForEachExport: PROC[eth: BcdOps.EXPHandle, eti: BcdDefs.EXPIndex]
 RETURNS[stop: BOOL�LSE] ~ {
ir: SMLoad.IR ~ SMLoad.BuildInterface[loadInfo, eth];
loadInfo.exports[n] ← ir;
n ← n+1};
  
loadInfo.exports ← (ls.z).NEW[SMLoad.IRSeqRecord[loadInfo.bcdBase.nExports+1]];
IF loadInfo.bcdBase.nModules = 1 THEN
-- build interface record for a compiler-produced module
loadInfo.exports[0] ← SMLoad.BuildFramePtrInterface[loadInfo.bcdBase, loadInfo[0].frame];
[] ← BcdOps.ProcessExports[loadInfo.bcdBase, ForEachExport]};
 
-- load state should not be locked

ProcessPlusAndThen: PROC[ls: LS, root: Tree.Link] ~ {
 
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 %s and %s.\n",
  IO.atom[left.name], IO.atom[right.name]];
 RETURN[left]};
result ← SMLoad.AllocateIR[left.name, left.size];
result.stamp ← left.stamp;
result.resolved ← TRUE;
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 %s.\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
 IF EmptyLink[result[i].link] THEN result.resolved ← FALSE;
 ENDLOOP;
};
 
ForEachNode: SAFE PROC[node, parent: Tree.Link] ~ TRUSTED {
SELECT TreeOps.OpName[node] FROM
 $union, $then => {
  left: SMLoad.IR ~ PossibleCoercion[SMVal.ValOfNthSon[node, 1]];
  right: SMLoad.IR ~ PossibleCoercion[SMVal.ValOfNthSon[node, 2]];
  TreeOps.PutExt[node, BinaryOp[left, right, TreeOps.OpName[node]]]};
 $subscript => {
  gb: Tree.Link ~ TreeOps.NthSon[node, 1];
  left: Tree.Link ~ SMVal.ValOf[gb];
  selector: Tree.Name ~ TreeOps.GetName[TreeOps.NthSon[node, 2]];
  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);
  loadMod: SMVal.LoadMod ~ NARROW[SMVal.GetExtFromParse[left]];
  exports: SMLoad.IRSeq ~ loadMod.loadInfo.exports;
  FOR i: NAT IN [0 .. exports.size) DO
  IF exports[i].name = desiredName THEN {
   TreeOps.PutExt[node, exports[i]];
   EXIT};
  REPEAT
   FINISHED =>
   IF typeName # $CONTROL THEN
   ls.out.PutF["Error - %s is not exported by %s.\n",
   IO.atom[selector], IO.rope[loadMod.proj.localName]];
  ENDLOOP;
  };
  IN Tree.BindOp => {
  v: Tree.Link ~ SMVal.Select[left, selector];
  IF v # Tree.null THEN TreeOps.PutExt[node, PossibleCoercion[v]]
  ELSE ls.out.PutF["Error - %s is not a valid selector.\n", IO.atom[selector]]};
  ENDCASE;
  };
 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 ~ CHECKED {
  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.importedInterfaces ← NIL
ELSE {
ls.importedInterfaces ← (ls.z).NEW[SMLoad.IRSeqRecord[n]];
FOR i: NAT IN [1 .. n] DO
 id: Tree.Id ~ NARROW[TreeOps.GetExt[TreeOps.NthSon[formals, i]]];
 type: Tree.Link ~ SMVal.ValOf[SMVal.IdType[id]];
 stamp: TimeStamp.Stamp ← TimeStamp.Null;
 -- examine first son, it is either an apply for a mesa or an fiBcd for a bcd in the model
 WITH SMVal.ValOfNthSon[type, 1] SELECT FROM
  node: Tree.Handle =>
  IF TreeOps.OpName[node] IN Tree.ApplOp THEN
  stamp ← NARROW[TreeOps.GetExt[node], SMProj.Proj].stamp;
  fiBcd: SMFI.BcdFileInfo => stamp ← fiBcd.stamp;
  ENDCASE;
 IF stamp # TimeStamp.Null THEN
  ls.importedInterfaces[i-1] ← GetInterface[ls, stamp];
 ENDLOOP;
};
};

GetInterface: PROC[ls: LS, bcdVers: TimeStamp.Stamp] RETURNS[ir: SMLoad.IR] ~ {
-- called with loadstate locked
linkerIR: CedarLinkerOps.IR;
name: ATOM;
{
[interface~linkerIR, name~name] ← CedarLinkerOps.GetIR[version~bcdVers
  ! Loader.Error => {
   IF type = $versionMismatch THEN {
   ls.out.PutF["Error - version mismatch on %s\n",
     IO.string[LOOPHOLE[message]]];
   PilotLoadStateOps.ReleaseLoadState[];
   GOTO inputForNextIR};
   PilotLoadStateOps.ReleaseLoadState[]; REJECT} -- reject it
  ];
IF linkerIR = NIL THEN {
 -- this is one of
 --  1) an imported module from the loadstate (done on demand; see LookupFrame)
 --  2) an imported interface that is all-INLINES
 --  3) or an imported interface that no one exports (error)
 ir ← NIL}
ELSE {
 ir ← SMLoad.AllocateIR[name, linkerIR.size];
 ir.stamp ← bcdVers;
 FOR i: NAT IN [0 .. ir.size) DO ir[i] ← [link~linkerIR[i]] ENDLOOP};
EXITS
 inputForNextIR => [] ← PilotLoadStateOps.InputLoadState[];
};
RETURN};


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

-- traverses the value tree
ForEachApply: SAFE PROC[node, parent: Tree.Link] ~ TRUSTED {
IF TreeOps.OpName[node] IN Tree.ApplOp THEN
 WITH SMVal.GetExtFromParse[node] SELECT FROM
  loadMod: SMVal.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: SMVal.LoadMod, args: Tree.Link] ~ {
loadInfo: SMLoad.LoadInfo ~ loadMod.loadInfo;
bcdBase: BcdOps.BcdBase ~ loadInfo.bcdBase;
gfiMap: SMLoad.GfiMap ~ loadInfo.gfiMap;
imports: SMLoad.IRSeq ~ loadInfo.imports;
mod, imp: NAT ← 0;
 
ForEachImport: PROC[ith: BcdOps.IMPHandle, iti: BcdDefs.IMPIndex]
  RETURNS[stop: BOOL�LSE] ~ {
 fth: BcdOps.FTHandle ~ @LOOPHOLE[bcdBase + bcdBase.ftOffset, BcdDefs.Base][ith.file];
 FOR i: NAT IN [0 .. ith.ngfi) DO
  gfiMap[ith.gfi + i] ← [index~imp, whichOne~i];
  ENDLOOP;
 -- handle funny cases where two instances of the same interface are imported ???
 IF ith.gfi = gfiMap.size THEN
  gfiMap.size ← gfiMap.size + ith.ngfi;
 imports[imp] ← LookUpInterface[ls, fth.version, imp, args];
 -- imports[imp] may be NIL
 IF FALSE AND imports[imp] = NIL THEN {
  -- generates spurious warnings about Inline, etc.
  sym: Rope.Text ~ SMLoad.NSToRope[bcdBase, ith.name];
  ls.out.PutF["Warning- cannot find exporter of %s anywhere.\n", IO.rope[sym]]};
 imp ← imp + 1};
  
ForEachModule: PROC[mth: BcdOps.MTHandle, mti: BcdDefs.MTIndex]
  RETURNS[stop: BOOL�LSE] ~ {
 resolved: BOOL ← TRUE;
 [] ← SMLoad.OpenLinkSpace[loadInfo[mod].frame, mth, bcdBase];
 FOR i: CARDINAL IN [0 .. PilotLoaderOps.LinkSegmentLength[mth, bcdBase]) DO
  bound: BOOL;
  clink: PrincOps.ControlLink ← SMLoad.ReadLink[i];
  [clink, bound] ← NewLink[
    ls~ls, blink~PilotLoaderOps.IthLink[mth, i, bcdBase],
    oldclink~clink, loadMod~loadMod, frame~loadInfo[mod].frame,
    mth~mth, bcdBase~bcdBase, linkinx~i];
  IF bound THEN SMLoad.WriteLink[offset~i, link~clink]
  ELSE resolved ← FALSE;
  ENDLOOP;
 SMLoad.CloseLinkSpace[loadInfo[mod].frame];
 IF ~resolved THEN loadInfo.linksResolved ← FALSE;
 mod ← mod + 1};
  
IF bcdBase.nImports = 0 THEN RETURN; -- no imports
-- the first part of gfiMap, the map between config gfi's and real gfi's,
-- has already been computed
-- set up map between dummygfi's and the import table
-- IF gfiMap.size > bcdBase.firstdummy THEN ERROR;
gfiMap.size ← bcdBase.firstdummy; -- adjust for dummies to come
[] ← BcdOps.ProcessImports[bcdBase, ForEachImport];
loadInfo.linksResolved ← TRUE;
-- now run thru the frame links looking for imports to fill in
[] ← BcdOps.ProcessModules[bcdBase, ForEachModule]};

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

PossibleCoercion: SAFE PROC[t: Tree.Link] RETURNS[SMLoad.IR] ~ CHECKED {
SELECT TreeOps.OpName[t] FROM
IN Tree.ApplOp => {
 -- this is a coercion, simply use the first export
 loadMod: SMVal.LoadMod ~ NARROW[SMVal.GetExtFromParse[t]];
 RETURN[loadMod.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, bcdVers: TimeStamp.Stamp, imp: NAT, args: Tree.Link]
RETURNS[SMLoad.IR] ~ {
 
LookupOutside: PROC[id: Tree.Id] RETURNS[ir: SMLoad.IR] ~ {
ir ← ls.importedInterfaces[id.p-1]; -- id must be a formal
IF ir = NIL THEN
 ls.out.PutF["Can't import %s from load state\n", IO.atom[SMVal.IdName[id]]];
RETURN};
  
IF TreeOps.OpName[args] # $group THEN ERROR;
IF imp+1 > TreeOps.NSons[args] THEN
RETURN[HiddenImport[ls, args, bcdVers]];
WITH SMVal.ValOfNthSon[args, imp+1] SELECT FROM
node: Tree.Handle => RETURN[PossibleCoercion[node]];
id: Tree.Id => RETURN[LookupOutside[id]];
ENDCASE => ERROR;
};
 

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

CheckArg: TreeOps.Scan ~ CHECKED {
WITH t SELECT FROM
id: Tree.Id => {
type: Tree.Link ~ SMVal.ValOf[SMVal.IdType[id]];
IF TreeOps.OpName[type] IN Tree.ApplOp THEN {
typeArgs: Tree.Link ~ SMVal.ValOfNthSon[type, 2];

  CheckTypeArg: TreeOps.Scan ~ CHECKED {
  WITH SMVal.ValOf[t] SELECT FROM
  node: Tree.Handle => {
   argIr: SMLoad.IR ~ PossibleCoercion[node];
   IF argIr ~= NIL AND argIr.stamp = bcdVers THEN {
   IF ir ~= NIL AND ir ~= argIr THEN
   ls.out.PutF["Ambiguous implicit import of %s\n", IO.atom[ir.name]];
   ir ← argIr};
   };
  ENDCASE;
  CheckArg[t]}; -- multi-level hidden imports

TreeOps.ScanSons[typeArgs, CheckTypeArg]};
};
node: Tree.Handle =>
SELECT TreeOps.OpName[node] FROM
$union, $then => {
CheckArg[TreeOps.NthSon[node, 1]]; CheckArg[TreeOps.NthSon[node, 2]]};
ENDCASE => NULL; -- for now
ENDCASE;
};

TreeOps.ScanSons[args, CheckArg];
-- ir will be NIL here only if implicitly importing instance came from loadstate
IF ir = NIL THEN {
[] ← PilotLoadStateOps.InputLoadState[];
ir ← GetInterface[ls, bcdVers ! UNWIND => {PilotLoadStateOps.ReleaseLoadState[]}];
PilotLoadStateOps.ReleaseLoadState[]};
RETURN};


NewLink: PROC[
 ls: LS, blink: BcdDefs.Link, oldclink: PrincOps.ControlLink,
 loadMod: SMVal.LoadMod,
 frame: PrincOps.GlobalFrameHandle, mth: BcdOps.MTHandle, bcdBase: BcdOps.BcdBase,
 linkinx: CARDINAL]
RETURNS[newclink: PrincOps.ControlLink, resolved: BOOL] ~ {
loadInfo: SMLoad.LoadInfo ~ loadMod.loadInfo;
 
FindLink: PROC[blink: BcdDefs.Link] RETURNS[PrincOps.ControlLink, BOOL] ~ {
IF blink.gfi < loadInfo.bcdBase.firstdummy THEN {
 SELECT blink.vtag FROM
  $proc0, $proc1 => {
  rgfi: PrincOps.GFTIndex ~ loadInfo.gfiMap[blink.gfi].index;
  newclink ← SMLoad.ConvertLink[blink];
  newclink.gfi ← rgfi + loadInfo.gfiMap[blink.gfi].whichOne;
  resolved ← (rgfi ~= PrincOps.GFTNull)};
  $var => {
  [link~newclink] ← CedarLinkerOps.FindVariableLink[
  bcd~loadInfo.bcdBase, mthLink~blink,
  rgfi~loadInfo.gfiMap[blink.vgfi].index];
  resolved ← ~EmptyLink[newclink]};
  ENDCASE => NULL;
 }
ELSE {
 intNo: CARDINAL ~ loadInfo.gfiMap[blink.gfi].index;
 trueEP: CARDINAL ~
  blink.ep + (loadInfo.gfiMap[blink.gfi].whichOne * BcdDefs.EPLimit);
 ir: SMLoad.IR ← loadInfo.imports[intNo];
 IF ir = NIL THEN -- try the module frame table
  loadInfo.imports[intNo] ← ir ← LookupFrame[ls, loadInfo.bcdBase, intNo];
 -- import not satisfied?
 IF ir = NIL OR EmptyLink[ir[trueEP].link] THEN {
  ith: BcdOps.IMPHandle ~ GetImpHandle[loadInfo.bcdBase, intNo];
  fth: BcdOps.FTHandle ~
  @LOOPHOLE[loadInfo.bcdBase + loadInfo.bcdBase.ftOffset, BcdDefs.Base][ith.file];
  sym: Rope.Text ~ SMLoad.NSToRope[loadInfo.bcdBase, ith.name];
  ls.out.PutF["Warning - Unable to resolve import of item #%d from interface %s\n\tof %s ",
  IO.card[trueEP], IO.rope[sym], IO.rope[CS.RopeFromStamp[fth.version]]];
  ls.out.PutF["(the %dth import of %s).\n",
  IO.card[intNo], IO.rope[loadMod.proj.localName]];
  UpdatePendingList[ls, sym, frame, mth, bcdBase, linkinx, trueEP];
  RETURN[oldclink, FALSE]};
-- at this point module and variable links are set to their absolute addresses
newclink ← ir[trueEP].link; resolved ← TRUE};
RETURN[newclink, resolved]};
  
newclink ← oldclink; resolved ← FALSE;
SELECT blink.vtag FROM
$proc0, $proc1,
$var =>
 IF EmptyLink[oldclink] THEN [newclink, resolved] ← FindLink[blink];
ENDCASE => newclink ← LOOPHOLE[blink.typeID];
};

UpdatePendingList: PROC[
 ls: LS,
 name: Rope.Text, frame: PrincOps.GlobalFrameHandle,
 mth: BcdOps.MTHandle, bcdBase: BcdOps.BcdBase, linkinx, trueEP: CARDINAL] ~ {
atom: ATOM ~ Atom.MakeAtom[name];
pending: CedarLinkerOps.PendingList ← CedarLinkerOps.GetPendingList[atom];
-- pendingCount ← pendingCount + 1;
pending ← (ls.z).CONS[[frame, mth, bcdBase, linkinx, LOOPHOLE[trueEP]], pending];
CedarLinkerOps.SetPendingList[atom, pending]};
  
-- intNo starts at 0
GetImpHandle: PROC[bcdBase: BcdOps.BcdBase, intNo: CARDINAL]
RETURNS[ith: BcdOps.IMPHandle] ~ {
RETURN[@LOOPHOLE[bcdBase + bcdBase.impOffset, BcdDefs.Base]
  [LOOPHOLE[intNo*SIZE[BcdDefs.IMPRecord], BcdDefs.IMPIndex]]];
};

LookupFrame: PROC[ls: LS, bcdBase: BcdOps.BcdBase, intNo: CARDINAL]
RETURNS[SMLoad.IR] ~ {
ith: BcdOps.IMPHandle ~ GetImpHandle[bcdBase, intNo];
fth: BcdOps.FTHandle ~ @LOOPHOLE[bcdBase + bcdBase.ftOffset, BcdDefs.Base][ith.file];
name: ATOM ~ Atom.MakeAtom[SMLoad.NSToRope[bcdBase, ith.name]];
version: TimeStamp.Stamp ~ fth.version;
ir: SMLoad.IR;
clink: PrincOps.ControlLink;
old: REF BcdDefs.VersionStamp;
FOR l: LIST OF REF FrameListRecord ← ls.frameInterfaces, l.rest UNTIL l = NIL DO
IF l.first.stamp = version AND l.first.ir.name = name THEN
 RETURN[l.first.ir];
ENDLOOP;
old ← (ls.z).NEW[BcdDefs.VersionStamp ← version];
Atom.PutProp[name, $version, old];
-- try for imported module, this is very expensive
clink ← LoaderPrivate.GetModuleLink[atom~name];
IF ~EmptyLink[clink] THEN { -- found
ir ← SMLoad.AllocateIR[name, 1];
ir[0] ← [link~clink];
ir.stamp ← version}
ELSE ir ← NIL;
-- caches result so GetModuleLink is only called once per name
ls.frameInterfaces ← (ls.z).CONS[(ls.z).NEW[FrameListRecord ←
 [stamp~version, ir~ir]], ls.frameInterfaces];
RETURN[ir]};


-- call Paul Rovner's procedure to fixup the Cedar Atoms and Ropes section
ProcessCedarBcds: PROC[ls: LS, root: Tree.Link] ~ {

-- traverses the value tree
ForEachApply: SAFE PROC[node, parent: Tree.Link] ~ TRUSTED {
IF TreeOps.OpName[node] IN Tree.ApplOp THEN
 WITH SMVal.GetExtFromParse[node] SELECT FROM
  loadMod: SMVal.LoadMod => {
  loadInfo: SMLoad.LoadInfo ~ loadMod.loadInfo;
  bcdBase: BcdOps.BcdBase;
  IF loadInfo = NIL OR loadInfo.rtStarted THEN RETURN;
  bcdBase ← loadInfo.bcdBase;
  IF ~bcdBase.extended THEN RETURN;
  RTLoader.AcquireTypesAndLiterals[bcd~bcdBase, map~loadInfo.map];
  loadInfo.rtStarted ← TRUE};
  ENDCASE => NULL;
};

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

StartElemRecord: TYPE ~ RECORD [
prog: PROGRAM,
frame: PrincOps.GlobalFrameHandle];
 
Started: PUBLIC SAFE PROC[ls: LS] RETURNS[BOOL] ~ CHECKED {
RETURN [Loaded[ls] AND ls.started]};

StartAll: PUBLIC SAFE PROC[ls: LS, root: Tree.Link] ~ TRUSTED {
starr: LIST OF REF StartElemRecord;
prog: PROGRAM;
dontFork: BOOL ← TRUE;
 
-- traverses the value tree
ForEachNode: SAFE PROC[node, parent: Tree.Link] ~ CHECKED {
IF SMVal.Binding[node] THEN {
d: Tree.Link ~ SMVal.BtoD[node];
g: Tree.Link ~ SMVal.BtoG[node];
p: NAT ← 0;

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

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

StartModule: PROC[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: SMVal.LoadMod => {
   FOR i: NAT IN [0 .. loadMod.loadInfo.size) DO
   Runtime.ValidateGlobalFrame[loadMod.loadInfo[i].frame];
   IF loadMod.loadInfo[i].frame.started THEN {
   ls.out.PutF["Error - %s has already been started.\n",
   IO.rope[loadMod.proj.localName]];
   RETURN};
   ENDLOOP;
   ls.out.PutF["Will start %s\n", IO.rope[loadMod.proj.localName]];
   prog ← LOOPHOLE[loadMod.loadInfo.cm];
   starr ← (ls.z).CONS[(ls.z).NEW[StartElemRecord ← [
   prog~prog, frame~loadMod.loadInfo[0].frame]], starr];
   };
  ENDCASE;
  $subscript => StartModule[SMVal.ValOfNthSon[node, 1]];
  ENDCASE;
  };
 ENDCASE => NULL;
};

SMVal.VisitNodes[ls.tm, SMVal.OuterBody[root].body, ForEachNode];
starr ← LOOPHOLE[List.DReverse[LOOPHOLE[starr]]];
IF dontFork THEN StartProcedure[ls, starr]
ELSE Process.Detach[FORK StartProcedure[ls, starr]];
};
 
-- this procedure may be forked
StartProcedure: PROC[ls: LS, starr: LIST OF REF StartElemRecord] ~ {
i: CARDINAL ← 0;
ls.started ← TRUE;
{
ENABLE ABORTED, IO.UserAborted => {GOTO aborted};
FOR l: LIST OF REF StartElemRecord ← starr, l.rest UNTIL l = NIL DO
 i ← i + 1;
 IF l.first.frame.started THEN
  ls.out.PutF["Error - element %d of start list has already been started.\n", IO.card[i]]
 ELSE START l.first.prog;
 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]]};

}.


-- code not yet ready (needs additions to SMOps.MS or Global)

PutExportsInLoadState: PROC[g: SM.Global] ~ {
mi: SM.MI;
FOR l: SM.ModuleList ← g.moduleList, l.rest UNTIL l = NIL DO
mi ← l.first;
IF mi.exportedInterface THEN {
 FOR l: LIST OF SMLoad.IR ← g.moduleExports, l.rest UNTIL l = NIL DO
  IF l.first.bcdVers = mi.bcdVers THEN {
  AddInterfaceToLoadState[g, l.first];
  -- g.ttyout.PutF["%s exported into load state.\n", IO.rope[l.first.name]];
  EXIT};
  REPEAT
  FINISHED =>
  g.ttyout.PutF["Error - cannot find %s exported by this program.\n",
    IO.rope[mi.fileName]];
  ENDLOOP;
 };
ENDLOOP;
-- process any pendings we have found
IF g.toBeProcessed ~= NIL THEN
CedarExporterImpl.ProcessPendingEntries[g.toBeProcessed];
};

AddInterfaceToLoadState: PROC[g: SM.Global, ir: SMLoad.IR] ~ {
atom: ATOM ~ Atom.MakeAtom[ir.name];
pending: CedarLinkerOps.PendingList;
linkerIR: CedarLinkerOps.IR ~ CedarLinkerOps.GetIR[atom, ir.stamp, ir.size].interface;
FOR i: NAT IN [0 .. ir.size) DO
IF ~EmptyLink[ir[i].link] THEN linkerIR[i] ← ir[i].link;
ENDLOOP;
-- fill in any importers
pending ← CedarLinkerOps.GetPendingList[atom];
IF pending ~= NIL THEN {
[g.toBeProcessed, pending] ←
CedarExporterImpl.SaveResolvedEntries[g.toBeProcessed, pending, linkerIR];
CedarLinkerOps.SetPendingList[atom, pending]};
};