Go to most recent revision | 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.
*/
/* $Id: scan.c,v 1.1.1.1 1998/01/17 15:56:01 release Exp $ */
#ifndef lint
static char vcid[] = "$Id: scan.c,v 1.1.1.1 1998/01/17 15:56:01 release Exp $";
#endif /* lint */
/*
$Log: scan.c,v $
* Revision 1.1.1.1 1998/01/17 15:56:01 release
* First version to be checked into rolling release.
*
* Revision 1.31 1997/09/05 12:23:20 john
* bugfix
*
* Revision 1.29 1996/03/15 10:29:12 john
* Fixed bug in apply_general_tag
*
* Revision 1.28 1996/02/29 17:36:36 john
* Fix to shift op
*
* Revision 1.27 1996/02/19 09:25:23 john
* Fixed postlude with call
*
* Revision 1.26 1996/02/15 09:57:48 john
* Fixed bug in allocation of space for integer to floating point
* conversion.
*
* Revision 1.25 1996/01/23 16:58:30 john
* Fix to general procs
*
* Revision 1.24 1995/12/04 09:13:42 john
* Removed code
*
* Revision 1.23 1995/11/14 15:37:21 john
* Fixes to general procs
*
* Revision 1.22 1995/11/13 12:43:50 john
* Added prof_tag case
*
* Revision 1.21 1995/09/29 15:53:17 john
* Some changes for vcallers
*
* Revision 1.20 1995/09/20 10:46:58 john
* Added trap_tag
*
* Revision 1.19 1995/09/13 16:33:49 john
* Added special_tag
*
* Revision 1.18 1995/09/04 16:24:18 john
* Fix to general procs
*
* Revision 1.17 1995/08/31 15:47:39 john
* Added fmax_tag
*
* Revision 1.16 1995/08/30 16:15:12 john
* Fix to diagnostics
*
* Revision 1.15 1995/08/23 16:06:26 john
* Fix to compound_tag
*
* Revision 1.14 1995/08/04 15:50:44 john
* Minor change
*
* Revision 1.13 1995/07/27 10:09:55 john
* Changes to needs
*
* Revision 1.12 1995/07/04 09:08:09 john
* Temporary change to ident_tag
*
* Revision 1.11 1995/06/30 08:00:12 john
* Removed next_frame_tag made change to ident_tag
*
* Revision 1.10 1995/06/28 10:26:42 john
* Fixed needs for cont_tag
*
* Revision 1.9 1995/06/21 14:25:39 john
* Reformatting
*
* Revision 1.8 1995/06/15 09:43:57 john
* Fixed code for stack error handling
*
* Revision 1.7 1995/06/13 14:01:45 john
* A few cosmetic changes
*
* Revision 1.6 1995/05/23 13:26:09 john
* Reformatting
*
* Revision 1.5 1995/05/16 10:55:24 john
* Changes for spec 3.1
*
* Revision 1.4 1995/04/10 14:14:05 john
* Fix to likeplus
*
* Revision 1.3 1995/04/07 11:05:49 john
* Fix to scan_cond, and removed subvar_use
*
* Revision 1.2 1995/03/29 14:05:28 john
* Changes to keep tcheck happy
*
* Revision 1.1.1.1 1995/03/23 10:39:17 john
* Entered into CVS
*
* Revision 1.22 1995/03/23 10:13:55 john
* Several changes for AVS test suite
*
* Revision 1.21 1995/02/13 09:50:32 john
* Changed handling of cond_tag
*
* Revision 1.20 1995/01/26 13:49:17 john
* Removed unused code
*
* Revision 1.19 1995/01/10 09:44:53 john
* Modified register requirements.
*
*/
/*
scan.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 "common_types.h"
#include "exptypes.h"
#include "exp.h"
#include "expmacs.h"
#include "tags.h"
#include "procrectypes.h"
#include "bitsmacs.h"
#include "maxminmacs.h"
#include "regable.h"
#include "tempdecs.h"
#include "shapemacs.h"
#include "special.h"
#include "const.h"
#include "new_tags.h"
#include "flpt.h"
#include "install_fns.h"
#include "externs.h"
#include "extratags.h"
#include "frames.h"
#include "regexps.h"
#include "reg_defs.h"
#include "bool.h"
#include "oddtest.h"
#include "check.h"
#include "coder.h"
#include "szs_als.h"
#include "scan.h"
int maxfix, maxfloat; /* the maximum number of t-regs */
static int stparam, fixparam, floatparam;
/* used by scan to set initial parameter positions */
static int numparams=0;
extern alignment long_to_al PROTO_S ((int));
extern long notbranch[6];
extern bool do_tlrecursion;
static bool rscope_level = 0;
static bool nonevis = 1;
static int callerfortr;
needs scan PROTO_S ((exp *,exp **));
/*
identifies integer varieties which require more work to manipulate
(because of a lack of appropriate instructions)
*/
#define is_awkward_variety(vname) ((vname == scharhd || vname == ucharhd \
|| vname == swordhd || vname == uwordhd))
/*
declaration of scan.
needs is defined in procrectypes.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 procrectypes.h).
*/
#if DO_NEW_DIVISION
#define is_machine_divide(e) (name(bro(son(e))) != val_tag)
#else
#define is_machine_divide(e) 1
#endif
/*
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 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 threefix = {
3,0,0,0
};
needs fourfix = {
4,0,0,0
};
needs fivefix = {
5,0,0,0
};
needs onefloat = {
0, 1, 0, 0
}; /* needs 1 flt pt regs */
needs zeroneeds = {
0, 0, 0, 0
}; /* has no needs */
/*
Calculate the number of registers required to move a data item of
shape s to/from memory. Worst case values.
*/
needs shapeneeds
PROTO_N ( ( s ) )
PROTO_T ( shape s )
{
if(is_floating(name(s))){
return onefloat;
}
else{
ash as;
as = ashof(s);
if((as.ashalign==8) /*&& (name(s)==ptrhd)*/){
return fourfix;
}
if((as.ashalign==16)) {
return fivefix; /* If not aligned on 4 byte boundary */
}
if(valregable(s)){
return onefix;
}
else{
return twofix;
}
}
}
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;
}
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 || name(e)==null_tag ) {
return 0;
}
else {
return 1;
}
}
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)-1]);
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 dad = * (e);
exp prev;
bool commuted = 0;
#if 0
if(optop(*e)){
Assert(name(*br) != val_tag);
}
#endif
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 (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 (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;
commuted = 1;
a1.fixneeds = max (a2.fixneeds, a1.fixneeds + 1);
a1.propsneeds |= a2.propsneeds;
a1.maxargs = max (a1.maxargs, a2.maxargs);
}
else { /* ... its evaluation would disturb
accumulated result, so replace it by a
newly declared tag */
cca (at, br);
a1.fixneeds = max (a1.fixneeds, 2);
a1.propsneeds = a1.propsneeds | morefix | (pc << 1);
a1.maxargs = max (a1.maxargs, a2.maxargs);
}
}
} while (!last (* (br)));
return a1;
}
needs likediv
PROTO_N ( ( e, at ) )
PROTO_T ( exp *e X exp **at )
{
/* scan non-commutative fix pt operation
*/
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 (l.floatneeds, r.floatneeds);
pc = r.propsneeds & hasproccall;
if (r.fixneeds < maxfix && pc == 0) {/* ...it fits into registers */
l.fixneeds = max (l.fixneeds, r.fixneeds + 1);
l.propsneeds = l.propsneeds | r.propsneeds;
}
else { /* ...it requires new declaration of
second operand */
cca (at, arg);
l.fixneeds = max (l.fixneeds, 1);
l.propsneeds = l.propsneeds | morefix | (pc << 1);
l.maxargs = max (l.maxargs, r.maxargs);
}
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);
bool withert = !(optop(*e));
l = scan (arg, at);
arg = &bro(*arg);
r = scan (arg, at);
l.fixneeds = max (l.fixneeds, r.fixneeds);
pcr = r.propsneeds & hasproccall;
pcl = l.propsneeds & hasproccall;
if (r.floatneeds <= l.floatneeds && r.floatneeds < maxfloat && pcr==0) {
l.floatneeds = max (2, max (l.floatneeds, r.floatneeds + 1));
l.propsneeds = l.propsneeds | r.propsneeds;
ClearRev(op);
}
else if (pcl == 0 && l.floatneeds<=r.floatneeds && l.floatneeds<maxfloat ) {
l.floatneeds = max (2, max (r.floatneeds, l.floatneeds + 1));
l.propsneeds = l.propsneeds | r.propsneeds;
SetRev(op);
}
else if (r.floatneeds < maxfloat && pcr == 0) {
l.floatneeds = max (2, max (l.floatneeds, r.floatneeds + 1));
l.propsneeds = l.propsneeds | r.propsneeds;
ClearRev(op);
}
else {
cca (at, arg);
ClearRev(op);
l.floatneeds = max (l.floatneeds, 2);
l.propsneeds = l.propsneeds | morefloat | (pcr << 1);
l.maxargs = max (l.maxargs, r.maxargs);
}
if (withert && l.fixneeds < 2) l.fixneeds = 2;
return l;
}
/*
maxneeds
Calculates a needs value. Each element of which is the
maximum of the corresponding elements in the two parameter needs
*/
needs maxneeds
PROTO_N ( ( a, b ) )
PROTO_T ( needs a X needs b )
{
needs an;
an.fixneeds = max (a.fixneeds, b.fixneeds);
an.floatneeds = max (a.floatneeds, b.floatneeds);
an.maxargs = max (a.maxargs, b.maxargs);
an.numparams=max(a.numparams,b.numparams);
an.propsneeds = a.propsneeds | b.propsneeds;
return an;
}
/*
calculates the needs of a tuple of expressions; any new
declarations required by a component expression will
replace the component expression
*/
needs maxtup
PROTO_N ( ( e, at ) )
PROTO_T ( exp e X exp **at )
{
exp * stat = &son(e);
needs an;
an = zeroneeds;
if(son(e) == nilexp) return zeroneeds;
while (an = maxneeds (an, scan (stat, at)), !last(*stat) ) {
stat = &bro(*stat);
}
return an;
}
/*
finds if usedname is only used in cont operation or as result
of ident i.e. value of name is unchanged over its scope
*/
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;
}
/* check if e is (let a = 0 in cond(inttest(L)=result; a=1 | L:top);
a ni ) This will be compiled later using set instructions instead
of branches
*/
exp absbool
PROTO_N ( ( id ) )
PROTO_T ( exp id )
{
if (isvar (id) && name (son (id)) == val_tag && no (son (id)) == 0
&& no (id) == 2 /* name initially 0 only used twice */ ) {
exp bdy = bro (son (id));
if (name (bdy) == seq_tag && name (bro (son (bdy))) == cont_tag &&
name (son (bro (son (bdy)))) == name_tag &&
son (son (bro (son (bdy)))) == id
/* one use is result of sequence body */ ) {
exp c = son (son (bdy));
if (last (c) && name (c) == cond_tag /* seq is cond=c; id */ ) {
exp first = son (c);
exp second = bro (son (c));
if (no (son (second)) == 1 /* only one jump to else */ &&
name (bro (son (second))) == top_tag
&& name (first) == seq_tag /* cond is (seq= first | L: top) */ ) {
exp s = son (son (first));
exp r = bro (son (first));
if (name (r) == ass_tag && name (son (r)) == name_tag &&
son (son (r)) == id && name (bro (son (r))) == val_tag &&
no (bro (son (r))) == 1 /* last of seq is id = 1 */ &&
last (s) && name (s) == test_tag && pt (s) == second
&& !is_floating (name (sh (son (s))))
/* *t of seq is int test jumping to
second */
) {
return s;
}
}
}
}
}
return 0;
}
exp * ptr_position
PROTO_N ( ( e ) )
PROTO_T ( exp e )
{
exp * a;
exp dad = father(e);
if (son(dad)==e) {
a = &son(dad);
}
else {
exp sib = son(dad);
while (bro(sib)!=e) { sib = bro(sib); }
a = &bro(sib);
}
return a;
}
bool chase
PROTO_N ( ( sel, e ) )
PROTO_T ( exp sel X exp *e )
{
/* distribute selection throughout compound expressions */
bool b = 0;
exp * one;
switch(name(*e)) {
case ident_tag :
case seq_tag :
case rep_tag :
case labst_tag : {
b = chase(sel, &bro(son(*e)));
break;
}
case solve_tag :
case cond_tag : {
one = &son(*e);
for(;;) {
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);
} /* ... continue to default */
}
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), 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;
}
/* check for C style varargs */
bool vascan
PROTO_N ( ( e ) )
PROTO_T ( exp *e )
{
bool result = FALSE;
exp tr;
int s2;
for(tr=son(*e); (name(tr)==ident_tag)&&(isparam(tr))&&(!result);
tr = bro(son(tr))){
s2 = shape_size(sh(son(tr)));
result = (name(sh(son(tr)))==cpdhd)&&last_param(tr)&&(s2==0);
}
return result;
}
bool gen_call;
bool in_vcallers_proc;
/*
scan
This procedure works out register requirements of an exp. At each
call the fix field of the needs is the number of fixpnt 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 regs and maxfloat). In these cases the prop field will
contain the bits morefix (or morefloat).
As well as working out the register requirements scan performs
some transformations on the procedure. It also determines whether
or not the procedure uses varargs, if it contains a division by a
non-constant, and if it may need to move values between float and
fixed point registers.
If the procedure does contain a division by a non constant then
those registers which are corrupted by the division instruction
are not made available to the register allocator for the duration
of that procedure (see settempregs()). A better, though more
complicated, solution would be to disallow the use of these
registers in evaluating the LHS of operations in which the RHS
contains a division.
*/
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 . NB order of recursive
calls with same at is critical */
static int has_old_varargs;
static int has_div;
static int has_float;
exp ste = * (e);
int nstare = name (ste);
switch (nstare) {
case 0 : {
return zeroneeds;
}
case compound_tag :
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 = (name(a) != name_tag || !isvar(son(a)) );
}
else cantdo = 1;
}
else if (last(bro(ste)) ) { cantdo = (name(bro(bro(ste))) != ident_tag) ;}
else cantdo = 1;
if (cantdo) {
/*can only deal with tuples in simple assignment or identity*/
int prps = (nl.propsneeds & hasproccall) << 1;
cca(at, ptr_position(ste));
nl = shapeneeds(sh(*(e)));
nl.propsneeds |= morefix;
nl.propsneeds |= prps;
}
if (nl.fixneeds <2) nl.fixneeds = 2;
return nl;
}
case cond_tag : {
exp t, f, v;
if (oddtest(ste, & t, &f, &v) ) {
/* transform to f((absbool(t) <<1)-1) */
exp bc = bro(ste);
bool lc = last(ste);
exp ab = getexp(sh(v),nilexp,0,t, nilexp, 0, 0, absbool_tag);
exp shl = getexp(sh(v), nilexp, 0, ab, nilexp, 0, 0, shl_tag);
exp v1 = getexp(sh(v), shl, 1, nilexp,nilexp, 0, 1, val_tag);
exp p = getexp(sh(v), nilexp, 1, shl, nilexp, 0, 0, plus_tag);
exp vm1 = getexp(sh(v), p, 1, nilexp,nilexp, 0, -1, val_tag);
bro(ab) = v1;
bro(shl) = vm1;
bro(t) = ab; setlast(t);
if (no(v)==-1){settest_number(t, notbranch[test_number(t)-1]);}
if (f==v) {
*e = p;
}
else {
son(bro(v)) = p;
bro(p) = bro(v);
*e = f;
}
bro(*e) = bc; if (lc) { setlast(*e); } else {clearlast(*e); }
return scan(e, at);
}
/*
if (is_maxlike(ste, &t) ) {
son(ste) = t;
bro(t) = ste; setlast(t);
setname(ste, maxlike_tag);
return scan(&son(ste), at);
}
if (is_minlike(ste, &t) ) {
son(ste) = t;
bro(t) = ste; setlast(t);
setname(ste, minlike_tag);
return scan(&son(ste), at);
}
*/
if (is_abslike(ste, &t) ) {
son(ste) = t;
bro(t) = ste; setlast(t);
setname(ste, abslike_tag);
return scan(&son(ste), at);
}
if (is_fabs(ste, &t) ) {
son(ste) = son(t);
bro(son(t)) = ste; setlast(son(t));
setname(ste, fabs_tag);
return scan(&son(ste), at);
}
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 : {
exp * stat;
exp * statat;
needs an;
stat = &son(*e);
statat = stat;
an = zeroneeds;
while (an = maxneeds (an, scan (stat, &statat)),
!last (* (stat))) {
stat = &bro(*stat);
statat = stat;
}
if ((an.propsneeds & usesproccall) != 0) {
an.propsneeds |= hasproccall;
}
return an;
}
/*
ident
shape of exp is body,
son is def, brother of son is body,
ptr of ident exp is chain of uses
*/
case ident_tag : {
needs bdy;
needs def;
exp stare = * (e);
exp * arg = &bro(son(stare)); /* ptr to body */
exp t = pt (stare);
exp s;
bool fxregble;
bool flregble;
bool old_nonevis = nonevis;
exp ab;
/* bdy.numparams=0;*/
#if 1
if (!iscaonly(stare)) setvis(stare);
if(name(son(stare)) == formal_callee_tag) {
setvis(stare);
}
#endif
if (isparam(stare) && name(son(stare)) != formal_callee_tag) {
exp def = son(stare);
shape shdef = sh(def);
long n = rounder(stparam, shape_align(shdef));
long sizep = shape_size(shdef);
numparams = min( numparams+rounder(sizep,REG_SIZE),6*REG_SIZE );
/*numparams=min(numparams+max(REG_SIZE,sizep),6*REG_SIZE);*/
/*Assert(name(def)==clear_tag); */
if (is_floating(name(shdef)) ) {
if (sizep<=64 && stparam <= 320 ) {
props(def) = floatparam;
maxfloat--;
}
}
else if (sizep<=64 && stparam<=320 ) { /*change for 64 bit regs*/
props(def) = fixparam;
maxfix--;
}
else if(stparam<=320){
props(def) = fixparam;
}
else props(def)=0;
stparam = rounder(n+sizep, 64 ); /* calculate the offset */
fixparam = 16+(stparam>>6); /* >> 6, was >>5 */
floatparam=16+(stparam>>6);
if(((isvis(stare) && props(son(stare))!=0 && (name(sh(son(stare)))==cpdhd)) || in_vcallers_proc) && last_param(stare)){
numparams=12*REG_SIZE; /* must allow space for all
parameter registers for
varargs function */
}
no(def)=n;
/* if varargs then save all param regs to stack */
if (!is_floating(name(shdef)) && !valregable(shdef))
setvis(stare);
/* now props(def) = pos parreg and no(def) = par stack address
*/
}
else if(isparam(stare) && name(son(stare)) == formal_callee_tag){
exp def = son(stare);
shape shdef = sh(def);
long sizep = shape_size(shdef);
long alp = shape_align(shdef);
long n = rounder(callee_size, alp);
no(def) = n;
callee_size = rounder(n+sizep, REG_SIZE);
}
if(gen_call) {
numparams = max(6*REG_SIZE,numparams);
}
nonevis &= !isvis(stare);
bdy = scan (arg, &arg);
/* scan the body-scope */
arg = &son(stare);
def = scan (arg, &arg);
bdy.numparams = numparams;
/* scan the initialisation of tag */
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 && !isvis(stare) &&
!isoutpar(stare) && (bdy.propsneeds & anyproccall)==0 ) {
/* leave pars in par regs or put in t-regs
!! WHAT ABOUT TEMP DECS !!
*/
int x = props(son(stare));
if (x != 0) {
no(stare)= x;
if (flregble) {
props(stare)|= infreg_bits;
}
else { props(stare) |= inreg_bits; }
}
else if (fxregble && bdy.fixneeds < maxfix &&
(bdy.propsneeds & morefix) == 0 ){
no(stare) = NO_REG;
props(stare) |= inreg_bits;
bdy.fixneeds+=1;
}
else if (flregble &&
bdy.floatneeds < maxfloat &&
(bdy.propsneeds & morefloat) == 0 ) {
no(stare) = NO_REG;
props(stare) |= infreg_bits;
bdy.floatneeds +=1;
}
else no(stare) = 100;
}
else no(stare) = 100;
}
else {
if ((ab = absbool (stare)) != nilexp) {
/* form is (let a = 0 in cond(test(L)=ab;
a=1 | L:top) ni replace declaration by
ABS */
bro (ab) = stare;
setlast (ab); /* father => *e */
son (stare) = ab;
pt (stare) = nilexp;
pt (ab) = nilexp;
setname (stare, absbool_tag);
return maxneeds (bdy, def);
}
if (!isvis (*e) && !isparam(*e) &&
(bdy.propsneeds & (anyproccall | uses2_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 */
)
) { /* put tag in result reg if definition is
call of proc, or body ends with return
tag, provided result is not used other
wise */
props (stare) |= (fxregble) ? inreg_bits : infreg_bits;
bdy.propsneeds |= uses2_bit;
no (stare) = 101; /* identification uses result reg in body
*/
}
else if (!isvar (*e) && !isparam(*e) &&
((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)
/* reff 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)
/* cont variable - not assigned to in
scope */
)
)
) {
props (stare) |= defer_bit;
/* dont take space for this dec */
}
else if (!isvar (stare) && !isvis(stare) &&
((props (stare) & 0x10 /* forced in const */ ) == 0)
&& (name (t) == name_tag || name (t) == val_tag )) {
props (stare) |= defer_bit;
/* dont take space for this dec */
}
else if (fxregble && (/*isinlined(stare)||*/
(bdy.fixneeds < maxfix &&
(bdy.propsneeds & morefix) == 0 &&
((bdy.propsneeds & anyproccall) == 0 ||
tempdec (stare,((bdy.propsneeds&morefix)==0 &&
bdy.fixneeds < maxfix-2 )))))) {
/* put this tag in some fixpt t-reg -
which will be decided in make_code */
props (stare) |= inreg_bits;
no (stare) = NO_REG; /* aha! */
bdy.fixneeds += 1;
}
else if (bdy.floatneeds < maxfloat &&
(bdy.propsneeds & morefloat) == 0 && flregble &&
((bdy.propsneeds & anyproccall) == 0
|| tempdec (stare, ((bdy.propsneeds & morefloat) == 0 &&
bdy.floatneeds < maxfloat-2/*6*/)))) {
/* put this tag in some float t-reg -
which will be decided in make_code */
props (stare) |= infreg_bits;
no (stare) = NO_REG;
bdy.floatneeds += 1;
}
else {
#if 1
if (fxregble && ((bdy.propsneeds & anyproccall) == 0) &&
(bdy.fixneeds < maxfix)){
SetPossParReg(stare); /* +1 to fixneeds ? */
bdy.fixneeds += 1;
}
#endif
no (stare) = 100;
/* allocate either on stack or saved reg */
}
}
bdy = maxneeds (bdy, def);
if ((bdy.propsneeds & usesproccall) != 0) {
bdy.propsneeds |= hasproccall;
}
return bdy;
}
/*
sequence
shape of exp is shape of end of sequence, son is sequence
holder, son of this is list of voided statements.
*/
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 ((an.propsneeds & usesproccall) != 0) {
an.propsneeds |= hasproccall;
}
return an;
}
stat = &bro(*stat);
arg = stat;
}
}
/*
goto
shape is bottom
son is exp for value jumped with
ptr is labelled exp
*/
case goto_tag : {
return zeroneeds;
}
case ass_tag :
case assvol_tag : {
exp * lhs = &son(*e);
exp * rhs = &bro(*lhs);
needs nr;
ash a;
nr = scan (rhs, at);
/* scan source */
a = ashof (sh (* (rhs)));
if (nstare != ass_tag || a.ashsize != a.ashalign || a.ashalign == 1) {
/* complicated move */
nr.propsneeds |= uses2_bit;
}
if (name (* (lhs)) == name_tag &&
(isvar (son (* (lhs))) ||
((nr.propsneeds & (hasproccall | morefix)) == 0
&& nr.fixneeds < maxfix
)
)
) { /* simple destination */
return nr;
}
else {
needs nl;
prop prps = (nr.propsneeds & hasproccall) << 1;
nl = scan (lhs, at);
/* scan destination */
nr.fixneeds += 1;
if (name (* (rhs)) == apply_tag && name(*(rhs))==apply_general_tag &&
nstare == ass_tag && (nl.propsneeds &
(uses2_bit | anyproccall)) == 0) {
/* source is proc call, so assign result
reg directly */
;
}
else if (nr.fixneeds >= maxfix || prps != 0) {
/* source and destination regs overlap, so identify source */
cca (at, rhs);
nl = shapeneeds (sh (* (rhs)));
nl.propsneeds |= morefix;
nl.propsneeds &= ~(prps >> 1);
nl.propsneeds |= prps;
}
return maxneeds (nl, nr);
}
}
case untidy_return_tag :
case res_tag : {
ash a;
needs x;
shape s;
exp * arg = &son(*e);
exp r, ss, t;
s = sh (* (arg));
a = ashof (s);
props(*e) = 0; /* clear possibility of tlrecirsion; may be set later */
x = scan (arg, at);
/* scan result exp ... */
if (is_floating (name (s))) {/* ... floating pt result */
x.propsneeds |= realresult_bit;
if (name (s) != shrealhd) {
x.propsneeds |= longrealresult_bit;
}
}
else {
if (!valregable (s)) {/* .... result does not fit into reg */
x.propsneeds |= long_result_bit;
}
}
if (a.ashsize != 0) { /* ...not a void result */
x.propsneeds |= has_result_bit;
}
if ((name (*e) == res_tag) &&
(x.propsneeds & (long_result_bit | anyproccall | uses2_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_tag: */
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;
}
x.propsneeds |= uses2_bit;
no (r) = 101; /* identification uses result reg in body
*/
}
}
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;
gen_call = 1;
nds = scan(fn,at);
if(nds.propsneeds & hasproccall){ /* Identify it */
cca(at,fn);
nds.propsneeds &= ~hasproccall;
nds.propsneeds |= 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_align(shonepar));
onepar = scan(par,at);
if(((i != 0) && (onepar.propsneeds & hasproccall)) ||
(onepar.fixneeds+(stpar>>6) > maxfix)){
/* not the first parameter, and calls a proc */
cca(at,par);
nds.propsneeds |= 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) = n;
}
n += shape_size(shonepar);
stpar = rounder(n,REG_SIZE);
cerl = &bro(*cerl);
}
nds.maxargs = max(nds.maxargs,stpar);
nds = maxneeds(scan(&bro(bro(son(application))),at),nds);
pstldnds = scan(&bro(bro(bro(son(application)))),at);
if(pstldnds.propsneeds & (anyproccall | uses2_bit)){
props(*e) = 1;
if(valregable(sh(application)) || floatregable(sh(application))) {
cca(at,ptr_position(application));
pstldnds.propsneeds |= usesproccall;
}
}
else{
props(*e) = 0;
}
nds = maxneeds(nds,pstldnds);
nds.propsneeds |= 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((onepar.propsneeds & hasproccall) || (onepar.fixneeds+1>maxfix)){
/* identify it */
cca(at,par);
nds.propsneeds |= 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 callees = *e;
exp *ptr = &son(callees);
needs ndsp,nds;
nds = zeroneeds;
ndsp = scan(ptr,at);
if((ndsp.propsneeds & hasproccall) || (ndsp.fixneeds+1 > maxfix)){
cca(at,ptr);
nds.propsneeds |= usesproccall;
nds = maxneeds(shapeneeds(sh(*ptr)),nds);
nds.maxargs = max(nds.maxargs,ndsp.maxargs);
}
else{
nds = ndsp;
}
ndsp = scan(&bro(son(*e)),at);
if((ndsp.propsneeds & hasproccall) || (ndsp.fixneeds+2 > maxfix)){
cca(at,&bro(son(callees)));
nds.propsneeds |= usesproccall;
nds = maxneeds(shapeneeds(sh(bro(son(*e)))),nds);
nds.maxargs = max(nds.maxargs,ndsp.maxargs);
}
else{
nds = maxneeds(ndsp,nds);
}
if(nds.fixneeds<5) nds.fixneeds = 5; /* ?? */
return nds;
}
case same_callees_tag : {
needs nds;
nds = zeroneeds;
nds.fixneeds = 4; /* ?? */
return nds;
}
case tail_call_tag : {
needs ndsp,nds;
exp *fn = &son(*e);
ndsp = scan(fn,at);
if((ndsp.propsneeds & hasproccall) || (ndsp.fixneeds+1 > maxfix)){
cca(at,fn);
nds.propsneeds |= usesproccall;
nds = maxneeds(shapeneeds(sh(*fn)),nds);
nds.maxargs = max(nds.maxargs,ndsp.maxargs);
}
else{
nds = ndsp;
}
gen_call = 1;
ndsp = scan(&bro(son(*e)),at);
nds = maxneeds(nds,ndsp);
return nds;
}
case apply_tag : {
exp application = *(e);
exp fn = son (application);
exp * par = &bro(fn);
exp * fnexp = &son(*e);
int parsize =0;
needs nds;
bool tlrecpos = nonevis && callerfortr && (rscope_level == 0);
int i;
nds = scan (fnexp, at);
/* scan the function exp ... */
if ((nds.propsneeds & hasproccall) != 0) {
/* .... it must be identified */
cca (at, fnexp);
nds.propsneeds &= ~hasproccall;
nds.propsneeds |= usesproccall;
fn = son(application);
par = &bro(fn);
}
if (name(fn) != name_tag ||
(son(son(fn)) != nilexp && name(son(son(fn))) != 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 && (onepar.propsneeds & hasproccall) != 0) ||
onepar.fixneeds+(parsize>>6) > maxfix) {
/* if it isn't the first parameter, and it
calls a proc, identify it */
cca (at, par);
nds.propsneeds |= usesproccall;
nds = maxneeds (shapeneeds (sh (* (par))), nds);
nds.maxargs = max (nds.maxargs, onepar.maxargs);
}
else {
nds = maxneeds (onepar, nds);
}
parsize = rounder(parsize, shape_align(shpar));
parsize = rounder(parsize+shape_size(shpar), REG_SIZE);
/* ? */
if ((!valregable(shpar) && !is_floating(name(shpar))) || parsize > 384) {
tlrecpos = 0;
}
if (last (* (par))) {
break;
}
par = &bro(*par);
}
#if DO_SPECIAL
if ((i = specialfn (fn)) > 0) {/* eg strlen */
nds = maxneeds (specialneeds (i), nds);
return nds;
}
else
if (i == -1) { /* call of strcpy .... */
exp par2 = * (par);
/* TEST for constant string?????????????????
if (name (par2) == eval_tag && name (son (par2)) == pack_tag
&& name (son (son (par2))) == string_tag) {
setname (* (e), ass_tag);
son (* (e)) = * (parlist);
son (par2) = son (son (par2));
sh (par2) = sh (son (par2));
bro (par2) = * (e) ;
bro(son(par2)) = par2;
return maxneeds (nds, twofix);
}
*/
}
#endif
if (tlrecpos) {
exp dad = father(application);
if (name(dad)==res_tag) {
props(dad) = 1; /* do a tl recursion*/
}
}
nds.propsneeds |= hasproccall;
nds.maxargs = max (nds.maxargs, parsize);
return nds;
}
case name_tag : {
if(is_vararg(*e)){
/* if the tag represents va_list (set in spec_toks.c) */
has_old_varargs = 1;
}
return shapeneeds (sh(*(e)));
}
case val_tag : {
exp s = sh(*e);
if (name(s)==offsethd && al2(s) >= 8) {
/* express disps in bytes */
no(*e) = no(*e) >>3;
}
/*... and continue */
}
FALL_THROUGH;
case env_size_tag :
case give_stack_limit_tag :
case null_tag :
case real_tag :
case string_tag :
case env_offset_tag :
case general_env_offset_tag :
case caller_name_tag :
/* case next_frame_tag :*/
case current_env_tag :
case make_lv_tag :
case last_local_tag :{
return shapeneeds (sh (* (e)));
}
case clear_tag :
case formal_callee_tag :
case top_tag :
case prof_tag :
case local_free_all_tag :{
return zeroneeds;
}
case set_stack_limit_tag :
#ifdef return_to_label_tag
case return_to_label_tag :
#endif
case diagnose_tag :
case neg_tag :
case case_tag :
case not_tag :
case offset_negate_tag :
case absbool_tag :
case goto_lv_tag :
case abs_tag :
case local_free_tag :{
exp * arg = &son(*e);
return scan (arg, at);
}
case fneg_tag :
case fabs_tag :
case chfl_tag : {
needs nds;
nds = scan(&son(*e), at);
if (!optop(*e) && nds.fixneeds <2) nds.fixneeds = 2;
return nds;
}
case alloca_tag : {
needs nds;
nds = scan(&son(*e), at);
if (nds.fixneeds <2) nds.fixneeds = 2;
return nds;
}
case bitf_to_int_tag : {
/* is bitfield signed or unsigned ?? */
exp * arg = &son(*e);
needs nds;
exp stararg;
exp stare;
int sizeb;
nds = scan (arg, at);
stararg = *(arg);
stare = * (e);
sizeb = ashof (sh (stararg)).ashsize;
if ((name(stararg)==name_tag &&
((sizeb == 8 && (no (stararg) & 7) == 0)
|| (sizeb == 16 && (no (stararg) & 15) == 0)
|| (sizeb == 32 && (no(stararg) & 31)== 0)
|| (sizeb == 64 && (no(stararg) & 63) ==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)
|| (sizeb == 64 && (no(son(stararg)) & 63)== 0)
)
)
) {
bool 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(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 = &son(*e);
s = scan (arg, at);
s.fixneeds = max (s.fixneeds, 2);
s.floatneeds = max (s.floatneeds, 2);
has_float = 1;
return s;
}
case shl_tag :
case shr_tag :
case long_jump_tag : {
exp * lhs = &son(*e);
exp * rhs = & bro(*lhs);
needs nr;
needs nl;
prop prps ;
nr = scan(rhs, at);
nl = scan (lhs, at);
rhs = &bro(*lhs);
prps = (nr.propsneeds & hasproccall) << 1;
if (nr.fixneeds >= maxfix || prps != 0) {
/* if reg requirements overlap, identify
second operand */
cca (at, rhs);
nl = shapeneeds (sh (* (rhs)));
nl.propsneeds |= morefix;
nl.propsneeds &= ~(prps >> 1);
nl.propsneeds |= prps;
}
nr.fixneeds += 1;
return maxneeds (nl, nr);
}
case test_tag : {
exp stare = *(e);
exp l = son (stare);
exp r = bro (l);
exp dad = father(stare);
bool xlike = (name(dad)==maxlike_tag || name(dad)==minlike_tag || name(dad)==abslike_tag);
/* don't do various optimisations if xlike */
if (!last (stare) && name (bro (stare)) == test_tag &&
no (stare) == no (bro (stare)) &&
props(stare)==props(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));
}
if (last (stare) && name (bro (stare)) == 0/* seq holder */
&& name (bro (bro (stare))) == test_tag &&
name (bro (bro (bro (stare)))) == seq_tag &&
no (stare) == no (bro (bro (stare))) &&
props(stare)==props(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;
}
if (!xlike && name (l) == val_tag && (props (stare) == 5 || props (stare) == 6)) {
/* commute const = x */
bro (l) = stare;
setlast (l);
bro (r) = l;
clearlast (r);
son (stare) = r;
r = l;
l = son (stare);
}
if (!xlike && name (r) == val_tag && (props (stare) == 5
|| props (stare) == 6) && no (r) == 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)) */
exp copy;
INT64 n = isbigval(bro(son(l)))?exp_to_INT64((bro(son(l)))):
make_INT64(0,no (bro (son (l))));
int x;
for(x = 0; INT64_lt(zero_int64,n);++x) {
/* for (x = 0; n > 0; x++) {*/
n = INT64_shift_left(n,1,1);
/*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 */
if(!is64(sh(son(stare))) && name(l)!=shl_tag ){
sh(son(stare)) = slongsh;
copy = getexp(s64sh,bro(son(stare)),0,son(stare),nilexp,0,0,
chvar_tag);
son(stare) = copy;
}
else{
sh(son(stare)) = s64sh;
}
}
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;
}
default: ;
}
}
else if (is_floating (name (sh (l)))) {
return fpop (e, at);
}
else if (!xlike && name (r) == val_tag && no (r) == 1 && !isbigval(r)
&& (props (stare) == 3 || props (stare) == 2)) {
no (r) = 0;
if (props (stare) == 3) {
props (stare) = 4;/* branch >=1 -> branch > 0 */
}
else {
props (stare) = 1;/* branch <1 -> branch <= 0 */
}
}
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;
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 = son (sum);
list = son (x);
/* ALTERATION #1 here to fix minor structural bug */
for (;;) {
if (!last (x)) {
bro (list) = son (bro (x));
clearlast (list);
list = bro (list);
x = bro (x);
}
else {
bro(list) = sum;
setlast (list);
son (sum) = son (son (sum));
/* use existing exp */
break;
}
}
x = getexp (sh (sum), bro (sum), last (sum), sum, nilexp,
0, 0, neg_tag);
setlast(sum); bro(sum)=x; /* set father of sum to be negate */
* (e) = x;
} /* end allneg */
else {
/* transform to ((..(..+..) - ..) -..) */
int n = 0;
exp brosum = bro (sum);
bool lastsum = last (sum);
exp x = son (sum);
exp newsum = sum;
list = nilexp;
for (;;) {
exp nxt = bro (x);
bool final = 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;
newsum = sum; /* use existing exp for add operations */
}
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;
} /* end else allneg */
return scan (e, at);
} /* end someneg - else continue to next
case */
}
FALL_THROUGH
case and_tag :
case mult_tag :
case or_tag :
case xor_tag : {
return likeplus (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){
failer("Mixed frame offsets not supported");
}
#endif
if(includes_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;
}
}
return likediv(e,at);
}
case locptr_tag :
case reff_tag :
case offset_pad_tag :
case chvar_tag : {
exp * arg = &son(*e);
needs nds;
nds = maxneeds (scan (arg, at),shapeneeds (sh (* (e))));
/* nds.fixneeds += 1;*/
return nds;
}
case float_tag : {
needs nds;
exp * arg = &son(*e);
nds = maxneeds (scan (arg, at), shapeneeds (sh (* (e))));
if ((name(sh(son(*(e)))) == ulonghd)||(name(sh(son(*(e))))==u64hd)) {
if (nds.floatneeds <2) nds.floatneeds =2; /* remove */
}
has_float = 1;
return nds;
}
case cont_tag :
case contvol_tag : {
exp * arg = &son(*e);
needs nds;
nds = maxneeds (scan (arg, at), shapeneeds (sh (* (e))));
if(is_awkward_variety(name(sh(*e)))){
nds.fixneeds = max(nds.fixneeds,4);
}
else{
nds.fixneeds = max (nds.fixneeds, 2);
}
if (nstare != cont_tag) {
nds.propsneeds |= uses2_bit;
}
return nds;
}
case offset_mult_tag :
case offset_div_tag : {
exp op2 = bro(son(*e));
shape s = sh(op2);
if (name(op2)==val_tag && no(op2) == 8 && name(s)==offsethd && al2(s) >= 8) {
/* offset is one byte */
exp op1 = son(*e);
bro(op1) = bro(*e);
if (last(*e)) { setlast(op1); } else {clearlast(op1); }
*e = op1;
return( scan(e, at));
}
/*... else continue */
}
FALL_THROUGH;
case div2_tag :
case rem2_tag :
case rem0_tag :
case div0_tag :
case offset_div_by_int_tag :{
if(is_machine_divide(*e)){
has_div = 1;
}
return likediv(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;
#ifdef make_stack_limit_tag
case make_stack_limit_tag :
#endif
case min_tag :
case max_tag :
case minus_tag :
case subptr_tag :
case minptr_tag :
case offset_max_tag :
case component_tag :{
return likediv (e, at);
}
case div1_tag : {
if(is_machine_divide(*e)){
has_div = 1;
}
if ((name(sh(*e)) & 1)==0) { setname(*e, div2_tag); }
return likediv(e,at);
}
case mod_tag : {
if(is_machine_divide(*e)){
has_div = 1;
}
if ((name(sh(*e)) & 1)==0) { setname(*e, rem2_tag); }
return likediv(e,at);
}
case fdiv_tag :
#if (FBASE==10) /* (FBASE==10) is now defunct */
{
/* replace X/const by X*const^-1 */
exp z = * (e);
exp a2 = bro (son (z));
if (name (a2) == real_tag) {
flt inverse;
flt unitflt;
str2flt ("1.0", &unitflt, (char **) 0);
if (flt_div (unitflt, flptnos[no (a2)], &inverse) == OKAY) {
int f = new_flpt ();
flptnos[f] = inverse;
no (a2) = f;
setname (z, fmult_tag);
}
}
}
#endif
case fplus_tag :
case fminus_tag :
case fmult_tag : {
exp op = *(e);
exp a2 = bro(son(op));
has_float = 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));
/* dont need to transfer error treatment - nans */
exp nd = getexp(sh(op), bro(op), 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 : {
has_float = 1;
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);
callerfortr = do_tlrecursion && !proc_has_setjmp(stare)
&& !proc_has_alloca(stare) && !proc_has_lv(stare) &&
!proc_uses_crt_env(stare);
callerfortr=0;
maxfix = 12; /* excluding regs corrupted by div */
maxfloat = 12; /* jm - 21? */
stparam = 0;
fixparam = 16;
floatparam = 16;
nonevis = 1;
rscope_level = 0;
numparams=0;
callee_size = 0;
gen_call = (name(stare) == general_proc_tag);
in_vcallers_proc = (gen_call && proc_has_vcallers(stare));
bexp = & son(*e);
bat = bexp;
body = scan (bexp, &bat);
/* scan the body of the proc */
if(gen_call || Has_fp){
/* reserve space for the link area */
callee_size += 4*PTR_SZ;
}
#if 0
if(name(stare) == proc_tag && gen_call) {
set_proc_has_gen_call(*e);
}
#endif
if(has_old_varargs){
set_has_c_vararg(*e);
has_old_varargs = 0;
}
if(has_div){
set_has_machine_division(*e);
has_div = 0;
}
if(has_float){
set_has_float(*e); /* need to allocate space on stack for
a float <-> int register move */
}
return body; /* should never require this in reg in C */
}
case movecont_tag : {
exp * d = &son(*e);
exp * s = & bro(*d);
exp * sz = &bro(*s);
needs nd;
needs ns;
needs nsz;
prop prps ;
nd = scan(d, at);
ns = scan (s, at);
nsz = scan(sz, at);
prps = (ns.propsneeds & hasproccall) << 1;
if (ns.fixneeds >= maxfix || prps != 0) {
/* if reg requirements overlap, identify
second operand */
cca (at, s);
ns = shapeneeds (sh (* (s)));
ns.propsneeds |= morefix;
ns.propsneeds &= ~(prps >> 1);
ns.propsneeds |= prps;
}
nd.fixneeds += 1;
nd = maxneeds (nd, ns); /* ns? */
prps= (nsz.propsneeds & hasproccall) << 1;
if (nd.fixneeds+nsz.fixneeds >= maxfix || prps != 0) {
/* if reg requirements overlap, identify last operand */
cca (at, sz);
nsz = shapeneeds (sh (* (sz)));
nsz.propsneeds |= morefix;
nsz.propsneeds &= ~(prps >> 1);
nsz.propsneeds |= prps;
}
nd.fixneeds+=1;
nd = maxneeds(nd,nsz);
if (nd.fixneeds < 4) nd.fixneeds = 3;
return nd;
}
case trap_tag :
case special_tag :{
return zeroneeds;
}
default: {
printf ("case %d not covered in needs scan\n", name (* e));
/* NB should call failer */
return zeroneeds;
}
}
}