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.

*/

/*

$Log: needscan.c,v $

 * Revision 1.1.1.1  1998/01/17  15:56:03  release

 * First version to be checked into rolling release.

 *

 * Revision 1.18  1996/11/29  10:38:05  wfs

 *    Change to "needscan.c" - compound parameters of size > 32 and < 64 were

 * not being properly aligned on the stack.

 *

 * Revision 1.17  1996/08/30  09:02:27  wfs

 * Various fixes of bugs arising from avs and pl_tdf tests.

 *

 * Revision 1.16  1996/08/06  10:50:11  wfs

 * bug fixes to pic code, enum diagnostics enabled.

 *

 * Revision 1.15  1996/04/18  11:09:15  wfs

 * Fixed a bug in "needscan.c" where "locptr_tag" was being wrapped around

 * the wrong exps.

 *

 * Revision 1.14  1996/03/28  10:53:14  wfs

 * Bug fixes to scan(), peephole optimisations in proc.c, and enum diagnostics.

 *

 * Revision 1.13  1996/03/22  13:34:12  wfs

 * Corrections to the dynamic initialization stuff in translat.c + bad

 * needscan.c code deleted.

 *

 * Revision 1.12  1996/03/14  16:18:44  wfs

 * tophed is not valregable + ptr position in apply_general case of scan() + superfluous "set -x" in bl_install script.

 *

 * Revision 1.11  1996/03/06  17:26:27  wfs

 * Fixed a bug in the profiling option.

 *

 * Revision 1.10  1996/03/04  18:15:10  wfs

 * Bug fix in scan(). diagnose=1 made all idents visible - but bitfields cannot

 * be visible.

 *

 * Revision 1.9  1996/03/04  13:19:09  wfs

 * Changes to hppatrans.1 manual + Mike Gerrard's needscan bug fix.

 *

 * Revision 1.8  1996/01/18  15:17:38  wfs

 * Left out a ";" in "needscan.c".

 *

 * Revision 1.7  1996/01/18  15:09:42  wfs

 * Corrected a syntax error in "needscan.c".

 *

 * Revision 1.6  1996/01/18  14:58:18  wfs

 * The "-default" option of "build" now sets BE_VERBOSE="true". Made a change

 * to the "apply_tag" case in scan() to ensure that space is reserved for

 * long double procedure call results even if they are not used.

 *

 * Revision 1.5  1996/01/11  14:46:31  wfs

 * Fixed bug in "ass_tag" case of scan(). Removed superfluous macro and comment.

 *

 * Revision 1.4  1996/01/10  17:18:53  wfs

 * Corrected definition of "IS_TREG" macro + cosmetic changes to needscan.c

 *

 * Revision 1.3  1996/01/08  12:01:58  wfs

 * Cosmetic changes to usage message in "hppatrans.c". "issparc" set to 0 in

 * "config.h". Change to "scan()" regarding the passing of 64 bit int params.

 *

 * Revision 1.2  1995/12/18  13:12:09  wfs

 * Put hppatrans uder cvs control. Major Changes made since last release

 * include:

 * (i) PIC code generation.

 * (ii) Profiling.

 * (iii) Dynamic Initialization.

 * (iv) Debugging of Exception Handling and Diagnostics.

 *

 * Revision 5.6  1995/10/23  15:47:23  wfs

 * Positioning of byte and halfwords on the stack was incomplete.

 *

 * Revision 5.5  1995/10/20  14:07:32  wfs

 * gcc compilation changes.

 *

 * Revision 5.4  1995/10/11  15:59:12  wfs

 * Cosmetic changes.

 *

 * Revision 5.3  1995/10/05  08:56:38  wfs

 * "isoutpar" check applied to parameters.

 *

 * Revision 5.2  1995/09/25  10:45:17  wfs

 * Two bug fixes.

 *

 * Revision 5.1  1995/09/15  13:01:15  wfs

 * Changes to "ident_tag" case. "trap_tag" case added.

 *

 * Revision 5.0  1995/08/25  13:42:58  wfs

 * Preperation for August 25 Glue release

 *

 * Revision 3.3  1995/08/25  10:14:21  wfs

 * A major revision. New 3.1 and 4.0 cases. "ident_tag" case rewritten

 * for the parameters. Register synonyms changed. MJG's bug fix

 * incorporated

 *

 * Revision 3.3  1995/08/25  10:14:21  wfs

 * A major revision. New 3.1 and 4.0 cases. "ident_tag" case rewritten

 * for the parameters. Register synonyms changed. MJG's bug fix

 * incorporated

 *

 * Revision 3.1  95/04/10  16:27:33  16:27:33  wfs (William Simmonds)

 * Apr95 tape version.

 * 

 * Revision 3.0  95/03/30  11:18:27  11:18:27  wfs (William Simmonds)

 * Mar95 tape version with CRCR95_178 bug fix.

 * 

 * Revision 2.0  95/03/15  15:28:17  15:28:17  wfs (William Simmonds)

 * spec 3.1 changes implemented, tests outstanding.

 * 

 * Revision 1.2  95/01/17  17:29:49  17:29:49  wfs (William Simmonds)

 * 

 * 

 * Revision 1.1  95/01/11  13:13:54  13:13:54  wfs (William Simmonds)

 * Initial revision

 * 

*/

#define HPPATRANS_CODE

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

		needscan.c

	Defines the scan through a program which reorganises it so that all

arguments of operations are suitable for later code-production. The procedure

scan evaluates the register requirements of an exp. The exps are produced

from the decoding process and the various exp -> exp transformations  in

the proc independent (common to other  translators)

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

#include "config.h"

#include "myassert.h"

#include "exptypes.h"

#include "exp.h"

#include "expmacs.h"

#include "tags.h"

#include "new_tags.h"

#include "common_types.h"

#include "check.h"

#include "proctypes.h"

#include "bitsmacs.h"

#include "maxminmacs.h"

#include "regable.h"

#include "tempdecs.h"

#include "shapemacs.h"

#include "special.h"

#include "const.h"

#include "flpt.h"

#include "install_fns.h"

#include "externs.h"

#include "regmacs.h"

#include "muldvrem.h"

#include "translat.h"

#include "comment.h"

#include "flags.h"

#include "proc.h"

#include "frames.h"

#include "extratags.h"

#include "needscan.h"

/* used by scan to set initial parameter positions */

extern alignment long_to_al PROTO_S ( ( unsigned long ) ) ;

extern int specialopt PROTO_S ((exp));

extern long notbranch[];	/* in makecode.c */

extern bool do_tlrecursion;

extern int nexps;

extern procrec *cpr;

static int stparam;		/* Size of parameter list in bits */

static int fixparam;		/* Next available place for param */

static int fltparam;

static bool rscope_level = 0;

static bool nonevis = 1;

static int callerfortr;

bool gen_call;

bool has_tail_call;

int maxfix, maxfloat;		/* the maximum number of t-regs */

/* advance declaration of scan */

needs scan PROTO_S ( ( exp *, exp ** ) ) ;

/*

	needs defined in proctypes.h.

	This is a structure which has two integers giving the number of

fixed and floating point registers required to contain live values in

the expression parameters. A further field prop is used for various

flags about certain forms of exp (mainly idents and procs). The maxargs

field gives the maximum size in bits for the parameters of all the

procs called in the exp. The needs of a proc body are preserved in the

needs field of the procrec (see proctypes.h).

*/

/* return ptrexp pointing to e */

exp *ptr_position 

    PROTO_N ( ( e ) )

    PROTO_T ( exp e )

{

  exp *res;

  exp dad = father(e);

  exp sib = son(dad);

  if (sib == e)

  {

    res = &son(dad);

  }

  else

  {

    while (bro(sib) != e)

    {

      sib = bro(sib);

    }

    res = &bro(sib);

  }

  return res;

}

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

		cca

This procedure effectively inserts a new declaration into an exp. This

is used to stop a procedure requiring more than the available number of

registers.

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

void tidy_ident PROTO_S ( ( exp ) ) ;

void cca

    PROTO_N ( (to,x) )

    PROTO_T ( exp **to X exp *x )

{

  if (name((**to))==diagnose_tag)

  {

      *to = &(son((**to)));  

  }

  if (x == (*to))

  {

    exp def = *(x);

    /* replace by  Let tg = def In tg Ni */

    exp id = getexp(sh(def), bro(def), last(def), def, nilexp,

		    0, 1, ident_tag);

    exp tg = getexp(sh(def), id, 1, id, nilexp,

		    0, 0, name_tag);

    pt(id) = tg;		/* use of tag */

    bro(def) = tg;		/* bro(def) is body of Let = tg */

    clearlast(def);

    *(x) = id;			/* replace pointer to x by Let */

    return;

  }

  else

  {				/* replace by Let tg = def In ato/def = tg Ni */

    exp def = *(x);

    exp ato = *(*to);

    exp id = getexp(sh(ato), bro(ato), last(ato), def, nilexp,

		    0, 1, ident_tag);

    exp tg = getexp(sh(def), bro(def), last(def), id, nilexp,

		    0, 0, name_tag);

    pt(id) = tg;		/* use of tg */

    bro(def) = ato;		/* ato is body of Let */

    clearlast(def);

    bro(ato) = id;		/* its father is Let */

    setlast(ato);

    *(*to) = id;		/* replace pointer to 'to' by Let */

    *(x) = tg;			/* replace use of x by tg */

    *to = &bro(def);		/* later replacement to same 'to' will be at

				 * body of Let */

    return;

  }

}

needs onefix = {1, 0, 0, 0};	/* needs one fix pt reg */

needs twofix = {2, 0, 0, 0};	/* needs 2 fix pt regs */

needs onefloat = {0, 1, 0, 0};	/* needs 1 flt pt regs */

needs zeroneeds = {0, 0, 0, 0};	/* has no needs */

#if 0		/* +++ optimise sharing of regs for idents */

bool subvar_use 

    PROTO_N ( ( uses ) )

    PROTO_T ( exp uses )

{				/* check to see if any uses of id is

				 * initialiser to subvar dec */

  for (; uses != nilexp; uses = pt(uses))

  {

    if (last(uses) && name(bro(uses)) == cont_tag)

    {

      exp c = bro(uses);

      if (!last(c) && last(bro(c)) && name(bro(bro(c))) == ident_tag)

      {

	exp id = bro(bro(c));

	if ((props(id) & subvar) != 0 && (props(id) & inanyreg) != 0)

	  return 1;

      }

    }

  }

  return 0;

}

#endif

/* this gives the needs for manipulating a value of shape s */

needs shapeneeds 

    PROTO_N ( ( s ) )

    PROTO_T ( shape s )

{

  if (is_floating(name(s)))

    return onefloat;

  else

  {

    if (valregable(s))

    {

      return onefix;

    }

    else

    {

      /* if the shape does not fit into a reg, needs two fixed regs for moving */

      return twofix;

    }

  }

}

/*

  Transform a non-bit offset into a bit offset.

  (borrowed from trans386)

*/

static void make_bitfield_offset 

    PROTO_N ( ( e, pe, spe, sha ) )

    PROTO_T ( exp e X exp pe X int spe X shape sha ){

  exp omul;

  exp val8;

  if (name(e) == val_tag){

    no(e) *= 8;

    return;

  }

  omul = getexp (sha, bro(e), (int)(last (e)), e, nilexp, 0, 0, offset_mult_tag);

  val8 = getexp (slongsh, omul, 1, nilexp, nilexp, 0, 8, val_tag);

  clearlast(e);

  setbro(e, val8);

  if(spe) {

    son(pe) = omul;

  }

  else{

    bro(pe) = omul;

  }

  return;

}

/*

 * these are basicly the expressions which cannot be accessed by a simple

 * load or store instruction

 */

bool complex 

    PROTO_N ( ( e ) )

    PROTO_T ( exp e )

{				/* these are basically the expressions which

				 * cannot be accessed by a simple load or

				 * store instruction */

  if (name(e) == name_tag ||

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

       isvar(son(son(e))))

      || name(e) == val_tag || name(e) == real_tag)

  {

    return 0;

  }

  else

  {

    return 1;

  }

}

void change_to_var

    PROTO_N ( (e) )

    PROTO_T ( exp e )

{

	/* change identity to variable definition */

	exp p = pt(e);

	shape ns;

	assert(name(e)==ident_tag && !isvar(e));

	setvar(e);

	setcaonly(e);

	ns = f_pointer(f_alignment(sh(son(e))));

	while (p != nilexp) {

		exp * pos = ptr_position(p);

		exp ncont = getexp(sh(p), bro(p), last(p), p, nilexp, 0, 0,

					cont_tag);

		bro(p) = ncont; setlast(p);

		sh(p) = ns;

		*pos = ncont;

		p = pt(p);

	}

}

void change_names

    PROTO_N ( (f, t, except) )

    PROTO_T ( exp f X exp t X exp except )

{

	/* replace uses of ident f (!= except) to uses of t */

	exp py = pt(f);

	assert(name(f)==ident_tag && name(t)==ident_tag && name(except)==name_tag);

	while (py != nilexp) {

		exp ppy = pt(py);

		if (py != except) {

			son(py) = t; /* change f to t */

			pt(py) = pt(t);

			pt(t) = py;   

			no(t)++;  /* maintain usage */

		}

		py = ppy;

	}

}			 

void tidy_ident

    PROTO_N ( (e) )

    PROTO_T ( exp e )

{

	/* replace Var/Id x = Var y = e1 in { e2; contents(y)} in e3;

	   by Var x = e1 in { e2/(y=>x); e3}

	   replace Var/Id x = Id y = e1 in {e2; y} in e3

	   by Var/Id x = e1 in { e2/y=>(cont)x; e3}

	*/

	exp init; exp bdyinit; exp idy;

	exp e1;

	exp e3;

	assert(name(e)==ident_tag);

	init = son(e);

	e3 = bro(init);

	if ( name(init) != ident_tag || isparam(e)) { return ;}

	tidy_ident(init);

	e1 = son(init);

	bdyinit = bro(e1);

	if (!isvar(init)) {

	  if (name(bdyinit) == seq_tag) {

	    	exp idy = bro(son(bdyinit));

		exp broe3;

		bool laste3;

		if (name(idy) != name_tag || son(idy) != init || 

			no(idy) !=0 || 

			shape_size(sh(idy)) != shape_size(sh(e1)) ||

			shape_align(sh(idy)) != shape_align(sh(e1)) ) {

		    return;

		}

		if (isvar(e)) {

			change_to_var(init);

		}

		change_names(init, e, idy);	  

		broe3 = bro(e3);

		laste3 = last(e3);

		bro(son(bdyinit)) = e3;

		bro(e3) = bdyinit; setlast(bdyinit);

				/* bdyinit is now { e2/(y=>x); e3} */

		bro(bdyinit) = broe3;

		if (laste3) { setlast(bdyinit); }

		else { clearlast(bdyinit); }

		son(e) = e1;  /* bro(e1) is bdyinit */

		return;

	  }

	  else

	  if (name(bdyinit)== name_tag && (idy = son(bdyinit))==init

		&& no(idy)==0 && 		    

		shape_size(sh(idy)) == shape_size(sh(e1)) &&

		shape_align(sh(idy)) == shape_align(sh(e1)) ) {

		/* form is Var/Id x = Id y = e1 in y in e3	

			=> Var x = e1 in e3 */

		bro(e1) = e3;

		son(e) = e1;

	  }

	  else return;			

	}

	else {

	  if (name(bdyinit) == seq_tag) {

		exp cy = bro(son(bdyinit));

		exp broe3;

		bool laste3;

		if (name(cy) != cont_tag) return;

		idy = son(cy);

		if (name(idy) != name_tag || no(idy) != 0 ||

			son(idy) != init ||

			shape_size(sh(cy)) != shape_size(sh(e1)) ||

			shape_align(sh(cy)) != shape_align(sh(e1)) ) {

			return;

		}

		if (!isvar(e)) {

			change_to_var(e);

			if (isvis(init)) { setvis(e); }

			if (!iscaonly(init)) { ClearCaonly(e); }

		}

		change_names(init,e,idy);

		broe3 = bro(e3);

		laste3 = last(e3);

		bro(son(bdyinit)) = e3;

		bro(e3) = bdyinit; setlast(bdyinit);

				/* bdyinit is now { e2/(y=>x); e3} */

		bro(bdyinit) = broe3;

		if (laste3) { setlast(bdyinit); }

		else { clearlast(bdyinit); }

		son(e) = e1;  /* bro(e1) is bdyinit */

		return;

	  }

	  else

	  if (name(bdyinit) == cont_tag) {

		exp cy =  bro(son(bdyinit));

		idy = son(cy);

		if (name(idy) != name_tag || no(idy) != 0 ||

			son(idy) != init ||

			shape_size(sh(cy)) != shape_size(sh(e1)) ||

			shape_align(sh(cy)) != shape_align(sh(e1)) ) {

			return;

		}

		/* form is Var x = Var y = e1 in cont(y) in e3	

			=> Var x = e1 in e3 */

		if (!isvar(e)) {

			change_to_var(e);

			if (isvis(init)) { setvis(e); }

			if (!iscaonly(init)) { ClearCaonly(e); }

		}

		bro(e1) = e3;

		son(e) = e1;

	  }

	  else return;

	}

}

int scan_cond

    PROTO_N ( (e, outer_id) )

    PROTO_T ( exp * e X exp outer_id )

{

	exp ste = *e;

	exp first = son (ste);

	exp labst = bro (first);

	exp second = bro (son (labst));

	assert(name(ste)==cond_tag);

	if (name(second)==top_tag && name(sh(first))==bothd && no(son(labst))==1

		&& name(first)==seq_tag && name(bro(son(first))) == goto_tag){

		/* cond is { ... test(L); ? ; goto X | L:make_top}

			if ? empty can replace by seq { ... not-test(X); make_top }

		*/

		exp l = son(son(first));

		while(!last(l)) { l = bro(l); }

		while(name(l)==seq_tag) { l = bro(son(l)); }

		if (name(l)==test_tag && pt(l)==labst) {

		   settest_number(l, notbranch[test_number(l)]);

		   pt(l) = pt(bro(son(first)));

		   bro(son(first)) = second;

		   bro(second) = first; setlast(second);

		   bro(first) = bro(ste); 

		   if(last(ste)) { setlast(first);} else { clearlast(first); }

		   *e = first;

		   return 1;

		}

		else return 0;

	}

	if (name (first) == seq_tag && name (second) == cond_tag 

	    && no(son(labst)) == 1 

	    && name (son (son (first))) == test_tag 

	    && pt (son (son (first))) == labst

	    && name (son (second)) == seq_tag

	    && name (son (son (son (second)))) == test_tag) {

				/* cond is ( seq (test to L;....| 

				   L:cond(seq(test;...),...) ) ..... */

	  exp test1 = son (son (first));

	  exp test2 = son (son (son (second)));

	  exp op11 = son(test1);

	  exp op21 = bro(op11);

	  exp op12 = son(test2);

	  exp op22 = bro(op12);

	  bool c1 = complex (op11);

	  bool c2 = complex (op21);

	  if (c1 && eq_exp (op11, op12)) {

				/* ....if first operands of tests are

				   same, identify them */

	    exp newid = getexp (sh (ste), bro (ste), last (ste), op11, nilexp,

		0, 2, ident_tag);

	    exp tg1 = getexp (sh (op11), op21, 0, newid, nilexp, 0, 0, name_tag);

	    exp tg2 = getexp (sh (op12), op22, 0, newid, nilexp, 0, 0, name_tag);

	    pt (newid) = tg1;

	    pt (tg1) = tg2;	/* uses of newid */

	    bro (op11) = ste; clearlast (op11);/* body of newid */

	    /* forget son test2 = son test1 */

	    bro (ste) = newid;

	    setlast (ste);	/* father body = newid */

	    son (test1) = tg1;

	    son (test2) = tg2;	/* relace 1st operands of test */

	    if (!complex(op21) ) { 

		/* if the second operand of 1st test is simple, then identification

			could go in a t-teg (!!!NB overloading of inlined flag!!!).... */

		setinlined(newid); 

	    }

	    kill_exp(op12, op12);

	    * (e) = newid;

	    if( scan_cond (&bro(son(labst)), newid) == 2 && complex(op22)) {

		/* ... however a further use of identification means that 

		   the second operand of the second test must also be simple */

		clearinlined(newid);

	    }

	    return 1;

	  }

	  else

	  if (c2 && eq_exp (op21, op22)) {

				/* ....if second operands of tests are

				   same, identify them */

	      exp newid = getexp (sh (ste), bro (ste), last (ste), op21,

		  nilexp, 0, 2, ident_tag);

	      exp tg1 = getexp (sh (op21), test1, 1,

		  newid, nilexp, 0, 0, name_tag);

	      exp tg2 = getexp (sh (op22), test2, 1, newid, nilexp,

		  0, 0, name_tag);

	      pt (newid) = tg1;

	      pt (tg1) = tg2;	/* uses of newid */

	      bro (op21) = ste; clearlast (op21);

	      /* body of newid */

	      /* forget bro son test2 = bro son test1 */

	      bro (ste) = newid;

	      setlast (ste);	/* father body = newid */

	      bro (op11) = tg1;

	      bro (op12) = tg2;

	      if (!complex(op11) ) { setinlined(newid); }

	      kill_exp(op22, op22);

	      /* relace 2nd operands of test */

	      * (e) = newid;

	      if (scan_cond (&bro(son(labst)), newid) == 2 && complex(op12) ) { 

			clearinlined(newid); 

	      }

	      return 1;

	  }

	  else

	  if (name (op12) != name_tag

		  && name (op11) == name_tag 

		  && son (op11) == outer_id

		  && eq_exp (son (outer_id), op12)

		) {		/* 1st param of test1 is already identified with

				   1st param of  test2 */

		exp tg = getexp (sh (op12), op22, 0, outer_id,

		    pt (outer_id), 0, 0, name_tag);

		pt (outer_id) = tg;

		no (outer_id) += 1;

		if (complex(op21) ){ clearinlined(outer_id); }

		/* update usage of ident */

		son (test2) = tg;

		kill_exp(op12, op12);

		if (scan_cond (&bro(son(labst)), outer_id) == 2 && complex(op22)) {

			clearinlined(outer_id);

		}

		return 2;

	      }

	}			

	return 0;

}

/*

 * does the scan on commutative and associative operations and may perform

 * various transformations allowed by these properties

 */

needs likeplus 

    PROTO_N ( ( e, at ) )

    PROTO_T ( exp * e X exp ** at )

{

  needs a1;

  needs a2;

  prop pc;

  exp *br = &son(*e);

  exp prev;

  bool commuted = 0;

  exp dad = * (e);

  a1 = scan(br, at);

  /* scan the first operand - won't be a val_tag */

  do {

    exp *prevbr;

    prevbr = br;

    prev = *(br);

    br = &bro(prev);

    a2 = scan(br, at);

    /* scan the next operand ... */

    if (name(*(br)) != val_tag) {

      a1.floatneeds = MAX_OF(a1.floatneeds, a2.floatneeds);

      pc = a2.propsneeds & hasproccall;

      if (a2.fixneeds < maxfix && pc == 0)

	/* ... its evaluation  will not disturb the accumulated result */

      {

	a1.fixneeds = MAX_OF(a1.fixneeds, a2.fixneeds + 1);

	a1.propsneeds = a1.propsneeds | a2.propsneeds;

      }

      else if (a1.fixneeds < maxfix && (a1.propsneeds & hasproccall) == 0 && !commuted)

      {

	/*

	 * ...its evaluation will call a proc, so put it first

	 */

	exp op1 = son(dad);

	exp cop = *(br);

	bool lcop = last(cop);

	bro(prev) = bro(cop);

	if (lcop)

	  setlast(prev);

	bro(cop) = op1;

	clearlast(cop);

	son(dad) = cop;

	br = (prev == op1) ? &bro(cop) : prevbr;

	op1->commuted=1;

	cop->commuted=1;

	commuted = 1;

	a1.fixneeds = MAX_OF(a2.fixneeds, a1.fixneeds + 1);

	a1.propsneeds |= a2.propsneeds;

	a1.maxargs = MAX_OF(a1.maxargs, a2.maxargs);

      }

      else

      {

	/*

	 * evaluation would disturb accumulated result, so replace it by a

	 * newly declared tag

	 */

	FULLCOMMENT("likeplus: insert ident");

	cca(at, br);

	a1.fixneeds = MAX_OF(a1.fixneeds, 2);

	a1.propsneeds = a1.propsneeds | morefix | (pc << 1);

	a1.maxargs = MAX_OF(a1.maxargs, a2.maxargs);

      }

    }

    else

    {

      FULLCOMMENT("likeplus: val_tag");

    }

  } while (!last(*(br)));

#if 1           			/* exception handling regs */

  if (!optop(*(e)))

  {

    if (a1.fixneeds < 4)

      a1.fixneeds = 4;

  }

#endif

  return a1;

}

/* scan non-commutative fix pt operation */

needs likediv 

    PROTO_N ( ( e, at ) )

    PROTO_T ( exp * e X exp ** at )

{

  needs l;

  needs r;

  prop pc;

  exp *arg = &son(*e);

  l = scan(arg, at);

  /* scan 1st operand */

  arg = &bro(*arg);

  r = scan(arg, at);

  /* scan second operand ... */

  l.floatneeds = MAX_OF(l.floatneeds, r.floatneeds);

  pc = r.propsneeds & hasproccall;

  if (r.fixneeds < maxfix && pc == 0)

  {

    /* fits into registers */

    l.fixneeds = MAX_OF(l.fixneeds, r.fixneeds + 1);

    l.propsneeds = l.propsneeds | r.propsneeds;

    FULLCOMMENT2("likediv: r.fixneeds(%d) < maxfix(%d) && pc == 0", r.fixneeds, maxfix);

  }

  else

  {

    /* requires new declaration of second operand */

    cca(at, arg);

    l.fixneeds = MAX_OF(l.fixneeds, 1);

    l.propsneeds = l.propsneeds | morefix | (pc << 1);

    l.maxargs = MAX_OF(l.maxargs, r.maxargs);

    FULLCOMMENT2("likediv: insert decl r.fixneeds=%d maxfix=%d", r.fixneeds, maxfix);

  }

#if 1				/* exception handling regs (from mips) */

  if (!optop(*(e)))

  {

    if (l.fixneeds < 4)

      l.fixneeds = 4;

  }

#endif

  return l;

}

needs fpop 

    PROTO_N ( ( e, at ) )

    PROTO_T ( exp * e X exp ** at )

{

  /* scans diadic floating point operation  */

  needs l;

  needs r;

  exp op = *(e);

  prop pcr, pcl;

  exp *arg = &son(op);

  l = scan(arg, at);

  arg = &bro(*arg);

  r = scan(arg, at);

  l.fixneeds = MAX_OF(l.fixneeds, r.fixneeds);

  pcr = r.propsneeds & hasproccall;

  pcl = l.propsneeds & hasproccall;

  if (!optop(*(e)))

  {

    if (l.fixneeds < 2)

      l.fixneeds = 2;

  }

#if use_long_double

    if ( name(sh(son(op)))==doublehd )

    {