-- Driver.mesa
-- last modified by Sweet, Oct 25, 1980 4:09 PM
-- last modified by Satterthwaite, November 2, 1982 3:52 pm

DIRECTORY
  Alloc: TYPE USING [Notifier, AddNotify, DropNotify],
  Code: TYPE USING [
    actenable, bodyComRetLabel, bodyFileIndex, bodyInRecord, bodyOutRecord,
    bodyRetLabel, caseCVState, catchcount, catchoutrecord, cfSize, codeptr,
    curctxlvl, fileindex, firstTemp, framesz, inlineFileIndex, mainBody,
    reentryLabel, StackNotEmptyAtStatement, substenable, tailJumpOK,
    tempcontext, tempstart, xtracting],
  CodeDefs: TYPE USING [
    AddressNotify, Base, CallsNotify, CCIndex, CCNull, codeType, 
    ConstructorNotify, CountingNotify, CrossJumpNotify, DJumpsNotify,
    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, globalFrameSize, nErrors, objectBytes, stopping, table, textIndex],
  FOpCodes: TYPE USING [
    qLADRB, qLI, qLINKB, qLL, qME, qMEL, qMXD, qMXDL, 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],
  Stack: TYPE USING [
    Decr, Depth, Dump, Incr, Init, Load, Off, On, Reset, StackImplNotify, Top],
  SymbolOps: TYPE USING [EnumerateBodies, NextSe, TransferTypes],
  Symbols: TYPE USING [
    Base, bodyType, BTIndex, CBTIndex, 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]};


  codeStart: LabelCCIndex;
  mLock: Tree.Link;
  longLock: BOOL;

  Module: PUBLIC PROC =
    BEGIN -- main driver for code generation
    (MPtr.table).AddNotify[DriverNotify];
    CPtr.bodyInRecord _ CPtr.bodyOutRecord _ RecordSENull;
    P5U.CgenUtilInit[MPtr.table];
    P5.TempInit[];
    Stack.Init[];  Stack.Off[];
    CPtr.inlineFileIndex _ NULLfileindex;
    CPtr.xtracting _ FALSE;
    CPtr.caseCVState _ none;
    CPtr.catchoutrecord _ RecordSENull;
    CPtr.catchcount _ 0;
    CPtr.actenable _ CPtr.substenable _ LabelCCNull;
    CPtr.codeptr _ codeStart _ LabelCCNull;
    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 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;

    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.cfSize _ 0;
      CPtr.bodyFileIndex _ CPtr.fileindex _ bb[bti].sourceIndex;
      CPtr.tailJumpOK _ TRUE;

      -- init the code stream and put down bracketing labels

      CPtr.bodyRetLabel _ P5U.LabelAlloc[];
      CPtr.bodyComRetLabel _ P5U.LabelAlloc[];
      CPtr.codeptr _ CCNull;
      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.qLINKB, frameOffset-localbase];
    ENDCASE;
      Stack.On[];
      CPtr.reentryLabel _ P5U.CreateLabel[];    -- for reentry on tail recursion
      PopInVals[CPtr.bodyInRecord, FALSE];
      P5.PurgePendTempList[];

      -- do type table and 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.qLADRB, 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[codeStart, bb[bti].entryIndex];
      END;
     ENDCASE;

    -- output the object code

    TreeOps.FreeNode[bodyNode];
    IF MPtr.nErrors = 0 THEN P5.OutBinary[bti, codeStart]
    ELSE
      BEGIN
      c, next: CCIndex;
      FOR c _ 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
    saveEnable: LabelCCIndex = CPtr.substenable;
    ss: StatementStateRecord;
    tSei: CSEIndex = P5U.OperandType[tb[node].son[1]];
    P5.PushStatementState[@ss];  CPtr.substenable _ CPtr.actenable;
    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[];
    nRets _ P5U.WordsForSei[CPtr.bodyOutRecord];
    P5.PopStatementState[@ss];  CPtr.substenable _ saveEnable;
    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] =
    BEGIN
    nParms: CARDINAL;
    r: VarIndex;
    t: Tree.Link;
    sei: ISEIndex;
    np: CARDINAL _ 0;

    IF irecord = CSENull THEN RETURN;
    nParms _ P5U.WordsForSei[irecord];
    IF nParms = 0 THEN RETURN;
    IF isenable THEN
      IF nParms <= 1 THEN RETURN
      ELSE P5U.Out1[FOpCodes.qLL,localbase+1];
    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 > MaxParmsInStack OR (isenable AND nParms > 1) 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 > MaxParmsInStack 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];
    [] _ P5.BuildArgRecord[t, CPtr.bodyOutRecord, FALSE, 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)]]];
    P5U.Out0[IF longLock THEN FOpCodes.qMEL ELSE 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]]];
    P5U.Out0[IF longLock THEN FOpCodes.qMXDL ELSE FOpCodes.qMXD];
    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, isResume, FALSE]
      ELSE P5.BuildArgRecord[tb[node].son[1], rSei, isResume, isResume, FALSE];
    nStack _ 
      IF nRetVals > MaxParmsInStack OR isResume AND nRetVals # 0 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[1]; 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: se Lexeme _ 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.