
<<Driver.mesa>>
<<last modified by Sweet, 25-Aug-82 11:33:02>>
<<last modified by Satterthwaite, January 22, 1986 5:03:19 pm PST>>

DIRECTORY
Alloc USING [Notifier, AddNotify, DropNotify],
CatchFormat: TYPE USING [cResume, msgOffset],
Code: TYPE USING [
actenable, bodyComRetLabel, bodyInRecord, bodyOutRecord, bodyRecurLabel,
bodyRetLabel, bodyStartLoc, caseCVState, catchcount, catchoutrecord, 
codeptr, codeStart, curctxlvl, enableLevel,
enableList, fileLoc, firstTemp, framesz, inlineFileLoc, 
inlineRetErrorLabel, inlineRetErrorListLabel, mainBody,
StackNotEmptyAtStatement, tailJumpOK, tempcontext,
tempstart, warnStackOverflow, xtracting],
CodeDefs: TYPE USING [
AddressNotify, Base, CallsNotify, CCIndex, CCNull, codeType,
ConstructorNotify, CountingNotify, CrossJumpNotify, DJumpsNotify, EINull,
ExpressionNotify, FinalNotify, FlowExpressionNotify, FlowNotify, JumpCCNull, 
LabelCCIndex, LabelCCNull, Lexeme, MaxParmsInStack, NullLex, 
OutCodeNotify, PeepholeNotify, SelectionNotify, StatementNotify, 
StatementStateRecord, StoreNotify, TempNotify, VarBasicsNotify, VarIndex, 
VarMoveNotify, VarUtilsNotify],
ComData: TYPE USING [
bodyIndex, codeByteOffsetList, codeOffsetList, jumpIndirectList, 
globalFrameSize, nErrors, objectBytes, table, stopping,  switches,
textIndex],
FOpCodes: TYPE USING [
qKFCB, qLA, qLI, qLKB, qLL, qLP, qME, qMX, qPSD, qRET, qSG],
P5: TYPE USING [
BuildArgRecord, EndCodeFile, Exp, ExtractFrom, Fixup, FreeTempSei,
GenStringBodyLex, LogHeapFree, OutBinary, PopStatementState, PRetLex,
ProcessGlobalStrings, ProcessLocalStrings, PurgePendTempList, PushArgRecord,
PushStatementState, StartCodeFile, StatementTree, TempInit],
P5L: TYPE USING [LoadAddress, TOSAddrLex, TOSLex, VarFinal, VarForLex],
P5S: TYPE USING [],
P5U: TYPE USING [
CgenUtilInit, CgenUtilNotify, CreateLabel, DeleteCell, InsertLabel, LabelAlloc,
NextVar, OperandType, Out0, Out1, OutJump, OutSource, PushLitVal,
TreeLiteralValue, WordsForSei],
PrincOps: TYPE USING [globalbase, localbase, sError, sErrorList],
SourceMap: TYPE USING [nullLoc, Up],
Stack: TYPE USING [
Decr, Depth, Dump, Incr, Init, Load, Off, On, Pop, Reset, StackImplNotify, Top],
SymbolOps: TYPE USING [EnumerateBodies, NextSe, SetCtxLevel, TransferTypes],
Symbols: TYPE USING [
Base, bodyType, BTIndex, CBTIndex, CCBTNull, CSEIndex, CSENull, ctxType, 
ISEIndex, ISENull, RecordSEIndex, RecordSENull, RootBti, seType],
Tree: TYPE USING [Base, Index, Link, Null, treeType],
TreeOps: TYPE USING [
FreeNode, FreeTree, MakeList, MakeNode, PushList, PushNode, PushSe, PushTree, 
SearchList];

Driver: PROGRAM
IMPORTS 
Alloc, MPtr: ComData, CPtr: Code, CodeDefs, P5, P5L, P5U, SourceMap, Stack, SymbolOps, TreeOps 
EXPORTS P5, P5S =
BEGIN
OPEN CodeDefs;

<<imported definitions>>

localbase: CARDINAL = PrincOps.localbase;
globalbase: CARDINAL = PrincOps.globalbase;

CSEIndex: TYPE = Symbols.CSEIndex;
CSENull: CSEIndex = Symbols.CSENull;
ISEIndex: TYPE = Symbols.ISEIndex;
ISENull: ISEIndex = Symbols.ISENull;
RecordSEIndex: TYPE = Symbols.RecordSEIndex;
RecordSENull: RecordSEIndex = Symbols.RecordSENull;


tb: Tree.Base;        -- tree base (local copy)
seb: Symbols.Base;        -- semantic entry base (local copy)
ctxb: Symbols.Base;        -- context entry base (local copy)
bb: Symbols.Base;        -- body entry base (local copy)
cb: CodeDefs.Base;        -- code base (local copy)

DriverNotify: Alloc.Notifier =
BEGIN  -- called by allocator whenever table area is repacked
seb _ base[Symbols.seType];
ctxb _ base[Symbols.ctxType];
bb _ base[Symbols.bodyType];
tb _ base[Tree.treeType];
cb _ base[codeType];
P5U.CgenUtilNotify[base]; 
AddressNotify[base];
ExpressionNotify[base];  FlowExpressionNotify[base];  FlowNotify[base];
Stack.StackImplNotify[base];  TempNotify[base];
StatementNotify[base];  SelectionNotify[base];
ConstructorNotify[base];  StoreNotify[base];  CountingNotify[base];
CallsNotify[base];
OutCodeNotify[base];  FinalNotify[base];
CrossJumpNotify[base]; DJumpsNotify[base];
PeepholeNotify[base]; 
VarUtilsNotify[base];  VarBasicsNotify[base];  VarMoveNotify[base];
END;


CodePassError: PUBLIC ERROR [n: CARDINAL] = CODE;

P5Error: PUBLIC PROC [n: CARDINAL] = {ERROR CodePassError[n]};


mLock: Tree.Link;
longLock: BOOL;

Module: PUBLIC PROC =
BEGIN -- main driver for code generation
ENABLE UNWIND => {Stack.Reset[]; P5L.VarFinal[]};
(MPtr.table).AddNotify[DriverNotify];
CPtr.bodyInRecord _ CPtr.bodyOutRecord _ RecordSENull;
P5U.CgenUtilInit[MPtr.table];
P5.TempInit[];
Stack.Init[];  Stack.Off[];
CPtr.warnStackOverflow _ MPtr.switches['o];
CPtr.inlineFileLoc _ SourceMap.nullLoc;
CPtr.xtracting _ FALSE;
CPtr.caseCVState _ none;
CPtr.catchoutrecord _ RecordSENull;
CPtr.catchcount _ 0;
CPtr.actenable _ Symbols.CCBTNull;
CPtr.codeptr _ CPtr.codeStart _ CCNull;
CPtr.enableList _ ALL[EINull];
MPtr.codeOffsetList _ NIL;
MPtr.codeByteOffsetList _ NIL;
MPtr.jumpIndirectList _ NIL;
P5.StartCodeFile[];
[] _ SymbolOps.EnumerateBodies[Symbols.RootBti, Body];
MPtr.objectBytes _ P5.EndCodeFile[];
Stack.Reset[];
P5L.VarFinal[];
(MPtr.table).DropNotify[DriverNotify]
END;


Body: PROC [bti: Symbols.BTIndex] RETURNS [stop: BOOL _ FALSE] =
BEGIN
WITH body: bb[bti] SELECT FROM
Callable => IF ~body.inline THEN 
WITH body SELECT FROM
Catch => NULL;
ENDCASE => ProcBody[LOOPHOLE[bti]];
ENDCASE;
END;


ProcBody: PROC [bti: Symbols.CBTIndex] =
BEGIN -- produces code for body
bodyNode: Tree.Index;

CPtr.mainBody _ (bti = Symbols.RootBti);
MPtr.bodyIndex _ bti;
MPtr.textIndex _ SourceMap.Up[bb[bti].sourceIndex];
CPtr.enableLevel _ 0;
CPtr.tailJumpOK _ TRUE;

WITH bi: bb[bti].info SELECT FROM
Internal =>
BEGIN
bodyNode _ bi.bodyTree;
CPtr.curctxlvl _ bb[bti].level;

<<set up input and output contexts>>
[CPtr.bodyInRecord, CPtr.bodyOutRecord] _ SymbolOps.TransferTypes[bb[bti].ioType];

CPtr.firstTemp _ CPtr.tempstart _ CPtr.framesz _ bi.frameSize;
CPtr.bodyStartLoc _ CPtr.fileLoc _ SourceMap.Up[bb[bti].sourceIndex];

<<init the code stream and put down bracketing labels>>

CPtr.bodyRetLabel _ P5U.LabelAlloc[];
CPtr.bodyComRetLabel _ P5U.LabelAlloc[];
CPtr.codeptr _ CCNull;
CPtr.codeStart _ P5U.CreateLabel[];
P5U.OutSource[SourceMap.Up[bb[bti].sourceIndex]];

<<init data for creating temporaries>>

SymbolOps.SetCtxLevel[CPtr.tempcontext, CPtr.curctxlvl];

<<tuck parameters away into the frame>>

IF Stack.Depth[] # 0 THEN SIGNAL CPtr.StackNotEmptyAtStatement;
WITH bb[bti] SELECT FROM
Inner => P5U.Out1[FOpCodes.qLKB, frameOffset-localbase];
ENDCASE;
CPtr.bodyRecurLabel _ P5U.CreateLabel[];
Stack.On[];
SPopInVals[
irecord: CPtr.bodyInRecord, isenable: FALSE, startParams: CPtr.mainBody];
P5.PurgePendTempList[];

<<do string literals>>

IF CPtr.mainBody THEN 
MPtr.globalFrameSize _ P5.ProcessGlobalStrings[MPtr.globalFrameSize];
CPtr.firstTemp _ CPtr.tempstart _ P5.ProcessLocalStrings[CPtr.tempstart, bi.thread];
bi.frameSize _ CPtr.framesz _ MAX [CPtr.framesz, CPtr.tempstart];

<<do initialization code and main body>>

IF CPtr.mainBody AND MPtr.stopping THEN
{P5U.Out1[FOpCodes.qLA, 0]; P5U.Out1[FOpCodes.qSG, globalbase]};

IF bb[bti].entry THEN SetLock[tb[bodyNode].son[4]]
ELSE mLock _ Tree.Null;

<<generate code for declaration initializations and statements>>

tb[bodyNode].son[2] _ P5.StatementTree[tb[bodyNode].son[2]];
tb[bodyNode].son[3] _ P5.StatementTree[tb[bodyNode].son[3]];
tb[bodyNode].son[1] _ Tree.Null;
IF Stack.Depth[] # 0 THEN SIGNAL CPtr.StackNotEmptyAtStatement;

<<push the return values onto the stack>>

InsertRetLabels[mLock # Tree.Null];
Stack.Reset[];
IF CPtr.mainBody AND MPtr.stopping THEN
{P5U.Out1[FOpCodes.qLI, 0]; P5U.Out1[FOpCodes.qSG, globalbase]};
Stack.Off[];
P5U.Out0[FOpCodes.qRET];
P5.PurgePendTempList[];

<<write frame size into bodyitem>>

bi.frameSize _ CPtr.framesz;

<<fixup jumps>>

IF MPtr.nErrors = 0 THEN P5.Fixup[CPtr.codeStart, bb[bti].entryIndex];
END;
ENDCASE;

<<output the object code>>

TreeOps.FreeNode[bodyNode];
IF MPtr.nErrors = 0 THEN P5.OutBinary[bti, CPtr.codeStart]
ELSE
BEGIN
c, next: CCIndex;
FOR c _ CPtr.codeStart, next WHILE c # CCNull DO
next _ cb[c].flink;
P5U.DeleteCell[c];
ENDLOOP;
END;
END;


SSubst: PROC [node: Tree.Index] RETURNS [nRets: CARDINAL] =
BEGIN
saveRetE: LabelCCIndex = CPtr.inlineRetErrorLabel;
saveRetEL: LabelCCIndex = CPtr.inlineRetErrorListLabel;
around: LabelCCIndex _ LabelCCNull;
ss: StatementStateRecord;
tSei: CSEIndex = P5U.OperandType[tb[node].son[1]];
JumpAround: PROC = {
IF around # LabelCCNull THEN RETURN;
around _ P5U.LabelAlloc[];
P5U.OutJump[Jump, around]};

P5.PushStatementState[@ss];  
CPtr.inlineRetErrorLabel _ P5U.LabelAlloc[];
CPtr.inlineRetErrorListLabel _ P5U.LabelAlloc[];
CPtr.bodyOutRecord _ SymbolOps.TransferTypes[tSei].typeOut;
tb[node].son[2] _ P5.StatementTree[tb[node].son[2]];
IF Stack.Depth[] # 0 THEN SIGNAL CPtr.StackNotEmptyAtStatement;
InsertRetLabels[FALSE]; -- if entry procedure, lock already dealt with
Stack.Reset[];
IF cb[CPtr.inlineRetErrorLabel].jumplist # CCNull THEN {
JumpAround[];
P5U.InsertLabel[CPtr.inlineRetErrorLabel];
P5U.Out1[FOpCodes.qKFCB, PrincOps.sError]};
IF cb[CPtr.inlineRetErrorListLabel].jumplist # CCNull THEN {
JumpAround[];
P5U.InsertLabel[CPtr.inlineRetErrorListLabel];
P5U.Out1[FOpCodes.qKFCB, PrincOps.sErrorList]};
IF around # LabelCCNull THEN P5U.InsertLabel[around];
nRets _ P5U.WordsForSei[CPtr.bodyOutRecord];
P5.PopStatementState[@ss];  
RETURN
END;

InsertRetLabels: PROC [monitored: BOOL] =
BEGIN
IF CPtr.bodyComRetLabel # LabelCCNull THEN
BEGIN
P5U.InsertLabel[CPtr.bodyComRetLabel];
IF monitored THEN ReleaseLock[];
IF cb[CPtr.bodyComRetLabel].jumplist # JumpCCNull THEN PushRetVals[];
P5U.InsertLabel[CPtr.bodyRetLabel];
CPtr.bodyComRetLabel _ LabelCCNull;
CPtr.bodyRetLabel _ LabelCCNull;
END;
END;


Subst: PUBLIC PROC [node: Tree.Index] =
BEGIN
[] _ SSubst[node];
END;

SubstExp: PUBLIC PROC [node: Tree.Index] RETURNS [Lexeme] =
BEGIN
nRets: CARDINAL = SSubst[node];
RETURN [P5.PRetLex[nRets, node, FALSE]]
END;

PopInVals: PUBLIC PROC [irecord: RecordSEIndex, isenable: BOOL] =
{SPopInVals[irecord: irecord, isenable: isenable, startParams: FALSE]};

SPopInVals: PROC [irecord: RecordSEIndex, isenable, startParams: BOOL] =
BEGIN
nParms: CARDINAL;
mp: CARDINAL = IF startParams THEN MaxParmsInStack - 1 ELSE MaxParmsInStack;
r: VarIndex;
t: Tree.Link;
sei: ISEIndex;
np: CARDINAL _ 0;

IF irecord = CSENull THEN RETURN;
nParms _ P5U.WordsForSei[irecord];
IF isenable THEN P5U.Out1[FOpCodes.qLL, CatchFormat.msgOffset];
IF nParms = 0 THEN {
IF isenable THEN Stack.Pop[];
RETURN};
sei _ P5U.NextVar[ctxb[seb[irecord].fieldCtx].seList];
UNTIL sei = ISENull DO
TreeOps.PushSe[sei]; TreeOps.PushTree[Tree.Null]; TreeOps.PushNode[assign, 2];
np _ np+1;
sei _ P5U.NextVar[SymbolOps.NextSe[sei]];
ENDLOOP;
TreeOps.PushList[np];
t _ TreeOps.MakeNode[exlist, 1];

IF nParms > mp OR isenable THEN
BEGIN
IF ~isenable THEN Stack.Incr[1];
r _ P5L.TOSAddrLex[nParms].lexbdoi;
END
ELSE
BEGIN
Stack.Incr[nParms];
r _ P5L.VarForLex[P5L.TOSLex[nParms]];
END;
P5.ExtractFrom[t, irecord, r, (nParms > mp AND ~isenable)];
t _ TreeOps.FreeTree[t];
END;


PushRetVals: PROC =
BEGIN -- pushes the return vals from a body onto the stack
sei: ISEIndex;
nRetVals: CARDINAL;
np: CARDINAL _ 0;
t: Tree.Link;

IF CPtr.bodyOutRecord = CSENull THEN RETURN;
nRetVals _ P5U.WordsForSei[CPtr.bodyOutRecord];
sei _ ctxb[seb[CPtr.bodyOutRecord].fieldCtx].seList;
UNTIL sei = ISENull DO
TreeOps.PushSe[sei];
np _ np+1;
sei _ P5U.NextVar[SymbolOps.NextSe[sei]];
ENDLOOP;
t _ TreeOps.MakeList[np];
sei _ ctxb[seb[CPtr.bodyOutRecord].fieldCtx].seList;
[] _ P5.BuildArgRecord[t, CPtr.bodyOutRecord, FALSE];
t _ TreeOps.FreeTree[t];
END;

SetLock: PROC [lock: Tree.Link] =
BEGIN
retryEntry: LabelCCIndex = P5U.CreateLabel[];
longLock _ P5L.LoadAddress[P5L.VarForLex[P5.Exp[(mLock _ lock)]]];
IF ~longLock THEN P5U.Out0[FOpCodes.qLP];
P5U.Out0[FOpCodes.qME];
P5U.Out1[FOpCodes.qLI, 0];
P5U.OutJump[JumpE, retryEntry];
END;


ReleaseLock: PUBLIC PROC =
BEGIN
Stack.Dump[];
[] _ P5L.LoadAddress[P5L.VarForLex[P5.Exp[mLock]]];
IF ~longLock THEN P5U.Out0[FOpCodes.qLP];
P5U.Out0[FOpCodes.qMX];
END;


SReturn: PROC [node: Tree.Index, isResume: BOOL] =
BEGIN -- generate code for RETURN and RESUME
nRetVals: CARDINAL;
nStack: CARDINAL;
rSei: RecordSEIndex;
monitored: BOOL;

IF ~isResume AND CommonRet[tb[node].son[1]] THEN
BEGIN
P5U.OutJump[Jump, CPtr.bodyComRetLabel];
RETURN
END;

monitored _ ~isResume AND tb[node].attr1;
IF monitored AND tb[node].attr2 THEN
{ReleaseLock[]; monitored _ FALSE};
rSei _ IF isResume THEN CPtr.catchoutrecord ELSE CPtr.bodyOutRecord;
nRetVals _ IF tb[node].attr3
THEN P5.PushArgRecord[tb[node].son[1], rSei, isResume]
ELSE P5.BuildArgRecord[tb[node].son[1], rSei, isResume];
nStack _ 
IF nRetVals > MaxParmsInStack OR 
isResume AND nRetVals > MaxParmsInStack - 1 THEN 1
ELSE nRetVals;

IF monitored THEN
{Stack.Dump[]; ReleaseLock[]};
IF nStack # 0 THEN
BEGIN
Stack.Load[Stack.Top[nStack], nStack];
Stack.Decr[nStack]; -- remove from model
END;
IF isResume THEN 
BEGIN
P5U.PushLitVal[CatchFormat.cResume]; Stack.Decr[1];
P5U.Out0[FOpCodes.qRET]; 
P5U.OutJump[JumpRet, LabelCCNull]; 
END
ELSE P5U.OutJump[Jump, CPtr.bodyRetLabel];
END;


Result: PUBLIC PROC [node: Tree.Index] = Return;

Return: PUBLIC PROC [node: Tree.Index] =
BEGIN -- produce code for RETURN
SReturn[node, FALSE ! P5.LogHeapFree => RESUME[FALSE, NullLex]];
END;


Resume: PUBLIC PROC [node: Tree.Index] =
BEGIN -- produce code for RESUME
SReturn[node, TRUE ! P5.LogHeapFree => RESUME[FALSE, NullLex]];
END;


CommonRet: PROC [t: Tree.Link] RETURNS [common: BOOL _ TRUE] =
BEGIN -- test if the returns list duplicats the returns declaration
sei: ISEIndex;

Item: PROC [t: Tree.Link] RETURNS [BOOL] =
BEGIN
WITH t SELECT FROM
symbol => common _ (sei = index);
literal, subtree => common _ FALSE;
ENDCASE;
IF sei # ISENull THEN sei _ P5U.NextVar[SymbolOps.NextSe[sei]];
RETURN [~common]
END;

IF t = Tree.Null THEN RETURN;
IF CPtr.bodyOutRecord # CSENull THEN
sei _ P5U.NextVar[ctxb[seb[CPtr.bodyOutRecord].fieldCtx].seList]
ELSE RETURN [FALSE];
TreeOps.SearchList[t, Item];
RETURN
END;

Lock: PUBLIC PROC [node: Tree.Index] =
BEGIN
saveLock: Tree.Link = mLock;
saveLongLock: BOOL = longLock;
SetLock[tb[node].son[2]];
tb[node].son[1] _ P5.StatementTree[tb[node].son[1]];
InsertRetLabels[TRUE]; -- we are in an INLINE procedure
mLock _ saveLock;  longLock _ saveLongLock;
END;

StringInit: PUBLIC PROC [node: Tree.Index] RETURNS [Lexeme] =
BEGIN -- inits string storage and pushes pointer on stack
nchars: CARDINAL = P5U.TreeLiteralValue[tb[node].son[2]];
l: Lexeme.se _ P5.GenStringBodyLex[nchars];
[] _ P5L.LoadAddress[P5L.VarForLex[l]];
P5.FreeTempSei[l.lexsei];
P5U.PushLitVal[0];
P5U.PushLitVal[nchars];
P5U.Out1[FOpCodes.qPSD, 0];
RETURN [P5L.TOSLex[1]]
END;

END.

