<> <> <> 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]]]}; <> 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]; <> IF Loaded[ls] THEN DeleteLoadStateEntry[ls, replace]; IF ~replace THEN { <> 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 { <> <> 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 { <> 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 { <> <> 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]; <> 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[]]]]}; }; <> BaseAddress: PROC[interval: VM.Interval] RETURNS[BcdDefs.BcdBase] ~ TRUSTED { RETURN[VM.AddressForPageNumber[interval.page]]}; DeleteLoadStateEntry: PROC[ls: LS, replace: BOOL] ~ { <> IF ~replace THEN ls.config _ LoadState.nullConfig}; <> 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 <> loadInfo.exports[0] _ SMLoad.BuildFramePtrInterface[loadInfo]; [] _ BcdOps.ProcessExports[bcd, ForEachExport]}; <> ProcessPlusAndThen: PROC[ls: LS, root: Tree.Link] ~ { <> Eval: PROC[t: Tree.Link] RETURNS[SMLoad.IR] ~ { SELECT TreeOps.OpName[t] FROM IN Tree.ApplOp => { <> 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 { <> 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]}; <> InputActuals: PROC[ls: LS, formals: Tree.Link] ~ { <> 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; <> 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] ~ { <> 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 { <> <<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 { <> 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 => { <> 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; <> }; 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]; <> 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]; <> 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]}; <> LoadInfo: TYPE~SMLoad.LoadInfo; LoadInfoRecord: PUBLIC TYPE~SMLoad.LoadInfoRecord; LoadedModule: PUBLIC PROC[info: LoadInfo] RETURNS[BOOL] ~ { RETURN[info # NIL AND info.nModules = 1]}; <> 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] ~ { <> 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["\n"]}; <> Unload: PUBLIC PROC[ls: LS, root: Tree.Link, unloadTheBcd: BOOL] ~ { <<****>> <> ls.config _ LoadState.nullConfig; ls.modelBcd _ NIL; ls.started _ FALSE; ls.modelActuals _ NIL}; }.