Subversion Repositories tendra.SVN

/*

    		 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: pwe $

$Date: 1998/03/11 11:03:21 $

$Revision: 1.3 $

$Log: const.c,v $

 * Revision 1.3  1998/03/11  11:03:21  pwe

 * DWARF optimisation info

 *

 * Revision 1.2  1998/01/29  16:59:07  pwe

 * hold2

 *

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

 * First version to be checked into rolling release.

 *

 * Revision 1.5  1998/01/09  09:28:40  pwe

 * prep restructure

 *

 * Revision 1.4  1997/10/10  18:15:21  pwe

 * prep ANDF-DE revision

 *

 * Revision 1.3  1996/11/04  15:15:13  currie

 * no err-jumps in const extraction

 *

Revision 1.2  1995/08/15 08:25:29  currie

Shift left + trap_tag

 * Revision 1.1  1995/04/06  10:44:05  currie

 * Initial revision

 *

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

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

 *                         const.c

 *  This file defines the routines which implement the TDF-to-TDF

 *  optimising transformation which removes constant expressions from

 *  program fragments (typically loops).

 *

 *  The type maxconst returns information about the expression under

 *  consideration. The field self is true if the expression as a whole is

 *  constant within the program fragment under consideration. If the

 *  entire expression is not constant (self is false) then the field cont

 *  is a list of the sub-expressions which are constant within the

 *  specified region.

 *

 *  The type maxconst is defined in consttypes.h

 *

 *  The principal procedures defined here are mc_list, repeat_consts and

 *  return_repeats. They are described below.

 *

 *  Also used externally is intnl_to.

 *

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

#include "config.h"

#include "common_types.h"

#include "consttypes.h"

#include "constmacs.h"

#include "tags.h"

#include "expmacs.h"

#include "exp.h"

#include "check.h"

#include "install_fns.h"

#include "shapemacs.h"

#include "check_id.h"

#include "flags.h"

#include "externs.h"

#include "installglob.h"

#include "is_worth.h"

#include "flpt.h"

#include "flpttypes.h"

#include "xalloc.h"

#include "messages_c.h"

#include "basicread.h"

#include "me_fns.h"

#ifdef NEWDIAGS

#include "dg_aux.h"

#endif

#include "const.h"

/* MACROS */

#define false 0

#define true  1

#define MAXUSE 16

#define VERYBIGUSAGE 100

#define MEMINC 64

#define nilmem ((memlist *)0)

/* IDENTITIES */

static maxconst self_const = {

  true, nilexp

},

/* the entire expression is constant */

    no_consts = {

  false, nilexp

};

/* no part of the expression is constant */

/* VARIABLES */

/* All variables initialised */

typedef struct _memlist {

  exp dec;

  int res;

  struct _memlist *next;

}   memlist;

		/* no need to init mem and fmem */

static memlist *mem = nilmem,	/* current list of frequent identifiers */

   *fmem = nilmem;		/* list of free cells */

static prop cond_flag = 0;	/* pushed value */

/* 1 => inside cond(..);  2 => after test() in cond() */

static int arg_is_reff;		/* no init needed */

/* arg is reffield, so contents doesn't need guarding */

#define globmax 100

static int glob_index;

static exp glob_dest[globmax];

static int has_lj_dest;

/* PROCEDURES */

exp get_repeats PROTO_S ((void));

static int find_glob

    PROTO_N ( (e) )

    PROTO_T ( exp e )

{

  int i;

  for ( i = 0; i < glob_index; i++)

    if (glob_dest[i] == e)

      return 1;

  return 0;

}

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

 *  ret_constlist returns the elements of a constants-list

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

void ret_constlist

    PROTO_N ( (head) )

    PROTO_T ( exp head )

{

  if (head != nilexp) {

    exp limit = pt (head), t = son (head), n;

    retcell (head);

    while (t != limit) {

      n = bro (t);

      retcell (t);

      t = n;

    }

    retcell (t);

  }

  return;

}

static maxconst max_const PROTO_S ( ( exp, exp, int ) ) ;

/* declaration - max_const and mc_list are mutually recursive */

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

 *  mc_list examines a list of expressions, and for each of them

 *  extracts the largest expressions which are constant within the

 *  region of interest.

 *

 *  Parameters:

 *        whole   the program region under consideration

 *        e       the first expression in the list. Expressions are

 *                linked via the brother field.

 *        ass_ok  all assignments in this region are to simple unaliassed

 *                variables

 *        good    if this is true AND all the expressions in the list are

 *                constant then the value self_const is returned.

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

static maxconst mc_list

    PROTO_N ( (whole, e, ass_ok, good) )

    PROTO_T ( exp whole X exp e X int ass_ok X int good )

{

  exp t = e;

  int contin = true;

  maxconst mc, result;

  result.self = good;

  result.cont = nilexp;

  do {

    /* NB - t may be killed within max_const (offset_mult) */

    /* so remember next one in list */

    exp next_t = bro (t);

    if (last (t))

      contin = false;

    mc = max_const (whole, t, ass_ok);

    if (mc.self) {

      /* the whole of t is constant */

      /* make a list element */

      exp w = getexp (f_bottom, nilexp, false, t, nilexp, cond_flag,

		       0, 0);

      if (result.cont == nilexp)/* first item - start a list */

	result.cont = getexp (f_bottom, nilexp, false, w, w, 0,  0, 0);

      else {			/* add this to list */

	bro (pt (result.cont)) = w;

	pt (result.cont) = w;

      }

    } else {

      result.self = false;	/* some part of e is not constant */

      if (mc.cont != nilexp) {	/* but t has constants in it */

	if (result.cont != nilexp) {	/* add them to list */

	  bro (pt (result.cont)) = son (mc.cont);

	  pt (result.cont) = pt (mc.cont);

	  retcell (mc.cont);

	} else			/* list was empty - start list */

	  result.cont = mc.cont;

      }

    }

    t = next_t;

  }

  while (contin);

  if (result.self) {

    ret_constlist (result.cont);

    return (self_const);

  }

  return result;

}

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

 *  intnl_to returns true if part is contained in whole

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

int intnl_to

    PROTO_N ( (whole, part) )

    PROTO_T ( exp whole X exp part )

{

  exp q = part;

  while (q != whole && q != nilexp && name(q) != hold_tag

		&& name(q) != hold2_tag &&

	 (name (q) != ident_tag || !isglob (q)))

    q = father (q);

  return q == whole;

}

/* heavily used idents are kept in lookup list */

static int not_assigned_to PROTO_S ( ( exp, exp ) ) ;

static int not_ass2

    PROTO_N ( (vardec, piece) )

    PROTO_T ( exp vardec X exp piece )

{

  /*

   * this replaces used_in with stronger test - see changes in assigns_alias

   */

  exp t = pt (vardec);

  exp q;

  exp upwards = t;

  do {				/* test each use of the identifier */

    q = t;

    while (q != nilexp && q != piece && q != vardec &&

	   name (q) != rep_tag &&

	   (name (q) != ident_tag || !isglob (q))) {

      upwards = q;

      q = bro (q);

    }

    if (q != nilexp && q != piece && name (q) == rep_tag) {

      /* q has got to a repeat, so */

      /* scan up repeat_list structure for holder of piece */

      exp h = pt (q), hp = pt (piece);

      while (h != nilexp && h != hp)

	h = bro (h);

      if (h == hp) {

	/* q was within piece */

	q = piece;

	upwards = son (q);

	while (!last (upwards))

	  upwards = bro (upwards);

      } else

	q = nilexp;

    }

    /* ascend from the use until we reach either vardec or piece */

    if (q == piece && last (upwards)) {	/* the use was in piece */

      if (isreallyass(t))

        return false;

      if (!last (t) && last (bro (t)) &&

	  (name (bro (bro (t))) == ass_tag ||

	   name (bro (bro (t))) == assvol_tag))

	return false;		/* the use was an assignment */

      if (!last (t) && last (bro (t))

	  && name (bro (bro (t))) == ident_tag) {

	/* use in declaration */

	if (!isvar (bro (bro (t))) &&

	    !not_assigned_to (bro (bro (t)), bro (t))) {

	  return false;

	}

      } else {

	exp dad = father (t);

	if (name (dad) == addptr_tag && son (dad) == t) {

	  /* use in subscript .... */

	  if (!last (dad) && last (bro (dad)) &&

	       (name (bro (bro (dad))) == ass_tag ||

	         name (bro (bro (dad))) == assvol_tag))

	    return false;		/* the use was an assignment */

	  if (!last (dad) && last (bro (dad)) &&

	      name (bro (bro (dad))) == ident_tag) {

	    /* ... which is identified */

	    if (!isvar (bro (bro (dad))) &&

		!not_assigned_to (bro (bro (dad)), bro (dad))) {

	      return false;

	    }

	  }

	}

      }

    }

    t = pt (t);

  } while (t != nilexp);

  return true;

}

static int not_assigned_to

    PROTO_N ( (vardec, body) )

    PROTO_T ( exp vardec X exp body )

{

  if (no (vardec) > VERYBIGUSAGE)

    return false;

  if (no (vardec) > MAXUSE) {

    /* when a variable is used many times the result from not_ass2 */

    /* is saved in an ordered list to avoid n-squared run-times    */

    memlist *ptr = mem;

    /* is this declaration known? */

    /* NOTE: memory is cleared after each repeat is processed */

    /* so any in memory refer to the current repeat */

    while (ptr != nilmem && (ptr->dec) != vardec)

      ptr = ptr->next;

    if (ptr == nilmem) {

      memlist **pp = &mem;

      /* insert with heavier used decs first */

      while (*pp != nilmem && no ((*pp)->dec) > no (vardec))

	pp = &((*pp)->next);

      if (fmem == nilmem) {

	/* add some cells onto the free list */

	memlist **fpp = &fmem;

	int i;

	*fpp = (memlist *) xcalloc (MEMINC, sizeof (memlist));

	for (i = 0; i < MEMINC; ++i) {

	  (*fpp)->next = (*fpp) + 1;

	  fpp = &((*fpp)->next);

	}

	*fpp = nilmem;

      }

      /* get a cell from the free list */

      ptr = fmem;

      fmem = ptr->next;

      /* remember this vardec */

      ptr->dec = vardec;

      ptr->res = not_ass2 (vardec, body);

      /* put cell into mem list */

      ptr->next = *pp;

      *pp = ptr;

    }

    return (ptr->res);

  } else

    /* default case - identifier not heavily used */

    return (not_ass2 (vardec, body));

}

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

 *  max_const extracts the largest expressions which are constant within

 *  the region of interest.

 *

 *  Parameters:

 *        whole   the program region under consideration

 *        e       the expression under consideration

 *        ass_ok  all assignments in this region are to simple unaliassed

 *                variables

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

static maxconst max_const

    PROTO_N ( (whole, e, ass_ok) )

    PROTO_T ( exp whole X exp e X int ass_ok )

{

  switch (name (e)) {

  case labst_tag:

    return mc_list (whole, bro (son (e)), ass_ok, false);

  case contvol_tag:

  case case_tag:

  case goto_tag:

  case apply_general_tag:

  case tail_call_tag:

    return no_consts;

  case fdiv_tag: {

    maxconst mc;

    maxconst mct;

    mc = max_const(whole, bro(son(e)), ass_ok);

    mct = mc_list (whole, son (e), ass_ok, optop(e));

    if (mct.self)

      return mct;

    if (mc.self && !strict_fl_div && optop(e)) {

      flpt f = new_flpt();

      exp funit;

      exp temp1;

      exp temp2;

      flt_copy (flptnos[fone_no], &flptnos[f]);

      funit = getexp(sh(e), nilexp, 0, nilexp, nilexp,

			0, f, real_tag);

      temp1 = me_b3(sh(e), funit, bro(son(e)), fdiv_tag);

      temp2 = me_b3(sh(e), son(e), temp1, fmult_tag);

#ifdef NEWDIAGS

      dgf(temp2) = dgf(e);

#endif

      replace(e, temp2, temp2);

      return max_const(whole, temp2, ass_ok);

    }

    else

      return mct;

  };

  case cond_tag:{

      prop old_cond_flag = cond_flag;

      maxconst mc;

      if (cond_flag == 0)

	cond_flag = 1;

      mc = mc_list (whole, son (e), ass_ok, false);

      cond_flag = old_cond_flag;

      return mc;

    }

  case test_tag:{

      maxconst mc;

      mc = mc_list (whole, son (e), ass_ok, false);

      if (cond_flag == 1)

	cond_flag = 2;

      return mc;

    }

  case val_tag:

  case proc_tag:

  case env_offset_tag:

  case general_env_offset_tag:

    return self_const;

  case name_tag:

    if (intnl_to (whole, son (e)))

      return no_consts;		/* internal const - may change */

    else

      return self_const;	/* external constant */

  case cont_tag:

    if ((name (son (e)) == name_tag) && isvar (son (son (e)))) {

      /* so e is extracting the contents of a variable */

      exp var = son (son (e));

      if (!intnl_to (whole, var) && (not_assigned_to (var, whole))

	  && ass_ok) {

	/*

	 * variable declared external to whole, and NEVER assigned to in

	 * whole

	 */

	if (iscaonly(var))

	  return self_const;

	if (isglob(var) && !find_glob(var))

	  return self_const;

	return no_consts;

	}

      else

	return no_consts;

    } else

      return mc_list (whole, son (e), ass_ok, ass_ok);

  case plus_tag:

  case and_tag:

  case or_tag:

  case xor_tag:

  case mult_tag:{

      maxconst mc;

      mc = mc_list (whole, son (e), ass_ok, optop(e));

      if (mc.cont != nilexp && pt (mc.cont) != son (mc.cont) && optop(e)) {

	/* more than 1 item in list */

	exp limit = pt (mc.cont), h = son (mc.cont), arg, this, last_h;

	int arg_count = 0;

	int tot_args = 1;

	this = son(e);

	while(!last(this)) {

	  this = bro(this);

	  ++tot_args;

	};

	/* remember for which operator these are arguments */

	/* NB - some items may not be args of this operator */

	while (h != nilexp) {

	  this = son (h);

	  arg = son (e);

	  while (arg != nilexp && arg != this)

	    arg = (last (arg) ? nilexp : bro (arg));

	  if (arg != nilexp) {

	    /* it's an argument of this operator */

	    ++arg_count;

	    pt (h) = e;

	    last_h = h;

	  }

	  h = (h == limit ? nilexp : bro (h));

	}

	/* remove reference to operator if only 1 arg is const */

	if (arg_count != tot_args && arg_count > 0) {

	  SET(last_h);

	  pt (last_h) = nilexp;

	};

      }

      return mc;

    }

  case addptr_tag:{

      exp p = son (e);

      maxconst mc, mx;

      /* find the root pointer */

      while (name (p) == addptr_tag)

	p = son (p);

      mc = max_const (whole, p, ass_ok);

      ret_constlist (mc.cont);

      if (mc.self) {

	/* root pointer is constant in this context */

	exp c_list = nilexp, v_list = nilexp, x, cph, *list;

	/* construct list of ALL constant parts */

	/* initial list element will hold const. ptr */

	cph = getexp (f_bottom, nilexp, false, nilexp, nilexp,

		      0,  0, 0);

	mc.self = false;	/* assume, for moment */

	mc.cont = getexp (f_bottom, nilexp, false, cph, cph,

			  0,  0, 0);

	/* return up the chain, testing the offsets */

	while (p != e) {

	  mx = max_const (whole, bro (p), ass_ok);

	  p = bro (p);		/* p is now the offset */

	  /* add offset to appropriate list */

	  list = (mx.self) ? &c_list : &v_list;

	  *list = getexp (nilexp, *list, 0, p, nilexp, 0,  0, 0);

	  if (mx.cont != nilexp) {

	    /* the offset is not constant, but PARTS of it are */

	    /* remove any "negate(name(...))" */

	    exp lim = pt (mx.cont), h = son (mx.cont);

	    while (h != nilexp) {

	      if (name (son (h)) == neg_tag &&

		  name (son (son (h))) == name_tag)

		no (h) = -1;	/* set "done" flag */

	      h = (h == lim ? nilexp : bro (h));

	    }

	    /* add constant parts to mc */

	    bro (pt (mx.cont)) = son (mc.cont);

	    son (mc.cont) = son (mx.cont);

	    retcell (mx.cont);

	  }

	  p = bro (p);		/* p is now the next higher operation */

	}

	if (v_list == nilexp) {

	  /* whole addptr expression is constant */

	  /* return c_list elements */

	  while (c_list != nilexp) {

	    x = c_list;

	    c_list = bro (c_list);

	    retcell (x);

	  }

	  ret_constlist (mc.cont);

	  return self_const;

	}

	/* go down the chain of addptrs, rearranging offsets */

	/* NB - assumes addptr is strictly diadic, so "last" */

	/* flags are already correct		       */

	/* put non-constant offsets at the higher levels */

	while (v_list != nilexp) {

	  /* put next offset in 2nd argument position */

	  x = son (p);

	  bro (x) = son (v_list);

	  bro (bro (x)) = p;

	  p = x;		/* point to 1st argument */

	  /* traverse v_list, returning elements */

	  x = v_list;

	  v_list = bro (x);

	  retcell (x);

	}

	/* the rest is constant - add it to mc.cont */

	son (cph) = p;

	/* and put constant offsets at the lower levels */

	while (c_list != nilexp) {

	  /* put next offset in 2nd argument position */

	  x = son (p);

	  bro (x) = son (c_list);

	  bro (bro (x)) = p;

	  p = x;		/* point to 1st argument */

	  /* traverse c_list, returning elements */

	  x = c_list;

	  c_list = bro (x);

	  retcell (x);

	}

	return mc;

      } else

	return mc_list (whole, son (e), ass_ok, true);

    }

  case offset_mult_tag:{

      exp arg1 = son (e);

      exp arg2 = bro (arg1);

      maxconst mc1, mc2;

      shape ofsh = sh (e);

      mc1 = max_const (whole, arg1, ass_ok);

      mc2 = max_const (whole, arg2, ass_ok);

      if (mc1.self && mc2.self)

	return self_const;

      if (mc2.self && mc1.cont != nilexp) {

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

         * the offset is const, and arg1 has some constant parts

         * so transform:

         *   offset_mult((a*b),K)

         * to:

         *   offset_mult(a,offset_mult(b,K))

         * rearranged so that the constant factors are grouped

         * with K so that the largest possible structure can be

         * extracted as constant

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

	exp klist = nilexp, nklist = nilexp;

	exp *ref;

	exp m_res;

	int j;

	ret_constlist (mc1.cont);

	if (name (arg1) == mult_tag) {

	  exp m_arg = son (arg1);

	  /* sort into const and varying args */

	  while (m_arg != nilexp) {

	    mc1 = max_const (whole, m_arg, ass_ok);

	    if (mc1.self) {

	      /* add to constant operand list */

	      klist = getexp (nilexp, klist, false, m_arg, nilexp,

			      0,  0, 0);

	    } else {

	      /* add to non-constant operand list */

	      nklist = getexp (nilexp, nklist, false, m_arg, nilexp,

			       0,  0, 0);

	      ret_constlist (mc1.cont);

	    }

	    if (last (m_arg))

	      m_arg = nilexp;

	    else

	      m_arg = bro (m_arg);

	  }

	  /* build offset_mult chain with const parts innermost */

	  m_res = copy (arg2);

	  for (j = 0; j < 2; ++j) {

	    exp *list = (j == 0) ? &klist : &nklist;

	    /* use klist, and then nklist */

	    while (*list != nilexp) {

	      exp z = *list;

	      exp a1 = copy (son (z));

	      exp offmul = getexp (ofsh, nilexp, false, a1, nilexp,

				   0,  0, offset_mult_tag);

	      setbro (a1, m_res);

	      clearlast (a1);

	      setbro (m_res, offmul);

	      setlast (m_res);

	      m_res = hold_check(offmul);

	      *list = bro (z);

	      retcell (z);

	    }

	  }

	  /* insert m_res - kill left overs */

	  ref = refto (father (e), e);

	  if (last (*ref))

	    setlast (m_res);

	  else

	    clearlast (m_res);

	  bro (m_res) = bro (*ref);

	  *ref = m_res;

	  kill_exp (e, e);

	} else

	  m_res = e;

	return mc_list (whole, son (m_res), ass_ok, true);

      }

      /* default action */

      return mc_list (whole, son (e), ass_ok, true);

    }

  default:

    if (son (e) == nilexp)

      return self_const;

    else

      return mc_list (whole, son (e), ass_ok, is_a (name (e)) && optop(e));

  }

}

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

 *  do_this_k

 *    replaces simple and compound constants in list by uses of a

 *    newly declared constant.

 *  Parameters:

 *        kdec    declaration of this new constant

 *        patn    pattern to look for

 *                NB where safe_eval has NOT been used,

 *                   patn is son(kdec)

 *        list    list of constant expresion holders

 *        limit   last constant holder in list

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

void do_this_k

    PROTO_N ( (kdec, patn, list, limit) )

    PROTO_T ( exp kdec X exp patn X exp list X exp limit )

{

  exp t = list;

  int scan = true;

  exp arglist = nilexp, ap;

  int nargs = 0;

  if (pt (list) != nilexp) {

    /* build required argument list */

    exp p = son (patn);

    while (p != nilexp) {

      exp arg_h = getexp (nilexp, arglist, 0, p, nilexp, 0, 0, 0);

      arglist = arg_h;

      ++nargs;

      p = (last (p) ? nilexp : bro (p));

    }

  }

  while (scan) {

    if (no (t) == 0) {

      if (pt (t) == nilexp && eq_exp (son (t), patn)) {

	/* simple correspondence */

	exp e = son (t);

	exp f = father (e);

	exp tagt = getexp (sh (e), bro (e),  (int)(last (e)),

			   kdec, pt (kdec), 0,  0, name_tag);

	pt (kdec) = tagt;

	++no (kdec);

#ifdef NEWDIAGS

	if (diagnose)

	  dg_extracted (tagt, *(refto (f, e)));

#endif

	*(refto (f, e)) = tagt;

	no (t) = -1;		/* dealt with */

	kill_exp (son (t), son (t));

      } else

      if (pt (t) != nilexp && name (pt (t)) == name (patn)) {

	/* try for complex match - at least the operator is correct */

	/* check errtreat ??? */

	int scan2 = true;

	int matched = 0;

	exp t2 = t, op = pt (t);

	while (matched >= 0 && scan2) {

	  if (no (t2) == 0 && pt (t2) == op) {

	    /* find match in argument list */

	    ap = arglist;

	    while (ap != nilexp &&

		   (pt (ap) != nilexp || !eq_exp (son (t2), son (ap)))

	      )

	      ap = bro (ap);

	    if (ap == nilexp)

	      matched = -1;

	    else {

	      pt (ap) = t2;

	      ++matched;

	    }

	  }

	  if (t2 == limit)

	    scan2 = false;

	  else

	    t2 = bro (t2);

	}

	if (matched == nargs) {

	  exp prev_arg = nilexp, oparg = son (op), cc;

	  int last_arg;

	  cc = getexp (sh (son (kdec)), op, 1, kdec, pt (kdec), 0,

		        0, name_tag);

	  pt (kdec) = cc;

	  ++no (kdec);

	  while (oparg != nilexp) {

	    last_arg = (int)last (oparg);

	    ap = arglist;

	    while (ap != nilexp && son (pt (ap)) != oparg)

	      ap = bro (ap);

	    if (ap == nilexp) {

	      /* this is one of the other args of op */

	      if (prev_arg == nilexp)

		son (op) = oparg;

	      else

		bro (prev_arg) = oparg;

	      clearlast (oparg);

	      prev_arg = oparg;