Subversion Repositories tendra.SVN

/*

 * Copyright (c) 2002-2006 The TenDRA Project <http://www.tendra.org/>.

 * All rights reserved.

 *

 * Redistribution and use in source and binary forms, with or without

 * modification, are permitted provided that the following conditions are met:

 *

 * 1. Redistributions of source code must retain the above copyright notice,

 *    this list of conditions and the following disclaimer.

 * 2. Redistributions in binary form must reproduce the above copyright notice,

 *    this list of conditions and the following disclaimer in the documentation

 *    and/or other materials provided with the distribution.

 * 3. Neither the name of The TenDRA Project nor the names of its contributors

 *    may be used to endorse or promote products derived from this software

 *    without specific, prior written permission.

 *

 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS

 * IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,

 * THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR

 * PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR

 * CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,

 * EXEMPLARY OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,

 * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;

 * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,

 * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR

 * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF

 * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

 *

 * $Id$

 */

/*

    		 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(exp, exp);

exp

next_exp(void)

{

  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(void)

{

  /* called at the start of tagdefs */

  alloc_freelist = alloc_list;

  freelist = nilexp;

  exps_left = 0;

  return;

}

/* create a new exp */

exp

getexp(shape s, exp b, int l, exp sn, exp px, prop pr, int n, 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(exp e)

{

  exp res = next_exp();

  *res = *e;

  return res;

}

/* makes a new shape */

exp

getshape(int l, alignment sn, alignment px, alignment pr, int n,

	 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(exp e)

{

  son(e) = freelist;

  freelist = (e);

  return;

}

/* true if part is inside whole */

int

internal_to(exp whole, 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(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(exp e, 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))) {

	  /* process if now no use of label and not doing deadvar */

	  altered (p, scope);

	}

      }

      kill_el(son(e), scope);

      retcell(e);

      return;

    }

  }

}

/* kill the arguments of a construction */

static void

kill_el (exp e, 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(shape a, 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(shape a, 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(void)

{

  return crt_labno++;

}

char *

intchars(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(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(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(exp main, 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) {

      /* remove unwanted statements */

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

    } else {

      /* form the result shape of the whole */

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

    }

  }

  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(exp f, exp e)

{

  exp *x = &son(f);

  while (*x != e) {

    x = &bro(*x);

  }

  return(x);

}

/* find the father of u */

exp

father(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(exp e, int n, exp scope)

{

  exp f;

  if (bro(e) == nilexp || e == scope || (name(e) == ident_tag && isglob(e))) {

    /* ignore if top of tree */

    return;

  }

  f = father(e);

  if (f == nilexp || bro(f) == nilexp || (name(f) == ident_tag && isglob(f))) {

    /* ignore if top of tree */

    return;

  }

  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 (exp e, exp scope)

{

  altaux(e, 1, scope);

}

/* replace old by e, and (if not doing deadvar) check whether any consequential

 * optimisations are possible */

void

replace(exp old, exp e, 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(exp e)

{

  exp t = copyexp(e);

  exp d = copyexp(son(e));

  setcopy(e);