Rev 2 | Blame | Compare with Previous | Last modification | View Log | RSS feed
/*
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.
*/
/*
VERSION INFORMATION
===================
--------------------------------------------------------------------------
$Header: /u/g/release/CVSROOT/Source/src/installers/sparc/common/needscan.c,v 1.3 1998/03/11 11:03:57 pwe Exp $
--------------------------------------------------------------------------
$Log: needscan.c,v $
* Revision 1.3 1998/03/11 11:03:57 pwe
* DWARF optimisation info
*
* Revision 1.2 1998/02/11 16:56:43 pwe
* corrections
*
* Revision 1.1.1.1 1998/01/17 15:55:55 release
* First version to be checked into rolling release.
*
* Revision 1.41 1997/12/04 19:54:21 pwe
* ANDF-DE V1.9
*
* Revision 1.40 1997/11/06 09:29:06 pwe
* ANDF-DE V1.8
*
* Revision 1.39 1997/10/23 09:33:06 pwe
* prep extra_diags
*
* Revision 1.38 1997/10/10 18:32:44 pwe
* prep ANDF-DE revision
*
* Revision 1.37 1997/08/23 13:54:19 pwe
* initial ANDF-DE
*
* Revision 1.36 1997/05/05 07:51:17 pwe
* correct offset_mult (val * val)
*
* Revision 1.35 1997/03/26 13:04:36 pwe
* general proc compatibility
*
* Revision 1.34 1997/02/18 11:48:08 pwe
* NEWDIAGS for debugging optimised code
*
* Revision 1.33 1996/11/04 12:55:14 pwe
* protect callee regs from caller call
*
* Revision 1.32 1996/10/03 08:51:16 pwe
* PIC global/large offset, and PIC case guardregs
*
* Revision 1.31 1996/09/18 12:03:52 pwe
* fixed PIC_code
*
* Revision 1.30 1996/09/10 16:24:26 pwe
* patch to prevent ass spin on tight loop
*
* Revision 1.29 1996/09/09 12:32:43 pwe
* protect result during postlude
*
* Revision 1.28 1996/09/06 16:50:18 pwe
* fix outpar doubles for postlude
*
* Revision 1.27 1996/09/04 15:47:51 pwe
* name change to avoid cc confusion
*
* Revision 1.26 1996/08/30 17:00:17 pwe
* ensure space available for struct return
*
* Revision 1.25 1996/08/28 11:47:45 pwe
* correct postlude with calls
*
* Revision 1.24 1996/06/19 15:38:26 john
* Changed env_offset
*
* Revision 1.23 1996/06/17 16:12:08 john
* Fix to offset_mult optimisation
*
* Revision 1.22 1996/02/29 17:39:38 john
* Fix to shift op
*
* Revision 1.21 1995/12/15 10:25:51 john
* Changed current_env
*
* Revision 1.20 1995/11/23 12:47:32 john
* Fix for general procs
*
* Revision 1.19 1995/11/17 16:21:03 john
* Fix to general proc call
*
* Revision 1.18 1995/11/10 10:11:42 john
* Fixed scan of prof_tag
*
* Revision 1.17 1995/11/09 17:24:51 john
* the result of inlining a function is no longer stored in
* a t reg.
*
* Revision 1.16 1995/11/07 09:41:34 john
* Changed parameter passing for general procs
*
* Revision 1.15 1995/10/31 12:47:26 john
* Change to needs for dynamic callees
*
* Revision 1.14 1995/10/27 10:50:49 john
* Fix to general procs
*
* Revision 1.13 1995/09/25 16:35:06 john
* Fix for outpar
*
* Revision 1.12 1995/09/19 14:32:01 john
* Added trap_tag
*
* Revision 1.11 1995/09/13 16:36:59 john
* Added special_tag to scan
*
* Revision 1.10 1995/08/31 15:57:14 john
* Fixed diagnostic bug & added fmax_tag
*
* Revision 1.9 1995/08/22 15:28:54 john
* Change to compound_tag
*
* Revision 1.8 1995/08/04 15:46:12 john
* Fix to maxneeds
*
* Revision 1.7 1995/07/17 16:44:16 john
* New case
*
* Revision 1.6 1995/07/14 16:32:43 john
* Various changes for new spec
*
* Revision 1.5 1995/06/21 14:29:21 john
* Reformatting
*
* Revision 1.4 1995/06/14 15:35:11 john
* Added support for give_stack_limit and set_stack_limit constructs.
*
* Revision 1.3 1995/05/26 12:59:59 john
* Changes for new spec
*
* Revision 1.2 1995/04/20 08:06:12 john
* Changed function definition
*
* Revision 1.1.1.1 1995/03/13 10:19:03 john
* Entered into CVS
*
* Revision 1.12 1995/01/23 08:51:03 john
* Modified case for allocating ident to t-reg.
*
* Revision 1.11 1994/12/21 12:09:38 djch
* Added max_tag and min_tag, corrected offset_max_tag
*
* Revision 1.10 1994/12/20 14:46:25 djch
* fixes to get the new cond scanning code working.
*
* Revision 1.9 1994/12/05 11:28:42 djch
* To fix CR94_013:DR116.plum_err, added scan_cond from Ian's MIPS.
*
* Revision 1.8 1994/12/01 13:12:04 djch
* Force envoffset'd idents to the stack.
* Consider returning bottom as returning void.
* Scan movecont with simplified version of apply_tag (for now)
* Added goto_lv_tag and abs_tag
*
* Revision 1.7 1994/07/06 13:49:25 djch
* After scan *e may not be the exp it was before, so use *(ptr_position(ste))
* instead of *e.
*
* Revision 1.6 1994/06/22 09:53:21 djch
* added div0 and rem0
*
* Revision 1.5 1994/05/24 08:10:23 djch
* Moved addptr to call likediv, since it is not commutative..
*
* Revision 1.4 1994/05/19 08:20:43 djch
* fixed chase not to distribute into exp with shape bottom (avoid field(goto))
*
* Revision 1.3 1994/05/13 13:05:10 djch
* Incorporates improvements from expt version
* moved declaratiosn inside long_double code.
* removed two wrong parts of test to optimise test_tags
* added decrements to keep ways there accurate
* removed swap for val on lhs, added optimization for x &2^n ==0 -> x<<k is -ve
* one fix from mips in neg_tag moving
*
* Revision 1.2 1994/05/03 15:08:59 djch
* ifdefed out rscope_tag
*
* Revision 1.9 93/11/19 16:30:46 16:30:46 ra (Robert Andrews)
* Declare long_to_al.
*
* Revision 1.8 93/09/27 14:51:19 14:51:19 ra (Robert Andrews)
* A number of changes to allow for long doubles.
*
* Revision 1.7 93/08/27 11:34:07 11:34:07 ra (Robert Andrews)
* A number of lint-like changes. Use of pset and pnset to set properties.
*
* Revision 1.6 93/08/18 11:16:20 11:16:20 ra (Robert Andrews)
* Reformatted.
*
* Revision 1.5 93/08/13 14:42:02 14:42:02 ra (Robert Andrews)
* Removed a couple of comments. Fixed maxtup to deal with the case when
* the compound initialiser does not consist entirely of constants (doesn't
* arise from C).
*
* Revision 1.4 93/07/12 15:17:15 15:17:15 ra (Robert Andrews)
* Some of the needs cases were nonsense. offset_mult is like mult, not div.
* offset_add etc should use likediv, not divneeds.
*
* Revision 1.3 93/07/05 18:22:38 18:22:38 ra (Robert Andrews)
* The test for return top was wrong - it should be checking the shape,
* not looking for a return ( make_top ).
*
* Revision 1.2 93/06/29 14:29:05 14:29:05 ra (Robert Andrews)
* The ( x / fp_const ) -> ( 1.0 / fp_const ) * x optimisation only applies
* if FBASE is 10.
*
* Revision 1.1 93/06/24 14:58:54 14:58:54 ra (Robert Andrews)
* Initial revision
*
--------------------------------------------------------------------------
*/
#define SPARCTRANS_CODE
/*
The functions in this file define 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 (common to other
translators).
*/
#include "config.h"
#include "common_types.h"
#include "myassert.h"
#include "exptypes.h"
#include "exp.h"
#include "expmacs.h"
#include "tags.h"
#include "extra_tags.h"
#include "new_tags.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 "me_fns.h"
#include "needscan.h"
#include "reg_defs.h"
#include "szs_als.h"
#include "makecode.h"
extern bool do_tlrecursion ;
extern prop notbranch[];
/*
LOCAL VARIABLES
*/
static int stparam ; /* Size of parameter list in bits */
static int fixparam ; /* Next available place for param */
static int rscope_level = 0 ;
static bool nonevis = 1 ;
static bool specialext ; /* for PIC_code, special globals require proc_uses_external */
static int callerfortr ;
int maxfix, maxfloat ; /* The maximum numbers of t-regs */
static bool gen_call; /* true if the scan is within a general proc */
static bool v_proc; /* true if the scan is within a general proc with vcallees */
#ifdef GENCOMPAT
static bool trad_proc; /* true if the scan is within a proc with no callees */
#endif
/*
THE TYPE DESCRIBING REGISTER NEEDS
The type needs is 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).
*/
/*
FIND A POINTER TO EXPRESSION 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 ) ;
}
/*
INSERT A NEW DECLARATION
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 cca
PROTO_N ( ( to, x ) )
PROTO_T ( exp ** to X exp * x ){
#ifndef NEWDIAGS
if (name((**to))==diagnose_tag){
*to = &(son((**to)));
}
#endif
if ( x == ( *to ) ) {
/* replace by Let tg = def In tg Ni */
exp def = *x ;
exp id = getexp ( sh ( def ), bro ( def ), ( int ) last ( def ),
def, nilexp, 0, 1, ident_tag ) ;
exp tg = getexp ( sh ( def ), id, 1, id, nilexp, 0, 0, name_tag ) ;
/* use of tag */
pt ( id ) = tg ;
/* bro ( def ) is body of Let = tg */
bro ( def ) = tg ;
clearlast ( def ) ;
/* replace pointer to x by Let */
*x = id ;
#ifdef NEWDIAGS
if (diagnose) {
dgf(id) = dgf(bro(son(id)));
dgf(bro(son(id))) = nildiag;
}
#endif
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 ), ( int ) last ( ato ),
def, nilexp, 0, 1, ident_tag ) ;
exp tg = getexp ( sh ( def ), bro ( def ), ( int ) last ( def ),
id, nilexp, 0, 0, name_tag ) ;
/* use of tg */
pt ( id ) = tg ;
/* ato is body of Let */
bro ( def ) = ato ;
clearlast ( def ) ;
/* its father is Let */
bro ( ato ) = id ;
setlast ( ato ) ;
/* replace pointer to 'to' by Let */
*( *to ) = id ;
/* replace use of x by tg */
*x = tg ;
/* later replacement to same 'to' will be at body of Let */
*to = &bro ( def ) ;
#ifdef NEWDIAGS
if (diagnose) {
dgf(id) = dgf(bro(son(id)));
dgf(bro(son(id))) = nildiag;
}
#endif
}
return ;
}
/*
BASIC REGISTER NEEDS
This represent the requirements, one fixed point register,
two fixed point registers, one floating point register and
no registers respectively.
*/
needs onefix = { 1, 0, 0, 0 } ;
needs twofix = { 2, 0, 0, 0 } ;
needs onefloat = { 0, 1, 0, 0 } ;
needs zeroneeds = { 0, 0, 0, 0 } ;
#if 0
/*
CHECK IF ANY USES OF id ARE AS AN INITIALISER FOR A DECLARATION
*/
bool subvar_use
PROTO_N ( ( uses ) )
PROTO_T ( exp uses )
{
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
/*
WORK OUT REGISTER NEEDS FOR A GIVEN SHAPE
*/
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 ) ;
}
}
/* NOT REACHED */
}
/*
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;
}
/*
IS AN EXPRESSSION COMPLEX?
An expression is complex if, basically, it cannot be accessed by a
simple load or store instruction.
*/
bool complex
PROTO_N ( ( e ) )
PROTO_T ( exp e ){
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 || name(e) == null_tag ) {
return ( 0 ) ;
}
else {
return ( 1 ) ;
}
/* NOT REACHED */
}
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[(int)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;
}
/*
WORK OUT REGISTER NEEDS FOR PLUS-LIKE OPERATIONS
The operation will be n-ary, commutative and associative.
*/
needs likeplus
PROTO_N ( ( e, at ) )
PROTO_T ( exp * e X exp ** at ){
needs a1 ;
needs a2 ;
prop pc ;
exp *br = &son ( *e ) ;
exp dad = *e ;
exp prev ;
bool commuted = 0 ;
/* scan the first operand - won't be a val_tag */
a1 = scan ( br, at ) ;
/* likeplus exp with 1 operand should never occur */
assert ( !( last ( *br ) ) ) ;
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 = ( prop ) ( a2.prps & 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.prps = ( prop ) ( a1.prps | a2.prps ) ;
}
else if ( a1.fixneeds < maxfix &&
pntst ( a1, hasproccall ) == 0 &&
!commuted ) {
/* ...its evaluation will call a proc, so put it first */
exp op1 = son ( dad ) ;
exp cop = *br ;
bool lcop = ( bool ) last ( cop ) ;
bro ( prev ) = bro ( cop ) ;
if ( lcop ) setlast ( prev ) ;
bro ( cop ) = op1 ;
clearlast ( cop ) ;
son ( dad ) = cop ;
br = ( prev == op1 ) ? &bro ( cop ) : prevbr ;
commuted = 1 ;
a1.fixneeds = MAX_OF ( a2.fixneeds, a1.fixneeds + 1 ) ;
pnset ( a1, a2.prps ) ;
a1.maxargs = MAX_OF ( a1.maxargs, a2.maxargs ) ;
}
else {
/* evaluation would disturb accumulated result, so replace
it by a newly declared tag */
cca ( at, br ) ;
a1.fixneeds = MAX_OF ( a1.fixneeds, 2 ) ;
pnset ( a1, morefix | ( pc << 1 ) ) ;
a1.maxargs = MAX_OF ( a1.maxargs, a2.maxargs ) ;
}
} else {
/* nothing */
}
} while ( !last ( *br ) ) ;
#if 1
/* exception handling regs (from mips) */
if ( !optop ( *e ) ) {
if ( a1.fixneeds < 4 ) a1.fixneeds = 4 ;
}
#endif
return ( a1 ) ;
}
/*
WORK OUT REGISTER NEEDS FOR DIVIDE-LIKE OPERATIONS
The operation will be binary and non-commutative.
*/
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 = ( prop ) ( r.prps & hasproccall ) ;
if ( r.fixneeds < maxfix && pc == 0 ) {
/* fits into registers */
l.fixneeds = MAX_OF ( l.fixneeds, r.fixneeds + 1 ) ;
pnset ( l, r.prps ) ;
}
else {
/* requires new declaration of second operand */
cca ( at, arg ) ;
l.fixneeds = MAX_OF ( l.fixneeds, 1 ) ;
pnset ( l, morefix | ( pc << 1 ) ) ;
l.maxargs = MAX_OF ( l.maxargs, r.maxargs ) ;
}
#if 1
/* exception handling regs (from mips) */
if ( !optop ( *e ) ) {
if ( l.fixneeds < 4 ) l.fixneeds = 4 ;
}
#endif
return ( l ) ;
}
/*
WORK OUT REGISTER NEEDS FOR FLOATING-POINT OPERATIONS
The operation will be binary.
*/
needs fpop
PROTO_N ( ( e, at ) )
PROTO_T ( exp * e X exp ** at ){
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 = ( prop ) ( r.prps & hasproccall ) ;
pcl = ( prop ) ( l.prps & hasproccall ) ;
#if use_long_double
if ( name ( sh ( son ( op ) ) ) == doublehd ) {
ClearRev ( op ) ;
arg = &son ( op ) ;
if ( !is_o ( name ( *arg ) ) || pcl ) cca ( at, arg ) ;
arg = &bro ( son ( op ) ) ;
if ( !is_o ( name ( *arg ) ) || pcr ) cca ( at, arg ) ;
l.floatneeds = MAX_OF ( l.floatneeds, r.floatneeds ) ;
l.maxargs = MAX_OF ( l.maxargs, r.maxargs ) ;
pnset ( l, hasproccall ) ;
return ( l ) ;
}
#endif
if ( r.floatneeds <= l.floatneeds &&
r.floatneeds < maxfloat && pcr == 0 ) {
l.floatneeds = MAX_OF ( l.floatneeds, r.floatneeds + 1 ) ;
l.floatneeds = MAX_OF ( 2, l.floatneeds ) ;
pnset ( l, r.prps ) ;
ClearRev ( op ) ;
}
else if ( pcl == 0 && l.floatneeds <= r.floatneeds &&
l.floatneeds < maxfloat ) {
l.floatneeds = MAX_OF ( r.floatneeds, l.floatneeds + 1 ) ;
l.floatneeds = MAX_OF ( 2, l.floatneeds ) ;
pnset ( l, r.prps ) ;
SetRev ( op ) ;
}
else if ( r.floatneeds < maxfloat && pcr == 0 ) {
l.floatneeds = MAX_OF ( l.floatneeds, r.floatneeds + 1 ) ;
l.floatneeds = MAX_OF ( 2, l.floatneeds ) ;
pnset ( l, r.prps ) ;
ClearRev ( op ) ;
}
else {
cca ( at, arg ) ;
ClearRev ( op ) ;
l.floatneeds = MAX_OF ( l.floatneeds, 2 ) ;
pnset ( l, morefloat | ( pcr << 1 ) ) ;
l.maxargs = MAX_OF ( l.maxargs, r.maxargs ) ;
}
return ( l ) ;
}
/*
WORK OUT THE MAXIMUM OF TWO REGISTER NEEDS
*/
needs maxneeds
PROTO_N ( ( a, b ) )
PROTO_T ( needs a X needs b ){
needs an ;
an.fixneeds = MAX_OF ( a.fixneeds, b.fixneeds ) ;
an.floatneeds = MAX_OF ( a.floatneeds, b.floatneeds ) ;
an.maxargs = MAX_OF ( a.maxargs, b.maxargs ) ;
an.callee_size = MAX_OF(a.callee_size,b.callee_size);
an.prps = ( prop ) ( a.prps | b.prps ) ;
return ( an ) ;
}
/*
WORK OUT THE REGISTER NEEDS OF A TUPLE OF EXPRESSIONS
*/
needs maxtup
PROTO_N ( ( e, at ) )
PROTO_T ( exp e X exp ** at ){
exp *s = &son ( e ) ;
needs an ;
an = zeroneeds ;
if( *s == nilexp) return an;
while (an = maxneeds (an, scan (s, at)), !last(*s) ) {
s = &bro(*s);
}
return an;
/* NOT REACHED */
}
/*
IS A VALUE UNCHANGED OVER ITS SCOPE?
This routine finds if usedname is only used in cont operation or as
result of ident.
*/
bool unchanged
PROTO_N ( ( usedname, ident ) )
PROTO_T ( exp usedname X exp ident ){
exp uses = pt ( usedname ) ;
while ( uses != nilexp ) {
if ( intnl_to ( ident, uses ) ) {
if ( !last ( uses ) || name ( bro ( uses ) ) != cont_tag ) {
exp z = uses ;
while ( z != ident ) {
if ( !last ( z ) || ( name ( bro ( z ) ) != seq_tag &&
name ( bro ( z ) ) != ident_tag ) ) {
return ( 0 ) ;
}
z = bro ( z ) ;
}
}
}
uses = pt ( uses ) ;
}
return ( 1 ) ;
}
/*
CHASE STRUCTURE PROCEDURE RESULTS
The SPARC convention for delivering a struct from a procedure is
to have an extra pointer parameter in the proc; this means that
there must always be space in the calling work-space for the
result struct whether or not the value is used e.g. as in
f ( x ) or f ( x ).a etc. This procedure is part of the
mechanism to determine whether it is necessary to insert a dummy
declaration to ensure that this space exists.
*/
bool chase
PROTO_N ( ( sel, e ) )
PROTO_T ( exp sel X exp * e ){
exp *one ;
bool b = 0 ;
switch ( name ( *e ) ) {
case rep_tag :
case ident_tag :
case seq_tag :
case labst_tag : {
b = chase ( sel, &bro ( son ( *e ) ) ) ;
break ;
}
case solve_tag :
case cond_tag : {
one = &son ( *e ) ;
for ( ; ; ) {
b = ( bool ) ( b | chase ( sel, one ) ) ;
if ( last ( *one ) ) break ;
one = &bro ( *one ) ;
}
break ;
}
case field_tag : {
if ( chase ( *e, &son ( *e ) ) ) {
/* inner field has been distributed */
exp stare = *e ;
exp ss = son ( stare ) ;
if ( !last ( stare ) ) clearlast ( ss ) ;
bro ( ss ) = bro ( stare ) ;
sh ( ss ) = sh ( stare ) ;
*e = ss ;
return ( chase ( sel, e ) ) ;
}
/* FALL THROUGH */
}
default : {
if ( (son ( sel ) != *e) && (name (sh(*e)) != bothd)) {
/* only change if not outer */
exp stare = *e ;
exp newsel = getexp ( sh ( sel ), bro ( stare ),
( int ) last ( stare ), stare,
nilexp, props ( sel ), no ( sel ),
name ( sel ) ) ;
*e = newsel ;
bro ( stare ) = newsel ;
setlast ( stare ) ;
b = 1 ;
}
}
}
if ( b ) sh ( *e ) = sh ( sel ) ;
return ( b ) ;
}
exp need_result_space
PROTO_N ( ( e ) )
PROTO_T ( exp e ) {
/* dad if application needs to reserve space for struct result */
exp dad = father ( e );
switch (name (dad)) {
case 0: /* void in sequence, or param of apply_gen */
case apply_tag:
case caller_tag:
case field_tag:
return dad;
case ident_tag:
if (e == son (dad))
return nilexp;
return (need_result_space (dad));
case rep_tag:
if (e == son (dad))
return dad;
/* else fall through */
case cond_tag:
case solve_tag:
case labst_tag:
case seq_tag:
#ifndef NEWDIAGS
case diagnose_tag:
#endif
return (need_result_space (dad));
default:
return nilexp;
}
}
bool spin_lab
PROTO_N ( ( lab ) )
PROTO_T ( exp lab ) {
/* true if label implies a tight spin */
exp dest = lab;
exp temp, ll;
for (;;) {
assert (name(dest) == labst_tag);
temp = bro(son(dest));
if (temp == nilexp || name(temp) != goto_tag)
return 0;
ll = lab;
for (;;) {
if (pt(temp) == ll)
return 1;
if (ll == dest)
break;
ll = pt(bro(son(ll)));
}
dest = pt(temp);
};
return 0;
}
/* Check for legal conditions for asm */
static void id_in_asm
PROTO_N ( ( id ) )
PROTO_T ( exp id )
{
if (!isparam(id) || !props(son(id)))
setvis (id);
return;
}
static int is_asm_opnd
PROTO_N ( ( e, ext ) )
PROTO_T ( exp e X int ext )
{
unsigned char n = name (e);
if (n == name_tag) {
id_in_asm (son(e));
return 1;
}
if (n == cont_tag && name(son(e)) == name_tag && isvar(son(son(e)))) {
id_in_asm (son(son(e)));
return 1;
}
return (n == val_tag || n == real_tag || n == null_tag ||
(n == reff_tag && name(son(e)) == name_tag));
}
static int is_asm_var
PROTO_N ( ( e, ext ) )
PROTO_T ( exp e X int ext )
{
unsigned char n = name (e);
if (n == name_tag && isvar(son(e))) {
id_in_asm (son(e));
return 1;
}
return 0;
}
void check_asm_seq
PROTO_N ( ( e, ext ) )
PROTO_T ( exp e X int ext )
{
if (name(e) == asm_tag) {
if ((asm_string(e) && name(son(e)) == string_tag) ||
(asm_in(e) && is_asm_opnd(son(e), ext)) ||
(asm_var(e) && is_asm_var(son(e), ext)) )
return;
}
if (name(e) == seq_tag) {
exp t = son(son(e));
for (;;) {
check_asm_seq (t, ext);
if (last(t))
break;
t = bro(t);
}
check_asm_seq (bro(son(e)), ext);
}
else
if (name(e) != top_tag)
fail ("illegal ~asm");
return;
}
/*
SCAN AN EXPRESSION TO CALCULATE REGISTER NEEDS
This procedure works out register requirements of an exp. At each
call the fix field of the needs is the number of fixed point
registers required to contain live values to evaluate this
expression. This never exceeds maxfix because if it would have,
a new declaration is introduced in the exp tree (similarly for
floating registers and maxfloat). In these cases the prop field
will contain the bits morefix (or morefloat).
Scan also works out various things concerned with proc calls.
The maxargs field contains the maximum size in bits of the space
required for the parameters of all the procedures called in the
exp.
An exp proc call produces a hasproccall bit in the prop field, if
this is transformed as part of the definition of a new declaration
the bit is replaced by a usesproccall. The distinction is only used
in unfolding nested proc calls; SPARC requires this to be done
statically. The condition that a proc exp is a leaf (i.e. no proc
calls) is that its prop contains neither bit. If an ident exp
is suitable, scan marks the props of ident with either inreg or
infreg bits to indicate that a t-reg may be used for this tag.
A thorough understanding of needs along with other procedures that
do switch ( name ( exp ) ) requires a knowledge of the meaning of
the fields of the exp in each case (this is documented somewhere).
*/
needs scan
PROTO_N ( ( e, at ) )
PROTO_T ( exp * e X exp ** at ){
/* e is the expression to be scanned, at is the place to put any
new decs. The order of recursive calls with same at is
critical. */
exp ste = *e ;
int nstare = ( int ) name ( ste ) ;
#if 0
/* ignore diagnostic information */
while ( nstare == diag_tag || nstare == cscope_tag ||
nstare == fscope_tag ) {
e = &son ( ste ) ;
ste = *e ;
nstare = name ( ste ) ;
}
#endif
switch ( nstare ) {
case 0 : {
return ( zeroneeds ) ;
}
#if 0
case compound_tag : {
return ( maxtup ( ste, at ) ) ;
}
#else
case compound_tag :
#endif
case nof_tag :
case concatnof_tag :
case ncopies_tag : {
needs nl ;
bool cantdo ;
exp dad ;
if ( name ( ste ) == ncopies_tag &&
name ( son ( ste ) ) != name_tag &&
name ( son ( ste ) ) != val_tag ) {
nl = scan ( &son ( *e ), at ) ;
cca ( at, &son ( *e ) ) ;
}
else {
nl = maxtup ( *e, at ) ;
}
dad = father ( ste ) ;
if ( name ( dad ) == compound_tag ||
name ( dad ) == nof_tag ||
name ( dad ) == concatnof_tag ) {
cantdo = 0 ;
}
else {
if ( last ( ste ) ) {
if ( name ( bro ( ste ) ) == ass_tag ) {
exp a = son ( bro ( ste ) ) ;
cantdo = ( bool ) ( name ( a ) != name_tag ||
!isvar ( son ( a ) ) ) ;
}
else {
cantdo = 1 ;
}
}
else {
if ( last ( bro ( ste ) ) ) {
cantdo = ( bool ) ( name ( bro ( bro ( ste ) ) ) !=
ident_tag ) ;
}
else {
cantdo = 1 ;
}
}
}
if ( cantdo ) {
/* can only deal with tuples in simple assignment or id */
int prpsx = ( int ) ( pntst ( nl, hasproccall ) << 1 ) ;
cca ( at, ptr_position ( ste ) ) ;
nl = shapeneeds ( sh ( *e ) ) ;
pnset ( nl, morefix ) ;
pnset ( nl, prpsx ) ;
}
if ( nl.fixneeds < 2 ) nl.fixneeds = 2 ;
return ( nl ) ;
}
case cond_tag : {
/* exp first = son ( ste ) ;
exp labst = bro ( first ) ;
exp second = bro ( son ( labst ) ) ; */
if (scan_cond(e, nilexp) !=0) {
return scan(e, at);
} /* else goto next case */
}
/* FALL THROUGH */
case labst_tag :
case rep_tag :
case solve_tag : {
needs an ;
exp *stat ;
exp *statat ;
stat = &son ( *e ) ;
statat = stat ;
an = zeroneeds ;
while ( an = maxneeds ( an, scan ( stat, &statat ) ),
!last ( *stat ) ) {
stat = &bro ( *stat ) ;
statat = stat ;
}
if ( pntst ( an, usesproccall ) != 0 ) {
pnset ( an, hasproccall ) ;
}
return ( an ) ;
}
case ident_tag : {
needs bdy ;
needs def ;
exp stare = *e ;
exp *arg = &bro ( son ( stare ) ) ;
exp t, s ;
bool fxregble ;
bool flregble ;
bool old_nonevis = nonevis ;
if ( no ( stare ) == 0 ) {
/* no uses, should have caonly flag and no var flag */
setcaonly ( stare ) ;
clearvar ( stare ) ;
#ifdef NEWDIAGS
t = pt (stare);
while (t) {
assert (isdiaginfo (t));
setdiscarded (t);
t = pt(t);
}
#endif
}
if ( isvar ( stare ) && ( !iscaonly ( stare ) ||
all_variables_visible ) ) {
setvis ( stare ) ;
}
if (name(son(stare)) == formal_callee_tag) {
setvis(stare);
}
if ( isparam ( stare ) && name(son(stare))!= formal_callee_tag) {
/* Use the input regs %i0..%i5 for first 6*32 bits of params */
exp def2 = son ( stare ) ;
shape shdef = sh ( def2 ) ;
int n = stparam ;
int sizep = ( int ) shape_size ( shdef ) ;
int last_reg;
#ifdef GENCOMPAT
if (!trad_proc) {
#else
if(gen_call) {
#endif
if(v_proc) {
last_reg = 4;
}
else {
last_reg = 5;
}
}
else {
last_reg = 6;
}
assert ( name ( def2 ) == clear_tag ) ;
if ( ( stparam >> 5 ) < ( last_reg ) /*&& !(isenvoff(stare))*/ ) {
/* Param regs %i0..%i5 */
/* is >= 1 param reg free for (part-of) the param */
/* Use an available param reg */
if(v_proc && (stparam>>5)==last_reg) {
/* reserve R_I5 for use as local reg */
props(def2) = 0;
stparam += 32;
n = stparam;
}
else {
props ( def2 ) = ( prop ) fixparam ;
}
}
else {
/* Pass by stack */
/* envoffset'ed this way always */
props ( def2 ) = 0 ;
}
/* "offset" in params */
no ( def2 ) = n ;
stparam = rounder ( n + sizep, 32 ) ;
/* ( stparam / 32 ) */
fixparam = R_I0 + ( stparam >> 5 ) ;
}
else if(isparam(stare) && name(son(stare)) == formal_callee_tag){
exp def2 = son(stare);
exp shdef = sh(def2);
int sizep = shape_size(shdef);
int alp = shape_align(shdef);
int n = rounder(callee_size,alp);
no(def2) = n;
callee_size = rounder(n+sizep,32);
props(def2) = 0;
}
nonevis = ( bool ) ( nonevis & !isvis ( stare ) ) ;
bdy = scan ( arg, &arg ) ;
#if NO_TREG
/* force minimal t-reg usage */
bdy.fixneeds = maxfix ;
#endif
/* scan the body-scope */
arg = &son ( stare ) ;
/* scan the initialisation of tag */
def = scan ( arg, &arg ) ;
nonevis = old_nonevis ;
t = son ( stare ) ;
s = bro ( t ) ;
fxregble = fixregable ( stare ) ;
flregble = floatregable ( stare ) ;
if ( isparam ( stare ) ) {
if(name(son(stare)) != formal_callee_tag){
/* reg for param or else 0 */
int x = ( int ) props ( son ( stare ) ) ;
/* bit size of param */
int par_size = shape_size ( sh ( son ( stare ) ) ) ;
if ( par_size == 8 || par_size == 16 ) {
/* on to right end of word */
no ( son ( stare ) ) += 32 - par_size ;
}
if ( x != 0 && fxregble ) {
/* leave suitable pars in par regs */
no ( stare ) = x ;
pset ( stare, inreg_bits ) ;
}
else {
if ( x != 0 && flregble ) {
/* Caller has placed float param in par regs;
callee must store it out for use in float regs */
no ( stare ) = 0 ;
}
else {
/* Otherwise caller has placed param on stack */
no ( stare ) = R_NO_REG ;
}
}
}
else
no(stare) = R_NO_REG;
}
else {
if ( !isvis ( *e ) && isparam ( *e ) && !isoutpar(stare) &&
pntst ( bdy, anyproccall | uses_res_reg_bit ) == 0 &&
( fxregble || flregble ) &&
( ((name (t)==apply_tag) || (name(t)==apply_general_tag)) ||
( name ( s ) == seq_tag &&
name ( bro ( son ( s ) ) ) == res_tag &&
name ( son ( bro ( son ( s ) ) ) ) == cont_tag &&
isvar ( stare ) &&
name ( son ( son ( bro ( son ( s ) ) ) ) ) ==
name_tag &&
son ( son ( son ( bro ( son ( s ) ) ) ) ) ==
stare ) ) ) {
/* Let a : = .. ; return cont a */
/* integrate this with the block above,
otherwise NOTREACHED */
/* put tag in result reg if definition is call of proc,
or body ends with return tag, provided result is not
used otherwise */
pset ( stare, ( fxregble ? inreg_bits : infreg_bits ) ) ;
pnset ( bdy, uses_res_reg_bit ) ;
/* identification uses result reg in body */
no ( stare ) = R_USE_RES_REG ;
}
else if (isenvoff(stare)) /* MUST go on stack */ {
no ( stare ) = R_NO_REG ;
}
else if ( !isvar ( *e ) && !isparam ( *e ) &&
/* reff cont variable-not assigned to in scope */
( ( name ( t ) == reff_tag &&
name ( son ( t ) ) == cont_tag &&
name ( son ( son ( t ) ) ) == name_tag &&
isvar ( son ( son ( son ( t ) ) ) ) &&
!isvis ( son ( son ( son ( t ) ) ) ) &&
!isglob ( son ( son ( son ( t ) ) ) ) &&
unchanged ( son ( son ( son ( t ) ) ),
stare ) ) ||
/* cont variable - not assigned to in scope */
( name ( t ) == cont_tag &&
name ( son ( t ) ) == name_tag &&
isvar ( son ( son ( t ) ) ) &&
!isvis ( son ( son ( t ) ) ) &&
!isglob ( son ( son ( t ) ) ) &&
unchanged ( son ( son ( t ) ),
stare ) ) ) ) {
/* don't take space for this dec */
pset ( stare, defer_bit ) ;
}
else if ( !isvar ( stare ) &&
( ( props ( stare ) & 0x10 ) == 0 ) &&
( name ( t ) == name_tag ||
name ( t ) == val_tag ) ) {
/* don't take space for this dec */
pset ( stare, defer_bit ) ;
}
else if ( fxregble &&
pntst(bdy,morefix)==0 &&
(bdy.fixneeds < maxfix &&
( /*isinlined(stare) ||*/
pntst ( bdy, morefix ) == 0 &&
( pntst ( bdy, anyproccall ) == 0 ||
tempdec ( stare, ( bool )
( pntst ( bdy, morefix ) == 0 &&
bdy.fixneeds < maxfix_tregs - 2 ))))))
{
/* put this tag in some fixpt t-reg - which will be
decided in make_code */
pset ( stare, inreg_bits ) ;
no ( stare ) = 0 ;
bdy.fixneeds += 1 ;
}
else if ( bdy.floatneeds < maxfloat &&
pntst ( bdy, morefloat ) == 0 &&
flregble &&
( pntst ( bdy, anyproccall ) == 0 ||
tempdec ( stare, ( bool )
( pntst ( bdy, morefloat ) == 0 &&
bdy.floatneeds < MAXFLOAT_TREGS - 1 ) ) ) ) {
/* put this tag in some float t-reg - which will be
decided in make_code */
pset ( stare, infreg_bits ) ;
no ( stare ) = 0 ;
bdy.floatneeds += 1 ;
/* add isinlined when you enable float
reg allocation.... */
}
else {
/* allocate either on stack or saved reg */
no ( stare ) = R_NO_REG ;
}
}
bdy = maxneeds ( bdy, def ) ;
if ( pntst ( bdy, usesproccall ) != 0 ) {
pnset ( bdy, hasproccall ) ;
}
return ( bdy ) ;
}
case seq_tag : {
exp *arg = &bro ( son ( *e ) ) ;
needs an ;
exp *stat ;
an = scan ( arg, &arg ) ;
stat = &son ( son ( *e ) ) ;
arg = stat ;
for ( ; ; ) {
needs stneeds ;
stneeds = scan ( stat, &arg ) ;
/* initial statements voided */
an = maxneeds ( an, stneeds ) ;
if ( last ( *stat ) ) {
if ( pntst ( an, usesproccall ) != 0 ) {
pnset ( an, hasproccall ) ;
}
return ( an ) ;
}
stat = &bro ( *stat ) ;
arg = stat ;
}
/* NOT REACHED */
}
case goto_tag : {
needs nr ;
nr = zeroneeds ;
if (!sysV_assembler && spin_lab (pt(*e))) {
pnset ( nr, dont_optimise ) ; /* otherwise the SunOS assembler spins */
}
return ( nr ) ;
}
case ass_tag :
case assvol_tag : {
exp *lhs = &son ( *e ) ;
exp *rhs = &bro ( *lhs ) ;
needs nr ;
ash a ;
/* scan source */
nr = scan ( rhs, at ) ;
a = ashof ( sh ( *rhs ) ) ;
if ( nstare != ass_tag || a.ashsize != a.ashalign ||
a.ashalign == 1 ) {
/* struct/union assign */
if ( !( a.ashsize <= 32 && a.ashsize == a.ashalign ) ) {
/* memory block copy */
nr.fixneeds += 2 ;
}
}
if ( name ( *lhs ) == name_tag &&
( isvar ( son ( *lhs ) ) ||
( pntst ( nr, hasproccall | morefix ) == 0 &&
nr.fixneeds < maxfix ) ) ) {
/* simple destination */
return ( nr ) ;
}
else {
needs nl ;
prop prpx = ( prop ) ( pntst ( nr, hasproccall ) << 1 ) ;
nl = scan ( lhs, at ) ;
if ( (name(*rhs)==apply_tag || name(*rhs)==apply_general_tag) &&
nstare==ass_tag && pntst(nl,uses_res_reg_bit|anyproccall)==0) {
/* source is proc call, so assign result reg directly */
/* SKIP */ ;
}
else if ( nr.fixneeds >= maxfix || prpx != 0 ) {
/* source and dest regs overlap, so identify source */
cca ( at, rhs ) ;
nl = shapeneeds ( sh ( *rhs ) ) ;
pnset ( nl, morefix ) ;
pnclr ( nl, ( prpx >> 1 ) ) ;
pnset ( nl, prpx ) ;
}
nr.fixneeds += 1 ;
return ( maxneeds ( nl, nr ) ) ;
}
}
case untidy_return_tag :
case res_tag : {
ash a ;
needs x ;
shape s ;
exp *arg = &son ( *e ) ;
s = sh ( *arg ) ;
a = ashof ( s ) ;
/* clear possibility of tlrecirsion ; may be set later */
props ( *e ) = 0 ;
x = scan ( arg, at ) ;
/* scan result exp ... */
if ( is_floating ( name ( s ) ) && a.ashsize <= 64 ) {
/* ... floating pt result */
pnset ( x, realresult_bit ) ;
if ( name ( s ) != shrealhd ) {
pnset ( x, longrealresult_bit ) ;
}
}
else {
if ( !valregable ( s ) && name ( s ) != tophd ) {
/* ... result does not fit into reg */
pnset ( x, long_result_bit ) ;
}
}
if ( a.ashsize != 0 && name ( *arg ) != clear_tag ) {
/* ...not a void result */
pnset ( x, has_result_bit ) ;
}
#if 0
/* replace R_USE_RES_REG (from mips) by R_USE_R_I0 (here)
and R_USE_RO0 (ident_tag above) */
/* for present R_USE_RES_REG means R_USE_R_O0 */
/* MIPS has single res reg, on SPARC it is windowed per-proc */
if ( pntst ( x, ( long_result_bit | anyproccall |
uses_res_reg_bit ) ) == 0 ) {
r = son ( *e ) ;
if ( name ( r ) == ident_tag && isvar ( r ) &&
name ( ss = bro ( son ( r ) ) ) == seq_tag &&
name ( t = bro ( son ( ss ) ) ) == cont_tag &&
name ( son ( t ) ) == name_tag &&
son ( son ( t ) ) == r ) {
/* result is tag allocated into result reg - see ident */
if ( ( props ( r ) & inreg_bits ) != 0 ) {
x.fixneeds-- ;
}
else if ( ( props ( r ) & infreg_bits ) != 0 ) {
x.floatneeds-- ;
}
else {
props ( r ) |= ( is_floating ( name ( s ) ) ) ?
infreg_bits : inreg_bits ;
}
pnset ( x, uses_res_reg_bit ) ;
/* identification uses result reg in body */
no ( r ) = R_USE_RES_REG ;
}
}
#endif
return ( x ) ;
}
case apply_general_tag : {
exp application = *(e);
exp *fn = &son(application);
exp callers = bro(*fn);
exp *cerl = &son(callers);
int stpar = 0;
needs nds,pstldnds;
int i;
nds = scan(fn,at);
if(pntst(nds,hasproccall)!=0){ /* Identify it */
cca(at,fn);
pnclr(nds,hasproccall);
pnset(nds,usesproccall);
fn = &son(application);
}
for(i=0;i<no(callers);++i){
needs onepar;
shape shonepar = sh(*cerl);
exp * par = (name(*cerl)==caller_tag)?&son(*cerl):cerl;
int n = rounder(stpar + shape_size(shonepar), 32);
onepar = scan(par,at);
if((/*(i != 0) && */pntst(onepar,hasproccall)!=0) ||
(onepar.fixneeds+(stpar>>5) > maxfix)){
/* not the first parameter, and calls a proc */
/* or the first if we need to preserve callee_start_reg */
cca(at,par);
pnset(nds,usesproccall);
nds = maxneeds(shapeneeds(sh(*(par))),nds);
nds.maxargs = max(nds.maxargs,onepar.maxargs);
}
else{
nds = maxneeds(onepar,nds);
}
if(name(*cerl) == caller_tag){
no(*cerl) = stpar;
}
stpar = n;
cerl = &bro(*cerl);
}
nds.maxargs = max(nds.maxargs,stpar);
maxfix -= 6;
nds = maxneeds(scan(&bro(bro(son(application))),at),nds);
maxfix += 6;
pstldnds = scan(&bro(bro(bro(son(application)))),at);
if(pntst(pstldnds,anyproccall)!=0){
set_postlude_has_call(application);
}
else{
clear_postlude_has_call(application);
}
nds = maxneeds(nds,pstldnds);
if ( sparccpd (sh(application)) ) {
exp ap_context = need_result_space(application);
if (ap_context != nilexp) {
/* find space for tuple result */
assert ( name ( *( ptr_position ( application ) ) ) == apply_general_tag ) ;
cca ( at, ptr_position ( application ) ) ;
if (name(ap_context) != field_tag) {
/* if context is application parameter, treat as pointer */
setvar (bro(bro(application)));
sh(pt(bro(bro(application)))) = f_pointer(f_alignment(sh(application)));
}
pnset ( nds, usesproccall ) ;
}
else
pnset ( nds, hasproccall ) ;
}
else if ( name(bro(bro(bro(son(application))))) != top_tag && valregable(sh(application))
&& name(sh(application)) != tophd && name(sh(application)) != bothd ) {
cca ( at, ptr_position ( application ) ) ;
pnset ( nds, usesproccall ) ;
}
else {
pnset ( nds, hasproccall ) ;
}
return nds;
}
case make_callee_list_tag : {
exp cllees = *e;
exp *par = &son(cllees);
needs nds;
int stpar = 0,i;
nds = zeroneeds;
for(i=0;i<no(cllees);++i){
needs onepar;
shape shonepar = sh(*par);
int n = rounder(stpar,shape_align(shonepar));
onepar = scan(par,at);
if((pntst(onepar,hasproccall)!=0) || (onepar.fixneeds+1>maxfix)){
/* identify it */
cca(at,par);
pnset(nds,usesproccall);
nds = maxneeds(shapeneeds(sh(*par)),nds);
nds.maxargs = max(nds.maxargs,onepar.maxargs);
}
else{
nds = maxneeds(onepar,nds);
}
n += shape_size(shonepar);
stpar = rounder(n,REG_SIZE);
par = &bro(*par);
}
no(cllees) = stpar;
return nds;
}
case make_dynamic_callee_tag : {
exp cllees = *e;
exp *ptr = &son(cllees);
needs ndsp,nds;
nds = zeroneeds;
ndsp = scan(ptr,at);
if((pntst(ndsp,hasproccall)!=0) || (ndsp.fixneeds+1>maxfix)){
cca(at,ptr);
pnset(nds,usesproccall);
nds = maxneeds(shapeneeds(sh(*ptr)),nds);
nds.maxargs = max(nds.maxargs,ndsp.maxargs);
}
else{
nds = ndsp;
}
ndsp = scan(&bro(son(cllees)),at);
if((pntst(ndsp,hasproccall)!=0) || (ndsp.fixneeds+2>maxfix)){
cca(at,&bro(son(cllees)));
pnset(nds,usesproccall);
nds = maxneeds(shapeneeds(sh(bro(son(cllees)))),nds);
nds.maxargs = max(nds.maxargs,ndsp.maxargs);
}
else{
nds = maxneeds(ndsp,nds);
}
if(nds.fixneeds<10) nds.fixneeds = 10; /* ?? */
return nds;
}
case same_callees_tag: {
needs nds;
nds = zeroneeds;
nds.fixneeds = 6;
return nds;
}
case tail_call_tag: {
exp tlcl = *e;
needs ndsp,nds;
exp *fn = &son(tlcl);
ndsp = scan(fn,at);
if((pntst(ndsp,hasproccall)!=0) || (ndsp.fixneeds+1 > maxfix)){
cca(at,fn);
pnset(nds,usesproccall);
nds = maxneeds(shapeneeds(sh(*fn)),nds);
nds.maxargs = max(nds.maxargs,ndsp.maxargs);
}
else{
nds = ndsp;
}
ndsp = scan(&bro(son(tlcl)),at);
nds = maxneeds(nds,ndsp);
if(nds.fixneeds < 6) nds.fixneeds = 6;
return nds;
}
case apply_tag : {
int i ;
needs nds ;
int parsize = 0 ;
exp appl = *e ;
exp fn = son ( appl ) ;
exp *par = &bro ( fn ) ;
exp *fnexp = &son ( appl ) ;
bool tlrecpos = ( bool ) ( nonevis && callerfortr &&
( rscope_level == 0 ) ) ;
nds = scan ( fnexp, at ) ;
/* scan the function exp ... */
if ( pntst ( nds, hasproccall ) != 0 ) {
/* ... it must be identified */
cca ( at, fnexp ) ;
pnclr ( nds, hasproccall ) ;
pnset ( nds, usesproccall ) ;
fn = son ( appl ) ;
par = &bro ( fn ) ;
}
if ( name ( fn ) != name_tag ||
( son ( son ( fn ) ) != nilexp &&
((name ( son ( son ( fn ) ) ) != proc_tag ) ||
name(son(son(fn)))==general_proc_tag))) {
tlrecpos = 0 ;
}
for ( i = 1 ; !last ( fn ) ; ++i ) {
/* scan parameters in turn ... */
needs onepar ;
shape shpar = sh ( *par ) ;
onepar = scan ( par, at ) ;
if ( ( i != 1 && pntst ( onepar, hasproccall ) != 0 ) ||
onepar.fixneeds + ( parsize >> 5 ) > maxfix ) {
/* if it isn't the first parameter, and it calls
a proc, identify it */
cca ( at, par ) ;
pnset ( nds, usesproccall ) ;
nds = maxneeds ( shapeneeds ( sh ( *par ) ), nds ) ;
nds.maxargs = MAX_OF ( nds.maxargs, onepar.maxargs ) ;
}
else {
nds = maxneeds ( onepar, nds ) ;
}
parsize = ( int ) rounder ( parsize, shape_align ( shpar ) ) ;
parsize = rounder ( parsize + shape_size ( shpar ), 32 ) ;
if ( ( !valregable ( shpar ) &&
!is_floating ( name ( shpar ) ) ) ||
parsize > 128 ) {
tlrecpos = 0 ;
}
if ( last ( *par ) ) {
break ;
}
par = &bro ( *par ) ;
}
if ( specialopt ( fn ) ) {
/* eg vfork */
pnset ( nds, dont_optimise ) ;
}
if ( ( i = specialfn ( fn ) ) > 0 ) {
/* eg strlen */
#if 0
nds = maxneeds ( specialneeds ( i ), nds ) ;
#endif
return ( nds ) ;
}
else if ( i == -1 ) {
/* call of strcpy ... (removed) */
}
if ( tlrecpos ) {
exp dad = father ( appl ) ;
if ( name ( dad ) == res_tag ) {
props ( dad ) = 1 ; /* do a tl recursion */
}
}
if ( sparccpd (sh(appl)) ) {
exp ap_context = need_result_space(appl);
if (ap_context != nilexp) {
/* find space for tuple result */
assert ( name ( *( ptr_position ( appl ) ) ) == apply_tag ) ;
cca ( at, ptr_position ( appl ) ) ;
if (name(ap_context) != field_tag) {
/* if context is application parameter, treat as pointer */
setvar (bro(bro(appl)));
sh(pt(bro(bro(appl)))) = f_pointer(f_alignment(sh(appl)));
}
pnset ( nds, usesproccall ) ;
}
else
pnset ( nds, hasproccall ) ;
}
else {
pnset ( nds, hasproccall ) ;
}
nds.maxargs = MAX_OF ( nds.maxargs, parsize ) ;
/* clobber %o0..%o5,%o7 */
nds.fixneeds = MAX_OF ( nds.fixneeds, 8 ) ;
return ( nds ) ;
}
case movecont_tag : { /* Only whilst it aways generates memmove */
int i ;
needs nds ;
int parsize = 0 ;
exp mv = *e ;
exp *par = &son ( mv ) ;
bool tlrecpos = ( bool ) ( nonevis && callerfortr &&
( rscope_level == 0 ) ) ;
nds = zeroneeds;
for ( i = 1 ; i<=3 ; ++i ) {
/* scan parameters in turn ... */
needs onepar ;
shape shpar = sh ( *par ) ;
onepar = scan ( par, at ) ;
if ( ( i != 1 && pntst ( onepar, hasproccall ) != 0 ) ||
onepar.fixneeds + ( parsize >> 5 ) > maxfix ) {
/* if it isn't the first parameter, and it calls
a proc, identify it */
cca ( at, par ) ;
pnset ( nds, usesproccall ) ;
nds = maxneeds ( shapeneeds ( sh ( *par ) ), nds ) ;
nds.maxargs = MAX_OF ( nds.maxargs, onepar.maxargs ) ;
}
else {
nds = maxneeds ( onepar, nds ) ;
}
parsize = ( int ) rounder ( parsize, shape_align ( shpar ) ) ;
parsize = rounder ( parsize + shape_size ( shpar ), 32 ) ;
if ( ( !valregable ( shpar ) &&
!is_floating ( name ( shpar ) ) ) ||
parsize > 128 ) {
tlrecpos = 0 ;
}
assert ((i != 3) || last(*par));
par = &bro ( *par ) ;
}
if ( tlrecpos ) {
exp dad = father ( mv ) ;
if ( name ( dad ) == res_tag ) {
props ( dad ) = 1 ; /* do a tl recursion */
}
}
pnset ( nds, hasproccall ) ;
nds.maxargs = MAX_OF ( nds.maxargs, parsize ) ;
/* clobber %o0..%o5,%o7 */
nds.fixneeds = MAX_OF ( nds.fixneeds, 7 ) ;
return ( nds ) ;
}
case val_tag : {
exp s = sh ( *e ) ;
if ( name ( s ) == offsethd && al2 ( s ) >= 8 ) {
/* express disps in bytes */
no ( *e ) = no ( *e ) >> 3 ;
}
/* FALL THROUGH */
}
case env_size_tag :
case caller_name_tag :
case null_tag :
case real_tag :
case string_tag :
case env_offset_tag :
case current_env_tag :
case make_lv_tag :
case last_local_tag : {
return ( shapeneeds ( sh ( *e ) ) ) ;
}
case name_tag : {
needs nds;
nds = shapeneeds ( sh ( *e ) ) ;
if (PIC_code && isglob (son(*e))) {
long boff = no(*e) >> 3 ;
if (boff < -4096 || boff > 4095)
nds.fixneeds += 1 ;
}
return ( nds ) ;
}
case give_stack_limit_tag : {
specialext = 1;
return ( shapeneeds ( sh ( *e ) ) ) ;
}
case formal_callee_tag :
case clear_tag :
case top_tag :
case prof_tag :
case local_free_all_tag : {
return ( zeroneeds ) ;
}
case local_free_tag: {
needs nds;
nds = scan( &son(*e),at);
if(nds.fixneeds < 2) nds.fixneeds = 2;
}
#if 0
case rscope_tag : {
needs sn ;
exp *s = &son ( *e ) ;
#if 0
exp lst ;
#endif
rscope_level++ ;
#if 0
/* only needed when ( do_tlrecursion != 0 ) */
( void ) last_statement ( son ( *e ), &lst ) ; /* always true */
if ( name ( lst ) == res_tag ) {
/* can remove res */
exp *pos = ptr_position ( lst ) ;
exp t ;
bro ( son ( lst ) ) = bro ( lst ) ;
if ( last ( lst ) ) {
setlast ( son ( lst ) ) ;
}
else {
clearlast ( son ( lst ) ) ;
}
*pos = son ( lst ) ;
for ( t = father ( *pos ) ; name ( sh ( t ) ) == bothd ;
t = father ( t ) ) {
/* adjust ancestors to correct shape */
sh ( t ) = sh ( *pos ) ;
}
}
#endif
sn = scan ( s, &s ) ;
rscope_level-- ;
return ( sn ) ;
}
#endif
case set_stack_limit_tag : {
exp *arg = &son ( *e ) ;
specialext = 1;
return ( scan ( arg, at ) ) ;
}
#ifdef return_to_label_tag
case return_to_label_tag :
#endif
#ifndef NEWDIAGS
case diagnose_tag :
#endif
case goto_lv_tag :
case abs_tag :
case neg_tag :
case not_tag :
case offset_negate_tag : {
exp *arg = &son ( *e ) ;
if (error_treatment_is_trap ( *e ))
specialext = 1;
return ( scan ( arg, at ) ) ;
}
case case_tag :
{
needs s;
exp *arg = &son ( *e ) ;
s = scan ( arg, at ) ;
s.fixneeds = MAX_OF ( s.fixneeds, 2 ) ; /* dense case calls getreg */
return s;
}
case fneg_tag :
case fabs_tag :
case chfl_tag : {
needs nds ;
exp *pste;
if (error_treatment_is_trap ( *e ))
specialext = 1;
nds = scan ( &son ( *e ), at ) ;
pste = ptr_position(ste);
if ( !optop ( *pste ) && nds.fixneeds < 2 ) nds.fixneeds = 2 ;
#if use_long_double
{
exp op = *pste ;
if ( name ( sh ( op ) ) == doublehd ||
name ( sh ( son ( op ) ) ) == doublehd ) {
#if 0
if(name(*e) == fabs_tag){
replace_fabs(ste);
}
#endif
if ( !is_o ( name ( son ( op ) ) ) ||
pntst ( nds, hasproccall ) ) {
cca ( at, &son ( op ) ) ;
}
pnset ( nds, hasproccall ) ;
}
}
#endif
return ( nds ) ;
}
case bitf_to_int_tag : {
exp *arg = &son ( *e ) ;
needs nds ;
exp stararg ;
exp stare ;
int sizeb ;
nds = scan ( arg, at ) ;
stararg = *arg ;
stare = *e ;
sizeb = shape_size ( sh ( stararg ) ) ;
if ( ( name ( stararg ) == name_tag &&
( ( sizeb == 8 &&
( no ( stararg ) & 7 ) == 0 ) ||
( sizeb == 16 &&
( no ( stararg ) & 15 ) == 0 ) ||
( sizeb == 32 &&
( no ( stararg ) & 31 ) == 0 ) ) ) ||
( name ( stararg ) == cont_tag &&
( ( name ( son ( stararg ) ) != name_tag &&
name ( son ( stararg ) ) != reff_tag ) ||
( sizeb == 8 &&
( no ( son ( stararg ) ) & 7 ) == 0 ) ||
( sizeb == 16 &&
( no ( son ( stararg ) ) & 15 ) == 0 ) ||
( sizeb == 32 &&
( no ( son ( stararg ) ) & 31 ) == 0 ) ) ) ) {
/* these bitsint ( trimnof ( X ) ) could be implemented by
lb or lh instructions ... */
int sgned = name ( sh ( stare ) ) & 1 ;
shape ns = ( sizeb == 8 ) ? ( sgned ? scharsh : ucharsh ) :
( sizeb == 16 ) ? ( sgned ? swordsh : uwordsh ) :
sh ( stare ) ;
/* can use short loads instead of bits extractions */
if ( name ( stararg ) == cont_tag ) {
/* make the ptr shape consistent */
sh ( son ( stararg ) ) = f_pointer ( long_to_al (
( long ) shape_align ( ns ) ) ) ;
}
sh ( stararg ) = ns ;
setname ( stare, chvar_tag ) ;
}
return ( nds ) ;
}
case int_to_bitf_tag : {
exp *arg = &son ( *e ) ;
return ( scan ( arg, at ) ) ;
}
case round_tag : {
needs s ;
exp *arg ;
exp *pste;
int rm = ( int ) round_number ( *e ) ;
if (error_treatment_is_trap ( *e ))
specialext = 1;
arg = &son ( *e ) ;
s = scan ( arg, at ) ;
pste = ptr_position(ste);
s.fixneeds = MAX_OF ( s.fixneeds, 2 ) ;
if ( rm < 3 || name ( sh ( *pste ) ) == ulonghd ) {
s.floatneeds = MAX_OF ( s.floatneeds, 3 ) ;
}
else {
s.floatneeds = MAX_OF ( s.floatneeds, 2 ) ;
}
#if use_long_double
{
exp op = *pste ;
if ( name ( sh ( son ( op ) ) ) == doublehd ) {
if ( !is_o ( name ( son ( op ) ) ) ||
pntst ( s, hasproccall ) ) {
cca ( at, &son ( op ) ) ;
}
pnset ( s, hasproccall ) ;
}
}
#endif
return ( s ) ;
}
case shl_tag :
case shr_tag :
case long_jump_tag : {
int prpx ;
needs nl, nr ;
exp *lhs = &son ( *e ) ;
exp *rhs = &bro ( *lhs ) ;
nr = scan ( rhs, at ) ;
nl = scan ( lhs, at ) ;
rhs = &bro(*lhs);
prpx = ( int ) ( pntst ( nr, hasproccall ) << 1 ) ;
if ( nr.fixneeds >= maxfix || prpx != 0 ) {
/* if reg requirements overlap, identify second operand */
cca ( at, rhs ) ;
nl = shapeneeds ( sh ( *rhs ) ) ;
pnset ( nl, morefix ) ;
pnclr ( nl, ( prpx >> 1 ) ) ;
pnset ( nl, prpx ) ;
}
nr.fixneeds += 1 ;
nr.fixneeds += 1 ; /* why? */
return ( maxneeds ( nl, nr ) ) ;
}
case test_tag : {
exp stare = *e ;
exp l = son ( stare ) ;
exp r = bro ( l ) ;
if ( !last ( stare ) && name ( bro ( stare ) ) == test_tag &&
test_number ( stare ) == test_number ( bro ( stare ) ) &&
eq_exp ( l, son ( bro ( stare ) ) ) &&
eq_exp ( r, bro ( son ( bro ( stare ) ) ) ) ) {
/* same test following in seq list - remove second test */
if ( last ( bro ( stare ) ) ) setlast ( stare ) ;
bro ( stare ) = bro ( bro ( stare ) ) ;
no(son(pt(stare))) --; /* one less way there */
}
if ( last ( stare ) && name ( bro ( stare ) ) == 0 &&
name ( bro ( bro ( stare ) ) ) == test_tag &&
name ( bro ( bro ( bro ( stare ) ) ) ) == seq_tag &&
test_number ( stare ) ==
test_number ( bro ( bro ( stare ) ) ) &&
eq_exp ( l, son ( bro ( bro ( stare ) ) ) ) &&
eq_exp ( r, bro ( son ( bro ( bro ( stare ) ) ) ) ) ) {
/* same test following in seq res - void second test */
setname ( bro ( bro ( stare ) ), top_tag ) ;
son ( bro ( bro ( stare ) ) ) = nilexp ;
pt ( bro ( bro ( stare ) ) ) = nilexp ;
no(son(pt(stare))) --; /* one less way there */
}
assert ((name(l) == val_tag) ? (name(r) == val_tag) : 1);
/* jmf claims to have put one val
on right,so only allow val
test val */
if ( name(r) == val_tag &&
(props(stare) == 5 || props(stare) == 6) && /* eq/neq */
no (r) == 0 && /* against 0 */
name (l) == and_tag && name (bro (son (l))) == val_tag &&
(no (bro (son (l))) & (no (bro (son (l))) - 1)) == 0
)
{ /* zero test x & 2^n -> neg test (x shl
(31-n)) */
long n = no (bro (son (l)));
int x;
for (x = 0; n > 0; x++) {
n = n << 1;
}
if (x == 0) { /* no shift required */
bro (son (l)) = r; /* zero there */
son (stare) = son (l);/* x */
}
else {
setname (l, shl_tag);
no (bro (son (l))) = x;
}
props (stare) -= 3; /* test for neg */
sh (son (stare)) = slongsh;
}
if ( name ( l ) == bitf_to_int_tag &&
name ( r ) == val_tag &&
( props ( stare ) == 5 || props ( stare ) == 6 ) &&
( name ( son ( l ) ) == cont_tag ||
name ( son ( l ) ) == name_tag ) ) {
/* equality of bits against +ve consts doesnt need
sign adjustment */
long n = no ( r ) ;
switch ( name ( sh ( l ) ) ) {
case scharhd : {
if ( n >= 0 && n <= 127 ) {
sh ( l ) = ucharsh ;
}
break ;
}
case swordhd : {
if ( n >= 0 && n <= 0xffff ) {
sh ( l ) = uwordsh ;
}
break ;
}
}
}
else if ( is_floating ( name ( sh ( l ) ) ) ) {
return ( fpop ( e, at ) ) ;
}
else if ( name ( r ) == val_tag && no ( r ) == 1 &&
( props ( stare ) == 3 || props ( stare ) == 2 ) ) {
no ( r ) = 0 ;
if ( props ( stare ) == 3 ) {
/* branch >= 1 -> branch > 0 */
props ( stare ) = 4 ;
}
else {
/* branch < 1 -> branch <= 0 */
props ( stare ) = 1 ;
}
}
return ( likediv ( e, at ) ) ;
}
case plus_tag : {
/* replace any operands which are neg ( .. ) by -, if poss */
exp sum = *e ;
exp list = son ( sum ) ;
bool someneg = 0 ;
bool allneg = 1 ;
if (error_treatment_is_trap ( *e ))
specialext = 1;
for ( ; optop ( sum ) ; ) {
if ( name ( list ) == neg_tag ) {
someneg = 1 ;
}
else {
allneg = 0 ;
}
if ( last ( list ) ) break ;
list = bro ( list ) ;
}
if ( someneg ) {
/* there are some neg () operands */
if ( allneg ) {
/* transform - .. - ... to - ( .. + .. + ... ) */
exp x ;
/* Build a new list form operand of neg_tags, which
will become plus_tag operands */
x = son ( sum ) ;
list = son ( x ) ;
for ( ; ; ) {
/* 'x' moves along neg_tag's lists 'list' moves
along sons of neg_tag's lists, building a new list
eventually new list is made son of plus_tag */
if ( !last ( x ) ) {
bro ( list ) = son ( bro ( x ) ) ;
clearlast ( list ) ;
list = bro ( list ) ;
x = bro ( x ) ;
}
else {
/* set father to be */
bro ( list ) = sum ;
setlast ( list ) ;
/* set new sons of plus_tag */
son ( sum ) = son ( son ( sum ) ) ;
break ;
}
}
/* create new neg_tag to replace plus_tag, old
plus_tag being the operand of the new neg_tag */
x = getexp ( sh ( sum ), bro ( sum ), ( int ) last ( sum ),
sum, nilexp, 0, 0, neg_tag ) ;
setlast ( sum ) ;
/* set father of sum, new neg_tag exp */
bro ( sum ) = x ;
*e = x ;
}
else {
/* transform to ( ( .. ( .. + .. ) - .. ) - .. ) */
int n = 0 ;
exp brosum = bro ( sum ) ;
bool lastsum = ( bool ) last ( sum ) ;
exp x = son ( sum ) ;
exp newsum = sum ;
list = nilexp ;
for ( ; ; ) {
exp nxt = bro ( x ) ;
bool final = ( bool ) last ( x ) ;
if ( name ( x ) == neg_tag ) {
bro ( son ( x ) ) = list ;
list = son ( x ) ;
}
else {
bro ( x ) = newsum ;
newsum = x ;
if ( ( n++ ) == 0 ) {
setlast ( newsum ) ;
}
else {
clearlast ( newsum ) ;
}
}
if ( final ) break ;
x = nxt ;
}
if ( n > 1 ) {
son ( sum ) = newsum ;
/* use existing exp for add operations */
newsum = sum ;
}
for ( ; ; ) {
/* introduce - operations */
exp nxt = bro ( list ) ;
bro ( newsum ) = list ;
clearlast ( newsum ) ;
x = getexp ( sh ( sum ), nilexp, 0, newsum, nilexp,
0, 0, minus_tag ) ;
bro ( list ) = x ;
setlast ( list ) ;
newsum = x ;
if ( ( list = nxt ) == nilexp ) break ;
}
bro ( newsum ) = brosum ;
if ( lastsum ) {
setlast ( newsum ) ;
}
else {
clearlast ( newsum ) ;
}
*e = newsum ;
}
return ( scan ( e, at ) ) ;
}
/* FALL THROUGH */
}
case and_tag :
case or_tag :
case xor_tag : {
return ( likeplus ( e, at ) ) ;
}
#ifdef make_stack_limit_tag
case make_stack_limit_tag :
#endif
case minus_tag :
case subptr_tag :
case minptr_tag : {
if (error_treatment_is_trap ( *e ))
specialext = 1;
return ( likediv ( e, at ) ) ;
}
case addptr_tag :
{
exp ptr_arg = son(*e);
exp offset_arg = bro(ptr_arg);
int fralign = frame_al_of_ptr(sh(ptr_arg));
if(fralign){
int offalign = frame_al1_of_offset(sh(offset_arg));
#if 0
if(((offalign-1)&offalign)!=0){
fail("Mixed frame offsets not supported");
}
#endif
if(cees(offalign) && name(son(*e)) == current_env_tag) {
setcallee_offset(son(*e));
}
#if 0
if(include_vcallees(fralign) && l_or_cees(offalign)){
exp newexp = getexp(sh(ptr_arg),offset_arg,0,ptr_arg,nilexp,0,0,
locptr_tag);
bro(ptr_arg) = newexp;
setlast(ptr_arg);
son(*e) = newexp;
}
#endif
}
return likediv(e,at);
}
case locptr_tag :
case reff_tag :
case float_tag :
case offset_pad_tag :
case chvar_tag : {
exp *arg = &son ( *e ) ;
exp *pste;
needs nds ;
if (error_treatment_is_trap ( *e ))
specialext = 1;
nds = shapeneeds ( sh ( *e ) );
nds = maxneeds ( scan ( arg, at ), nds ) ;
pste = ptr_position(ste);
#if use_long_double
{
exp op = *pste ;
if ( name ( sh ( op ) ) == doublehd ) {
pnset ( nds, hasproccall ) ;
}
}
#endif
return ( nds ) ;
}
case cont_tag :
case contvol_tag : {
exp *arg = &son ( *e ) ;
needs nds ;
nds = maxneeds ( scan ( arg, at ), shapeneeds ( sh ( *e ) ) ) ;
nds.fixneeds = MAX_OF ( nds.fixneeds, 2 ) ;
return ( nds ) ;
}
case mult_tag :
mult_tag_case : {
if (error_treatment_is_trap ( *e ))
specialext = 1;
return ( multneeds ( e, at ) ) ;
}
case offset_mult_tag :
case offset_div_tag : {
exp op1 = son(*e);
exp op2 = bro ( op1) ;
shape s = sh ( op2 ) ;
if ( name ( op2 ) == val_tag && no ( op2 ) == 8 &&
name ( s ) == offsethd && al2 ( s ) >= 8 ) {
/* offset is one byte */
bro ( op1 ) = bro ( *e ) ;
if ( last ( *e ) ) {
setlast ( op1 ) ;
}
else {
clearlast ( op1 ) ;
}
sh(op1) = sh(*e);
*e = op1 ;
if (name(*e) == val_tag)
return ( shapeneeds ( sh ( *e ) ) ) ; /* disps already in bytes */
else
return ( scan ( e, at ) ) ;
}
if ( nstare == offset_mult_tag ) goto mult_tag_case ;
/* FALL THROUGH */
}
case div0_tag:
case div1_tag :
case div2_tag :
case offset_div_by_int_tag : {
if (error_treatment_is_trap ( *e ))
specialext = 1;
return ( divneeds ( e, at ) ) ;
}
case offset_add_tag :
case offset_subtract_tag : {
if((al2(sh(son(*e))) == 1) && (al2(sh(bro(son(*e)))) != 1)){
make_bitfield_offset(bro(son(*e)),son(*e),0,sh(*e));
}
if((al2(sh(son(*e))) != 1) && (al2(sh(bro(son(*e)))) == 1)){
make_bitfield_offset(son(*e),*e,1,sh(*e));
}
}
/* FALL_THROUGH */
case component_tag : {
return ( likediv ( e, at ) ) ;
}
case offset_max_tag: case max_tag: case min_tag:
{ needs nd;
nd = likediv(e, at);
nd.fixneeds = MAX_OF(nd.fixneeds, 3);
return nd;
}
case rem0_tag:
case mod_tag :
case rem2_tag : {
if (error_treatment_is_trap ( *e ))
specialext = 1;
return ( remneeds ( e, at ) ) ;
}
case fdiv_tag :
#if ( FBASE == 10 )
{
exp z = *e ;
exp a2 = bro ( son ( z ) ) ;
if ( name ( a2 ) == real_tag ) {
/* replace X / const by X * ( 1.0 / const ) */
flt inverse ;
flt unitflt ;
unitflt = flptnos [ fone_no ] ;
if ( flt_div ( unitflt, flptnos [ no ( a2 ) ],
&inverse ) == OKAY ) {
int f = new_flpt () ;
flptnos [f] = inverse ;
no ( a2 ) = f ;
setname ( z, fmult_tag ) ;
}
}
}
/* FALL THROUGH */
#endif
case fplus_tag :
case fminus_tag :
case fmult_tag : {
exp op = *e ;
exp a2 = bro ( son ( op ) ) ;
if (error_treatment_is_trap ( *e ))
specialext = 1;
if ( !last ( a2 ) ) {
/* + and * can have > 2 parameters - make them diadic
- can do better a + exp => let x = exp in a + x */
exp opn = getexp ( sh ( op ), op, 0, a2, nilexp,
0, 0, name ( op ) ) ;
/* don't need to transfer error treatment - nans */
exp nd = getexp ( sh ( op ), bro ( op ), ( int ) last ( op ),
opn, nilexp, 0, 1, ident_tag ) ;
exp id = getexp ( sh ( op ), op, 1, nd, nilexp,
0, 0, name_tag ) ;
pt ( nd ) = id ;
bro ( son ( op ) ) = id ;
setlast ( op ) ;
bro ( op ) = nd ;
while ( !last ( a2 ) ) a2 = bro ( a2 ) ;
bro ( a2 ) = opn ;
*e = nd ;
return ( scan ( e, at ) ) ;
}
return ( fpop ( e, at ) ) ;
}
case fmax_tag : {
return fpop(e,at);
}
case field_tag : {
needs str ;
exp *arg = &son ( *e ) ;
if ( chase ( *e, arg ) ) {
/* field has been distributed */
exp stare = *e ;
exp ss = son ( stare ) ;
if ( !last ( stare ) ) clearlast ( ss ) ;
bro ( ss ) = bro ( stare ) ;
sh ( ss ) = sh ( stare ) ;
*e = ss ;
return ( scan ( e, at ) ) ;
}
str = scan ( arg, at ) ;
return ( maxneeds ( str, shapeneeds ( sh ( *e ) ) ) ) ;
}
case general_proc_tag :
case proc_tag : {
exp *bexp ;
exp *bat ;
needs body ;
exp stare = *e ;
/* set number temp t-regs that can be used in proc */
maxfix = maxfix_tregs ;
maxfloat = MAXFLOAT_TREGS ;
/* on SPARC tail recursion is harder than MIPS and less of a win
but still worth implementing sometime */
assert ( do_tlrecursion==0 ) ;
callerfortr = do_tlrecursion && !proc_has_setjmp ( stare ) &&
!proc_has_alloca ( stare ) &&
!proc_has_lv ( stare ) &&
!proc_uses_crt_env ( stare ) ;
stparam = 0 ;
fixparam = R_I0 ;
nonevis = 1 ;
specialext = proc_has_checkstack(*e);
rscope_level = 0 ;
gen_call = (name(stare) == general_proc_tag);
v_proc = proc_has_vcallees(*e);
callee_size = 0;
#ifdef GENCOMPAT
trad_proc = !proc_may_have_callees(stare);
#endif
/* scan the body of the proc */
bexp = &son ( *e ) ;
bat = bexp ;
body = scan ( bexp, &bat ) ;
if (specialext)
set_proc_uses_external ( *e ) ;
#ifdef GENCOMPAT
if (!trad_proc) {
#else
if(gen_call){
#endif
callee_size += 4 * PTR_SZ;
}
/* should never require this in reg in C */
return ( body ) ;
}
case alloca_tag : {
needs nds ;
if (checkalloc ( *e ))
specialext = 1;
nds = scan ( &son ( *e ), at ) ;
if ( nds.fixneeds < 2 ) nds.fixneeds = 2 ;
return ( nds ) ;
}
case trap_tag :{
specialext = 1;
return zeroneeds;
}
case special_tag :{
return zeroneeds;
}
case asm_tag:
{
needs nds;
nds = zeroneeds;
if (props(*e) != 0)
fail ("~asm not in ~asm_sequence");
check_asm_seq (son(*e), 0);
/* clobber %o0..%o5,%o7 */
nds.fixneeds = MAX_OF ( nds.fixneeds, 8 ) ;
pnset ( nds, hasproccall ) ;
return ( nds ) ;
};
default : {
fail ( "Case not covered in needs scan" ) ;
return ( zeroneeds ) ;
}
}
/* NOT REACHED */
}