-- file Pass4Xc.mesa
-- last written by Satterthwaite, June 3, 1983 9:53 am

DIRECTORY
  Alloc: TYPE USING [Notifier],
  ComData: TYPE USING [
    interface, typeCARDINAL, typeINT, typeStringBody, zone],
  Environment: TYPE USING [maxCARDINAL, maxINTEGER],
  LiteralOps: TYPE USING [FindDescriptor],
  Log: TYPE USING [Error, ErrorTree, WarningTree],
  P4: TYPE USING [
    Attr, voidAttr, Prop, Repr, none, unsigned, both, other, RegCount, maxRegs,
    WordSeq, ValueDescriptor,
    BiasForType, BitsForType, CatchNest, CommonAttr, CommonProp, Exp,
    FillMultiWord, ForceType, LiteralAttr, MakeArgRecord, MakeStructuredLiteral,
    MakeTreeLiteral, OperandType, RegsForType, RelTest, RepForType,
    Rhs, RValue, StructuredLiteral, TreeLiteral, TreeLiteralValue, TypeExp,
    TypeForTree, VAttr, VPop, VProp, VPush, VRegs, VRep, WordsForType],
  Symbols: TYPE USING [
    Base, BitAddress, BitCount, ByteLength, WordLength,
    ISEIndex, CSEIndex, ISENull, codeCHAR, codeINT, lZ,
    ctxType, seType],
  SymbolOps: TYPE USING [
    ArgRecord, BitsPerElement, Cardinality, FirstCtxSe, NormalType, NextSe,
    PackedSize, VariantField, UnderType],
  SymLiteralOps: TYPE USING [TypeRef],
  Tree: TYPE USING [Base, Index, Link, NodeName, Null, treeType],
  TreeOps: TYPE USING [
    FreeNode, FreeTree, GetNode, IdentityMap, MakeNode, OpName, PopTree,
    PushLit, PushNode, PushSe, PushTree, SetAttr, SetInfo];

Pass4Xc: PROGRAM
    IMPORTS
      Log, LiteralOps, P4, SymbolOps, SymLiteralOps, TreeOps,
      dataPtr: ComData
    EXPORTS P4 = {
  OPEN SymbolOps, TreeOps, P4;

  CSEIndex: TYPE = Symbols.CSEIndex;
  WordLength: CARDINAL = Symbols.WordLength;

  tb: Tree.Base;	-- tree base address (local copy)
  seb: Symbols.Base;	-- se table base address (local copy)
  ctxb: Symbols.Base;	-- context table base address (local copy)

  ExpCNotify: PUBLIC Alloc.Notifier = {
    -- called by allocator whenever table area is repacked
    tb ← base[Tree.treeType];
    seb ← base[Symbols.seType];  ctxb ← base[Symbols.ctxType]};


 -- interval utilities
 
   NormalizeRange: PUBLIC PROC [t: Tree.Link] RETURNS [val: Tree.Link] = {
    next: Tree.Link;
    FOR val ← t, next DO
      WITH val SELECT FROM
	symbol => {
	  lBound: INTEGER = BiasForType[UnderType[index]];
	  THROUGH [1..2] DO
	    PushTree[MakeTreeLiteral[ABS[lBound]]];
	    IF lBound < 0 THEN PushNode[uminus, 1];
	    ENDLOOP;
	  PushTree[MakeTreeLiteral[Cardinality[index] - 1]];
	  PushNode[plus, 2];  SetInfo[dataPtr.typeINT];
	  next ← MakeNode[intCC, 2]};
	subtree => {
	  node: Tree.Index = index;
	  SELECT tb[node].name FROM
	    subrangeTC, cdot => {
	      next ← tb[node].son[2]; tb[node].son[2] ← Tree.Null; FreeNode[node]};
	    IN [intOO .. intCC] => EXIT;
	    ENDCASE => ERROR};
	ENDCASE => ERROR;
      ENDLOOP;
    RETURN};

  Interval: PUBLIC PROC [node: Tree.Index, bias: INTEGER, target: Repr]
      RETURNS [const: BOOL] = {
    OPEN tb[node];
    attr: Attr;
    nRegs: RegCount;
    son[1] ← RValue[son[1], bias, target];
    attr ← VAttr[]; nRegs ← VRegs[];
    son[2] ← RValue[son[2], bias, target];
    nRegs ← MAX[VRegs[], nRegs];  attr ← CommonAttr[attr, VAttr[]];
    VPop[];  VPop[];  VPush[bias, attr, nRegs];
    const ← StructuredLiteral[son[1]] AND StructuredLiteral[son[2]] AND ~attr1;
    RETURN};

  EmptyInterval: PUBLIC SIGNAL = CODE;

  ConstantInterval: PUBLIC PROC [node: Tree.Index] RETURNS [origin, range: INTEGER] = {
    OPEN tb[node];
    uBound: INTEGER;
    rep: Repr ← VRep[];
    empty: BOOL ← FALSE;
    origin ← TreeLiteralValue[son[1]];  uBound ← TreeLiteralValue[son[2]];
    SELECT name FROM
      intOO, intOC => {
	IF RelTest[son[1], son[2], relGE, rep] THEN empty ← TRUE;
	origin ← origin + 1;
	son[1] ← FreeTree[son[1]];
	name ← IF name = intOO THEN intCO ELSE intCC;
	son[1] ← MakeTreeLiteral[origin]};
      ENDCASE;
    SELECT name FROM
      intCC => IF RelTest[son[1], son[2], relG, rep] THEN empty ← TRUE;
      intCO => {
	IF RelTest[son[1], son[2], relGE, rep] THEN empty ← TRUE;
	uBound ← uBound - 1;
	son[2] ← FreeTree[son[2]];
	name ← intCC;  son[2] ← MakeTreeLiteral[uBound]};
      ENDCASE => ERROR;
    IF ~empty THEN range ← uBound - origin ELSE {SIGNAL EmptyInterval; range ← 0};
    RETURN};


 -- type utilities (move?)


 -- operators on types

  TypeOp: PUBLIC PROC [node: Tree.Index] RETURNS [val: Tree.Link] = {
    SELECT tb[node].name FROM

      size => val ← Size[node];
      first, last => val ← EndPoint[node];
      typecode => val ← TypeCode[node];
      ENDCASE => {
	Log.Error[unimplemented]; VPush[0, voidAttr, 0]; val ← [subtree[node]]};

    RETURN};


  Size: PROC [node: Tree.Index] RETURNS [val: Tree.Link] = {
    type: CSEIndex;

    ApplyLit: PROC [op: Tree.NodeName, val: WORD] = {
      PushTree[MakeTreeLiteral[val]];  PushNode[op, 2];
      SetInfo[dataPtr.typeINT];  SetAttr[1, FALSE];  SetAttr[2, FALSE]};

    IF OpName[tb[node].son[1]] = apply THEN {
      subNode: Tree.Index = GetNode[tb[node].son[1]];
      sei: Symbols.ISEIndex;
      bitsPerItem: Symbols.BitCount;
      TypeExp[tb[subNode].son[1]];  type ← UnderType[TypeForTree[tb[subNode].son[1]]];
      SELECT TRUE FROM
	(type = dataPtr.typeStringBody) => bitsPerItem ← Symbols.ByteLength;
	((sei ← VariantField[type]) # Symbols.ISENull) => {
	  subType: CSEIndex = UnderType[seb[sei].idType];
	  bitsPerItem ← WITH t: seb[subType] SELECT FROM
	    sequence => BitsPerElement[t.componentType, t.packed],
	    ENDCASE => ERROR};
	ENDCASE => ERROR;
      PushTree[tb[subNode].son[2]];  tb[subNode].son[2] ← Tree.Null;
      IF bitsPerItem < WordLength THEN {
	itemsPerWord: CARDINAL = WordLength/CARDINAL[bitsPerItem];
	ApplyLit[plus, itemsPerWord-1];  ApplyLit[div, itemsPerWord]}
      ELSE ApplyLit[times, bitsPerItem/WordLength];
      ApplyLit[plus, P4.WordsForType[type]];
      IF tb[node].son[2] # Tree.Null THEN {
	PushTree[tb[node].son[2]];  tb[node].son[2] ← Tree.Null;
	PushNode[times, 2]; 
	SetInfo[dataPtr.typeINT];  SetAttr[1, FALSE];  SetAttr[2, FALSE]}}
    ELSE {
      TypeExp[tb[node].son[1]];  type ← UnderType[TypeForTree[tb[node].son[1]]];
      IF tb[node].son[2] = Tree.Null THEN PushTree[MakeTreeLiteral[P4.WordsForType[type]]]
      ELSE {
	nBits: CARDINAL = P4.BitsForType[type];
	PushTree[tb[node].son[2]];  tb[node].son[2] ← Tree.Null;
	IF nBits <= Symbols.ByteLength THEN {
	  n: CARDINAL = WordLength/PackedSize[nBits];
	  ApplyLit[plus, n-1];  ApplyLit[div, n]}
	ELSE  ApplyLit[times, P4.WordsForType[type]]}};
    val ← Rhs[PopTree[], dataPtr.typeCARDINAL];  FreeNode[node]};

  EndPoint: PROC [node: Tree.Index] RETURNS [val: Tree.Link] = {
    OPEN tb[node];
    type, next: CSEIndex;
    first: BOOL = (name=first);
    MaxInteger: WORD = Environment.maxINTEGER;
    MaxWord: WORD = Environment.maxCARDINAL;
    v: WORD;
    vv: ARRAY [0..2) OF WORD;
    TypeExp[son[1]];
    FOR type ← UnderType[TypeForTree[son[1]]], next DO
      WITH seb[type] SELECT FROM
	basic => {
	  v ← SELECT code FROM
	    Symbols.codeINT => IF first THEN MaxInteger+1 ELSE MaxInteger,
	    Symbols.codeCHAR => IF first THEN 0 ELSE CARDINAL[Cardinality[type]-1],
	    ENDCASE => IF first THEN 0 ELSE MaxWord;
	  GO TO short};
	enumerated => {
	  v ← IF first THEN 0 ELSE CARDINAL[Cardinality[type]-1]; GO TO short};
	relative => next ← UnderType[offsetType];
	subrange => {v ← IF first THEN origin ELSE origin+range; GO TO short};
	long => {
	  vv ← IF UnderType[rangeType] = dataPtr.typeINT
	    THEN IF first THEN [0, MaxInteger+1] ELSE [MaxWord, MaxInteger]
	    ELSE IF first THEN [0, 0] ELSE [MaxWord, MaxWord];
	  GO TO long};
	ENDCASE => ERROR;
      REPEAT
	short => val ← MakeTreeLiteral[v];
	long => {
	  PushLit[LiteralOps.FindDescriptor[DESCRIPTOR[vv]]];
	  PushNode[mwconst, 1];  SetInfo[type];  val ← PopTree[]};
      ENDLOOP;
    FreeNode[node];
    VPush[0, LiteralAttr[RepForType[type]], RegsForType[type]]; RETURN};

  TypeCode: PROC [node: Tree.Index] RETURNS [val: Tree.Link] = {
    TypeExp[tb[node].son[1]];
    IF dataPtr.interface THEN val ← [subtree[index: node]]
     ELSE {
      val ← SymLiteralOps.TypeRef[TypeForTree[tb[node].son[1]], FALSE];
      FreeNode[node]};
    VPush[0, LiteralAttr[both], 1];  RETURN};


 -- misc transfer operators

  MiscXfer: PUBLIC PROC [node: Tree.Index] RETURNS [Tree.Link] = {
    type: CSEIndex;
    attr: Attr;
    SELECT tb[node].name FROM

      create => {
	tb[node].son[1] ← RValue[tb[node].son[1], 0, none];
	attr ← [prop: VProp[], rep: unsigned];  VPop[]};

      fork => {
	OPEN tb[node];
	son[1] ← Exp[son[1], none];
	attr.prop ← VProp[]; VPop[];  type ← OperandType[son[1]];
	WITH t: seb[type] SELECT FROM
	  transfer => {
	    son[2] ← MakeArgRecord[ArgRecord[t.typeIn], son[2]];
	    attr.prop ← CommonProp[attr.prop, VProp[]]; attr.rep ← other;  VPop[]};
	  ENDCASE => ERROR};

      ENDCASE => {Log.Error[unimplemented]; attr ← voidAttr};

    attr.prop.noXfer ← attr.prop.noFreeVar ← FALSE;  VPush[0, attr, maxRegs];
    IF tb[node].nSons > 2 THEN CatchNest[tb[node].son[3]];
    RETURN [[subtree[index: node]]]};


 -- NIL
 
  Nil: PUBLIC PROC [node: Tree.Index] RETURNS [Tree.Link] = {
    type: CSEIndex = tb[node].info;
    n: CARDINAL;
    words: ValueDescriptor;
    IF tb[node].son[1] # Tree.Null THEN TypeExp[tb[node].son[1]];
    n ← P4.WordsForType[type];
    words ← (dataPtr.zone).NEW[WordSeq[n]];
    FOR i: CARDINAL IN [0..n) DO words[i] ← 0 ENDLOOP;
    PushLit[LiteralOps.FindDescriptor[DESCRIPTOR[words]]];
    IF n > 1 THEN {PushNode[mwconst, 1]; SetInfo[type]};
    FreeNode[node];  (dataPtr.zone).FREE[@words];
    VPush[BiasForType[type], LiteralAttr[RepForType[type]], RegsForType[type]];
    RETURN [ForceType[PopTree[], type]]};


 -- misc addressing operators

  AddrOp: PUBLIC PROC [node: Tree.Index] RETURNS [val: Tree.Link] = {
    attr: Attr;
    nRegs: RegCount;
    SELECT tb[node].name FROM

      addr => val ← Addr[node];

      base => {
	tb[node].son[1] ← Exp[tb[node].son[1], none];
	nRegs ← VRegs[]; attr ← [prop: VProp[], rep: unsigned];  VPop[];
	VPush[0, attr, nRegs];  val ← [subtree[index: node]]};

      length => {
	type: CSEIndex;
	tb[node].son[1] ← Exp[tb[node].son[1], none];
	type ← OperandType[tb[node].son[1]];
	WITH seb[type] SELECT FROM
	  array => {
	    val ← MakeTreeLiteral[Cardinality[indexType]];
	    FreeNode[node];  attr ← LiteralAttr[both];  nRegs ← 1};
	  ENDCASE => {
	    val ← [subtree[index: node]]; attr ← [prop: VProp[], rep: both]; nRegs ← VRegs[]};
	VPop[];  VPush[0, attr, nRegs]};

      arraydesc =>
	val ← IF OpName[tb[node].son[1]] # list THEN Desc[node] ELSE DescList[node];

      ENDCASE => {
	Log.Error[unimplemented]; VPush[0, voidAttr, 0]; val ← [subtree[node]]};

    RETURN};


  Addr: PROC [node: Tree.Index] RETURNS [val: Tree.Link] = {
    OPEN tb[node];
    v: Tree.Link;
    subNode: Tree.Index;
    type, next: CSEIndex;
    prop: Prop;
    nRegs: RegCount;
    son[1] ← Exp[son[1], none];
    nRegs ← MAX[VRegs[], RegsForType[info]];  prop ← VProp[];
    FOR t: Tree.Link ← son[1], v DO
      WITH t SELECT FROM
	symbol => {
	  sei: Symbols.ISEIndex = index;
	  IF ctxb[seb[sei].idCtx].level = Symbols.lZ AND
	     (LOOPHOLE[seb[sei].idValue, Symbols.BitAddress].bd # 0 OR
	      LOOPHOLE[seb[sei].idInfo, CARDINAL] MOD WordLength # 0) THEN GO TO fail;
	  GO TO pass};
	subtree => {
	  subNode ← index;
	  SELECT tb[subNode].name FROM
	    dot, dollar =>  v ← tb[subNode].son[2];
	    index, dindex, seqindex =>
	      FOR  type ← NormalType[OperandType[tb[subNode].son[1]]], next DO
		WITH t: seb[type] SELECT FROM
		  array => IF t.packed THEN GO TO fail ELSE GO TO pass;
		  sequence => IF t.packed THEN GO TO fail ELSE GO TO pass;
		  arraydesc => next ← UnderType[t.describedType];
		  ENDCASE => ERROR;
		ENDLOOP;
	    apply => GO TO fail;
	    uparrow, reloc => GO TO pass;
	    cast, chop => v ← tb[subNode].son[1];
	    ENDCASE => ERROR};
	ENDCASE => ERROR;
      REPEAT
	pass => NULL;
	fail => Log.ErrorTree[nonAddressable, son[1]]; 
      ENDLOOP;
    val ← [subtree[index: node]];
    IF OpName[son[1]] = dot THEN {
      subNode ← GetNode[son[1]];
      IF TreeLiteral[tb[subNode].son[1]] THEN {
	val ← MakeStructuredLiteral[
	    TreeLiteralValue[tb[subNode].son[1]] + LOOPHOLE[
	      seb[NARROW[tb[subNode].son[2], Tree.Link.symbol].index].idValue,
	      Symbols.BitAddress].wd,
	    info];
	FreeNode[node]}};
    VPop[];
    VPush[0, [prop: prop, rep: unsigned], nRegs];  RETURN};


  Desc: PROC [node: Tree.Index] RETURNS [Tree.Link] = {
    subNode: Tree.Index = GetNode[tb[node].son[1]];
    long: BOOL = tb[subNode].attr2;
    prop: Prop;
    nRegs: RegCount;
    subType: CSEIndex;
    tb[subNode].son[1] ← Exp[tb[subNode].son[1], none];
    nRegs ← VRegs[];  prop ← VProp[];  VPop[];
    subType ← OperandType[tb[subNode].son[1]];
    WITH t: seb[subType] SELECT FROM
      array => {
	n: CARDINAL = Cardinality[t.indexType];
	IF n = 0 THEN Log.WarningTree[sizeClash, tb[subNode].son[1]];
	IF t.packed AND (BitsForType[subType] MOD WordLength # 0) THEN
	  Log.ErrorTree[nonAddressable, tb[subNode].son[1]];
	PushTree[[subtree[subNode]]];  PushTree[MakeTreeLiteral[n]]};
      sequence => {
	copy: Tree.Link = IdentityMap[tb[subNode].son[1]];
	cNode: Tree.Index = NARROW[copy, Tree.Link.subtree].index;
	PushTree[tb[subNode].son[1]];  PushTree[MakeTreeLiteral[0]];
	PushNode[seqindex, 2];  SetInfo[UnderType[t.componentType]];
	SetAttr[2, long];  SetAttr[3, FALSE];
	tb[subNode].son[1] ← PopTree[];  PushTree[[subtree[subNode]]];
	tb[cNode].son[2] ← FreeTree[tb[cNode].son[2]];
	tb[cNode].son[2] ← [symbol[index: t.tagSei]];
	tb[cNode].info ← dataPtr.typeCARDINAL;
	PushTree[copy]};
      record => {  -- StringBody only (compatibility glitch)
	copy: Tree.Link = IdentityMap[tb[subNode].son[1]];
	sei: Symbols.ISEIndex = NextSe[NextSe[FirstCtxSe[t.fieldCtx]]];
	PushTree[tb[subNode].son[1]];  PushSe[sei];  PushNode[dollar, 2];
	SetInfo[UnderType[seb[sei].idType]];  SetAttr[2, long];
	tb[subNode].son[1] ← PopTree[];  PushTree[[subtree[subNode]]];
	PushTree[copy];  PushSe[NextSe[FirstCtxSe[t.fieldCtx]]];  PushNode[dollar, 2];
	SetInfo[dataPtr.typeCARDINAL]; SetAttr[2, long]};
      ENDCASE => {
	Log.ErrorTree[typeClash, tb[subNode].son[1]];
	PushTree[[subtree[subNode]]];  PushTree[Tree.Null]};
    PushTree[Tree.Null];  PushNode[list, 3];  tb[node].son[1] ← PopTree[];
    VPush[0, [prop: prop, rep: other], MAX[RegsForType[tb[node].info], nRegs]];
    RETURN [[subtree[index: node]]]};

  DescList: PROC [node: Tree.Index] RETURNS [val: Tree.Link] = {
    subNode: Tree.Index = GetNode[tb[node].son[1]];
    type: CSEIndex = tb[node].info;
    subType: CSEIndex;
    prop: Prop;
    nRegs: RegCount;
    tb[subNode].son[1] ← RValue[tb[subNode].son[1], 0, unsigned];
    nRegs ← VRegs[];  prop ← VProp[];  subType ← OperandType[tb[subNode].son[1]];
    WITH seb[subType] SELECT FROM
      ref =>
	IF BitsForType[refType] MOD WordLength # 0 THEN
	  Log.ErrorTree[nonAddressable, tb[subNode].son[1]];
      ENDCASE;
    tb[subNode].son[2] ← RValue[tb[subNode].son[2], 0, none];
    nRegs ← MAX[VRegs[], nRegs];  prop ← CommonProp[VProp[], prop];
    IF tb[subNode].son[3] # Tree.Null THEN TypeExp[tb[subNode].son[3]];
    VPop[]; VPop[];
    IF StructuredLiteral[tb[subNode].son[1]] AND TreeLiteral[tb[subNode].son[2]] THEN {
      n: CARDINAL = WordsForType[type];
      words: ValueDescriptor ← (dataPtr.zone).NEW[WordSeq[n]];
      FillMultiWord[words, 0, tb[subNode].son[1]];
      words[n-1] ← TreeLiteralValue[tb[subNode].son[2]];
      PushLit[LiteralOps.FindDescriptor[DESCRIPTOR[words]]];
      PushNode[mwconst, 1];  SetInfo[type];
      (dataPtr.zone).FREE[@words];
      val ← PopTree[];  FreeNode[node]}
    ELSE val ← [subtree[index: node]];
    VPush[0, [prop: prop, rep: other], MAX[RegsForType[type], nRegs]];  RETURN};

  }.