
<<SaffronCreateProgramGraphImpl.Mesa>>
<<James Rauen, August 8, 1988 7:47:19 pm PDT>>
    <<Last edited by: James Rauen August 23, 1988 5:37:50 pm PDT>>
    <<>>
    <<Implementation of the functions defined in SaffronProgramGraphDecls.ThreeC4>>
    <<>>
DIRECTORY
Rope USING [ROPE],
SaffronBaseDef USING [],
SaffronContextPrivateTypes USING [ValueNodeBody],
SaffronErrorHandling USING [InternalError],
SaffronPGDef USING [],
SaffronProgramGraphPrivateTypes;

SaffronCreateProgramGraphImpl: CEDAR PROGRAM
IMPORTS SaffronErrorHandling
EXPORTS SaffronBaseDef, SaffronPGDef
= BEGIN

OPEN
EH: SaffronErrorHandling,
PG: SaffronProgramGraphPrivateTypes,
PT: SaffronContextPrivateTypes;

ProgramGraphNode: TYPE = REF ProgramGraphNodeBody;
ProgramGraphNodeBody: PUBLIC TYPE = PG.ProgramGraphNodeBody;

ProcedureGraphNode: TYPE = REF ProcedureGraphNodeBody;
ProcedureGraphNodeBody: PUBLIC TYPE = PG.ProcedureGraphNodeBody;

ProgramFragmentNode: TYPE = REF ProgramFragmentNodeBody;
ProgramFragmentNodeBody: PUBLIC TYPE = PG.ProgramFragmentNodeBody;

ParameterizedFieldDescriptorNode: TYPE = REF ParameterizedFieldDescriptorNodeBody;
ParameterizedFieldDescriptorNodeBody: PUBLIC TYPE = PG.ParameterizedFieldDescriptorNodeBody;

ValueNode: TYPE = REF ValueNodeBody;
ValueNodeBody: PUBLIC TYPE = PT.ValueNodeBody;
<<Parameterized Field Descriptor>>
EmptyPFD: PUBLIC PROC RETURNS [ParameterizedFieldDescriptorNode] = BEGIN
RETURN [NEW[ParameterizedFieldDescriptorNodeBody _ [NIL, NIL]]];
END;

AddNestedCellToPFD: PUBLIC PROC [pfd: ParameterizedFieldDescriptorNode] RETURNS [ParameterizedFieldDescriptorNode] = BEGIN
cell: PG.ParameterizedFieldDescriptorCell _ NEW[PG.ParameterizedFieldDescriptorCellBody _ [
next: NIL,
k: nested[]
]];
RETURN [AddCellToPFD[pfd, cell]];
END;

AddStaticLinkCellToPFD: PUBLIC PROC [pfd: ParameterizedFieldDescriptorNode] RETURNS [ParameterizedFieldDescriptorNode] = BEGIN
cell: PG.ParameterizedFieldDescriptorCell _ NEW[PG.ParameterizedFieldDescriptorCellBody _ [
next: NIL,
k: staticLink[]
]];
RETURN [AddCellToPFD[pfd, cell]];
END;

AddVarsCellToPFD: PUBLIC PROC [pfd: ParameterizedFieldDescriptorNode, id: Rope.ROPE] RETURNS [ParameterizedFieldDescriptorNode] = 
BEGIN
<<id should probably be a GEN.IdNode instead...>>
cell: PG.ParameterizedFieldDescriptorCell _ NEW[PG.ParameterizedFieldDescriptorCellBody _ [
next: NIL,
k: vars[id]
]];
RETURN [AddCellToPFD[pfd, cell]];
END;

AddFieldNameCellToPFD: PUBLIC PROC [pfd: ParameterizedFieldDescriptorNode, fieldName: Rope.ROPE] RETURNS 
[ParameterizedFieldDescriptorNode] = BEGIN
cell: PG.ParameterizedFieldDescriptorCell _ NEW[PG.ParameterizedFieldDescriptorCellBody _ [
next: NIL,
k: fieldName[fieldName]
]];
RETURN [AddCellToPFD[pfd, cell]];
END;

AddCellToPFD: PROC [pfd: ParameterizedFieldDescriptorNode, cell: PG.ParameterizedFieldDescriptorCell] RETURNS 
[ParameterizedFieldDescriptorNode] = BEGIN
IF pfd.firstCell = NIL
THEN pfd.firstCell _ cell
ELSE pfd.lastCell.next _ cell;
pfd.lastCell _ cell;
RETURN [pfd];
END;

PFDIsLocal: PUBLIC PROC [pfd: ParameterizedFieldDescriptorNode] RETURNS [BOOLEAN] = BEGIN
RETURN [(pfd.firstCell # NIL) AND (pfd.firstCell.kind # staticLink)];
END;
<<Program Graph>>
CreateEmptyProgramGraph: PUBLIC PROC RETURNS [ProgramGraphNode] = BEGIN
RETURN [NEW[ProgramGraphNodeBody _ [NIL, NIL, NIL]]];
END;

FakeDamageProgramGraph: PUBLIC PROC [pg: ProgramGraphNode]RETURNS [ProgramGraphNode] = BEGIN
RETURN [pg];
END;

AddSubroutineProcedureGraphToProgramGraph: PUBLIC PROC [subroutine: ProcedureGraphNode, pg: ProgramGraphNode] RETURNS 
[ProgramGraphNode] = BEGIN
cell: PG.ProcedureGraphCell _ NEW[PG.ProcedureGraphCellBody _ [NIL, subroutine]];
IF pg.firstSubroutine = NIL
THEN pg.firstSubroutine _ cell
ELSE pg.lastSubroutine.next _ cell;
pg.lastSubroutine _ cell;
RETURN [pg];
END;

AddMainProcedureGraphToProgramGraph: PUBLIC PROC [main: ProcedureGraphNode, pg: ProgramGraphNode] RETURNS [ProgramGraphNode] = BEGIN
IF pg.main = NIL
THEN {
pg.main _ main;
RETURN [pg];
}
ELSE
ERROR EH.InternalError["Tried adding a second main routine to program graph"];
END;
<<Procedure Graph>>
MakeProcedureGraph: PUBLIC PROC [pf: ProgramFragmentNode] RETURNS [ProcedureGraphNode] = BEGIN
returnNode: PG.OperationNode _ NEW[PG.OperationNodeBody _ [
signalCatchNode: NIL,
outgoingActionEdges: NIL,
effects: NEW[PG.OpReturnBody _ NULL]
]];
LinkToReturn: PROC [node: PG.OperationNode] = 
{node.outgoingActionEdges.to _ returnNode};
DemandProgramFragmentNodeInvariant[pf];
MapOntoExitingOperationNodes[pf, LinkToReturn];
RETURN [NEW[PG.ProcedureGraphNodeBody _ [code: pf]]];
END;
<<Program Fragment>>
ConcatProgramFragments: PUBLIC PROC [pf1, pf2: ProgramFragmentNode] RETURNS [ProgramFragmentNode] = BEGIN
SELECT TRUE FROM
ProgramFragmentIsNoOp[pf1] => RETURN [pf2];
ProgramFragmentIsNoOp[pf2] => RETURN [pf1];
ENDCASE => {
LinkEm: PROC [node: PG.OperationNode] = 
{node.outgoingActionEdges.to _ pf2.firstOperation};
DemandProgramFragmentNodeInvariant[pf1];
DemandProgramFragmentNodeInvariant[pf2];
MapOntoExitingOperationNodes[pf1, LinkEm];
RETURN [NEW[ProgramFragmentNodeBody _ [pf1.firstOperation, pf2.exitingOperations]]];
};
END;

DemandProgramFragmentNodeInvariant: PROC [pf: ProgramFragmentNode] = BEGIN
Insist: PROC [operation: PG.OperationNode] = BEGIN
IF operation.outgoingActionEdges.label # next
OR operation.outgoingActionEdges.to # NIL
OR operation.outgoingActionEdges.next # NIL
THEN ERROR EH.InternalError["Program graph representation invariant violated"];
END;
MapOntoExitingOperationNodes[pf, Insist];
END;

ProgramFragmentIsNoOp: PROC [pf: ProgramFragmentNode] RETURNS [BOOLEAN] = BEGIN
RETURN [pf.firstOperation = NIL AND pf.exitingOperations = NIL];
END;

MapOntoExitingOperationNodes: PROC [pf: ProgramFragmentNode, proc: PROC [PG.OperationNode]] = BEGIN
FOR opList: LIST OF PG.OperationNode _ pf.exitingOperations, opList.rest 
WHILE (opList # NIL) DO
proc[opList.first];
ENDLOOP;
END;

MakeSingleOperationProgramFragment: PROC [effects: REF ANY] RETURNS [ProgramFragmentNode] = BEGIN
opNode: PG.OperationNode _ NEW[PG.OperationNodeBody _ [
signalCatchNode: NIL,
outgoingActionEdges: NEW[PG.OutgoingActionsCellBody _ [next, NIL, NIL]],
effects: effects
]];
RETURN[NEW[ProgramFragmentNodeBody _ [opNode, LIST[opNode]]]]
END;

MakePGPushConstant: PUBLIC PROC [v: ValueNode] RETURNS [ProgramFragmentNode] = {
IF (v.kind # static) AND (v.kind # trash)
 THEN ERROR EH.InternalError["PushConstant argument is neither constant nor trash!"];
RETURN[MakeSingleOperationProgramFragment[NEW[PG.OpPushConstantBody _ [v]]]]; 
};

MakePGNoOp: PUBLIC PROC RETURNS [ProgramFragmentNode] = {
RETURN[NEW[ProgramFragmentNodeBody _ [NIL, NIL]]]
};

MakePGNegate: PUBLIC PROC RETURNS [ProgramFragmentNode] = {
RETURN[MakeSingleOperationProgramFragment[NEW[PG.OpUnaryFunctionBody _ [negate[]]]]];
};

MakePGNot: PUBLIC PROC RETURNS [ProgramFragmentNode] = {
RETURN[MakeSingleOperationProgramFragment[NEW[PG.OpUnaryFunctionBody _ [not[]]]]];
};

MakePGAdd: PUBLIC PROC RETURNS [ProgramFragmentNode] = {
RETURN[MakeSingleOperationProgramFragment[NEW[PG.OpBinaryFunctionBody _ [add[]]]]]; 
};

MakePGSubtract: PUBLIC PROC RETURNS [ProgramFragmentNode] = {
RETURN[MakeSingleOperationProgramFragment[NEW[PG.OpBinaryFunctionBody _ [subtract[]]]]]; 
};

MakePGMultiply: PUBLIC PROC RETURNS [ProgramFragmentNode] = {
RETURN[MakeSingleOperationProgramFragment[NEW[PG.OpBinaryFunctionBody _ [multiply[]]]]]; 
};

MakePGDivide: PUBLIC PROC RETURNS [ProgramFragmentNode] = {
RETURN[MakeSingleOperationProgramFragment[NEW[PG.OpBinaryFunctionBody _ [divide[]]]]]; 
};

MakePGMod: PUBLIC PROC RETURNS [ProgramFragmentNode] = {
RETURN[MakeSingleOperationProgramFragment[NEW[PG.OpBinaryFunctionBody _ [mod[]]]]]; 
};

MakePGAnd: PUBLIC PROC RETURNS [ProgramFragmentNode] = {
RETURN[MakeSingleOperationProgramFragment[NEW[PG.OpBinaryFunctionBody _ [and[]]]]]; 
};

MakePGOr: PUBLIC PROC RETURNS [ProgramFragmentNode] = {
RETURN[MakeSingleOperationProgramFragment[NEW[PG.OpBinaryFunctionBody _ [or[]]]]]; 
};

MakePGEqual: PUBLIC PROC RETURNS [ProgramFragmentNode] = {
RETURN[MakeSingleOperationProgramFragment[NEW[PG.OpBinaryFunctionBody _ [equal[]]]]]; 
};

MakePGNotEqual: PUBLIC PROC RETURNS [ProgramFragmentNode] = {
RETURN[MakeSingleOperationProgramFragment[NEW[PG.OpBinaryFunctionBody _ [notEqual[]]]]]; 
};

MakePGLoadLocal: PUBLIC PROC [pfd: ParameterizedFieldDescriptorNode] RETURNS [ProgramFragmentNode] = {
RETURN[MakeSingleOperationProgramFragment[NEW[PG.OpLoadLocalBody _ [pfd, NIL]]]];
};

MakePGLoadIndirect: PUBLIC PROC [pfd: ParameterizedFieldDescriptorNode] RETURNS [ProgramFragmentNode] = {
RETURN[MakeSingleOperationProgramFragment[NEW[PG.OpLoadIndirectBody _ [pfd, NIL, NIL]]]];
};

MakePGStoreLocal: PUBLIC PROC [pfd: ParameterizedFieldDescriptorNode] RETURNS [ProgramFragmentNode] = {
RETURN[MakeSingleOperationProgramFragment[NEW[PG.OpStoreLocalBody _ [pfd, NIL]]]];
};

MakePGStoreIndirect: PUBLIC PROC [pfd: ParameterizedFieldDescriptorNode] RETURNS [ProgramFragmentNode] = {
RETURN[MakeSingleOperationProgramFragment[NEW[PG.OpStoreIndirectBody _ [pfd, NIL, NIL]]]];
};

MakePGTest: PUBLIC PROC [ifPart, thenPart, elsePart: ProgramFragmentNode] RETURNS [ProgramFragmentNode] = BEGIN
fork: PG.OperationNode _ NEW[PG.OperationNodeBody _ [
signalCatchNode: NIL,
outgoingActionEdges: NEW[PG.OutgoingActionsCellBody _ [ifTrue, thenPart.firstOperation, NEW[PG.OutgoingActionsCellBody _ [ifFalse, 
elsePart.firstOperation, NIL]]]],
effects: NEW[PG.OpTestBody]
]];
exitList: LIST OF PG.OperationNode _ NIL;
LinkToFork: PROC [node: PG.OperationNode] = {node.outgoingActionEdges.to _ fork};
AddToExitList: PROC [node: PG.OperationNode] = {exitList _ CONS[node, exitList]};
DemandProgramFragmentNodeInvariant[ifPart];
DemandProgramFragmentNodeInvariant[thenPart];
DemandProgramFragmentNodeInvariant[elsePart];
MapOntoExitingOperationNodes[ifPart, LinkToFork];
MapOntoExitingOperationNodes[thenPart, AddToExitList];
MapOntoExitingOperationNodes[elsePart, AddToExitList];
RETURN [NEW[ProgramFragmentNodeBody _ [ifPart.firstOperation, exitList]]];
END;
END.