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

$Revision: 1.3 $

$Log: check.c,v $

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

 * DWARF optimisation info

 *

 * Revision 1.2  1998/02/11  16:56:36  pwe

 * corrections

 *

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

 * First version to be checked into rolling release.

 *

 * Revision 1.41  1998/01/09  09:28:25  pwe

 * prep restructure

 *

 * Revision 1.40  1997/12/04  19:38:53  pwe

 * ANDF-DE V1.9

 *

 * Revision 1.39  1997/10/10  18:15:13  pwe

 * prep ANDF-DE revision

 *

 * Revision 1.38  1997/08/23  13:24:00  pwe

 * no invert order, and NEWDIAGS inlining

 *

 * Revision 1.37  1997/08/06  10:58:22  currie

 * Catch overflowed constants, PlumHall requirement

 *

 * Revision 1.36  1996/10/01  08:59:19  currie

 * correct chvar exceptions ADA

 *

Revision 1.35  1996/06/24 17:26:57  currie

PIC code with name substitution

Revision 1.34  1996/06/13 09:24:55  currie

Bitfield alignments

Revision 1.33  1996/06/05 15:29:48  currie

parameter alignment in make_cmpd

 * Revision 1.32  1996/02/28  11:36:18  currie

 * assign to promoted pars

 *

 * Revision 1.31  1996/02/21  09:39:00  currie

 * hppa var_callers + inlined bug

 *

 * Revision 1.30  1996/01/22  14:25:31  currie

 * char parameters on bigendian

 *

 * Revision 1.29  1996/01/17  10:28:06  currie

 * param alignment + case bigval

 *

 * Revision 1.28  1996/01/10  14:58:43  currie

 * BIGEND var params chars & shorts

 *

 * Revision 1.27  1995/11/29  15:30:09  currie

 * computed signed nat

 *

 * Revision 1.26  1995/11/01  11:29:45  currie

 * 32 place shifts

 *

 * Revision 1.25  1995/10/26  10:14:22  currie

 * solve_tag - kill_exp scope reduced

 *

 * Revision 1.24  1995/10/17  12:59:23  currie

 * Power tests + case + diags

 *

 * Revision 1.24  1995/10/17  12:59:23  currie

 * Power tests + case + diags

 *

 * Revision 1.23  1995/10/13  15:14:58  currie

 * case + long ints on alpha

 *

 * Revision 1.22  1995/10/12  15:52:47  currie

 * inlining bug

 *

 * Revision 1.21  1995/10/11  17:09:56  currie

 * avs errors

 *

 * Revision 1.20  1995/10/06  14:41:53  currie

 * Env-offset alignments + new div with ET

 *

 * Revision 1.18  1995/10/04  09:17:26  currie

 * CR95_371 + optimise compounds

 *

 * Revision 1.17  1995/10/03  11:44:58  currie

 * field(compound)

 *

 * Revision 1.16  1995/10/02  10:55:54  currie

 * Alpha varpars + errhandle

 *

 * Revision 1.15  1995/09/19  16:06:43  currie

 * isAlpha!!

 *

 * Revision 1.14  1995/09/15  13:29:00  currie

 * hppa + add_prefix + r_w_m complex

 *

 * Revision 1.13  1995/09/11  15:35:32  currie

 * caller params -ve

 *

 * Revision 1.12  1995/08/31  14:18:56  currie

 * mjg mods

 *

 * Revision 1.11  1995/08/29  10:45:43  currie

 * Various

 *

 * Revision 1.10  1995/08/15  08:25:27  currie

 * Shift left + trap_tag

 *

 * Revision 1.10  1995/08/15  08:25:27  currie

 * Shift left + trap_tag

 *

 * Revision 1.9  1995/08/09  08:59:54  currie

 * round bug

 *

 * Revision 1.8  1995/08/02  13:17:57  currie

 * Various bugs reported

 *

 * Revision 1.7  1995/07/06  09:14:00  currie

 * rem & VERSION

 *

 * Revision 1.6  1995/07/05  09:26:30  currie

 * continue wrong

 *

 * Revision 1.5  1995/07/03  13:42:36  currie

 * Tail call needs fp

 *

 * Revision 1.4  1995/06/26  13:04:32  currie

 * make_stack_limit, env_size etc

 *

 * Revision 1.3  1995/06/22  09:16:19  currie

 * offset_mult bug + power

 *

 * Revision 1.2  1995/05/05  08:10:45  currie

 * initial_value + signtures

 *

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

 * Initial revision

 *

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

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

                             check.c

  The routine check performs the bottom-up TDF-to-TDF optimising

  transformations. When a new exp is created check is applied to

  see if a recognised situation has arisen. check assumes that

  all components of this new exp have already had check applied to them.

  It returns 1 if it has made a change, 0 if not.

  hold_check holds an exp as the son of a dummy exp and then

  applies check. the need for this operation is explained in

  the overall documentation.

  eq_exp compares two exp for equality of effect.

  dochvar takes the int, i, and delivers the number which results from

  changing its variety to that specified by the shape, t.

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

#include "config.h"

#include "common_types.h"

#include "xalloc.h"

#include "expmacs.h"

#include "exp.h"

#include "tags.h"

#include "flpt.h"

#include "flags.h"

#include "externs.h"

#include "install_fns.h"

#include "shapemacs.h"

#include "check_id.h"

#include "me_fns.h"

#include "basicread.h"

#include "szs_als.h"

#include "installglob.h"

#include "machine.h"

#include "messages_c.h"

#include "natmacs.h"

#include "f64.h"

#include "misc_c.h"

#include "readglob.h"

#include "misc_c.h"

#ifdef NEWDIAGS

#include "dg_aux.h"

#endif

#if is80x86

#include "localflags.h"

#endif

#include "check.h"

extern shape containedshape PROTO_S ((int,int));

/* MACROS */

  /* codes for error treaments */

#define impossible 1

#define ignore 2

/* IDENTITIES */

static int  masks[33] = {

  0,

  0x1, 0x3, 0x7, 0xf,

  0x1f, 0x3f, 0x7f, 0xff,

  0x1ff, 0x3ff, 0x7ff, 0xfff,

  0x1fff, 0x3fff, 0x7fff, 0xffff,

  0x1ffff, 0x3ffff, 0x7ffff, 0xfffff,

  0x1fffff, 0x3fffff, 0x7fffff, 0xffffff,

  0x1ffffff, 0x3ffffff, 0x7ffffff, 0xfffffff,

  0x1fffffff, 0x3fffffff, 0x7fffffff, (int)0xffffffff

};

ntest int_inverse_ntest[] = {0, 4, 3, 2, 1, 6, 5};

ntest real_inverse_ntest[] = {0, 10, 9, 8, 7, 6, 5, 4, 3, 2, 1,

				 12, 11, 14, 13};

ntest exchange_ntest[] = {0, 3, 4, 1, 2, 5, 6, 9, 10, 7, 8, 11, 12, 13,

				 14};

#if FBASE == 10

static char maxdigs[] = "4294967296";

#endif

/* PROCEDURES */

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

  hold_check holds an exp as the son of a dummy exp and then

  applies check. After checking it retcells the dummy exp.

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

/* puts body on a hold */

exp hold

    PROTO_N ( (body) )

    PROTO_T ( exp body )

{

  exp body_hold = next_exp();

  son (body_hold) = body;

  bro (body) = body_hold;

  setlast (body);

  bro (body_hold) = nilexp;

#if diagnose_registers

  setname (body_hold, hold_tag);

#else

  setname (body_hold, 102);

#endif

  return (body_hold);

}

exp hold_check

    PROTO_N ( (r) )

    PROTO_T ( exp r )

{

  exp h, sn;

  h = hold (r);

  IGNORE check (r, r);

  sn = son (h);

  bro(sn) = nilexp;

  retcell (h);

  return (sn);

}

exp hold_const_check

    PROTO_N ( (r) )

    PROTO_T ( exp r )

{

  exp ans;

  int old = all_variables_visible;

  all_variables_visible = 0;

  ans = hold_check (r);

  all_variables_visible = old;

  return ans;

}

static exp varchange

    PROTO_N ( (s, e) )

    PROTO_T ( shape s X exp e )

{

				/* applies a change_var operation to e, to

				   get shape s */

  exp r = getexp (s, nilexp, 0, e, nilexp, 0, 0,

      chvar_tag);

  setlast(e);

  bro(e) = r;

  return (hold_check (r));

}

static int flpt_power_of_2

    PROTO_N ( (f) )

    PROTO_T ( flpt f )

{

  flt * r = &flptnos[f];

  unsigned short us = r -> mant[0];

  int i;

  if ((us & (us - 1)) != 0)

    return 0;

  for (i = 1; i < MANT_SIZE; i++) {

    if (r -> mant[i] != 0)

      return 0;

  };

  return 1;

}

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

   eq_explist compares two descendant lists of exp for equality.

   The given values, their bro's, bro(bro)'s  etc are compared until

   an unequal pair is found or the end of one of the  lists (last) is

   found. In this case the lists are equal iff both ends have been

   reached.

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

static int eq_explist

    PROTO_N ( (al, bl) )

    PROTO_T ( exp al X exp bl )

{

  if (al == nilexp && bl == nilexp)

    return (1);

  if (al == nilexp || bl == nilexp)

    return (0);

  if (!eq_exp (al, bl))

    return (0);

  if (last (al) && last (bl))

    return (1);

  if (last (al) || last (bl))

    return (0);

  return (eq_explist (bro (al), bro (bl)));

}

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

    eq_exp compares two exp for equality of effect. If the name of either

    exp is in the side-effecting group (!is_a) the exp are not equal.

    This is a crude test, but if it says the exps are equal this is so.

    contvol is forbidden.

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

int eq_exp

    PROTO_N ( (a, b) )

    PROTO_T ( exp a X exp b )

{

  if (name (a) == name (b)) {

    if (name (a) == name_tag)

      return (son (a) == son (b) && no (a) == no (b) &&

	  eq_shape (sh (a), sh (b)));

    if (!is_a (name (a)) || !eq_shape (sh (a), sh (b)) ||

		 name(a) == contvol_tag)

      return (0);

    if (name (a) == real_tag) {

      int   res = flt_cmp (flptnos[no (a)], flptnos[no (b)]);

      return (res == 0);

    };

    if (name(a) == val_tag)  {

      if (isbigval(a)) {

	int res;

	if (!isbigval(b))

	  return 0;

	res = flt_cmp (flptnos[no (a)], flptnos[no (b)]);

        return (res == 0);

      };

      if (isbigval(b))

	return 0;

      return (no(a) == no(b));

    };

    return (no (a) == no (b) &&

	eq_explist (son (a), son (b)));

  };

  return (0);

}

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

   repbycont replaces e by the exp which loads top, ie. does nothing.

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

static void repbycont

    PROTO_N ( (e, has_label, scope) )

    PROTO_T ( exp e X bool has_label X exp scope )

{

  exp n = getexp (f_top, bro (e), (int)(last (e)), nilexp, nilexp, 0, 0, top_tag);

  if (has_label) {

    no (son (pt (e)))--;

    pt (e) = nilexp;

  };

#ifdef NEWDIAGS

  dgf(n) = dgf(e);

#endif

  replace (e, n, e);

  kill_exp (e, e);

  if (scope !=e) altered(n,scope);

}

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

   repbygo replaces e by a goto the label.

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

static void repbygo

    PROTO_N ( (e, lab, scope) )

    PROTO_T ( exp e X exp lab X exp scope )

{

  exp g = getexp (f_bottom, nilexp, 0, nilexp, lab, 0, 0, goto_tag);

  exp n = getexp (f_top, g, 1, nilexp, nilexp, 0, 0, top_tag);

  son (g) = n;

  ++no (son (lab));

#ifdef NEWDIAGS

  dgf(g) = dgf(e);

#endif

  replace (e, g, e);

  kill_exp (e, e);

  if (scope !=e) altered(g,scope);

}

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

   nos tests the exp t to see if it is a construction that can be

   eliminated from a sequence.  It is ignorable or has no side effect.

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

static int nos PROTO_S ((exp t));

static int noslist

    PROTO_N ( (tl) )

    PROTO_T ( exp tl )

{

  if (tl == nilexp)

    return (1);

  if (last (tl))

    return (nos (tl));

  return (nos (tl) && noslist (bro (tl)));

}

static int nos

    PROTO_N ( (t) )

    PROTO_T ( exp t )

{

  unsigned char n = name(t);

  if (n == top_tag || n == ignorable_tag)

    return (1);

  if (n == compound_tag || n == nof_tag) return noslist(son(t));

  return (	(is_a (n) &&

		 optop(t) &&

		 ((n == name_tag && !islastuse(t)) ||

		  n == val_tag ||

		  noslist (son (t))

		 )

		) ||

           	(n == ident_tag && !isenvoff(t) &&

		 nos (son (t)) &&

	     	 nos (bro (son (t)))

		)

	 );

}

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

   check_seq carries out transformations on sequences.

   Statements with no effect are removed.

   Anything after an unconditional goto, or any other statement

   producing a bottom shape, is removed.

   No changes are propagated outside the exp "scope".

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

static int maxes [] = {0, 0, 0, 127, 255, 32767, 65535,

		 (int)0x7fffffff, (int)0xffffffff};

static int mins[] = {0, 0, 0, -128, 0, -32768, 0, (int)0xffffffff, 0};

static shape * us_shape[] = {&f_bottom, &f_bottom, &f_top, &ucharsh,

				&ucharsh,

				&uwordsh, &uwordsh, &ulongsh, &ulongsh};

static exp make_test

    PROTO_N ( (nt, lab, arg1, arg2, nm) )

    PROTO_T ( ntest nt X exp lab X exp arg1 X exp arg2 X unsigned char nm )

{

  exp r;

  r = getexp (f_top, nilexp, 0, arg1, lab, 0, 0, nm);

  fno(r) = (float)0.5;

  settest_number(r, (int)nt);

  setbro(arg1, arg2);

  clearlast(arg1);

  ++no(son(lab));

  setfather (r, arg2);

  return r;

}

static int simple

    PROTO_N ( (e) )

    PROTO_T ( exp e )

{

  if (name(e) == cont_tag && name(son(e)) == name_tag)

    return 1;

  if (name(e) == cont_tag && name(son(e)) == cont_tag &&

	name(son(son(e))) == name_tag)

    return 1;

  if (name(e) == cont_tag && name(son(e)) == reff_tag &&

	name(son(son(e))) == cont_tag &&

	name(son(son(son(e)))) == name_tag)

    return 1;

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

    return 1;

  return 0;

}

static exp tests_to_bounds

    PROTO_N ( (a, b) )

    PROTO_T ( exp a X exp b )

{

  exp x = son(a);

  int na = no(bro(x));

  int nb = no(bro(son(b)));

  int ntemp;

  ntest nta = test_number(a);

  ntest ntb = test_number(b);

  ntest nttemp;

  exp lab = pt(a);

  shape sha = sh(x);

  if (simple(x))

    return nilexp;

  if (nta == f_greater_than) {

    if (na == maxes[name(sha)])

      return nilexp;

    nta = f_greater_than_or_equal;

    ++na;

  };

  if (ntb == f_greater_than) {

    if (nb == maxes[name(sha)])

      return nilexp;

    ntb = f_greater_than_or_equal;

    ++nb;

  };

  if (ntb == f_greater_than_or_equal) {

    ntemp = na;

    na = nb;

    nb = ntemp;

    nttemp = nta;

    nta = ntb;

    ntb = nttemp;

  };

  if (nta != f_greater_than_or_equal)

    return nilexp;

  if (ntb != f_less_than_or_equal && ntb != f_less_than)

    return nilexp;

  if (ntb == f_less_than) {

    if (nb == mins[name(sha)])

      return nilexp;

    ntb = f_less_than_or_equal;

    --nb;

  };

  UNUSED(ntb);

  if (is_signed(sha)) {

    if (nb < na)

      return nilexp;

  }

  else {

    if ((unsigned int)nb < (unsigned int)na)

      return nilexp;

  };

  no(son(lab)) -= 1; /* one is removed by kill_exp below */

  if (na == nb) {

    kill_exp(b, b);

    return make_test(f_equal, lab, x, me_shint(sha, na), test_tag);

  };

  {

    exp s = hold_check(me_b2(x, me_shint(sha, na), minus_tag));

    exp n = me_shint(sha, nb -na);

    shape new_sha = *us_shape[name(sha)];

    sh(s) = new_sha;

    sh(n) = new_sha;

    kill_exp(b, b);

    return make_test(f_less_than_or_equal, lab, s, n, test_tag);

  };

}

static int check_seq

    PROTO_N ( (e, scope) )

    PROTO_T ( exp e X exp scope )

{

  exp z = son (e);

  exp t, k, kk;

  int changed = 0;

  if (name(sh(bro(son(e)))) == bothd && name(sh(e)) != bothd) {

    sh(e) = f_bottom;

    changed = 1;

  };

  while (name (sh (son (z))) == bothd || nos (son (z))) {

    if (name (sh (son (z))) == bothd) {

      if (!last (son (z))) {

	kk = bro (son (z));

	while (kk != nilexp) {

	  k = kk;

	  if (!last (k))

	    kk = bro (k);

	  else

	    kk = nilexp;

#ifdef NEWDIAGS

	  dg_dead_code (k, son(z));

#endif

	  kill_exp (k, k);

	};

      };

#ifdef NEWDIAGS

      if (diagnose) {

	dg_dead_code (bro(z), son(z));

	dg_whole_comp (e, son(z));

      }

#endif

      kill_exp (bro (z), bro (z));	/* kill dead variable refs */

      setfather (e, z);			/* before replace */

      replace (e, son (z), scope);

      retcell (z);

      retcell (e);

      return (1);

    };

    if (last (son (z))) {

#ifdef NEWDIAGS

      if (diagnose) {

	dg_rdnd_code (son(z), bro(z));

	dg_whole_comp (e, bro(z));

      }

#endif

      replace (e, bro (z), scope);

      kill_exp (son (z), son (z));

      retcell (z);

      retcell (e);

      return (1);

    };

#ifdef NEWDIAGS

    if (diagnose)

      dg_rdnd_code (son(z), bro(son(z)));

#endif

    k = son (z);

    son (z) = bro (son (z));

    kill_exp (k, k);

  };

  t = son (z);

  for (;;) {

    if (name(t) == test_tag && name(bro(son(t))) == val_tag &&

	  !isbigval(bro(son(t))) &&

	  name(sh(son(t))) <= ulonghd) {

      exp b;

      exp bnds;

      exp * ref;

      if (last(t)) {

	b = bro(bro(t));

        if (name(b) == test_tag && name(bro(son(b))) == val_tag &&

	    !isbigval(bro(son(b))) &&

	    pt(t) == pt(b) &&

	    eq_exp(son(t), son(b))) {

	  bnds = tests_to_bounds(t, b);

	  if (bnds == nilexp) {

	    if (changed)

	      altered(e, scope);

	    return 0;

	  };

	  if (t == son(z)) {

#ifdef NEWDIAGS

	    if (diagnose)

	      dg_whole_comp (e, bnds);

#endif

	    replace(e, bnds, scope);

	    retcell(e);

	    return 1;

	  };

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

	  bro(*ref) = bro(t);

	  setlast(*ref);

	  setlast(bnds);

	  bro(bnds) = e;

	  bro(z) = bnds;

          return 0;

	}

	else {

	  if (changed)

	    altered(e, scope);

	  return 0;

	};

      };

      b = bro(t);

      if (name(b) == test_tag && name(bro(son(b))) == val_tag &&

	    !isbigval(bro(son(b))) &&

	    pt(t) == pt(b) &&

	    eq_exp(son(t), son(b))) {

	exp brob = bro(b);

	int lb = last(b);

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

	bnds = tests_to_bounds(t, b);

	if (bnds != nilexp) {

	  bro(bnds) = brob;

	  if (lb)

	    setlast(bnds);

	  else

	    clearlast(bnds);

	  *ref = bnds;

	  t = bnds;

	};

      };

    };

    if (last (t)) {

      if (changed)

	altered(e, scope);

      return 0;

    };

    if (name (sh (bro (t))) == bothd) {

      if (!last (bro (t))) {

	kk = bro (bro (t));

	while (kk != nilexp) {

	  k = kk;

	  if (!last (k))

	    kk = bro (k);

	  else

	    kk = nilexp;

#ifdef NEWDIAGS

	  if (diagnose)

	    dg_dead_code (k, bro(t));

#endif

	  kill_exp (k, k);

	};

      };

#ifdef NEWDIAGS

      if (diagnose)

	dg_dead_code (bro(z), bro(t));

#endif

      kill_exp (bro (z), bro (z));

      bro (z) = bro (t);

      setlast (bro (z));

      bro (bro (z)) = e;

      setlast (t);

      bro (t) = z;

      sh(e) = f_bottom;

      altered(e, scope);

      return 0;

    };

    if (nos (bro (t))) {

      if (last (bro (t))) {

#ifdef NEWDIAGS

	if (diagnose)

	  dg_rdnd_code (bro(t), bro(z));

#endif

	kill_exp (bro (t), bro (t));

	setlast (t);

	bro (t) = z;

	return 0;

      };

      k = bro (t);

      bro (t) = bro (bro (t));

#ifdef NEWDIAGS

      if (diagnose)

	dg_rdnd_code (k, bro(t));

#endif

      kill_exp (k, k);

      changed = 1;

    }

    else

      t = bro (t);

  }

  /* UNREACHED */

}

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

   comm_ass applies the commutative and associative laws to replace e

   by an improved version. op_tag is the operation involved. If

   the errtreat is not ignore or impossible, no change is made. C

   programs will always use ignore or impossible.

   All the arguments of sub-operations with the same op_tag (they will

   anyway have the same shape) are flattened into one argument list,

   provided that dive is 1.

   All the constants are combined into one, which is placed as the last

   constant. The parameter "one" is the unit for the given operation

   (0 for + , 1 for * , allones for and, 0 for or, 0 for xor) and this

   constant is eliminated. If the operation has a zero, "has_zero" is

   set and "zero" is the constant (0 for * , 0 for and, allones for or).

   No changes are propagated outside the exp "scope".

   If isreal is 1 the operation has real arguments and results, otherwise

   integer.

   fn(a, b) is applicable to exps defining constants of the correct type

   (integer or real) and delivers an exp defining a constant which is

   the result of the op_tag applied to these constants.

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

static int  f_one PROTO_S ((flpt f));

static int seq_distr PROTO_S ((exp e, exp scope));

static int comm_ass

    PROTO_N ( (e, op_tag, fn, one, has_zero, zero, scope, dive, isreal) )

    PROTO_T ( exp e X unsigned char op_tag X

	      void  (*fn) PROTO_S (( exp, exp, int )) X

	      int one X int has_zero X int zero X exp scope X

	      int dive X int isreal )

{

  exp t = son (e);		/* starting element */

  int changed = last (t);

  exp  cst;		/* start the accumulated constant */

  exp cst_u = nilexp;	/* holds exp representing one if created here */

  int looping;

  if (isreal)

     cst = getexp (sh (e), nilexp, 0, nilexp, nilexp, 0, one, real_tag);

  else  {

     cst = me_shint(sh(e), one);

     if (one == -1 && shape_size(sh(e)) == 64) {