Subversion Repositories tendra.SVN

/*

    Copyright (c) 1993 Open Software Foundation, Inc.

    All Rights Reserved

    Permission to use, copy, modify, and distribute this software

    and its documentation for any purpose and without fee is hereby

    granted, provided that the above copyright notice appears in all

    copies and that both the copyright notice and this permission

    notice appear in supporting documentation.

    OSF DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING

    ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A

    PARTICULAR PURPOSE.

    IN NO EVENT SHALL OSF BE LIABLE FOR ANY SPECIAL, INDIRECT, OR

    CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM

    LOSS OF USE, DATA OR PROFITS, WHETHER IN ACTION OF CONTRACT,

    NEGLIGENCE, OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION

    WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.

*/

/*

    		 Crown Copyright (c) 1997

    This TenDRA(r) Computer Program is subject to Copyright

    owned by the United Kingdom Secretary of State for Defence

    acting through the Defence Evaluation and Research Agency

    (DERA).  It is made available to Recipients with a

    royalty-free licence for its use, reproduction, transfer

    to other parties and amendment for any purpose not excluding

    product development provided that any such use et cetera

    shall be deemed to be acceptance of the following conditions:-

        (1) Its Recipients shall ensure that this Notice is

        reproduced upon any copies or amended versions of it;

        (2) Any amended version of it shall be clearly marked to

        show both the nature of and the organisation responsible

        for the relevant amendment or amendments;

        (3) Its onward transfer from a recipient to another

        party shall be deemed to be that party's acceptance of

        these conditions;

        (4) DERA gives no warranty or assurance as to its

        quality or suitability for any purpose and DERA accepts

        no liability whatsoever in relation to any use to which

        it may be put.

*/

/**********************************************************************

$Author: release $

$Date: 1998/02/04 15:49:01 $

$Revision: 1.2 $

$Log: needscan.c,v $

 * Revision 1.2  1998/02/04  15:49:01  release

 * Added OSF copyright message.

 *

 * Revision 1.1.1.1  1998/01/17  15:55:57  release

 * First version to be checked into rolling release.

 *

 * Revision 1.4  1996/10/14  17:31:56  pwe

 * include called callees in env_size

 *

 * Revision 1.3  1996/10/14  15:53:31  pwe

 * preserve regresult during postlude

 *

 * Revision 1.2  1996/10/04  16:03:03  pwe

 * add banners and mod for PWE ownership

 *

**********************************************************************/

/******************************************************************

		needs_scan.c

	Defines the scan through a program which reorganises it so that all

arguments of operations are suitable for later code-production. The procedure

scan evaluates the register requirements of an exp. The exps are produced

from the decoding process and the various exp -> exp transformations  in

the proc independent (common to other  translators)

******************************************************************/

#include "config.h"

#include "memtdf.h"

#include "codegen.h"

#include "myassert.h"

#include "comment.h"

#include "common_types.h"

#include "exptypes.h"

#include "exp.h"

#include "expmacs.h"

#include "tags.h"

#include "localtypes.h"

#include "procrectypes.h"

#include "bitsmacs.h"

#include "maxminmacs.h"

#include "regable.h"

#include "tempdecs.h"

#include "shapemacs.h"

#include "const.h"

#include "flpt.h"

#include "install_fns.h"

#include "externs.h"

#include "flags.h"

#include "machine.h"

#include "translat.h"

#include "check.h"

#include "makecode.h"

#include "needscan.h"

#include "me_fns.h"

#include "stack.h"

#include "error.h"

#include "dynamic_init.h"

/*

 * Will an ident exp be in memory?

 * We have to guess at this stage for non globals.

 */

#define INMEMIDENT(ident_exp)	(isvis(ident_exp) || isglob(ident_exp))

/*

 * Will evaluating exp 'e' cause last instruction to be a load from store?

 * Always false if generating diagnostics, we dont want to rearrange in

 * this case as it makes debugging less obvious.

 * This is not exact, register contents tracking may find a copy in reg.

 */

#define LOADFROMSTORE(e) \

	( \

	!diagnose \

	&& \

	( \

	  (name(e) == cont_tag && (name(son(e)) != name_tag || INMEMIDENT(son(son(e))))) \

	  || \

	  (name(e) == name_tag && isglob(son(e))) /* load of TOC entry */ \

	) \

	)

int maxfix, maxfloat;		/* the maximum number of t-regs */

bool tail_call;

bool gen_call;

long callee_size;

long max_callees;

long no_of_returns;

int end_param;

/* The following are used for allocating param regs to t-regs */

static int freefixed;

static int freefloat;

static int stparam, fixparam, floatparam;

extern bool do_tlrecursion;

static bool nonevis = 1;

static bool rep_tag_scanned;

int scan_cond PROTO_S ((exp *,exp));

needs scan PROTO_S ((exp *, exp ** ));

static void number_caller_parameter PROTO_S ((exp));

static void number_callee_parameter PROTO_S ((exp));

/* declaration of scan.

   needs is defined in procrectypes.h.

   This is a structure which has two integers giving

   the number of fixed and floating point registers required to contain live values

   in the expression parameters. A further field prop is used for various

   flags about certain forms of exp (mainly idents and procs). The maxargs

   field gives the maximum size in bits for the parameters of all the procs

   called in the exp. The needs of a proc body are preserved in the needs field

   of the procrec (see procrectypes.h).

   */

/***************************************************************

		cca

This procedure effectively inserts a new declaration into an exp. This

is used to stop a procedure requiring more than the available number of

registers.

****************************************************************/

static void cca PROTO_N ((to,x)) PROTO_T (exp * *to X exp * x)

{

  if (name((**to))==diagnose_tag)

  {

    *to = &son((**to));

  }

  if (x == (*to))

  {

    exp def = *(x);

    /* replace by  Let tg = def In tg Ni */

    exp id = getexp(sh(def), bro(def), last(def), def, nilexp,

		    0, 1, ident_tag);

    exp tg = getexp(sh(def), id, 1, id, nilexp,

		    0, 0, name_tag);

    pt(id) = tg;		/* use of tag */

    bro(def) = tg;		/* bro(def) is body of Let = tg */

    clearlast(def);

    *(x) = id;			/* replace pointer to x by Let */

    return;

  }

  else

  {				/* replace by Let tg = def In ato/def = tg Ni */

    exp def = *(x);

    exp ato = *(*to);

    exp id = getexp(sh(ato), bro(ato), last(ato), def, nilexp,

		    0, 1, ident_tag);

    exp tg = getexp(sh(def), bro(def), last(def), id, nilexp,

		    0, 0, name_tag);

    pt(id) = tg;		/* use of tg */

    bro(def) = ato;		/* ato is body of Let */

    clearlast(def);

    bro(ato) = id;		/* its father is Let */

    setlast(ato);

    *(*to) = id;		/* replace pointer to 'to' by Let */

    *(x) = tg;			/* replace use of x by tg */

    *to = &bro(def);		/* later replacement to same 'to' will be at

				 * body of Let */

    return;

  }

}

/* General useful needs */

static needs onefix = { 1, 0, 0, 0 };			/* needs one fix pt reg */

static needs twofix = { 2, 0, 0, 0 };			/* needs 2 fix pt regs */

static needs onefloat = { 0, 1, 0, 0 };			/* needs 1 flt pt regs */

static needs zeroneeds = { 0, 0, 0, 0 };		/* has no needs */

static needs shapeneeds PROTO_N ((s)) PROTO_T (shape s)

{				/* this gives the needs for manipulating a

				 * value of shape s */

  if (is_floating(name(s)))

  {

    return onefloat;

  }

  else

  {

    if (valregable(s))

    {

      return onefix;

    }

    else

    {				/* if the shape does not fit into a reg, needs

				 * two fixed regs for moving ... */

      return twofix;

    }

  }

}

static bool complex PROTO_N ((e)) PROTO_T (exp e)

{				/* these are basically the expressions which

				 * cannot be accessed by a simple load or

				 * store instruction */

  if (name(e) == name_tag ||

      (

       name(e) == cont_tag && 

       name(son(e)) == name_tag 

       && isvar(son(son(e)))

       ) || 

      name(e) == val_tag || 

      name(e) == real_tag

      )

  {

    return 0;

  }

  else

  {

    return 1;

  }

}

needs commutative_scan PROTO_N ((e,at)) PROTO_T (exp * e X exp * *at)

{

  /*

   * does the scan on commutative and associative operations and may perform

   * various transformations allowed by these properties

   */

  needs a1;

  needs a2;

  exp dad = *(e);

  exp *br = &son(*e);

  exp prev;

  bool dont_commute;

  ASSERT(father(son(*e)) == *e);

  /* scan the first operand - won't be a val_tag */

  a1 = scan(br, at);

  /* 

   * if first operand is a proc, or ends with a load instruction,

   * it is not worth doing a commute to a later position

   */

  dont_commute = (a1.fixneeds >= maxfix || (a1.propsneeds & hasproccall))

		 || LOADFROMSTORE(*br);

  do

  {

    exp *prevbr;

    prevbr = br;

    prev = *(br);

    br = &bro(prev);

    a2 = scan(br, at);

    /* scan the next operand ... */

    if (name(*(br)) != val_tag)

    {

      prop pc;

      bool all_treg_needs;

      a1.floatneeds = max(a1.floatneeds, a2.floatneeds);

      pc = a2.propsneeds & hasproccall;

      all_treg_needs = (a2.fixneeds >= maxfix || pc != 0);

      if ( !dont_commute

	   &&

	   (all_treg_needs || LOADFROMSTORE(*br))

	   &&

	   (a1.fixneeds < maxfix && (a1.propsneeds & hasproccall) == 0)

	 )

      {

	/*

	 * ...its evaluation will call a proc, or ends with a load instruction,

	 * so put it first

	 */

	exp op1 = son(dad);

	exp cop = *(br);

	bool lcop = last(cop);

	bro(prev) = bro(cop);

	if (lcop)

	  setlast(prev);

	bro(cop) = op1;

	clearlast(cop);

	son(dad) = cop;

	br = (prev == op1) ? &bro(cop) : prevbr;

	dont_commute = 1;

	a1.fixneeds = max(a2.fixneeds, a1.fixneeds + 1);

	a1.propsneeds |= a2.propsneeds;

	a1.maxargs = max(a1.maxargs, a2.maxargs);

      }

      else if (all_treg_needs)

      {				/* ... its evaluation would disturb

				 * accumulated result, so replace it by a

				 * newly declared tag */

	cca(at, br);

	a1.fixneeds = max(a1.fixneeds, 2);

	a1.propsneeds = a1.propsneeds | morefix | (pc << 1);

	a1.maxargs = max(a1.maxargs, a2.maxargs);

      }

      else

      {

	/*

	 * ... its evaluation  will not disturb the accumulated result

	 */

	a1.fixneeds = max(a1.fixneeds, a2.fixneeds + 1);

	a1.propsneeds = a1.propsneeds | a2.propsneeds;

      }

    }

  } while (!last(*(br)));

  return a1;

}

needs non_commutative_scan PROTO_N ((e,at)) PROTO_T (exp * e X exp * *at)

{

  /*

   * scan non-commutative fix pt operation

   */

  needs l;

  needs r;

  prop pc;

  exp *arg = &son(*e);

  l = scan(arg, at);

  /* scan 1st operand */

  arg = &bro(*arg);

  r = scan(arg, at);

  /* scan second operand ... */

  l.floatneeds = max(l.floatneeds, r.floatneeds);

  pc = r.propsneeds & hasproccall;

  if (r.fixneeds < maxfix && pc == 0)

  {				/* ...it fits into registers */

    l.fixneeds = max(l.fixneeds, r.fixneeds + 1);

    l.propsneeds = l.propsneeds | r.propsneeds;

  }

  else

  {				/* ...it requires new declaration of second

				 * operand */

    cca(at, arg);

    l.fixneeds = max(l.fixneeds, 1);

    l.propsneeds = l.propsneeds | morefix | (pc << 1);

    l.maxargs = max(l.maxargs, r.maxargs);

  }

  return l;

}

static needs fpop PROTO_N ((e,at)) PROTO_T (exp * e X exp * *at)

{

  /* scans diadic floating point operation  */

  needs l;

  needs r;

  exp op = *(e);

  prop pcr, pcl;

  exp *arg = &son(op);

  l = scan(arg, at);

  arg = &bro(*arg);

  r = scan(arg, at);

  l.fixneeds = max(l.fixneeds, r.fixneeds);

  pcr = r.propsneeds & hasproccall;

  pcl = l.propsneeds & hasproccall;

  if (r.floatneeds <= l.floatneeds && r.floatneeds < maxfloat && pcr == 0)

  {

    l.floatneeds = max(2, max(l.floatneeds, r.floatneeds + 1));

    l.propsneeds = l.propsneeds | r.propsneeds;

    ClearRev(op);

  }

  else if (pcl == 0 && l.floatneeds <= r.floatneeds && l.floatneeds < maxfloat)

  {

    l.floatneeds = max(2, max(r.floatneeds, l.floatneeds + 1));

    l.propsneeds = l.propsneeds | r.propsneeds;

    SetRev(op);

  }

  else if (r.floatneeds < maxfloat && pcr == 0)

  {

    l.floatneeds = max(2, max(l.floatneeds, r.floatneeds + 1));

    l.propsneeds = l.propsneeds | r.propsneeds;

    ClearRev(op);

  }

  else

  {

    cca(at, arg);

    ClearRev(op);

    l.floatneeds = max(l.floatneeds, 2);

    l.propsneeds = l.propsneeds | morefloat | (pcr << 1);

    l.maxargs = max(l.maxargs, r.maxargs);

  }

  return l;

}

/**********************************************************************

	maxneeds

Calculates a needs value. Each element of which is the maximum of the

corresponding elements in the two parameter needs

**********************************************************************/

static needs maxneeds PROTO_N ((a,b)) PROTO_T (needs a X needs b)

{

  needs an;

  an.fixneeds = max(a.fixneeds, b.fixneeds);

  an.floatneeds = max(a.floatneeds, b.floatneeds);

  an.maxargs = max(a.maxargs, b.maxargs);

  an.propsneeds = a.propsneeds | b.propsneeds;

  return an;

}

/**********************************************************************

	maxsequence

**********************************************************************/

static needs maxtup PROTO_N ((e,at)) PROTO_T (exp e X exp ** at)

{				/* calculates the needs of a tuple of

				 * expressions; any new declarations required

				 * by a component expression will replace the

				 * component expression */

  exp *stat = &son(e);

  needs an;

  an = zeroneeds;

  if(*stat==nilexp )

  {

    return an;

  }

  while (an = maxneeds(an, scan(stat, at)), !last(*stat))

  {

    stat = &bro(*stat);

  }

  return an;

}

static bool unchanged PROTO_N ((usedname,ident)) PROTO_T (exp usedname X exp ident)

{

  /*

   * finds if usedname is only used in cont operation or as result of ident

   * i.e. value of name is unchanged over its scope

   */

  exp uses = pt(usedname);

  while (uses != nilexp)

  {

    if (intnl_to(ident, uses))

    {

      if (!last(uses) || name(bro(uses)) != cont_tag)

      {

	exp z = uses;

	while (z != ident)

	{

	  if (!last(z) ||

	      (name(bro(z)) != seq_tag && name(bro(z)) != ident_tag))

	  {

	    return 0;

	  }

	  z = bro(z);

	}

      }

    }

    uses = pt(uses);

  }

  return 1;

}

static exp *ptr_position PROTO_N ((e)) PROTO_T (exp e)

{

  exp *a;

  exp dad = father(e);

  if (son(dad) == e)

  {

    a = &son(dad);

  }

  else

  {

    exp sib = son(dad);

    while (bro(sib) != e)

    {

      sib = bro(sib);

    }

    a = &bro(sib);

  }

  return a;

}

/*

 * The POWER convention for delivering a struct from a procedure is is have an

 * extra pointer parameter in the proc; this means that there always must be

 * space in the calling work-space for the result struct whether or not the

 * value is used e.g. as in f(x); or f(x).a etc. This proc is part of the

 * mechanism to determine whether it is necessary to insert a dummy

 * declaration to ensure that this space exists.

 */

static bool chase PROTO_N ((sel,e)) PROTO_T (exp sel X exp * e)

{

  /* distribute selection throughout compound expressions */

  bool b = 0;

  exp *one;

  switch (name(*e))

  {

  case ident_tag:

  case seq_tag:

  case rep_tag:

  case labst_tag:

    {

      b = chase(sel, &bro(son(*e)));

      break;

    }

  case solve_tag:

  case cond_tag:

    {

      one = &son(*e);

      for (;;)

      {

	b |= chase(sel, one);

	if (last(*one))

	  break;

	one = &bro(*one);

      }

      break;

    }

  case field_tag:

    {

      if (chase(*e, &son(*e)))

      {

	/* inner field has been distributed */

	exp stare = *e;

	exp ss = son(stare);

	if (!last(stare))

	  clearlast(ss);

	bro(ss) = bro(stare);

	sh(ss) = sh(stare);

	*e = ss;

	return chase(sel, e);

      }				/* ... continue to default */

    }

  default:

    {

      if (son(sel) != *e)

      {				/* only change if not outer */

	exp stare = *e;

	exp newsel = getexp(sh(sel), bro(stare), last(stare), stare, nilexp,

			    props(sel), no(sel), name(sel));

	*e = newsel;

	bro(stare) = newsel;

	setlast(stare);

	b = 1;

      }

    }

  }

  if (b)

    sh(*e) = sh(sel);

  return b;

}

/********************************************************************

		scan

	This procedure works out register requirements of an exp. At each

call the fix field of the needs is the number of fixpnt registers required to contain live values to evaluate this expression. This never exceeds maxfix

because if it would have, a new declaration is introduced in the exp tree (similarly for floating regs and maxfloat). In these cases the prop field will

contain the bits morefix (or morefloat).

	Scan also works out various things concerned with proc calls.

The maxargs field contains the max size in bits of the space required for the

parameters of all the procedures called in the exp. An exp proc call

produces a hasproccall bit in the prop field, if this is transformed as part of

the definition of a new declaration the bit is replaced by a usesproccall. The

distinction is only used in unfolding nested proc calls; POWER requires this to

be done statically. The condition that a proc exp is a leaf (i.e no proc calls)

is that its prop contains neither bit.

	If an ident exp is suitable, scan marks the props of ident with

either inreg or infreg bits to indicate that a t reg may be used for this tag.

	A thorough understanding of needs along with other procedures

that do switch(name(exp)) requires a knowledge of the meaning of the fields

of the exp in each case.

********************************************************************/

needs scan PROTO_N ((e,at)) PROTO_T (exp * e X exp * *at)

{

  /*

   * e is the expression to be scanned, at is the place to put any new decs .

   * NB order of recursive calls with same at is critical

   */

  exp ste = *(e);

  int nstare = name(ste);

  static long exp_num = 0;		/* count of exps we evaluate */

  exp_num++;

  ASSERT(*e != nilexp);

  switch (nstare)

  {

   case 0:

    {/* zero_tag */

      return zeroneeds;

    };

   case compound_tag:

   case nof_tag:

   case concatnof_tag:

   case ncopies_tag:

    {

      needs nl;

      bool cantdo;

      exp dad;

      if(nstare==nof_tag && son(ste)==nilexp)

	return zeroneeds;

      if (name(ste) == ncopies_tag && name(son(ste)) != name_tag

	  && name(son(ste)) != val_tag)

      {

	nl = scan(&son(*e), at);

	cca(at, &son(*e));

      }

      else

      {

	nl = maxtup(*(e), at);

      }

      ste = *e;

      dad = father(ste);

      if (name(dad) == compound_tag || 

	  name(dad) == nof_tag || 

	  name(dad) == concatnof_tag)

      {

	cantdo = 0;

      }

      else if (last(ste))

      {

	if (name(bro(ste)) == ass_tag)

	{

	  exp a = son(bro(ste));

	  cantdo = (name(a) != name_tag || !isvar(son(a)));

	}

	else

	{

	  cantdo = 1;

	}

      }

      else if (last(bro(ste)))

      {

	cantdo = (name(bro(bro(ste))) != ident_tag);

      }

      else

      {

	cantdo = 1;

      }

      if (cantdo)

      {

	/* can only deal with tuples in simple assignment or identity */

	int prps = (nl.propsneeds & hasproccall) << 1;

	cca(at, ptr_position(ste));

	nl = shapeneeds(sh(*(e)));

	nl.propsneeds |= morefix;

	nl.propsneeds |= prps;

      }

      nl.fixneeds = max(nl.fixneeds,2);

      return nl;

    };

  case cond_tag:

    {

      if (scan_cond(e, nilexp) !=0) 

      {

	return scan(e, at);

      }                   /* Else goto next case */

    }

    /*FALLTHROUGH*/

   case rep_tag:

   case solve_tag:

    {

      exp *stat;

      exp *statat;

      needs an;

      stat = &son(*e);

      statat = stat;

      an = zeroneeds;

      rep_tag_scanned=0;

      /* 

       * Simply scan each argument

       * The arguments are effectively independent pieces

       * of code for these constructions 

       */

      /***********************************************************/

      /*    _        _________                                   */

      /*   |_|----->|        _|                                  */

      /*  /         |    _  |_|                                  */

      /* e          |___|_|___|                                  */

      /*               / |                                       */

      /*              /  |                                       */

      /*          stat(1)|       stat(2)       stat(3)           */

      /*             ____v____  /  _________  /  _________       */ 

      /*            |        _|/  |        _|/  |        _|      */

      /*            |    _  |_|-->|    _  |_|-->|    _  |_|-->   */

      /*            |___|_|___|   |___|_|___|   |___|_|___|      */

      /*                                                         */

      /***********************************************************/

      while (an = maxneeds(an, scan(stat, &statat)), !last(*(stat)))

      {

	stat = &bro(*stat);

	statat = stat;

      }

      if(name(*e)==rep_tag)

      {

	if (rep_tag_scanned==0)

	{

	  setinnermost(*e);

	}

	else

	{

	  clearinnermost(*e);

	}

      }

      rep_tag_scanned=1;

      if ((an.propsneeds & usesproccall) != 0)

      {

	an.propsneeds |= hasproccall;

      }

      return an;

    }

  case labst_tag:

    {

      exp *stat;

      exp *statat;

      needs an;

      int expn = exp_num;

      ASSERT(!last(son(*e)));

      ASSERT(last(bro(son(*e))));

      /****************************************/

      /*    _     _________                   */

      /*   |_|-->| labst   |                  */

      /*  /      |    _    |                  */

      /* e       |___|_|___|   stat           */

      /*              |       /               */

      /*          ____v____  /  ________      */

      /*         | clear  _|/  |       _|     */

      /*         |       |_|-->|      |_|     */

      /*         |_________|   |________|     */

      /*                                      */

      /****************************************/

      stat = &bro(son(*e));

      statat = stat;

      an = scan(stat, &statat);

      if ((an.propsneeds & usesproccall) != 0)

      {

	an.propsneeds |= hasproccall;

      }

      /*

       * ptno(son()) is set to exp number so that make_code can estimate

       * distances of conditional branches, which is limited on POWER.

       */

      ptno(son(*e)) = expn;

      return an;

    }

/*********************************************************************

  ident_tag

shape of exp is body,

son is def, brother of son is body,

ptr of ident exp is chain of uses

*********************************************************************/

   case ident_tag:

    {

      needs bdy;

      needs defneeds;

      exp stare = *(e);

      exp *arg;

      exp t = pt(stare), s;

      bool fxregble;

      bool flregble;

      bool old_nonevis = nonevis;

      bool uses_R_RESULT;

      bool uses_FR_RESULT;

#if 0

      /* We can't do this because of env_offset not appearing in the list of uses */