MimP5InstallImpl.mesa
Copyright Ó 1987, 1988, 1989, 1990, 1991, 1993 by Xerox Corporation. All rights reserved.
Russ Atkinson (RRA) June 1, 1991 1:03 pm PDT
Foote, May 19, 1993 9:32 am PDT
DIRECTORY
Alloc,
IntCodeDefs,
IntCodeStuff,
IntCodeUtils,
LiteralOps,
MimCode,
MimData,
MimP5,
MimP5U,
MimP5Install USING [],
MimZones,
MobDefs,
Pass4ToPass5,
RCMap,
RCMapEncode,
RefText,
Rope,
SymbolOps,
Symbols,
SymLiteralOps,
Target: TYPE MachineParms,
TargetConversions,
TypeStrings;
MimP5InstallImpl:
PROGRAM
IMPORTS Alloc, IntCodeStuff, IntCodeUtils, LiteralOps, MimData, MimP5, MimP5U, MimZones, Pass4ToPass5, RCMapEncode, RefText, Rope, SymbolOps, SymLiteralOps, TargetConversions, TypeStrings
EXPORTS MimP5Install
= BEGIN
newStyle:
BOOL ¬
FALSE;
Set this TRUE when we have loader support!
RRA: May 21, 1989 2:28:32 pm PDT
smallStyle:
BOOL ¬
FALSE;
Set this TRUE when we have loader support!
canHandleAddr:
BOOL ¬
FALSE;
Set this TRUE when we have C2C support!
RRA: September 7, 1989 6:46:33 pm PDT
canHandleFields:
BOOL ¬
FALSE;
Set this TRUE when we have C2C support!
RRA: September 7, 1989 8:24:58 pm PDT
CodeList: TYPE = MimCode.CodeList;
LocationRep: TYPE = IntCodeDefs.LocationRep;
Node: TYPE = IntCodeDefs.Node;
NodeList: TYPE = IntCodeDefs.NodeList;
NodeRep: TYPE = IntCodeDefs.NodeRep;
OperRep: TYPE = IntCodeDefs.OperRep;
ROPE: TYPE = Rope.ROPE;
Type:
TYPE = Symbols.Type;
nullType: Type = Symbols.nullType;
Var: TYPE = IntCodeDefs.Var;
bitsPerWord: NAT = Target.bitsPerWord;
bytesPerWord: NAT = Target.bitsPerWord/Target.bitsPerChar;
z: ZONE ¬ IntCodeUtils.zone;
runtimePrefix:
ROPE ¬ "XR←";
note: the '← is actually a '← with postfix prop: "Modern" family XCPrintFonts
lagNum: NAT = 12;
lagNames:
REF LagNamesArray ¬
NIL;
LagNamesArray: TYPE = ARRAY [0..lagNum) OF ROPE;
lagOpers:
REF LagOpersArray ¬
NIL;
LagOpersArray: TYPE = ARRAY [0..lagNum) OF Node;
assumeGlobalsInitZero: BOOL ¬ TRUE;
GenInstallationProc:
PUBLIC
PROC
[name:
ROPE, gfType: Symbols.Type, module: IntCodeDefs.ModuleNode] = {
cl: CodeList ¬ MimP5U.NewCodeList[];
typeCache: TypeCache ¬ z.NEW[TypeCacheRep ¬ []];
eachType: SymLiteralOps.TypesVisitor = {
IF used
THEN {
dest: Node ¬ MimP5.Exp[SymLiteralOps.TypeRef[type]];
destVar: Var ¬ NARROW[dest];
IF lastType = Symbols.nullType
OR
NOT SymbolOps.EqTypes[SymbolOps.own, type, lastType]
THEN {
For each type we emit the initialization using the type string and RC map
dest: Node ¬ MimP5.Exp[SymLiteralOps.TypeRef[type]];
destVar: Var ¬ NARROW[dest];
MimP5U.MoreCode[cl, MimP5U.Assign[
lhs: destVar,
rhs: EmitType[type, typeCache]]];
}
ELSE {
src: Node ¬ MimP5.Exp[SymLiteralOps.TypeRef[lastType]];
srcVar: Var ¬ NARROW[src];
MimP5U.MoreCode[cl, MimP5U.Assign[
lhs: destVar,
rhs: srcVar]];
};
lastType ¬ type;
};
};
eachRefLit: SymLiteralOps.RefLitsVisitor = {
[item: RefLitItem, type: Symbols.Type, used: BOOL]
IF used
THEN {
dest: Node;
ss: SymbolOps.SubString;
WITH item
SELECT
FROM
atom => {
ss ¬ SymbolOps.SubStringForName[SymbolOps.own, pName];
dest ¬ MimP5.Exp[SymLiteralOps.AtomRef[pName]];
};
text => {
str: LONG STRING ¬ LiteralOps.StringValue[value];
ss ¬ [str, 0, str.length];
dest ¬ MimP5.Exp[SymLiteralOps.TextRef[value]];
};
ENDCASE => ERROR;
Note: perform an initializing counted assignment to the slot in the global frame.
MimP5U.MoreCode[cl, MimP5U.ApplyOp[
MimP5U.CedarOpNode[simpleAssignInit],
MimP5U.MakeNodeList2[
MimP5U.Address[dest],
InstallCall[name: "GetRefLiteral",
n1: MimP5.Exp[SymLiteralOps.TypeRef[type]],
n2: EmitString[ss, mesa, writer],
bits: Target.bitsPerRef]]]];
};
};
offset, length: CARD;
uz: UNCOUNTED ZONE ¬ MimZones.tempUZ;
writer: TargetConversions.Writer ¬ TargetConversions.NewWriter[];
buffer: REF TEXT ¬ RefText.New[50];
zero: Node ¬ MimP5U.MakeConstInt[0];
base: RCMap.Base = MimP5U.GetRCMapBase[];
typesVar: Var ¬ NIL;
label: IntCodeDefs.Label ¬ MimP5U.AllocLabel[];
lastType: Type ¬ Symbols.nullType;
CountArgs:
PROC [seb: Symbols.Base, cse: Symbols.CSEIndex]
RETURNS [
INT] =
TRUSTED {
count: INT ¬ 0;
IF cse # Symbols.CSENull
THEN
WITH se: seb[cse]
SELECT
FROM
record => count ¬ SymbolOps.CtxEntries[SymbolOps.own, se.fieldCtx];
ENDCASE => ERROR;
RETURN [count];
};
HandleImportsExports:
PROC [parent: IntCodeDefs.Label] = {
importsVisitor: Pass4ToPass5.ImportsVisitor = {
[mdi: Symbols.MDIndex, formal: Symbols.Name, irSei: Symbols.ISEIndex, irType: Symbols.CSEIndex, sei: Symbols.ISEIndex, link: MobDefs.Link]
seb: Symbols.Base = Alloc.Bounds[MimData.table, Symbols.seType].base;
IF lastMdi # mdi
THEN {
irPtr ¬ NIL;
WITH se: seb[irType]
SELECT
FROM
definition => {
slots ¬ se.slots;
irPtr ¬ MimP5.VarForInterface[link.modIndex];
IF irLocal =
NIL
THEN
irLocal ¬ NewLocalTemp[cl, parent, Target.bitsPerRef];
IF (newStyle
OR MimData.switches['k])
AND formal # seb[irSei].hash
THEN {
MimP5U.MoreCode[cl, MimP5U.Assign[
irLocal,
InstallCall[name: "ImportInterfaceX",
n1: EmitName[formal, c, writer],
n2: EmitName[seb[irSei].hash, c, writer],
n3: EmitType[irType, typeCache],
n4: MimP5U.MakeConstInt[slots],
bits: Target.bitsPerRef]]];
}
ELSE {
MimP5U.MoreCode[cl, MimP5U.Assign[
irLocal,
InstallCall[name: "ImportInterface",
n1: EmitName[formal, c, writer],
n2: EmitType[irType, typeCache],
n3: MimP5U.MakeConstInt[slots],
bits: Target.bitsPerRef]]];
};
MimP5U.MoreCode[cl, MimP5U.Assign[irPtr, irLocal]];
};
ref => {
This is an imported module
ut: Type = MimP5.Clarify[se.refType];
linkVar: Var ¬ MimP5.VarForLink[link, Target.bitsPerRef];
IF (newStyle
OR MimData.switches['k])
AND formal # seb[irSei].hash
THEN {
MimP5U.MoreCode[cl,
InstallCall[name: "ImportProgramX",
n1: EmitName[formal, c, writer],
n2: EmitName[seb[irSei].hash, c, writer],
n3: EmitType[ut, typeCache],
n4: MimP5U.Address[linkVar],
bits: Target.bitsPerRef]];
}
ELSE {
MimP5U.MoreCode[cl,
InstallCall[name: "ImportProgram",
n1: EmitName[formal, c, writer],
n2: EmitType[ut, typeCache],
n3: MimP5U.Address[linkVar],
bits: Target.bitsPerRef]];
};
};
ENDCASE;
lastMdi ¬ mdi;
};
IF ~seb[sei].constant
THEN {
ut: Symbols.CSEIndex = MimP5.Clarify[seb[sei].idType];
linkVar: Var ¬ MimP5.VarForLink[link, MimP5U.BitsForType[ut]];
SELECT link.tag
FROM
proc => {
ut: Symbols.CSEIndex = MimP5.Clarify[seb[sei].idType];
WITH se: seb[ut]
SELECT
FROM
transfer =>
IF se.mode = proc
THEN {
ImportProc[irPtr, index, unitsOut, unitsIn, argCount]
unitsOut: CARD = SymbolOps.AUsForType[SymbolOps.own, se.typeOut];
unitsIn: CARD = SymbolOps.AUsForType[SymbolOps.own, se.typeIn];
index: CARD ¬ link.offset;
nargs: CARD = CountArgs[seb, se.typeIn];
IF index >= slots THEN ERROR;
IF (smallStyle
OR MimData.switches['k])
AND unitsOut < 256
AND unitsIn < 256
AND index < 256
AND nargs < 256
THEN {
Special case where all constant arguments are < 256 and can be encoded in a single word. Encoding is the same for ImportProcS and ExportProcS.
encoded: CARD = unitsOut*(256*LONG[256]*256)
+ unitsIn*(256*LONG[256])
+ index*256
+ nargs;
MimP5U.MoreCode[cl, InstallCall[
name: "ImportProcS",
n1: irLocal,
n2: MimP5U.MakeConstCard[encoded]
]];
}
ELSE
MimP5U.MoreCode[cl, InstallCall[
name: "ImportProc",
n1: irLocal,
n2: MimP5U.MakeConstInt[index],
n3: MimP5U.MakeConstInt[unitsOut],
n4: MimP5U.MakeConstInt[unitsIn],
n5: MimP5U.MakeConstInt[nargs]
]];
};
ENDCASE;
};
ENDCASE;
};
};
exportsVisitor: Pass4ToPass5.ExportsVisitor = {
[mdi: Symbols.MDIndex, formal: Symbols.Name, irSei: Symbols.ISEIndex, irType: Symbols.CSEIndex, ts: TypeStrings.TypeString, sei: Symbols.ISEIndex, link: MobDefs.EXPLink]
seb: Symbols.Base = Alloc.Bounds[MimData.table, Symbols.seType].base;
index: CARD = link.to;
indexExp: Node = MimP5U.MakeConstCard[index];
IF lastMdi # mdi
THEN {
irPtr ¬ NIL;
WITH t: seb[irType]
SELECT
FROM
definition => {
slots ¬ t.slots;
irPtr ¬ MimP5.VarForInterface[link.from.modIndex];
IF irLocal =
NIL
THEN
irLocal ¬ NewLocalTemp[cl, parent, Target.bitsPerRef];
IF (newStyle
OR MimData.switches['k])
AND formal # seb[irSei].hash
THEN {
MimP5U.MoreCode[cl, MimP5U.Assign[
irLocal,
InstallCall[name: "ExportInterfaceX",
n1: EmitName[formal, c, writer],
n2: EmitName[seb[irSei].hash, c, writer],
n3: EmitType[irType, typeCache],
n4: MimP5U.MakeConstInt[slots],
bits: Target.bitsPerRef]]];
}
ELSE {
MimP5U.MoreCode[cl, MimP5U.Assign[
irLocal,
InstallCall[name: "ExportInterface",
n1: EmitName[formal, c, writer],
n2: EmitType[irType, typeCache],
n3: MimP5U.MakeConstInt[slots],
bits: Target.bitsPerRef]]];
};
MimP5U.MoreCode[cl, MimP5U.Assign[irPtr, irLocal]];
};
ENDCASE;
lastMdi ¬ mdi;
};
SELECT link.from.tag
FROM
var => {
ExportVar[irPtr, index, addr]
expr: Node ¬ MimP5U.Address[MimP5.Exp[[symbol[sei]]]];
IF index >= slots THEN ERROR;
MimP5U.MoreCode[cl,
InstallCall[name: "ExportVar",
n1: irLocal,
n2: indexExp,
n3: expr]];
};
proc => {
ut: Symbols.CSEIndex = MimP5.Clarify[seb[sei].idType];
expr: Node ¬ MimP5.Exp[[symbol[sei]]];
IF index >= slots THEN ERROR;
WITH se: seb[ut]
SELECT
FROM
transfer =>
SELECT se.mode
FROM
signal, error => {
WITH expr
SELECT
FROM
apply: IntCodeDefs.ApplyNode =>
WITH apply.proc
SELECT
FROM
oper: IntCodeDefs.OperNode =>
WITH oper.oper
SELECT
FROM
mesa: IntCodeDefs.MesaOper =>
IF mesa.mesa = addr
THEN
WITH apply.args.first
SELECT
FROM
var: Var => {
MimP5U.MoreCode[cl, InstallCall[
name: "ExportVar",
n1: irLocal,
n2: indexExp,
n3: expr
]];
RETURN;
};
ENDCASE;
ENDCASE;
ENDCASE;
ENDCASE;
ERROR;
The error or signal value should have been the address of a variable!
};
proc => {
ExportProc[irPtr, index, proc, unitsOut, unitsIn, argCount]
unitsOut: CARD = SymbolOps.AUsForType[SymbolOps.own, se.typeOut];
unitsIn: CARD = SymbolOps.AUsForType[SymbolOps.own, se.typeIn];
nargs: CARD = CountArgs[seb, se.typeIn];
name: Node ← EmitName[seb[sei].hash, c, writer];
IF (smallStyle
OR MimData.switches['k])
AND unitsOut < 256
AND unitsIn < 256
AND index < 256
AND nargs < 256
THEN {
Special case where all constant arguments are < 256 and can be encoded in a single word. Encoding is the same for ExportProcS and ImportProcS.
encoded: CARD = unitsOut*(256*LONG[256]*256)
+ unitsIn*(256*LONG[256])
+ index*256
+ nargs;
The ppcr incremental loader can't lookup symbols by value, so to give the runtime a chance to maintain a load state we include the name of the exported procedure in the ExportProc call. There's staging trickery here to keep from hurting XSoft. We rely on the fact that none of the currently interesting C compilers complain about a mismatch in the number of arguments to a C procedure. Then we use a macro in InstallationSupport.h to split uses of ExportProcS into ExportProcS and ExportProcSWithName in code generated by this new code.
MimP5U.MoreCode[cl, InstallCall[
name: "ExportProcS",
n1: irLocal,
n2: expr,
n3: MimP5U.MakeConstCard[encoded],
n4: name
]]
}
ELSE
MimP5U.MoreCode[cl, InstallCall[
name: "ExportProc",
n1: irLocal,
n2: indexExp,
n3: expr,
n4: MimP5U.MakeConstInt[unitsOut],
n5: MimP5U.MakeConstInt[unitsIn],
n6: MimP5U.MakeConstInt[nargs],
n7: name
]];
RETURN;
};
ENDCASE => ERROR;
ENDCASE => ERROR;
};
type => {
ExportType[name, absType, concType]
name: Node ¬ EmitName[seb[sei].hash, c, writer];
absType: Node ¬ EmitGetTypeIndex[ts, zero, writer];
concType: Node ¬ EmitType[MimP5.Clarify[sei], typeCache];
MimP5U.MoreCode[cl,
InstallCall[name: "ExportType",
n1: name,
n2: absType,
n3: concType]];
};
other => {
ExportVar[irPtr, index, val] {for programs}
expr: Node ¬ MimP5.Exp[[symbol[sei]]];
SELECT SymbolOps.XferMode[SymbolOps.own, seb[sei].idType]
FROM
program => {};
ENDCASE => ERROR;
MimP5U.MoreCode[cl,
InstallCall[name: "ExportVar",
n1: irLocal,
n2: indexExp,
n3: expr]];
};
ENDCASE => ERROR;
};
lastMdi: Symbols.MDIndex ¬ Symbols.MDNull;
irPtr: Var ¬ NIL;
irLocal: Var ¬ NIL;
slots: NAT ¬ 0;
Pass4ToPass5.VisitImports[importsVisitor];
lastMdi ¬ Symbols.MDNull;
Pass4ToPass5.VisitExports[exportsVisitor];
};
lagNames ¬ z.NEW[LagNamesArray ¬ ALL[NIL]];
lagOpers ¬ z.NEW[LagOpersArray ¬ ALL[NIL]];
First we need to initialize the descriptor bodies for all of the top-level procedures
FOR each: NodeList ¬ module.procs, each.rest
WHILE each #
NIL
DO
WITH each.first
SELECT
FROM
labNode: IntCodeDefs.LabelNode =>
WITH labNode.label.node
SELECT
FROM
lambda: IntCodeDefs.LambdaNode =>
IF lambda.parent =
NIL
THEN {
Now initialize the procedure
bti: Symbols.CBTIndex ¬ LOOPHOLE[labNode.label.id];
body: Node ¬ MimP5.ProcDescForBti[bti: bti, body: TRUE];
MimP5U.MoreCode[cl, MimP5U.Assign[
lhs: MimP5U.TakeFieldVar[body, 0, bitsPerWord],
rhs: MimP5.ProcLabelForBti[bti: bti, direct: FALSE]]];
IF
NOT assumeGlobalsInitZero
THEN
MimP5U.MoreCode[cl, MimP5U.Assign[
lhs: MimP5U.TakeFieldVar[body, bitsPerWord, bitsPerWord],
rhs: zero]];
};
ENDCASE;
ENDCASE;
ENDLOOP;
typeCache.typeVar ← NewLocalTemp[cl, label];
typeCache.writer ¬ writer;
[offset, length] ¬ SymLiteralOps.DescribeTypes[];
SymLiteralOps.EnumerateTypes[eachType];
Emit code to initialize all of the type variables
SymLiteralOps.EnumerateRefLits[eachRefLit];
Emit code to initialize all of the REF literals (should not cause more types)
Now emit the code to declare the global frame
MimP5U.MoreCode[cl,
InstallCall[name: "DeclareGlobalFrame",
n1: EmitRope[name, c, writer],
n2: MimP5U.MesaOpNode[op: globalFrame, bits: Target.bitsPerLongPtr],
n3: EmitType[gfType, typeCache],
n4: MimP5.ProcDescForBti[Symbols.RootBti]]];
Now emit the code to handle the imports & exports
HandleImportsExports[label];
{
Create the installation procedure (no descriptor body needed!)
body: NodeList ¬ MimP5U.ExtractList[cl];
ConstantRhs:
PROC [node: Node, addrOK:
BOOL]
RETURNS [
BOOL] = {
WITH node
SELECT
FROM
const: REF NodeRep.const => RETURN [TRUE];
var: Var =>
WITH var.location
SELECT
FROM
comp:
REF LocationRep.composite => {
FOR each: NodeList ¬ comp.parts, each.rest
WHILE each #
NIL
DO
IF NOT ConstantRhs[each.first, addrOK] THEN RETURN [FALSE];
ENDLOOP;
RETURN [TRUE];
};
field:
REF LocationRep.field =>
IF canHandleFields
THEN
WITH field.base
SELECT
FROM
const: REF NodeRep.const => RETURN [TRUE];
ENDCASE;
dummy: REF LocationRep.dummy => RETURN [TRUE];
ENDCASE;
apply:
REF NodeRep.apply =>
IF apply.handler =
NIL
THEN
WITH apply.proc
SELECT
FROM
oper:
REF NodeRep.oper =>
WITH oper.oper
SELECT
FROM
mesa:
REF OperRep.mesa =>
SELECT mesa.mesa
FROM
addr =>
IF addrOK
THEN
RETURN [IsGlobalLoc[apply.args.first]
OR ConstantRhs[apply.args.first, FALSE]];
all => RETURN [ConstantRhs[apply.args.first, FALSE]
AND ConstantRhs[apply.args.rest.first, FALSE]];
ENDCASE;
ENDCASE;
ENDCASE;
opNode:
REF NodeRep.oper =>
WITH opNode.oper
SELECT
FROM
code: REF OperRep.code => RETURN [TRUE];
ENDCASE;
ENDCASE;
RETURN [FALSE];
};
IsGlobalLoc:
PROC [node: Node]
RETURNS [
BOOL] = {
DO
WITH node
SELECT
FROM
var: Var =>
WITH var.location
SELECT
FROM
gv: REF LocationRep.globalVar => RETURN [TRUE];
field: REF LocationRep.field => {node ¬ field.base; LOOP};
ENDCASE;
ENDCASE;
RETURN [FALSE];
ENDLOOP;
};
GlobalDisjoint:
PROC [gVar: Node]
RETURNS [
BOOL] = {
id: INT ¬ 0;
gStart: INT ¬ 0;
gLen: INT ¬ gVar.bits;
DO
WITH gVar
SELECT
FROM
var: Var =>
WITH var.location
SELECT
FROM
gv: REF LocationRep.globalVar => {id ¬ var.id; EXIT};
field:
REF LocationRep.field => {
gStart ¬ gStart + field.start;
gVar ¬ field.base;
LOOP;
};
ENDCASE;
ENDCASE;
ERROR;
ENDLOOP;
FOR each: NodeList ¬ keptList, each.rest
WHILE each #
NIL
DO
eVar: Node ¬ each.first;
eStart: INT ¬ 0;
eLen: INT ¬ eVar.bits;
DO
WITH eVar
SELECT
FROM
var: Var =>
WITH var.location
SELECT
FROM
gv:
REF LocationRep.globalVar => {
IF id # var.id THEN RETURN [TRUE];
IF (eStart+eLen) <= gStart THEN RETURN [TRUE];
IF (gStart+gLen) <= eStart THEN RETURN [TRUE];
RETURN [FALSE];
};
field:
REF LocationRep.field => {
eStart ¬ eStart + field.start;
eVar ¬ field.base;
LOOP;
};
ENDCASE;
ENDCASE;
ERROR;
ENDLOOP;
ENDLOOP;
RETURN [TRUE];
};
DoList:
PROC [list: NodeList]
RETURNS [
BOOL] = {
FOR each: NodeList ¬ list, each.rest
WHILE each #
NIL
DO
WITH each.first
SELECT
FROM
comment: REF NodeRep.comment => LOOP;
source:
REF NodeRep.source =>
IF DoList[source.nodes] THEN LOOP;
block:
REF NodeRep.block =>
IF DoList[block.nodes] THEN LOOP;
assn:
REF NodeRep.assign =>
IF IsGlobalLoc[assn.lhs]
AND IntCodeUtils.SideEffectFree[assn.rhs,
FALSE]
THEN {
IF ConstantRhs[assn.rhs, canHandleAddr]
AND GlobalDisjoint[assn.lhs]
AND assn.rhs.bits = bitsPerWord
THEN {
Move the assignment from the initialization procedure to the installation procedure.
new: NodeList ¬ IntCodeUtils.NodeListCons[assn, NIL];
IF tail = NIL THEN head ¬ new ELSE tail.rest ¬ new;
tail ¬ new;
each.first ¬ movedComment;
};
keptList ¬ IntCodeUtils.NodeListCons[assn.lhs, keptList];
LOOP;
};
ENDCASE;
RETURN [FALSE];
ENDLOOP;
RETURN [TRUE];
};
movedComment: Node = IntCodeStuff.GenComment["moved to installation proc"];
head: NodeList ¬ NIL;
tail: NodeList ¬ NIL;
keptList: NodeList ¬ NIL;
WITH module.procs.first
SELECT
FROM
initLab: IntCodeDefs.LabelNode =>
WITH initLab.label.node
SELECT
FROM
initLambda: IntCodeDefs.LambdaNode => {
[] ¬ DoList[initLambda.body];
IF tail # NIL THEN {tail.rest ¬ body; body ¬ head};
};
ENDCASE => ERROR;
ENDCASE => ERROR;
label.node ¬ z.NEW[NodeRep.lambda ¬ [details: lambda[
parent: NIL,
descBody: NIL,
kind: install,
bitsOut: 0,
formalArgs: NIL,
body: body]]];
};
Insert the installation procedure into the module
module.procs ¬ MimP5U.MakeNodeList[
z.NEW[NodeRep.label ¬ [0, label[label]]],
module.procs];
z.FREE[@lagNames];
z.FREE[@lagOpers];
};
NewLocalTemp:
PROC [cl: CodeList, parent: IntCodeDefs.Label, bits:
INT ¬ Target.bitsPerRef]
RETURNS [Var] = {
v: Var ¬ MimP5U.MakeTemp[cl, bits].var;
WITH v.location
SELECT
FROM
local: IntCodeDefs.LocalVarLocation => local.parent ¬ parent;
ENDCASE => ERROR;
RETURN [v];
};
TypeCache: TYPE = REF TypeCacheRep;
TypeCacheRep:
TYPE =
RECORD [
writer: TargetConversions.Writer ¬ NIL,
lastType: Type ¬ nullType,
typeVar: Var ¬ NIL,
probes: INT ¬ 0,
misses: INT ¬ 0
];
EmitType:
PROC [type: Type, typeCache: TypeCache]
RETURNS [Node] = {
zero: Node ¬ MimP5U.MakeConstInt[0];
node: Node ¬ zero;
IF type # nullType
THEN {
typeVar: Var = typeCache.typeVar;
typeCache.probes ¬ typeCache.probes + 1;
IF typeVar #
NIL
AND typeCache.lastType = type
THEN
RETURN [typeVar];
typeCache.misses ¬ typeCache.misses + 1;
{
uz: UNCOUNTED ZONE ¬ MimZones.tempUZ;
ts: TypeStrings.TypeString ¬ TypeStrings.Create[SymbolOps.own, type, uz];
rcMap: RCMap.Index ¬ MimP5U.RCMapForType[type];
IF rcMap # RCMap.nullIndex
THEN {
buffer: REF TEXT ¬ RefText.ObtainScratch[50];
base: RCMap.Base = MimP5U.GetRCMapBase[];
buffer ¬ RCMapEncode.MapToDesc[base, rcMap, buffer];
node ¬ EmitRope[LOOPHOLE[buffer], mesa, typeCache.writer];
RefText.ReleaseScratch[buffer];
};
node ¬ EmitGetTypeIndex[ts, node, typeCache.writer];
uz.FREE[@ts];
};
typeCache.lastType ¬ type;
IF typeVar #
NIL
THEN
node ¬ IntCodeStuff.GenAssign[typeVar, node, typeVar.bits];
};
RETURN [node];
};
EmitGetTypeIndex:
PROC
[ts: TypeStrings.TypeString, rcmap: Node, writer: TargetConversions.Writer]
RETURNS [Node] = {
IF smallStyle
OR MimData.switches['k]
THEN
WITH rcmap
SELECT
FROM
wc:
REF NodeRep.const.word =>
IF wc.word = IntCodeDefs.zerosWord
THEN
RETURN [InstallCall[name: "GetTypeIndexS",
n1: EmitString[[ts, 0, ts.length], mesa, writer],
bits: Target.bitsPerWord]];
ENDCASE;
RETURN [InstallCall[name: "GetTypeIndex",
n1: EmitString[[ts, 0, ts.length], mesa, writer],
n2: MimP5U.MakeConstInt[0], -- RRA: eventually need a better description
n3: rcmap, -- no RC map possible for abstract type
bits: Target.bitsPerWord]];
};
Kind: TYPE = {mesa, c};
EmitName:
PROC
[name: Symbols.Name, kind: Kind ¬ mesa, writer: TargetConversions.Writer ¬
NIL]
RETURNS [Node] = {
ss: SymbolOps.SubString ¬ SymbolOps.SubStringForName[SymbolOps.own, name];
RETURN [EmitString[ss, kind, writer]];
};
EmitString:
PROC
[ss: SymbolOps.SubString, kind: Kind ¬ mesa, writer: TargetConversions.Writer ¬
NIL]
RETURNS [Node] = {
len: CARDINAL ¬ ss.length;
max: CARDINAL ¬ len;
align: NAT ¬ IF kind = mesa THEN Target.bitsPerWord ELSE Target.bitsPerAU;
IF writer =
NIL
THEN writer ¬ TargetConversions.NewWriter[]
ELSE TargetConversions.ResetWriter[writer];
SELECT kind
FROM
mesa => {
A Mesa string (starts with two copies of the length)
max ¬ max + (bytesPerWord - max MOD bytesPerWord);
TargetConversions.PutCard[writer, len, Target.bitsPerStringBound];
TargetConversions.PutCard[writer, max, Target.bitsPerStringBound];
};
ENDCASE;
FOR i:
CARDINAL
IN [ss.offset..ss.offset+ss.length)
DO
TargetConversions.PutChar[writer, ss.base[i]];
ENDLOOP;
TargetConversions.PutCard[writer, 0, Target.bitsPerChar];
Make all strings zero-terminated
Pad to word boundary (for mesa strings)
THROUGH (len..max)
DO
TargetConversions.PutCard[writer, 0, Target.bitsPerChar];
ENDLOOP;
RETURN [MimP5U.Address[z.NEW [NodeRep.const.bytes ¬ [0, const[bytes[
align, TargetConversions.WriterContents[writer]]]]]]];
};
EmitRope:
PROC
[rope:
ROPE, kind: Kind ¬ mesa, writer: TargetConversions.Writer ¬
NIL]
RETURNS [Node] = {
len: NAT ¬ Rope.Length[rope];
max: CARDINAL ¬ len;
align: NAT ¬ IF kind = mesa THEN Target.bitsPerWord ELSE Target.bitsPerAU;
IF writer =
NIL
THEN writer ¬ TargetConversions.NewWriter[]
ELSE TargetConversions.ResetWriter[writer];
SELECT kind
FROM
mesa => {
A Mesa string (starts with two copies of the length)
max ¬ max + (bytesPerWord - max MOD bytesPerWord);
TargetConversions.PutCard[writer, len, Target.bitsPerStringBound];
TargetConversions.PutCard[writer, len, Target.bitsPerStringBound];
};
ENDCASE;
FOR i:
NAT
IN [0..len)
DO
TargetConversions.PutChar[writer, Rope.Fetch[rope, i]];
ENDLOOP;
TargetConversions.PutCard[writer, 0, Target.bitsPerChar];
Make all strings zero-terminated
Pad to word boundary (for mesa strings)
THROUGH (len..max)
DO
TargetConversions.PutCard[writer, 0, Target.bitsPerChar];
ENDLOOP;
RETURN [MimP5U.Address[z.NEW [NodeRep.const.bytes ¬ [0, const[bytes[
align, TargetConversions.WriterContents[writer]]]]]]];
};
InstallCall:
PROC
[name:
ROPE, n1, n2, n3, n4, n5, n6, n7: Node ¬
NIL, bits:
INT ¬ 0]
RETURNS [Node] = {
oper: Node ¬ NIL;
nl: NodeList ¬ IF n7 = NIL THEN NIL ELSE MimP5U.MakeNodeList[n7];
IF nl # NIL OR n6 # NIL THEN nl ¬ MimP5U.MakeNodeList[n6, nl];
IF nl # NIL OR n5 # NIL THEN nl ¬ MimP5U.MakeNodeList[n5, nl];
IF nl # NIL OR n4 # NIL THEN nl ¬ MimP5U.MakeNodeList[n4, nl];
IF nl # NIL OR n3 # NIL THEN nl ¬ MimP5U.MakeNodeList[n3, nl];
IF nl # NIL OR n2 # NIL THEN nl ¬ MimP5U.MakeNodeList[n2, nl];
IF nl # NIL OR n1 # NIL THEN nl ¬ MimP5U.MakeNodeList[n1, nl];
IF name = NIL THEN ERROR;
FOR i: [0..lagNum)
IN [0..lagNum)
DO
n: ROPE ¬ lagNames[i];
IF n = name THEN {oper ¬ lagOpers[i]; EXIT};
IF n =
NIL
OR i = lagNum-1
THEN {
victim: [0..lagNum) ¬ IF n = NIL THEN i ELSE 0;
oper ¬ z.NEW[NodeRep.machineCode ¬
[bits: 0, details: machineCode[Rope.Concat[runtimePrefix, name]]]];
lagNames[victim] ¬ name;
lagOpers[victim] ¬ oper;
EXIT;
};
ENDLOOP;
RETURN [MimP5U.ApplyOp[oper, nl, bits]];
};
END.