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.

*/

/* 	$Id: dump_distr.c,v 1.1.1.1 1998/01/17 15:55:59 release Exp $	 */

#ifndef lint

static char vcid[] = "$Id: dump_distr.c,v 1.1.1.1 1998/01/17 15:55:59 release Exp $";

#endif /* lint */

/* 

   dump_distrib.c

*/

#include "config.h"

#include "common_types.h"

#include "exptypes.h"

#include "exp.h"

#include "expmacs.h"

#include "tags.h"

#include "bitsmacs.h"   

#include "new_tags.h"

#include "procrectypes.h"

#include "shapemacs.h"

#include "frames.h"

#include "regable.h"

#include "reg_defs.h"

#include "dump_distr.h"

bool do_dump_opt = 1;		/*  may be unset by -d flag */

static  space zsp = {

  0, 0

};				/* long fixed, long flt */

void maxsp

    PROTO_N ( ( a, b ) )

    PROTO_T ( space *a X space b )

{

  a -> fixed |= b.fixed;

  a -> flt |= b.flt;

}

/* 

   accumulate s regs used in e; pars gives bits indicating 

   which s-regs are used for the parameters of current proc; 

   incpars says dont ignore pars in registers 

*/

space suses

    PROTO_N ( ( e, pars, incpars ) )

    PROTO_T ( exp e X space *pars X int incpars )

{

  space ans;

  ans = zsp;

  if (e == nilexp)

    return ans;

  switch (name(e)) {

  case name_tag: {

    exp id = son (e);

    if (name (id) == ident_tag) {

      if (isglob (id) || (props (id) & inanyreg) == 0)

	return ans /* global or not in register */ ;

      if ((props (id) & defer_bit) != 0)

	return suses (son (id), pars, incpars);/*dec does not take space*/

      if (isparam(id) && no(id) !=0 && 

	  ((!incpars && props(son(id)) != 0) || no(id)==props(son(id)) ) )

	/* par in original reg (perhaps destined for sreg) */

	return ans;

      if ((props(id) & infreg_bits)!=0 ) {

	if (no (id) != NO_REG  && no(id)!=0) {/* uses floating s-reg */

	  if(isparam(id) && props(son(id))!=0 && props(son(id))>=incpars){

	    return ans;

	  }

	  else{

	    ans.flt = (1<<(no(id)));

	  }

	}

      }

      else

	if (no (id) != 0 && no (id) != 32) {

	  /* in s seg */

	  if (isparam(id) && props(son(id)) !=0 && 

	      props(son(id)) >= incpars) return ans;

	  ans.fixed = 1 << (no (id));

	}

    }

    break;

  }

  case case_tag: 

  {

    return suses (son (e), pars, incpars);

  }

  case seq_tag: {

    exp t = son (son (e));

    ans = suses (bro (son (e)), pars, incpars);

    for (;;) {

      maxsp (&ans, suses (t, pars,incpars));

      if (last (t)) {

	return ans;

      }

      t = bro (t);

    }

  }

  case env_offset_tag :

  case 0 : 

  case goto_tag : 

  case val_tag :

  case special_tag :

  case null_tag : 

  case real_tag : 

  case string_tag : 

  case clear_tag : 

  case current_env_tag :

  case top_tag : {

    break;

  }

  case apply_general_tag:

  case tail_call_tag:

  {

    maxsp(&ans,*pars);

    goto def1;

  }

  case apply_tag: {

    /* proc call preserves s-regs; however must make sure that any

	   pars destined for s-regs get there */

    exp dad = father(e);

    if (name(dad)==res_tag && props(dad)) {

      /* tl recursion  - don't have to dump link or later regs */

      int i;

      exp p = bro(son(e));

      if (last(son(e)) || name(p)==top_tag) return ans;

      for(i=(incpars>6)?incpars:6; ; i++) {

	if (!valregable(sh(p))) i=22;

	maxsp(&ans, suses(p, pars, i));

	if(last(p)) return ans;

	p = bro(p);

      }

    } else 	maxsp (&ans, *pars);

  }				/* else cont to default */

  FALL_THROUGH

  default: def1:{

    exp t = son (e);

    maxsp (&ans, suses (t, pars,incpars));

    while (t!=nilexp && !last (t)) {

      t = bro (t);

      maxsp (&ans, suses (t, pars,incpars));

    }

  }

  }

  return ans;

}

bool sameregs

    PROTO_N ( ( a,b ) )

    PROTO_T ( space *a X space *b )

{

  return ((a -> fixed | b -> fixed) == b -> fixed && (a -> flt | b -> flt) == b -> flt);

}

space remd

    PROTO_N ( ( tobd,dmpd ) )

    PROTO_T ( space *tobd X space *dmpd )

{

  /* any regs left out of tobd after dmpd has been done */

  space ans;

  ans.fixed = tobd -> fixed & ~dmpd -> fixed;

  ans.flt = tobd -> flt & ~dmpd -> flt;

  return ans;

}

/* 

   replace exp in pe by new dump with props = fixeds and 

   no = flts to be dumped ; thread different dumps to same rsc 

   via pt; delivers bool to say whether all sregs have been 

   dumped 

*/

bool placedump

    PROTO_N ( ( pe, dmpd, tobd, nds ) )

    PROTO_T ( exp *pe X space *dmpd X space *tobd X space *nds )

{

  exp e = *pe;

  exp dflt = getexp(nilexp, nilexp, 1, nilexp,nilexp, 0, nds->flt & ~dmpd->flt, dump_tag);

  exp dump = getexp (sh (e), bro (e), last (e), e, dflt, 0, (nds -> fixed & ~dmpd -> fixed),

       dump_tag);

  bro (e) = dump;

  setlast (e);

  *(pe) = dump;

  (dmpd -> fixed) |= nds -> fixed;

  (dmpd -> flt) |= nds -> flt;

  return sameregs (tobd, dmpd);

}

/* 

   delivers last exp in seq first after all tests (to second) ; 

   beforeb is space up to end of tests; second only use beforeb;

   otherwise nilexp 

*/

exp goodcond

    PROTO_N ( ( first, second, beforeb, pars ) )

    PROTO_T ( exp first X exp second X space *beforeb X space *pars )

{

  exp t;

  space nds;

  int   n = no (son (second));	/* no of uses of labst second */

  if (name (first) != seq_tag)

    return nilexp;

  t = son (son (first));

  *beforeb = zsp;

  for (;;) {

    maxsp(beforeb, suses(t, pars, 0));

    if (name (t) == test_tag) {

      if (pt (t) != second)

	return nilexp;

      if (--n == 0) break;

    }

    if (last (t)) {

     	return nilexp;

    }

    t = bro (t);

  }

  nds = suses (second, pars, 0);

  if (sameregs (&nds, beforeb))

    return t;

  return nilexp;

}

bool alljumps

    PROTO_N ( ( e, slv, nol ) )

    PROTO_T ( exp e X exp slv X int *nol )

{

  /* all all branches to labsts of slove_tag slv in e ? */

  recurse:

  switch (name(e)) {

  case case_tag: {

    exp z = bro(son(e));

    for(;;) {

      if (father(pt(z))==slv) {

	if (--(*nol)==0) return 1;

      }

      if (last(z)) { e = son(e); goto recurse; }

      z = bro(z);

    }

  }

  case goto_tag: case test_tag: {

    if (father(pt(e))==slv) {

      if (--(*nol)==0) return 1;

    }

    if (name(e)== goto_tag) return 0;

    /* and continue */

  }

  FALL_THROUGH

  case name_tag: case val_tag: case float_tag: case string_tag:

    return 0;

  default: {

    exp se = son(e);

    if (se==nilexp) return 0;

    for(;;) {

      if (last(se)) { e = se; goto recurse; }

      if (alljumps(se, slv, nol)) return 1;

      se = bro(se);

    }

  }

  }

}

bool goodsolve

    PROTO_N ( ( e ) )

    PROTO_T ( exp e )

{

  exp m = bro(son(e));

  int nol;

  for(nol=0;;nol++) {

    if (no(son(m))!=1) return 0; /* more than one branch to labst */

    if (last(m)) break;

    m = bro(m);

  }

  return alljumps(son(e), e, &nol);

}

static int  notregs;

static int  notfregs;

 /* use to make sure of enough t-regs which are not par regs; I reuse any

    par registers whose pars are put in s-regs as t-regs  */

void pushdumps

    PROTO_N ( ( pe, dmpd, tobd, pars ) )

    PROTO_T ( exp *pe X space *dmpd X space *tobd X space *pars )

{

  /* tries to delay the dumps of the s-regs as late as possible 

     ; pe is the place in the tree to insert any dump found

     necessary in this recursion; dmpd gives the sregs already dumped and

     tobd is all which may have to be dumped; pars give the registers

     containing the initial position of any parameters */

  space nds;

  exp e = *(pe);

  exp *arg;

  switch (name (e)) {

  case ident_tag: {

    nds = suses (son (e), pars,0);

    if ((props (e) & inanyreg) != 0 && no (e) == 0) {

      /*  This definition will be allocated into a t-reg so make sure

	  of enough t-regs which are not par regs; I reuse any par

	  registers whose pars are put in s-regs as t-regs  */

      if (is_floating (name (sh (son (e))))) {

	if (notfregs-- < 0) {

	  nds = remd (tobd, dmpd);

	  placedump ( pe, dmpd, tobd, &nds);

	  return;

	}

      }

      else {

	if (notregs-- < 0) {

	  nds = remd (tobd, dmpd);

	  placedump ( pe, dmpd, tobd, &nds);

	  return;

	}

      }

    }

    if (name (son (e)) != clear_tag || 

	(isparam(e) && props(son(e))==0 /* ie initially on stack */)  ) {

      /* id could be in s-reg; find from use */

      maxsp (&nds, suses (pt (e), pars, 0));

    }

    if (sameregs (&nds, dmpd) ||

	!placedump ( pe, dmpd, tobd, &nds)) {

      /* not all regs have been dumped - continue with body */

      arg = &bro(son (e));

      pushdumps ( arg, dmpd, tobd, pars);

    }	

    return;

  }

  case seq_tag: {

    exp prev;

    exp list = son (son (e));

    if (last(list) ) {

      nds = suses(bro(son(e)), pars, 22);

      if (nds.fixed==0 && nds.flt==0) {

	/* seq consists of two exps with last not using regs */

	pushdumps(&son(son(e)), dmpd, tobd, pars);

	return;

      }

    }

    nds = suses (list, pars, 0);

    if (!sameregs (&nds, dmpd)) {

      /* first statement uses undumped s-regs */

      if (placedump ( pe, dmpd, tobd, &nds)) {

	return;

      }

    }

    prev = list;

    while (!last (list)) {

      prev = list;

      list = bro (list);

      nds = suses (list, pars, 0);

      if (!sameregs (&nds, dmpd)) {

	/* uses undumped s-regs; construct new seq as result of this

	   one .... */

	exp s_hold = getexp (sh (e), bro (son (e)), 0, list, nilexp, 0, 0,

		name (son (e)));

	exp seq = getexp (sh (e), e, 1, s_hold, nilexp, 0, 0, seq_tag);

	bro (prev) = son (e);

	setlast (prev);

	bro (son (e)) = seq;

	bro (bro (s_hold)) = seq;

	while (!last (list)) {

	  list = bro (list);

	}

	bro (list) = s_hold;

	/* .... and continue with new result */

	arg = &bro(son (e));

	if (!placedump ( arg, dmpd, tobd, &nds)) {

	  pushdumps ( arg, dmpd, tobd, pars);

	}

	return;

      }

    }

    /* no new s-regs used - carry on with result */

    arg = &bro(son (e));

    pushdumps ( arg, dmpd, tobd, pars);

    return;

  }

  case cond_tag: {

    exp first = son (e);

    exp second = bro (first);

    exp t;

    bool same;

    space beforeb;

    nds = suses (first, pars, 0);

    same = sameregs (&nds, dmpd);

    if (!same && (t = goodcond (first, second, &beforeb, pars)) != nilexp) {

      /* worth looking further  into first part */

      if (!sameregs(&beforeb, dmpd) ) {

	if (placedump ( pe, dmpd, tobd, &beforeb)) {

	  return;

	}

      }	  	

      if (!last (t)) {

	exp seq_hold =

	  getexp (sh (first), bro (son (first)), 0, bro (t), nilexp, 0, 0,

		  name (son (first)));

	exp new =

	  getexp (sh (first), first, 1, seq_hold, nilexp, 0, 0, seq_tag);

	exp x = son (seq_hold);

	while (!last (x)) {

	  x = bro (x);

	}

	bro (x) = seq_hold;	/* set dad son seq_hold */

	bro (bro (seq_hold)) = new;

	setlast (bro (seq_hold));/* set dad of seq_hold */

	bro (son (first)) = new;

	setlast (t);

	bro (t) = son (first);

	/* first is now (t; (rest of first)) */

      }

      arg = &bro(son (first));

      pushdumps ( arg, dmpd, tobd, pars);

      return;

    }

    if (!same) {		/* new s-regs used in first part */

      if (placedump ( pe, dmpd, tobd, &nds)) {

	return;

      }

    }

    arg = &bro(son (e));

    pushdumps ( arg, dmpd, tobd, pars);

    return;

  }

/*    case diag_tag: 

    case fscope_tag: 

    case cscope_tag: {

	arg= &son(e);

	pushdumps ( arg, dmpd, tobd, pars);

	return;

      }

*/

  case labst_tag: {		/* can only arrive here from cond */

    arg = &bro(son (e));

    pushdumps ( arg, dmpd, tobd, pars);

    return;

  }

  case solve_tag: {

    if (goodsolve(e)) {

      exp m = bro(son(e));

      space old_dmpd;	

      nds = suses(son(e), pars, 0);

      if (!sameregs(&nds, dmpd)) {

	if (placedump(pe, dmpd,tobd, &nds) ) return;

      }

      old_dmpd = *dmpd;

      for(;;) {

	pushdumps(&bro(son(m)), dmpd, tobd, pars);

	if (last(m)) return;

	m = bro(m);

	*dmpd = old_dmpd;

      }

    } /* else continue ... */		

  }

    FALL_THROUGH

  default: {

      nds = suses(e, pars, 0);

      if (!sameregs(&nds, dmpd)) {

	placedump ( pe, dmpd, tobd, &nds);

      }

    }

  }	

}

void dump_opt

    PROTO_N ( ( rscope, tobd, pars ) )

    PROTO_T ( exp rscope X space *tobd X space *pars )

{

  /* rscope is proc-tag exp;  tobd is set of s-regs to be dumped; 

     pars is subset of tobd which will be used as  parameters of 

     proc */

  exp  * arg;

  space dmpd;

  dmpd = zsp;			/* those regs already dumped */

  arg = &son(rscope);

  notregs = 10;

  notfregs = 8;			/* no of t-regs != par regs */

  if (!do_dump_opt || No_S || sameregs (tobd, &dmpd)) {

    (void)placedump ( arg, &dmpd, tobd, tobd);

  }

  else {

    (void)pushdumps ( arg, &dmpd, tobd, pars);

  }

  return;

}