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

$Revision: 1.3 $

$Log: exp.c,v $

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

 * DWARF optimisation info

 *

 * Revision 1.2  1998/02/18  11:22:10  pwe

 * test corrections

 *

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

 * First version to be checked into rolling release.

 *

 * Revision 1.7  1998/01/09  09:28:45  pwe

 * prep restructure

 *

 * Revision 1.6  1997/10/23  09:24:10  pwe

 * extra diags

 *

 * Revision 1.5  1997/02/18  12:56:23  currie

 * NEW DIAG STRUCTURE

 *

 * Revision 1.4  1996/07/23  12:28:37  currie

 * copying env_offsets

 *

Revision 1.3  1996/04/19 10:42:28  currie

Globals flags in copy

 * Revision 1.2  1995/10/11  17:10:00  currie

 * avs errors

 *

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

 * Initial revision

 *

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

 * Initial revision

 *

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

#include "config.h"

#include "common_types.h"

#include "externs.h"

#include "xalloc.h"

#include "installglob.h"

#include "expmacs.h"

#include "tags.h"

#include "table_fns.h"

#include "shapemacs.h"

#include "check.h"

#include "flpt.h"

#include "basicread.h"

#include "messages_c.h"

#include "install_fns.h"

#include "flags.h"

#ifdef NEWDIAGS

#include "readglob.h"

#include "dg_aux.h"

#endif

#include "exp.h"

/* VARIABLES */

/* All variables initialised */

int crt_labno = 0;	/* init by init_exp */

  /* the list of unused returned cells */

exp freelist;	/* init by init_exp */

  /* the number of unused cells in the block */

int exps_left;	/* init by init_exp */

  /* the next free pointer in the block which is used if the freelist

     is empty */

static exp next_exp_ptr;	/* no need to init */

  /* the types used to record a list of blocks for reuse, if

     separate_units is set */

struct expalloc_cell_t {struct expalloc_cell_t * tl; exp hd;};

typedef struct expalloc_cell_t expalloc_cell;

static expalloc_cell * alloc_list = (expalloc_cell *)0;

		/* good init for the whole run */

static expalloc_cell * alloc_freelist = (expalloc_cell *)0;

		/* good init for the whole run */

static char  ic_buff[21];	/* no init needed */

/* IDENTITY */

static int current_alloc_size = 20000;

/* PROCEDURES */

void altered PROTO_S ( ( exp, exp ) ) ;

exp next_exp

    PROTO_Z ()

{

  exp res;

  if (freelist != nilexp)

    {  /* first try to allocate fron the freelist */

      res = freelist;

      freelist = son(freelist);

      return res;

    };

    /* if the freelist is empty we allocate from a block of exps */

  if (exps_left == 0)

   {  /* if the block is empty we must allocate another */

     if (alloc_freelist)

       {  /* if there is anything in this list of blocks we can reuse

             it and we do not need to calloc */

         exps_left = current_alloc_size;

         next_exp_ptr = alloc_freelist -> hd;

         alloc_freelist = alloc_freelist -> tl;

       }

     else

       {  /* otherwise we must calloc a new block */

         exps_left = current_alloc_size;

         next_exp_ptr = (exp)xcalloc(exps_left, sizeof(struct exp_t));

          { /* and if we are after the start of tagdefs we put

               the block on to alloc_list so that it can be reused

               for the next unit */

            expalloc_cell * temp =

               (expalloc_cell *)xmalloc(sizeof(expalloc_cell));

            temp -> tl = alloc_list;

            temp -> hd = next_exp_ptr;

            alloc_list = temp;

          };

       };

   };

  --exps_left;

  res = next_exp_ptr++;

  return res;

}

void set_large_alloc

    PROTO_Z ()

{

  /* called at the start of tagdefs */

  alloc_freelist = alloc_list;

  freelist = nilexp;

  exps_left = 0;

  return;

}

   /* create a new exp */

exp getexp

    PROTO_N ( (s, b, l, sn, px, pr, n, tg) )

    PROTO_T ( shape s X exp b X int l X exp sn X exp px X prop pr X int n X unsigned char tg )

{

  exp res = next_exp();

  sh(res) = s;

  bro(res) = b;

  if (l)

   setlast(res);

  else

   clearlast(res);

  son(res) = sn;

  pt(res) = px;

  props(res) = pr;

  no(res) = n;

  name(res) = tg;

  parked(res) = 0;

#ifdef NEWDIAGS

  dgf(res) = nildiag;

#endif

  return res;

}

exp copyexp

    PROTO_N ( (e) )

    PROTO_T ( exp e )

{

  exp res = next_exp();

  *res = *e;

  return res;

}

  /* makes a new shape */

exp getshape

    PROTO_N ( (l, sn, px, pr, n, tg) )

    PROTO_T ( int l X alignment sn X alignment px X alignment pr X int n X unsigned char tg )

{

  exp res = next_exp();

  if (l)

   setlast(res);

  else

   clearlast(res);

  res ->sonf.ald = sn;

  res -> ptf.ald = px;

  res -> brof.ald = pr;

  no(res) = n;

  name(res) = tg;

  return res;

}

  /* return an exp cell to the freelist */

void retcell

    PROTO_N ( (e) )

    PROTO_T ( exp e )

{

  son(e) = freelist;

  freelist = (e);

  return;

}

  /* true if part is inside whole */

int internal_to

    PROTO_N ( (whole, part) )

    PROTO_T ( exp whole X exp part )

{

  int f = 1;

  exp q = part;

  while (q != whole && q != nilexp &&

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

    f = (int)(last (q));

    q = bro (q);

  };

  /* ascend from part until we reach either whole or top of tree */

  return (f && q == whole);

}

static void kill_el PROTO_S ((exp e, exp scope));

  /* kill an exp, return it and its components to the freelist,

     if necessary remove uses of tags and labels, and propagate

     changes to identity and variable declarations and to labels

     but not outside scope */

void kill_exp

    PROTO_N ( (e, scope) )

    PROTO_T ( exp e X exp scope )

{

  if (e != nilexp) {

    unsigned char n = name (e);

    if (n == name_tag) {

      exp q = son (e);

#ifdef NEWDIAGS

      if (!isdiaginfo(e))

	--no (son (e));		/* decrease usage count */

#else

      --no (son (e));		/* decrease usage count */

#endif

      while (pt (q) != e)

	q = pt (q);

      pt (q) = pt (e);		/* remove from usage list */

      if (

          no (son (e)) == 0 &&

	  son (son (e)) != nilexp &&

	  bro (son (son (e))) != nilexp &&

	  (scope == nilexp || internal_to (scope, son (e))))

	IGNORE check (son (e), scope);

      /* check the declaration if now no use */

      retcell (e);

      return;

    };

    if (n == solve_tag) {

      int looping;

      if (!last (son (e))) {

	exp t = bro (son (e));

	do {

	  no (son (t)) = 0;

	  looping = !last (t);

	  t = bro (t);

	}

	while (looping);

      };

      if (pt(e) != nilexp)

        son (pt (e)) = nilexp;

      kill_el (son (e), scope);

      retcell (e);

      return;

    };

    if (n == ident_tag) {

      ++no (e);

      kill_el (son (e), scope);

#ifdef NEWDIAGS

      if (diagnose && pt(e))	/* allow diags to hold on to id */

	diag_kill_id (e);

      else

#endif

      retcell (e);

      return;

    };

    if (n == labst_tag) {

      ++no (e);

      --proc_label_count;

      kill_el (bro (son (e)), scope);

      retcell (son (e));

      retcell (e);

      return;

    };

    if (n == case_tag) {

      exp b = bro(son(e));

      while (b != nilexp) {

	exp nextb = bro(b);

	int l = last(b);

	--no(son(pt(b)));

	if (son(b) != nilexp) retcell(son(b));

	retcell(b);

	if (l) break;

	b = nextb;

      }

      kill_exp (son (e), scope);

      retcell (e);

      return;

    };

    if (n == cond_tag) {

      no (son (bro (son (e)))) = 0;

      kill_el (son (e), scope);

      retcell (e);

      return;

    };

    if (n == rep_tag) {

      if (pt(e) != nilexp)

        son (pt (e)) = nilexp;

      no (son (bro (son (e)))) = 0;

      kill_el (son (e), scope);

      retcell (e);

      return;

    };

    if (n == real_tag || (n == val_tag && isbigval(e))) {

      flpt_ret (no (e));

      retcell (e);

      return;

    };

    if (n == val_tag) {

      retcell (e);

      return;

    };

    if (n == env_offset_tag || n == string_tag || n==general_env_offset_tag)

     {

      retcell (e);

      return;

     };

    {

      exp p = pt (e);

      if (p != nilexp && (props (son (p)) & 1) == 0) {

	/* decrease label usage count */

	--no (son (p));

	if (

            no (son (p)) == 0 && !is_loaded_lv(p) &&

	    bro (son (p)) != nilexp &&

	    (scope == nilexp || internal_to (scope, p)))

	  altered (p, scope);	/* process if now no use of label and not

				   doing deadvar */

      };

      kill_el (son (e), scope);

      retcell (e);

      return;

    };

  };

}

/* kill the arguments of a construction */

static void kill_el

    PROTO_N ( (e, scope) )

    PROTO_T ( exp e X exp scope )

{

  if (e != nilexp) {

    int l;

    exp next;

    do {

      l = (int)(last (e));

      next = bro (e);

      kill_exp (e, scope);

      e = next;

    }

    while (!l && e != nilexp);

  };

}

  /* return the shape delivered by a conditional (or similar construct)

     which delivers an a from one branch and a b from the other */

shape lub_shape

    PROTO_N ( (a, b) )

    PROTO_T ( shape a X shape b )

{

  int asz = shape_size(a);

  int bsz = shape_size(b);

  if (name(a) ==bothd)

   return b;

  if (name(b) == bothd)

   return a;

  if (asz == bsz && shape_align(a) == shape_align(b))

    return (a);

  return (f_top);

}

  /* true if the shapes are equal */

int eq_shape

    PROTO_N ( (a, b) )

    PROTO_T ( shape a X shape b )

{

  if (name(a) != name(b))

     return 0;

  if (shape_size(a)!=shape_size(b) ||

           is_signed(a)!=is_signed(b) ||

           shape_align(a)!=shape_align(b) ||

           al1(a)!=al1(b))

     return 0;

  if (name(a) == nofhd)

     return 1;

  else

     return (al2(a)==al2(b));

}

  /* source of numbers for local labels */

int next_lab

    PROTO_Z ()

{

  return crt_labno++;

}

char *intchars

    PROTO_N ( (n) )

    PROTO_T ( int n )

{

  int  r, d;

  char *ind;

  ind = &ic_buff[19];

  ic_buff[20] = 0;

  d = (n < 0) ? -n : n;

  do {

    r = d % 10;

    d = d / 10;

    *ind = (char)(r + 48); /* CAST:jmf: must be in 48:57 */

    --ind;

  }

  while (d != 0);

  if (n < 0) {

    *ind = '-';

    --ind;

  };

  return (ind + 1);

}

void case_item

    PROTO_N ( (i) )

    PROTO_T ( exp i )

{

  exp l = global_case;

  exp t = l;

  int go = 1;

  exp  newhigh = (son (i) == nilexp) ? i : son (i);

  exp  thigh;

  exp  nlow,

        nhigh;

  while (go && bro (t) != nilexp) {

    exp j = bro (t);

    exp  highj = (son (j) == nilexp) ? j : son (j);

    if (docmp_f((int)f_greater_than, i, highj))

      t = bro (t);

    else

      go = 0;

  };

  if (t != l) {

    thigh = (son (t) == nilexp) ? t : son (t);

  }

  else {

    SET(thigh);

  };

  if (bro (t) != nilexp) {

    nlow = bro (t);

    nhigh = (son (bro (t)) == nilexp) ? nlow : son (bro (t));

  }

  else {

    SET(nlow); SET(nhigh);

  };

  if (t != l && docmp_f((int)f_less_than_or_equal, i, thigh))

    failer (CASE_OVERLAP);

  if (bro (t) != nilexp &&

	 docmp_f((int)f_greater_than_or_equal, newhigh, nlow))

    failer (CASE_OVERLAP);

  if (isbigval(i) || isbigval(newhigh)) {

    bro (i) = bro (t);

    bro (t) = i;

    return;

  };

  if (t != l && (no(i)-1) == no(thigh) && pt (i) == pt (t)) {

    if (bro (t) != nilexp && (no(newhigh)+1) == no(nlow)

	&& pt (i) == pt (bro (t))) {

      if (son (bro (t)) != nilexp) {

	if (son (t) != nilexp)

	  retcell (son (t));

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

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

	return;

      };

      if (son (t) != nilexp) {

	no (son (t)) = no(nhigh);

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

	return;

      };

      setson (t, getexp (slongsh, nilexp, 1, nilexp, nilexp, 0,

			  no(nhigh), 0));

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

      return;

    };

    if (son (t) != nilexp) {

      no (son (t)) = no(newhigh);

      return;

    };

    setson (t, getexp (slongsh, nilexp, 1, nilexp,

			 nilexp, 0, no(newhigh), 0));

    return;

  };

  if (bro (t) != nilexp && (no(newhigh) + 1) == no(nlow)

      && pt (i) == pt (bro (t))) {

    if (son (bro (t)) != nilexp) {

      no (bro (t)) = no(i);

      return;

    };

    if (son (i) != nilexp) {

      no (son (i)) = no(nhigh);

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

      bro (t) = i;

      return;

    };

    son (i) = bro (t);

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

    bro (t) = i;

    return;

  };

  bro (i) = bro (t);

  bro (t) = i;

  return;

}

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

  scan_solve is part of the process of reading a solve construction.

  It scans the exp e, to increment the count of labels used by e.

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

void scan_solve

    PROTO_N ( (e) )

    PROTO_T ( exp e )

{

  unsigned char  n = name (e);

  switch (n) {

    case name_tag:

    case make_lv_tag:

    case env_offset_tag:

    case general_env_offset_tag:

      return;

    case clear_tag:

      return;

    case ident_tag: {

	scan_solve (son (e));

	scan_solve (bro (son (e)));

	return;

      };

    case case_tag:

      {

	exp t = son (e);

	while (!last (t)) {

	  exp s = son (pt (bro (t)));

	  if (isvar (s)) {

	    ++no (s);

	  };

	  t = bro (t);

	};

	scan_solve (son (e));

	return;

      };

    default:

      {

	if (pt (e) != nilexp) {

	  exp s = son (pt (e));

	  if (isvar (s)) {

	    ++no (s);

	  };

	};

	if (son (e) != nilexp) {

	  exp t = son (e);

	  while (scan_solve (t), !last (t))

	    t = bro (t);

	};

	return;

      };

  };

}

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

  clean_labelled processes a labelled statement after it has been read.

  It places the labelled statements in a good order.

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

exp clean_labelled

    PROTO_N ( (main, placelabs) )

    PROTO_T ( exp main X label_list placelabs )

{

  int   i,

        crt_no;

  int go = 1;

  shape s;

  exp r, q;

  int n = placelabs.number;

  int  *ord;			/* records the order in which the

				   statemnts are to be placed */

  int   ord_no;

  for (i = 0; i < n; ++i) {	/* set up the labels */

    exp l = get_lab(placelabs.elems[i]);

    exp t = son (l);

    no (t) = is_loaded_lv(l);

    setcrtsolve (t);		/* defined in expmacs = props(t) = 1 */

  };

  crt_no = 0;

  ord = (int *) xcalloc (n, sizeof (int));

  ord_no = 0;

  scan_solve (main);		/* mark the labels used by the initiator

				*/

  while (go) {			/* continue as long as we have added a

				   statement */

    go = 0;

    for (i = 0; i < n; ++i) {	/* look for unprocessed but used sts */

      int   j = ((i + crt_no) % n);

      exp t = get_lab(placelabs.elems[j]);

      if ((props (son (t)) & 8) == 0 && no (son (t)) != 0) {

	/* we have found an unprocessed but used statement */

	go = 1;

	props (son (t)) = 5;

	scan_solve (t);		/* now scan it to mark the things it uses

				*/

	props (son (t)) = (prop)((props (son (t)) & 0xfb) | 8);

	ord[ord_no++] = j;

      };

    };

  };

  s = sh (main);

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

    exp lab = get_lab(placelabs.elems[i]);

    exp t = son (lab);

    if ((props (t) & 8) != 8) {

      kill_exp (bro (t), bro (t));/* remove unwanted statements */

    }

    else

      s = lub_shape (s, sh (lab));

    /* form the result shape of the whole */

  };

  r = getexp (s, nilexp, 0, main, crt_repeat, 0, 0, solve_tag);

  q = main;

  for (i = 0; i < ord_no; ++i) {/* set up the solve with the statements in

				   the order specified by ord */

    clearlast (q);

    bro (q) = get_lab(placelabs.elems[ord[i]]);

    q = bro (q);

    props (son (q)) = (prop)(props(son(q)) & 0xfe);

  };

  son (crt_repeat) = r;

  crt_repeat = bro(crt_repeat);

  setfather(r, q);

  return (r);

}

/* find the (unique) downward reference to e */

exp * refto

    PROTO_N ( (f, e) )

    PROTO_T ( exp f X exp e )

{

  exp * x = &son (f);

  while (*x != e)

    x = &bro (*x);

  return (x);

}

/* find the father of u */

exp father

    PROTO_N ( (e) )

    PROTO_T ( exp e )

{

  if (e == nilexp)

    return (e);

  while (!last (e))

    e = bro (e);

  return (bro (e));

}

/* auxiliary routine for altered, looks up

   in the tree n levels, checking */

static void altaux

    PROTO_N ( (e, n, scope) )

    PROTO_T ( exp e X int n X exp scope )

{

  exp f;

  if (bro (e) == nilexp || e == scope ||

      (name (e) == ident_tag && isglob (e)))

    return;			/* ignore if top of tree */

  f = father (e);

  if (f == nilexp || bro (f) == nilexp ||

      (name (f) == ident_tag && isglob (f)))

    return;			/* ignore if top of tree */

  if (name (f) == 0) {

    altaux (f, n, scope);

    return;

  };

  if (!check (f, scope) && n > 1) {

    /* do check until n is exhausted */

    altaux (f, n - 1, scope);

    return;

  };

}

/* e has been altered. see if any exp

   higher up the tree can now recognise an

   optimisation (using check) */

void altered

    PROTO_N ( (e, scope) )

    PROTO_T ( exp e X exp scope )

{

  altaux (e, 1, scope);

}

/* replace old by e, and (if not doing

   deadvar) check whether any

   consequential optimisations are

   possible */

void replace

    PROTO_N ( (old, e, scope) )

    PROTO_T ( exp old X exp e X exp scope )

{

  exp f = father (old);

  exp * ref = refto (f, old);

  if (last (*ref))

    setlast (e);

  else

    clearlast (e);

  bro (e) = bro (*ref);

  *ref = e;

  if (scope == old)

    return;

  altered (e, scope);

}

/* copy a labelled statement and put links

   into pt so that copies of uses of the

   original can refer to the copy */

void copy_labst

    PROTO_N ( (e) )

    PROTO_T ( exp e )

{

  exp t = copyexp (e);

  exp d = copyexp (son (e));

  setcopy(e);

  no (t) = 0;

  no (d) = 0;

  pt (d) = pt (e);

  pt (t) = nilexp;

  pt (e) = t;

  son (t) = d;

  ++proc_label_count;

}

/* end the copy of a labelled statement

   and restore the original state */

exp undo_labst

    PROTO_N ( (e) )

    PROTO_T ( exp e )

{

  exp r = pt (e);

  pt (e) = pt (son (r));

  clearcopy(e);

  return (r);

}

exp copy_res PROTO_S ( ( exp, exp, exp ) ) ;

exp copy PROTO_S ( ( exp ) ) ;

/* used to copy cond, repeat and solve so

   that copies of references to the

   labelled statements can refer to the

   copies of the labelled statements */

static exp copy_cpd

    PROTO_N ( (e, new_record, var, lab) )

    PROTO_T ( exp e X exp new_record X exp var X exp lab )

{

  exp t = copyexp (e);

  exp q;

  exp j, c, s, n, k;

  if (new_record != nilexp) {	/* record the construction */

    pt (t) = new_record;

    son (new_record) = t;

  };

  /* copy the labelled statements */

  q = bro (son (e));

  copy_labst (q);

  while (!last (q)) {

    q = bro (q);

    copy_labst (q);

  }

  /* copy the bodies of the labelled statments */

  q = bro (son (e));

  while (j = copy_res (bro (son (q)), var, lab),

      c = pt (q),

      bro (son (c)) = j,

      bro (j) = c,

      setlast (j),

      !last (q))

    q = bro (q);

  /* copy the lead statement */

  s = copy_res (son (e), var, lab);

  son (t) = s;

  clearlast (s);

  q = bro (son (e));

  n = s;

  /* restore the labelled statements */

  while (k = undo_labst (q),

      bro (n) = k,

      clearlast (n),

      !last (q)) {

    q = bro (q);

    n = bro (n);

  };

  n = bro (n);

  setlast (n);

  bro (n) = t;

  return (t);