-- Driver.mesa
-- last modified by Sweet, Oct 25, 1980 4:09 PM
-- last modified by Satterthwaite, 31-Dec-81 13:21:00

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: BOOLEAN;

  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: BOOLEAN ← 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: BOOLEAN] =
    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: BOOLEAN] =
    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: BOOLEAN] =
    BEGIN -- generate code for RETURN and RESUME
    nRetVals: CARDINAL;
    nStack: CARDINAL;
    rSei: RecordSEIndex;
    monitored: BOOLEAN;

    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: BOOLEAN ← TRUE] =
    BEGIN -- test if the returns list duplicats the returns declaration
    sei: ISEIndex;

    Item: PROC [t: Tree.Link] RETURNS [BOOLEAN] =
      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.