-- Driver.mesa
-- last modified by Sweet, 25-Aug-82 11:33:02
-- last modified by Satterthwaite, December 16, 1982 9:21 am

DIRECTORY
  Alloc USING [Notifier, AddNotify, DropNotify],
  CatchFormat: TYPE USING [cResume, msgOffset],
  Code: TYPE USING [
    actenable, bodyComRetLabel, bodyFileIndex, bodyInRecord, bodyOutRecord,
    bodyRecurLabel, bodyRetLabel, caseCVState, catchcount, catchoutrecord, 
    codeptr, codeStart, curctxlvl, enableLevel,
    enableList, fileindex, firstTemp, framesz, inlineFileIndex, 
    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, NULLfileindex, 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],
  SDDefs USING [sError, sErrorList],
  Stack: TYPE USING [
    Decr, Depth, Dump, Incr, Init, Load, Off, On, Pop, Reset, StackImplNotify, Top],
  SymbolOps: TYPE USING [EnumerateBodies, NextSe, 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, 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.inlineFileIndex _ NULLfileindex;
    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 _ 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.bodyFileIndex _ CPtr.fileindex _ 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[bb[bti].sourceIndex];

      -- init data for creating temporaries

      ctxb[CPtr.tempcontext].level _ 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, SDDefs.sError]};
    IF cb[CPtr.inlineRetErrorListLabel].jumplist # CCNull THEN {
      JumpAround[];
      P5U.InsertLabel[CPtr.inlineRetErrorListLabel];
      P5U.Out1[FOpCodes.qKFCB, SDDefs.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, 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, FALSE]
      ELSE P5.BuildArgRecord[tb[node].son[1], rSei, isResume, FALSE];
    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;
    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;
    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.