Rev 2 | 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.
*/
/**********************************************************************
$Author: pwe $
$Date: 1998/03/11 11:03:19 $
$Revision: 1.3 $
$Log: check.c,v $
* Revision 1.3 1998/03/11 11:03:19 pwe
* DWARF optimisation info
*
* Revision 1.2 1998/02/11 16:56:36 pwe
* corrections
*
* Revision 1.1.1.1 1998/01/17 15:55:46 release
* First version to be checked into rolling release.
*
* Revision 1.41 1998/01/09 09:28:25 pwe
* prep restructure
*
* Revision 1.40 1997/12/04 19:38:53 pwe
* ANDF-DE V1.9
*
* Revision 1.39 1997/10/10 18:15:13 pwe
* prep ANDF-DE revision
*
* Revision 1.38 1997/08/23 13:24:00 pwe
* no invert order, and NEWDIAGS inlining
*
* Revision 1.37 1997/08/06 10:58:22 currie
* Catch overflowed constants, PlumHall requirement
*
* Revision 1.36 1996/10/01 08:59:19 currie
* correct chvar exceptions ADA
*
Revision 1.35 1996/06/24 17:26:57 currie
PIC code with name substitution
Revision 1.34 1996/06/13 09:24:55 currie
Bitfield alignments
Revision 1.33 1996/06/05 15:29:48 currie
parameter alignment in make_cmpd
* Revision 1.32 1996/02/28 11:36:18 currie
* assign to promoted pars
*
* Revision 1.31 1996/02/21 09:39:00 currie
* hppa var_callers + inlined bug
*
* Revision 1.30 1996/01/22 14:25:31 currie
* char parameters on bigendian
*
* Revision 1.29 1996/01/17 10:28:06 currie
* param alignment + case bigval
*
* Revision 1.28 1996/01/10 14:58:43 currie
* BIGEND var params chars & shorts
*
* Revision 1.27 1995/11/29 15:30:09 currie
* computed signed nat
*
* Revision 1.26 1995/11/01 11:29:45 currie
* 32 place shifts
*
* Revision 1.25 1995/10/26 10:14:22 currie
* solve_tag - kill_exp scope reduced
*
* Revision 1.24 1995/10/17 12:59:23 currie
* Power tests + case + diags
*
* Revision 1.24 1995/10/17 12:59:23 currie
* Power tests + case + diags
*
* Revision 1.23 1995/10/13 15:14:58 currie
* case + long ints on alpha
*
* Revision 1.22 1995/10/12 15:52:47 currie
* inlining bug
*
* Revision 1.21 1995/10/11 17:09:56 currie
* avs errors
*
* Revision 1.20 1995/10/06 14:41:53 currie
* Env-offset alignments + new div with ET
*
* Revision 1.18 1995/10/04 09:17:26 currie
* CR95_371 + optimise compounds
*
* Revision 1.17 1995/10/03 11:44:58 currie
* field(compound)
*
* Revision 1.16 1995/10/02 10:55:54 currie
* Alpha varpars + errhandle
*
* Revision 1.15 1995/09/19 16:06:43 currie
* isAlpha!!
*
* Revision 1.14 1995/09/15 13:29:00 currie
* hppa + add_prefix + r_w_m complex
*
* Revision 1.13 1995/09/11 15:35:32 currie
* caller params -ve
*
* Revision 1.12 1995/08/31 14:18:56 currie
* mjg mods
*
* Revision 1.11 1995/08/29 10:45:43 currie
* Various
*
* Revision 1.10 1995/08/15 08:25:27 currie
* Shift left + trap_tag
*
* Revision 1.10 1995/08/15 08:25:27 currie
* Shift left + trap_tag
*
* Revision 1.9 1995/08/09 08:59:54 currie
* round bug
*
* Revision 1.8 1995/08/02 13:17:57 currie
* Various bugs reported
*
* Revision 1.7 1995/07/06 09:14:00 currie
* rem & VERSION
*
* Revision 1.6 1995/07/05 09:26:30 currie
* continue wrong
*
* Revision 1.5 1995/07/03 13:42:36 currie
* Tail call needs fp
*
* Revision 1.4 1995/06/26 13:04:32 currie
* make_stack_limit, env_size etc
*
* Revision 1.3 1995/06/22 09:16:19 currie
* offset_mult bug + power
*
* Revision 1.2 1995/05/05 08:10:45 currie
* initial_value + signtures
*
* Revision 1.1 1995/04/06 10:44:05 currie
* Initial revision
*
***********************************************************************/
/*********************************************************************
check.c
The routine check performs the bottom-up TDF-to-TDF optimising
transformations. When a new exp is created check is applied to
see if a recognised situation has arisen. check assumes that
all components of this new exp have already had check applied to them.
It returns 1 if it has made a change, 0 if not.
hold_check holds an exp as the son of a dummy exp and then
applies check. the need for this operation is explained in
the overall documentation.
eq_exp compares two exp for equality of effect.
dochvar takes the int, i, and delivers the number which results from
changing its variety to that specified by the shape, t.
*********************************************************************/
#include "config.h"
#include "common_types.h"
#include "xalloc.h"
#include "expmacs.h"
#include "exp.h"
#include "tags.h"
#include "flpt.h"
#include "flags.h"
#include "externs.h"
#include "install_fns.h"
#include "shapemacs.h"
#include "check_id.h"
#include "me_fns.h"
#include "basicread.h"
#include "szs_als.h"
#include "installglob.h"
#include "machine.h"
#include "messages_c.h"
#include "natmacs.h"
#include "f64.h"
#include "misc_c.h"
#include "readglob.h"
#include "misc_c.h"
#ifdef NEWDIAGS
#include "dg_aux.h"
#endif
#if is80x86
#include "localflags.h"
#endif
#include "check.h"
extern shape containedshape PROTO_S ((int,int));
/* MACROS */
/* codes for error treaments */
#define impossible 1
#define ignore 2
/* IDENTITIES */
static int masks[33] = {
0,
0x1, 0x3, 0x7, 0xf,
0x1f, 0x3f, 0x7f, 0xff,
0x1ff, 0x3ff, 0x7ff, 0xfff,
0x1fff, 0x3fff, 0x7fff, 0xffff,
0x1ffff, 0x3ffff, 0x7ffff, 0xfffff,
0x1fffff, 0x3fffff, 0x7fffff, 0xffffff,
0x1ffffff, 0x3ffffff, 0x7ffffff, 0xfffffff,
0x1fffffff, 0x3fffffff, 0x7fffffff, (int)0xffffffff
};
ntest int_inverse_ntest[] = {0, 4, 3, 2, 1, 6, 5};
ntest real_inverse_ntest[] = {0, 10, 9, 8, 7, 6, 5, 4, 3, 2, 1,
12, 11, 14, 13};
ntest exchange_ntest[] = {0, 3, 4, 1, 2, 5, 6, 9, 10, 7, 8, 11, 12, 13,
14};
#if FBASE == 10
static char maxdigs[] = "4294967296";
#endif
/* PROCEDURES */
/***********************************************************************
hold_check holds an exp as the son of a dummy exp and then
applies check. After checking it retcells the dummy exp.
***********************************************************************/
/* puts body on a hold */
exp hold
PROTO_N ( (body) )
PROTO_T ( exp body )
{
exp body_hold = next_exp();
son (body_hold) = body;
bro (body) = body_hold;
setlast (body);
bro (body_hold) = nilexp;
#if diagnose_registers
setname (body_hold, hold_tag);
#else
setname (body_hold, 102);
#endif
return (body_hold);
}
exp hold_check
PROTO_N ( (r) )
PROTO_T ( exp r )
{
exp h, sn;
h = hold (r);
IGNORE check (r, r);
sn = son (h);
bro(sn) = nilexp;
retcell (h);
return (sn);
}
exp hold_const_check
PROTO_N ( (r) )
PROTO_T ( exp r )
{
exp ans;
int old = all_variables_visible;
all_variables_visible = 0;
ans = hold_check (r);
all_variables_visible = old;
return ans;
}
static exp varchange
PROTO_N ( (s, e) )
PROTO_T ( shape s X exp e )
{
/* applies a change_var operation to e, to
get shape s */
exp r = getexp (s, nilexp, 0, e, nilexp, 0, 0,
chvar_tag);
setlast(e);
bro(e) = r;
return (hold_check (r));
}
static int flpt_power_of_2
PROTO_N ( (f) )
PROTO_T ( flpt f )
{
flt * r = &flptnos[f];
unsigned short us = r -> mant[0];
int i;
if ((us & (us - 1)) != 0)
return 0;
for (i = 1; i < MANT_SIZE; i++) {
if (r -> mant[i] != 0)
return 0;
};
return 1;
}
/***********************************************************************
eq_explist compares two descendant lists of exp for equality.
The given values, their bro's, bro(bro)'s etc are compared until
an unequal pair is found or the end of one of the lists (last) is
found. In this case the lists are equal iff both ends have been
reached.
***********************************************************************/
static int eq_explist
PROTO_N ( (al, bl) )
PROTO_T ( exp al X exp bl )
{
if (al == nilexp && bl == nilexp)
return (1);
if (al == nilexp || bl == nilexp)
return (0);
if (!eq_exp (al, bl))
return (0);
if (last (al) && last (bl))
return (1);
if (last (al) || last (bl))
return (0);
return (eq_explist (bro (al), bro (bl)));
}
/***********************************************************************
eq_exp compares two exp for equality of effect. If the name of either
exp is in the side-effecting group (!is_a) the exp are not equal.
This is a crude test, but if it says the exps are equal this is so.
contvol is forbidden.
***********************************************************************/
int eq_exp
PROTO_N ( (a, b) )
PROTO_T ( exp a X exp b )
{
if (name (a) == name (b)) {
if (name (a) == name_tag)
return (son (a) == son (b) && no (a) == no (b) &&
eq_shape (sh (a), sh (b)));
if (!is_a (name (a)) || !eq_shape (sh (a), sh (b)) ||
name(a) == contvol_tag)
return (0);
if (name (a) == real_tag) {
int res = flt_cmp (flptnos[no (a)], flptnos[no (b)]);
return (res == 0);
};
if (name(a) == val_tag) {
if (isbigval(a)) {
int res;
if (!isbigval(b))
return 0;
res = flt_cmp (flptnos[no (a)], flptnos[no (b)]);
return (res == 0);
};
if (isbigval(b))
return 0;
return (no(a) == no(b));
};
return (no (a) == no (b) &&
eq_explist (son (a), son (b)));
};
return (0);
}
/**********************************************************************
repbycont replaces e by the exp which loads top, ie. does nothing.
**********************************************************************/
static void repbycont
PROTO_N ( (e, has_label, scope) )
PROTO_T ( exp e X bool has_label X exp scope )
{
exp n = getexp (f_top, bro (e), (int)(last (e)), nilexp, nilexp, 0, 0, top_tag);
if (has_label) {
no (son (pt (e)))--;
pt (e) = nilexp;
};
#ifdef NEWDIAGS
dgf(n) = dgf(e);
#endif
replace (e, n, e);
kill_exp (e, e);
if (scope !=e) altered(n,scope);
}
/**********************************************************************
repbygo replaces e by a goto the label.
**********************************************************************/
static void repbygo
PROTO_N ( (e, lab, scope) )
PROTO_T ( exp e X exp lab X exp scope )
{
exp g = getexp (f_bottom, nilexp, 0, nilexp, lab, 0, 0, goto_tag);
exp n = getexp (f_top, g, 1, nilexp, nilexp, 0, 0, top_tag);
son (g) = n;
++no (son (lab));
#ifdef NEWDIAGS
dgf(g) = dgf(e);
#endif
replace (e, g, e);
kill_exp (e, e);
if (scope !=e) altered(g,scope);
}
/**********************************************************************
nos tests the exp t to see if it is a construction that can be
eliminated from a sequence. It is ignorable or has no side effect.
**********************************************************************/
static int nos PROTO_S ((exp t));
static int noslist
PROTO_N ( (tl) )
PROTO_T ( exp tl )
{
if (tl == nilexp)
return (1);
if (last (tl))
return (nos (tl));
return (nos (tl) && noslist (bro (tl)));
}
static int nos
PROTO_N ( (t) )
PROTO_T ( exp t )
{
unsigned char n = name(t);
if (n == top_tag || n == ignorable_tag)
return (1);
if (n == compound_tag || n == nof_tag) return noslist(son(t));
return ( (is_a (n) &&
optop(t) &&
((n == name_tag && !islastuse(t)) ||
n == val_tag ||
noslist (son (t))
)
) ||
(n == ident_tag && !isenvoff(t) &&
nos (son (t)) &&
nos (bro (son (t)))
)
);
}
/**********************************************************************
check_seq carries out transformations on sequences.
Statements with no effect are removed.
Anything after an unconditional goto, or any other statement
producing a bottom shape, is removed.
No changes are propagated outside the exp "scope".
**********************************************************************/
static int maxes [] = {0, 0, 0, 127, 255, 32767, 65535,
(int)0x7fffffff, (int)0xffffffff};
static int mins[] = {0, 0, 0, -128, 0, -32768, 0, (int)0xffffffff, 0};
static shape * us_shape[] = {&f_bottom, &f_bottom, &f_top, &ucharsh,
&ucharsh,
&uwordsh, &uwordsh, &ulongsh, &ulongsh};
static exp make_test
PROTO_N ( (nt, lab, arg1, arg2, nm) )
PROTO_T ( ntest nt X exp lab X exp arg1 X exp arg2 X unsigned char nm )
{
exp r;
r = getexp (f_top, nilexp, 0, arg1, lab, 0, 0, nm);
fno(r) = (float)0.5;
settest_number(r, (int)nt);
setbro(arg1, arg2);
clearlast(arg1);
++no(son(lab));
setfather (r, arg2);
return r;
}
static int simple
PROTO_N ( (e) )
PROTO_T ( exp e )
{
if (name(e) == cont_tag && name(son(e)) == name_tag)
return 1;
if (name(e) == cont_tag && name(son(e)) == cont_tag &&
name(son(son(e))) == name_tag)
return 1;
if (name(e) == cont_tag && name(son(e)) == reff_tag &&
name(son(son(e))) == cont_tag &&
name(son(son(son(e)))) == name_tag)
return 1;
if (name(e) == name_tag && !isvar(son(e)))
return 1;
return 0;
}
static exp tests_to_bounds
PROTO_N ( (a, b) )
PROTO_T ( exp a X exp b )
{
exp x = son(a);
int na = no(bro(x));
int nb = no(bro(son(b)));
int ntemp;
ntest nta = test_number(a);
ntest ntb = test_number(b);
ntest nttemp;
exp lab = pt(a);
shape sha = sh(x);
if (simple(x))
return nilexp;
if (nta == f_greater_than) {
if (na == maxes[name(sha)])
return nilexp;
nta = f_greater_than_or_equal;
++na;
};
if (ntb == f_greater_than) {
if (nb == maxes[name(sha)])
return nilexp;
ntb = f_greater_than_or_equal;
++nb;
};
if (ntb == f_greater_than_or_equal) {
ntemp = na;
na = nb;
nb = ntemp;
nttemp = nta;
nta = ntb;
ntb = nttemp;
};
if (nta != f_greater_than_or_equal)
return nilexp;
if (ntb != f_less_than_or_equal && ntb != f_less_than)
return nilexp;
if (ntb == f_less_than) {
if (nb == mins[name(sha)])
return nilexp;
ntb = f_less_than_or_equal;
--nb;
};
UNUSED(ntb);
if (is_signed(sha)) {
if (nb < na)
return nilexp;
}
else {
if ((unsigned int)nb < (unsigned int)na)
return nilexp;
};
no(son(lab)) -= 1; /* one is removed by kill_exp below */
if (na == nb) {
kill_exp(b, b);
return make_test(f_equal, lab, x, me_shint(sha, na), test_tag);
};
{
exp s = hold_check(me_b2(x, me_shint(sha, na), minus_tag));
exp n = me_shint(sha, nb -na);
shape new_sha = *us_shape[name(sha)];
sh(s) = new_sha;
sh(n) = new_sha;
kill_exp(b, b);
return make_test(f_less_than_or_equal, lab, s, n, test_tag);
};
}
static int check_seq
PROTO_N ( (e, scope) )
PROTO_T ( exp e X exp scope )
{
exp z = son (e);
exp t, k, kk;
int changed = 0;
if (name(sh(bro(son(e)))) == bothd && name(sh(e)) != bothd) {
sh(e) = f_bottom;
changed = 1;
};
while (name (sh (son (z))) == bothd || nos (son (z))) {
if (name (sh (son (z))) == bothd) {
if (!last (son (z))) {
kk = bro (son (z));
while (kk != nilexp) {
k = kk;
if (!last (k))
kk = bro (k);
else
kk = nilexp;
#ifdef NEWDIAGS
dg_dead_code (k, son(z));
#endif
kill_exp (k, k);
};
};
#ifdef NEWDIAGS
if (diagnose) {
dg_dead_code (bro(z), son(z));
dg_whole_comp (e, son(z));
}
#endif
kill_exp (bro (z), bro (z)); /* kill dead variable refs */
setfather (e, z); /* before replace */
replace (e, son (z), scope);
retcell (z);
retcell (e);
return (1);
};
if (last (son (z))) {
#ifdef NEWDIAGS
if (diagnose) {
dg_rdnd_code (son(z), bro(z));
dg_whole_comp (e, bro(z));
}
#endif
replace (e, bro (z), scope);
kill_exp (son (z), son (z));
retcell (z);
retcell (e);
return (1);
};
#ifdef NEWDIAGS
if (diagnose)
dg_rdnd_code (son(z), bro(son(z)));
#endif
k = son (z);
son (z) = bro (son (z));
kill_exp (k, k);
};
t = son (z);
for (;;) {
if (name(t) == test_tag && name(bro(son(t))) == val_tag &&
!isbigval(bro(son(t))) &&
name(sh(son(t))) <= ulonghd) {
exp b;
exp bnds;
exp * ref;
if (last(t)) {
b = bro(bro(t));
if (name(b) == test_tag && name(bro(son(b))) == val_tag &&
!isbigval(bro(son(b))) &&
pt(t) == pt(b) &&
eq_exp(son(t), son(b))) {
bnds = tests_to_bounds(t, b);
if (bnds == nilexp) {
if (changed)
altered(e, scope);
return 0;
};
if (t == son(z)) {
#ifdef NEWDIAGS
if (diagnose)
dg_whole_comp (e, bnds);
#endif
replace(e, bnds, scope);
retcell(e);
return 1;
};
ref = refto(father(t), t);
bro(*ref) = bro(t);
setlast(*ref);
setlast(bnds);
bro(bnds) = e;
bro(z) = bnds;
return 0;
}
else {
if (changed)
altered(e, scope);
return 0;
};
};
b = bro(t);
if (name(b) == test_tag && name(bro(son(b))) == val_tag &&
!isbigval(bro(son(b))) &&
pt(t) == pt(b) &&
eq_exp(son(t), son(b))) {
exp brob = bro(b);
int lb = last(b);
ref = refto(father(t), t);
bnds = tests_to_bounds(t, b);
if (bnds != nilexp) {
bro(bnds) = brob;
if (lb)
setlast(bnds);
else
clearlast(bnds);
*ref = bnds;
t = bnds;
};
};
};
if (last (t)) {
if (changed)
altered(e, scope);
return 0;
};
if (name (sh (bro (t))) == bothd) {
if (!last (bro (t))) {
kk = bro (bro (t));
while (kk != nilexp) {
k = kk;
if (!last (k))
kk = bro (k);
else
kk = nilexp;
#ifdef NEWDIAGS
if (diagnose)
dg_dead_code (k, bro(t));
#endif
kill_exp (k, k);
};
};
#ifdef NEWDIAGS
if (diagnose)
dg_dead_code (bro(z), bro(t));
#endif
kill_exp (bro (z), bro (z));
bro (z) = bro (t);
setlast (bro (z));
bro (bro (z)) = e;
setlast (t);
bro (t) = z;
sh(e) = f_bottom;
altered(e, scope);
return 0;
};
if (nos (bro (t))) {
if (last (bro (t))) {
#ifdef NEWDIAGS
if (diagnose)
dg_rdnd_code (bro(t), bro(z));
#endif
kill_exp (bro (t), bro (t));
setlast (t);
bro (t) = z;
return 0;
};
k = bro (t);
bro (t) = bro (bro (t));
#ifdef NEWDIAGS
if (diagnose)
dg_rdnd_code (k, bro(t));
#endif
kill_exp (k, k);
changed = 1;
}
else
t = bro (t);
}
/* UNREACHED */
}
/**********************************************************************
comm_ass applies the commutative and associative laws to replace e
by an improved version. op_tag is the operation involved. If
the errtreat is not ignore or impossible, no change is made. C
programs will always use ignore or impossible.
All the arguments of sub-operations with the same op_tag (they will
anyway have the same shape) are flattened into one argument list,
provided that dive is 1.
All the constants are combined into one, which is placed as the last
constant. The parameter "one" is the unit for the given operation
(0 for + , 1 for * , allones for and, 0 for or, 0 for xor) and this
constant is eliminated. If the operation has a zero, "has_zero" is
set and "zero" is the constant (0 for * , 0 for and, allones for or).
No changes are propagated outside the exp "scope".
If isreal is 1 the operation has real arguments and results, otherwise
integer.
fn(a, b) is applicable to exps defining constants of the correct type
(integer or real) and delivers an exp defining a constant which is
the result of the op_tag applied to these constants.
**********************************************************************/
static int f_one PROTO_S ((flpt f));
static int seq_distr PROTO_S ((exp e, exp scope));
static int comm_ass
PROTO_N ( (e, op_tag, fn, one, has_zero, zero, scope, dive, isreal) )
PROTO_T ( exp e X unsigned char op_tag X
void (*fn) PROTO_S (( exp, exp, int )) X
int one X int has_zero X int zero X exp scope X
int dive X int isreal )
{
exp t = son (e); /* starting element */
int changed = last (t);
exp cst; /* start the accumulated constant */
exp cst_u = nilexp; /* holds exp representing one if created here */
int looping;
if (isreal)
cst = getexp (sh (e), nilexp, 0, nilexp, nilexp, 0, one, real_tag);
else {
cst = me_shint(sh(e), one);
if (one == -1 && shape_size(sh(e)) == 64) {
flpt f = new_flpt();
flt * fp = &flptnos[f];
int i;
fp->sign = 1;
fp->exp = 3;
for (i=0; i< 4; ++i)
fp->mant[i] = 65535;
no(cst) = f;
setbigval(cst);
cst_u = cst;
};
};
if (!optop(e))
return 0;
do { /* look to see if a change will be made */
if ((name (t) == op_tag && optop(t)) || name (t) == val_tag ||
name(t) == real_tag)
changed = 1;
looping = !last (t);
t = bro (t);
}
while (looping);
if (changed) { /* continue if there will be a change */
exp p, q;
t = son (e); /* start */
q = getexp (sh (e), nilexp, 0, nilexp, nilexp, 0, 0, op_tag);
seterrhandle(q, errhandle(e));
/* start the result */
p = q; /* p is used to point to the current place
where the next item will be added (as
bro). */
do {
while (name (t) == op_tag && optop(t) && dive)
t = son (t); /* dive down same operator */
if (name (t) == val_tag || name(t) == real_tag) {
fn (cst, t, errhandle(e)); /* accumulate constant value */
#ifdef NEWDIAGS
if (diagnose)
dg_detach_const (t, cst);
#endif
}
else { /* add item at p and move p on */
bro (p) = t;
clearlast (p);
p = bro (p);
};
while (last (t) && bro (t) != e)
t = bro (t); /* ascend from sub-item */
}
while ((last (t)) ? 0 : (t = bro (t), 1));
son (q) = bro (q); /* put q into correct form (we were using
its bro) */
if (p == q) {
/* no items but constant */
retcell(q);
#ifdef NEWDIAGS
if (diagnose)
dg_whole_comp (e, cst);
#endif
replace (e, cst, scope);
retcell(e);
return (1);
};
if (has_zero &&
((!isreal && no(cst) == zero && !isbigval(cst)) ||
(isreal && flptnos[no(cst)].sign == 0))) {
/* zero constant. Replace by a sequence of expressions delivering
the zero, so as to keep side effects */
exp r;
setname (q, 0); /* use q a seq holder */
son (q) = bro (q);
bro (p) = q;
setlast (p);
clearlast (q);
bro (q) = cst;
r = getexp (sh (e), nilexp, 0, q, nilexp, 0, 0, seq_tag);
#ifdef NEWDIAGS
if (diagnose)
dgf(r) = dgf(e);
#endif
replace (e, hc (r, cst), scope);
return (1);
};
if ((!isreal &&
(no(cst) != one || (isbigval(cst) && cst != cst_u))) ||
(isreal && cmpflpt(no(cst), one, 6))) {
/* form result if there is a non-unit
constant term */
bro (p) = cst;
clearlast (p);
p = bro (p);
son (q) = bro (q);
bro (p) = q;
setlast (p);
sh (q) = sh (e);
#ifdef NEWDIAGS
if (diagnose)
dgf(q) = dgf(e);
#endif
replace (e, q, scope);
retcell(e);
return (1);
};
#ifdef NEWDIAGS
if (diagnose)
dgf(e) = combine_diaginfo (dgf(e), dgf(cst));
#endif
retcell(cst); /* there are no constants other than unit*/
if (son (q) == p) { /* form result if single item and no
constant */
sh (p) = sh (e);
#ifdef NEWDIAGS
if (diagnose)
dg_whole_comp (e, p);
#endif
replace (e, hold_check(p), scope);
retcell(e);
return (1);
};
bro (p) = q; /* form result if no constant and more
than one arg */
setlast (p);
sh (q) = sh (e);
#ifdef NEWDIAGS
if (diagnose)
dg_whole_comp (e, q);
#endif
replace (e, q, scope);
retcell(e);
return (1);
};
return 0; /* return from here if no change made */
}
/* dochvar takes the int, i, and delivers
the number which results from changing
its variety to that specified by the
shape, t. */
int dochvar
PROTO_N ( (i, t) )
PROTO_T ( int i X shape t )
{
if (name(t) == bitfhd) {
int m = masks[shape_size(t)];
int x = i & m;
if (is_signed(t)) {
int sm = ((m+1)>>1) & x;
x -= (sm << 1);
}
return x;
}
switch (shape_size(t))
{
case 8:
{
if (is_signed(t))
{
int x = i & 0xff;
if (x & 128)
return (i | (~0xff));
return (i & 0xff);
}
else
return (i & 0xff);
};
case 16:
{
if (is_signed(t))
{
int x = i & 0xffff;
if (x & 32768)
return (i | (~0xffff));
return (i & 0xffff);
}
else
return (i & 0xffff);
};
case 32:
{
if (is_signed(t))
{
int x = i & (int)0xffffffff;
if (x & (int)0x80000000)
return (i | (~(int)0xffffffff));
return (i & (int)0xffffffff);
}
else
return (i & (int)0xffffffff);
};
case 64:
return (i);
default:
return (i & masks[shape_size(t)]);
};
}
static void dochvar_f
PROTO_N ( (xa, sha) )
PROTO_T ( flt64 * xa X shape sha )
{
if (shape_size(sha) == 64)
return;
*xa = int_to_f64(dochvar((int)xa->small, sha), is_signed(sha));
return;
}
static void bigres
PROTO_N ( (a, xp) )
PROTO_T ( exp a X flt64 * xp )
{
int bg;
dochvar_f(xp, sh(a));
no(a) = f64_to_flpt(*xp, is_signed(sh(a)), &bg, shape_size(sh(a)));
if (bg)
setbigval(a);
else
clearbigval(a);
return;
}
static int check_size
PROTO_N ( (a, sg, sz) )
PROTO_T ( flt64 a X int sg X int sz )
{
int t = (int)a.small;
if (sz > 32)
return 0;
if (sg && (t >> 31) == a.big && (sz == 32 || (t >> (sz-1)) == a.big))
return 0;
if (!sg && a.big == 0 && (sz == 32 || (t >> sz) == 0))
return 0;
return 1;
}
/* used as a fn parameter for comm_ass q.v. */
static void fplus_fn
PROTO_N ( (ap, b, et) )
PROTO_T ( exp ap X exp b X int et )
{
int a = no(ap);
int nob = no (b);
flt resval;
int status;
UNUSED (et);
status = flt_add (flptnos[a], flptnos[nob], &resval);
if (status == OKAY) {
flpt_round((int)f_to_nearest,
flpt_bits((floating_variety)(name(sh(b))-shrealhd)),
&resval);
flptnos[nob] = resval;
no(ap) = nob;
}
else
failer(ILLEGAL_FLADD);
return;
}
/* used as a fn parameter for comm_ass q.v. */
static void fmult_fn
PROTO_N ( (ap, b, et) )
PROTO_T ( exp ap X exp b X int et )
{
int a = no(ap);
int nob = no (b);
flt resval;
int status;
UNUSED (et);
status = flt_mul (flptnos[a], flptnos[nob], &resval);
if (status == OKAY) {
flpt_round((int)f_to_nearest,
flpt_bits((floating_variety)(name(sh(b))-shrealhd)),
&resval);
flptnos[nob] = resval;
no(ap) = nob;
}
else
failer(ILLEGAL_FLMULT);
return;
}
/* auxiliary function used for comm_ass by plus */
static void plus_fn
PROTO_N ( (ap, b, et) )
PROTO_T ( exp ap X exp b X int et )
{
flt64 x;
flpt fa, fb;
int sg = is_signed(sh(ap));
flt resval;
int ov;
fa = f64_to_flt(exp_to_f64(ap), sg);
fb = f64_to_flt(exp_to_f64(b), sg);
IGNORE flt_add (flptnos[fa], flptnos[fb], &resval);
/* status cannot be wrong */
flptnos[fa] = resval;
x = flt_to_f64(fa, sg, &ov);
if (et != f_wrap.err_code &&
(ov || constovf(b) || check_size(x, sg, shape_size(sh(ap)))))
setconstovf(ap);
/* if (extra_checks && sg && !in_proc_def &&
(ov || (shape_size(sh(ap)) <= 32 && check_size(x, sg, 32)))) {
failer(ADD_OUT_OF_BOUNDS);
exit(EXIT_FAILURE);
};
*/
flpt_ret(fa);
flpt_ret(fb);
bigres(ap, &x);
return;
}
/* subtract constant from constant */
static void minus_fn
PROTO_N ( (ap, b, et) )
PROTO_T ( exp ap X exp b X int et )
{
flt64 x;
flpt fa, fb;
int sg = is_signed(sh(ap));
flt resval;
int ov;
fa = f64_to_flt(exp_to_f64(ap), sg);
fb = f64_to_flt(exp_to_f64(b), sg);
IGNORE flt_sub (flptnos[fa], flptnos[fb], &resval);
/* status cannot be wrong */
flptnos[fa] = resval;
x = flt_to_f64(fa, sg, &ov);
if (et != f_wrap.err_code &&
(ov || constovf(b) || check_size(x, sg, shape_size(sh(ap)))))
setconstovf(ap);
/* if (extra_checks && sg && !in_proc_def &&
(ov || (shape_size(sh(ap)) <= 32 && check_size(x, sg, 32)))) {
failer(ADD_OUT_OF_BOUNDS);
exit(EXIT_FAILURE);
};
*/
flpt_ret(fa);
flpt_ret(fb);
bigres(ap, &x);
return;
}
/* negate a constant exp, b, producing int */
static void neg_fn
PROTO_N ( (b) )
PROTO_T ( exp b )
{
flt64 x;
x = exp_to_f64(b);
x.big = ~x.big;
x.small = ~x.small;
if (x.small == (unsigned int)0xffffffff) {
++x.big;
};
++x.small;
bigres(b, &x);
return;
}
/* negate a constant exp, b, producing int */
static void not_fn
PROTO_N ( (b) )
PROTO_T ( exp b )
{
flt64 x;
x = exp_to_f64(b);
x.big = ~x.big;
x.small = ~x.small;
bigres(b, &x);
return;
}
/* auxiliary function used for comm_ass by mult */
static void mult_fn
PROTO_N ( (ap, b, et) )
PROTO_T ( exp ap X exp b X int et )
{
flt64 x;
flpt fa, fb;
int sg = is_signed(sh(ap));
flt resval;
int ov;
fa = f64_to_flt(exp_to_f64(ap), sg);
fb = f64_to_flt(exp_to_f64(b), sg);
IGNORE flt_mul (flptnos[fa], flptnos[fb], &resval);
/* status cannot be wrong */
flptnos[fa] = resval;
x = flt_to_f64(fa, sg, &ov);
if (et != f_wrap.err_code &&
(ov || constovf(b) || check_size(x, sg, shape_size(sh(ap)))))
setconstovf(ap);
if (sg && extra_checks &&
(ov || (shape_size(sh(ap)) <= 32 && check_size(x, sg, 32)))) {
failer(MULT_OUT_OF_BOUNDS);
exit(EXIT_FAILURE);
};
flpt_ret(fa);
flpt_ret(fb);
bigres(ap, &x);
return;
}
/* auxiliary function used for comm_ass by and */
static void and_fn
PROTO_N ( (ap, b, et) )
PROTO_T ( exp ap X exp b X int et )
{
flt64 xa, xb;
UNUSED (et);
xa = exp_to_f64(ap);
xb = exp_to_f64(b);
xa.small &= xb.small;
xa.big &= xb.big;
bigres(ap, &xa);
return;
}
/* auxiliary function used for comm_ass by or */
static void or_fn
PROTO_N ( (ap, b, et) )
PROTO_T ( exp ap X exp b X int et )
{
flt64 xa, xb;
UNUSED (et);
xa = exp_to_f64(ap);
xb = exp_to_f64(b);
xa.small |= xb.small;
xa.big |= xb.big;
bigres(ap, &xa);
return;
}
/* auxiliary function used for comm_ass by xor */
static void xor_fn
PROTO_N ( (ap, b, et) )
PROTO_T ( exp ap X exp b X int et )
{
flt64 xa, xb;
UNUSED (et);
xa = exp_to_f64(ap);
xb = exp_to_f64(b);
xa.small ^= xb.small;
xa.big ^= xb.big;
bigres(ap, &xa);
return;
}
/* not used for comm_ass */
static void domaxmin
PROTO_N ( (ap, b, mx) )
PROTO_T ( exp ap X exp b X int mx )
{
flt64 xa, xb;
int use_a;
xa = exp_to_f64(ap);
xb = exp_to_f64(b);
if (is_signed(sh(ap))) {
if (xa.big > xb.big)
use_a = mx;
if (xa.big < xb.big)
use_a = !mx;
if (xa.big == xb.big) {
if (xa.small >= xb.small)
use_a = mx;
else
use_a = !mx;
};
}
else {
if ((unsigned int)xa.big > (unsigned int)xb.big)
use_a = mx;
if ((unsigned int)xa.big < (unsigned int)xb.big)
use_a = !mx;
if (xa.big == xb.big) {
if (xa.small >= xb.small)
use_a = mx;
else
use_a = !mx;
};
};
SET(use_a);
if (use_a)
bigres(ap, &xa);
else
bigres(ap, &xb);
return;
}
/* produce allones for integer length of shape of e. */
static int all_ones
PROTO_N ( (e) )
PROTO_T ( exp e )
{
switch (shape_size(sh(e))) {
case 8:
return (0xff);
case 16:
return (0xffff);
default:
return (0xffffffff);
}
}
/* obey div1 on constants */
static void dodiv1
PROTO_N ( (ap, b) )
PROTO_T ( exp ap X exp b )
{
flt64 x;
flpt fa, fb;
int sg = is_signed(sh(ap));
flt resval;
int ov;
fa = f64_to_flt(exp_to_f64(ap), sg);
fb = f64_to_flt(exp_to_f64(b), sg);
IGNORE flt_div (flptnos[fa], flptnos[fb], &resval);
/* status cannot be wrong */
IGNORE flpt_round_to_integer((int)f_toward_smaller, &resval);
flptnos[fa] = resval;
x = flt_to_f64(fa, sg, &ov);
flpt_ret(fa);
flpt_ret(fb);
bigres(ap, &x);
return;
}
/* obey div2 on constants */
static void dodiv2
PROTO_N ( (ap, b) )
PROTO_T ( exp ap X exp b )
{
flt64 x;
flpt fa, fb;
int sg = is_signed(sh(ap));
flt resval;
int ov;
fa = f64_to_flt(exp_to_f64(ap), sg);
fb = f64_to_flt(exp_to_f64(b), sg);
IGNORE flt_div (flptnos[fa], flptnos[fb], &resval);
/* status cannot be wrong */
IGNORE flpt_round_to_integer((int)f_toward_zero, &resval);
flptnos[fa] = resval;
x = flt_to_f64(fa, sg, &ov);
flpt_ret(fa);
flpt_ret(fb);
bigres(ap, &x);
return;
}
/* obey mod on constants */
static void domod
PROTO_N ( (ap, b) )
PROTO_T ( exp ap X exp b )
{
exp top = copy(ap);
dodiv1(top, b);
mult_fn(b, top, f_wrap.err_code);
neg_fn(b);
plus_fn(ap, b, f_wrap.err_code);
return;
}
/* obey rem2 on constants */
static void dorem2
PROTO_N ( (ap, b) )
PROTO_T ( exp ap X exp b )
{
exp top = copy(ap);
dodiv2(top, b);
mult_fn(b, top, f_wrap.err_code);
neg_fn(b);
plus_fn(ap, b, f_wrap.err_code);
return;
}
/* obey shift (places signed) on constants */
static void doshl
PROTO_N ( (e) )
PROTO_T ( exp e )
{
flt64 x;
exp arg1 = son(e);
exp arg2 = bro(arg1);
int pl = no(arg2);
shape sha = sh(e);
int sg = is_signed(sha);
sh(arg1) = sh(e);
x = exp_to_f64(arg1);
if (name(e) == shl_tag) { /* shift left */
if (isbigval(arg2) || pl >= shape_size(sha)) {
no(arg1) = 0;
clearbigval(arg1);
return;
};
if (pl >= 32) {
x.big = (int)(x.small << (pl-32));
x.small = 0;
}
else {
x.big <<= pl;
x.big |= (int)(x.small >> (32-pl));
x.small <<= pl;
};
}
else { /* shift right */
if (isbigval(arg2) || pl >= shape_size(sha)) {
no(arg1) = 0;
if (sg) {
if (isbigval(arg1)) {
if (flptnos[no(arg1)].sign == -1)
no(arg1) = -1;
}
else
if (no(arg1) < 0)
no(arg1) = -1;
};
clearbigval(arg1);
return;
};
if (pl >= 32) {
if (sg) {
x.small = (unsigned int)(x.big >> (pl-32));
x.big = x.big >> 31;
}
else {
x.small = ((unsigned int)x.big) >> (pl-32);
x.big = 0;
};
}
else {
if (sg) {
x.small >>= pl;
x.small |= (unsigned int)(x.big << (32-pl));
x.big >>= pl;
}
else {
x.small >>= pl;
x.small |= (unsigned int)(x.big << (32-pl));
x.big = (int)(((unsigned int)x.big) >> pl);
};
};
};
bigres(arg1, &x);
return;
}
#if has_setcc
/* included if target has a setcc operation, to set a bit from the
condition flags */
static exp absbool
PROTO_N ( (id) )
PROTO_T ( exp id )
{
/* check if e is (let a = 0 in
cond(test(L)=result; a=1 | L:top); a )
If so, return the test, otherwise
nilexp. */
if (isvar (id) && name (son (id)) == val_tag && no (son (id)) == 0 &&
!isbigval(son(id))
&& 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));
#ifndef NEWDIAGS
if (name(c) == diagnose_tag)
c = son(c);
#endif
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 &&
!isbigval(bro(son(r))) &&
no (bro (son (r))) == 1 /* last of seq is id = 1 */ &&
last (s) && name (s) == test_tag && pt (s) == second
/* start of seq is int test jumping to second */
)
return s;
} /* cond is (seq= first | L: top) */
}; /* seq is cond=c; id */
if (last(c) && name(c) == condassign_tag) {
/* seq is condassign = c; id */
exp s = son (c);
exp r = bro (s);
if (name (son (r)) == name_tag &&
son (son (r)) == id && name (bro (son (r))) == val_tag &&
!isbigval(bro(son(r))) &&
no (bro (son (r))) == 1 /* last of seq is id = 1 */)
return s;
}; /* seq is condassign = c; id */
} /* one use is result of sequence body */
} /* name initially 0 only used twice */
return nilexp;
}
#endif
/* distributes the operation e into a sequence, ie if e = op(seq(d ...;
c), a) produces seq(d...; op(c,a)) */
static int seq_distr
PROTO_N ( (e, scope) )
PROTO_T ( exp e X exp scope )
{
exp x = son(e);
exp y;
if (last(x) || (!last(x) && last(bro(x)))) {
if (name(x) == seq_tag || name(x) == ident_tag) {
exp b = bro(son(x));
exp r;
if (name(x) == ident_tag) { clearinlined(x); }
if (last(x))
r = me_u3(sh(e), copy(b), name(e));
else {
#ifdef NEWDIAGS
if (diagnose)
dg_restruct_code (x, bro(x), +1);
#endif
r = me_b3(sh(e), copy(b), bro(x), name(e));
}
pt(r) = pt(e);
no(r) = no(e);
props(r) = props(e);
r = hold_check(r);
sh(x) = sh(e);
replace(b, r, r); /* dgf preserved in copy */
kill_exp(b, b);
#ifdef NEWDIAGS
if (diagnose)
dg_whole_comp (e, x);
#endif
replace(e, x, scope);
return 1;
};
};
if (!last(x) && last(bro(x))) {
y = bro(x);
if (name(y) == seq_tag || name(y) == ident_tag) {
exp b = bro(son(y));
exp r;
if (name(y) == ident_tag) { clearinlined(y); }
#ifdef NEWDIAGS
if (diagnose)
dg_restruct_code (y, x, -1);
#endif
r = me_b3(sh(e), x, copy(b), name(e));
pt(r) = pt(e);
no(r) = no(e);
props(r) = props(e);
r = hold_check(r);
sh(y) = sh(e);
replace(b, r, r); /* dgf preserved in copy */
kill_exp(b, b);
#ifdef NEWDIAGS
if (diagnose)
dg_whole_comp (e, y);
#endif
replace(e, y, scope);
return 1;
};
};
return 0;
}
/* reverses (ie. nots) test numbers */
unsigned char revtest[6] = {
4, 3, 2, 1, 6, 5
};
/* returns sign if |f|=1, otherwise 0 */
static int f_one
PROTO_N ( (f) )
PROTO_T ( flpt f )
{
flt fconst;
fconst = flptnos[f];
if (fconst.mant[0] == 1 && fconst.exp == 0) {
int i = 1;
while (i < MANT_SIZE && fconst.mant[i] == 0)
++i;
if (i == MANT_SIZE)
return (fconst.sign);
else
return (0);
}
else
return (0);
}
/* applies fneg */
static exp fneg
PROTO_N ( (e) )
PROTO_T ( exp e )
{
exp n = getexp (sh (e), nilexp, 0, e, nilexp, 0, 0, fneg_tag);
setlast (e);
bro (e) = n;
return (n);
}
/* applies binary floating point operations */
static int check_fp2
PROTO_N ( (e, scope) )
PROTO_T ( exp e X exp scope )
{
exp a1 = son (e);
exp a2 = bro (a1);
flpt f1, f2;
flt resval;
int status;
if (name (a1) == real_tag && name (a2) == real_tag) {
/* this will condense to a single constant */
f1 = no (a1);
f2 = no (a2);
switch (name (e)) EXHAUSTIVE {
case fplus_tag:
status = flt_add (flptnos[f1], flptnos[f2], &resval);
break;
case fminus_tag:
status = flt_sub (flptnos[f1], flptnos[f2], &resval);
break;
case fmult_tag:
status = flt_mul (flptnos[f1], flptnos[f2], &resval);
break;
case fdiv_tag:
status = flt_div (flptnos[f1], flptnos[f2], &resval);
break;
}
if (status == OKAY) {
flpt_round((int)f_to_nearest,
flpt_bits((floating_variety)(name(sh(e)) - shrealhd)),
&resval);
flptnos[f1] = resval;
flpt_ret (f2);
replace (e, a1, scope);
retcell (e);
retcell (a2);
return (1);
}
else
return (0);
}
else { /* see if one arg is constant */
exp v_arg, c_arg;
if (name (a1) == real_tag) {
f1 = no (a1);
c_arg = a1;
v_arg = a2;
}
else
if (name (a2) == real_tag) {
f1 = no (a2);
c_arg = a2;
v_arg = a1;
}
else
return (0); /* no change possible */
switch (name (e)) {
case fplus_tag:
if (flptnos[f1].sign == 0) {
/* x+0 or 0+x */
flpt_ret (f1);
replace (e, v_arg, scope);
retcell (e);
retcell (c_arg);
return (1);
}
else
return (0);
case fminus_tag:
if (flptnos[f1].sign == 0) {
/* x-0 or 0-x */
flpt_ret (f1);
if (v_arg == a2) {
/* 0-x = -x */
v_arg = fneg (v_arg);
}
replace (e, v_arg, scope);
retcell (e);
retcell (c_arg);
return (1);
}
else
return (0);
case fmult_tag:
if (flptnos[f1].sign == 0) {
/* x*0 or 0*x */
replace (e, c_arg, scope);
retcell (e);
kill_exp (v_arg, scope);
return (1);
}
else {
int u = f_one (f1);
if (u == 0)
return (0);
/* x*1 or x*(-1) or 1*x or (-1)*x */
if (u == -1)
v_arg = fneg (v_arg);
flpt_ret (f1);
replace (e, v_arg, scope);
retcell (e);
retcell (c_arg);
return (1);
}
case fdiv_tag:
if (flptnos[f1].sign == 0 && v_arg == a2) {
/* 0/x */
replace (e, c_arg, scope);
retcell (e);
kill_exp (v_arg, scope);
return (1);
}
else {
int u = f_one (f1);
if (u == 0 || v_arg == a2)
return (0);
/* x/1 or x/(-1) */
if (u == -1)
v_arg = fneg (v_arg);
flpt_ret (f1);
replace (e, v_arg, scope);
retcell (e);
retcell (c_arg);
return (1);
}
}
};
return (0);
}
/* compares integer constants using the test given by test_no */
static int docmp
PROTO_N ( (sha, test_no, c1, c2) )
PROTO_T ( shape sha X unsigned char test_no X int c1 X int c2 )
{
int c;
switch (shape_size(sha)) EXHAUSTIVE {
case 8:
if (is_signed(sha))
{
int d1 = (c1 & 0x80) ? (c1 | ~0x7f) : (c1 & 0xff);
int d2 = (c2 & 0x80) ? (c2 | ~0x7f) : (c2 & 0xff);
switch (test_no) EXHAUSTIVE {
case 1:
c = (d1 > d2);
break;
case 2:
c = (d1 >= d2);
break;
case 3:
c = (d1 < d2);
break;
case 4:
c = (d1 <= d2);
break;
case 5:
c = (d1 == d2);
break;
case 6:
c = (d1 != d2);
break;
};
break;
}
else
{
unsigned char d1 = (unsigned char)(c1 & 0xff);
unsigned char d2 = (unsigned char)(c2 & 0xff);
switch (test_no) EXHAUSTIVE {
case 1:
c = (d1 > d2);
break;
case 2:
c = (d1 >= d2);
break;
case 3:
c = (d1 < d2);
break;
case 4:
c = (d1 <= d2);
break;
case 5:
c = (d1 == d2);
break;
case 6:
c = (d1 != d2);
break;
};
break;
};
case 16:
if (is_signed(sha))
{
int d1 = (c1 & 0x8000) ? (c1 | ~0x7fff) : (c1 & 0xffff);
int d2 = (c2 & 0x8000) ? (c2 | ~0x7fff) : (c2 & 0xffff);
switch (test_no) EXHAUSTIVE {
case 1:
c = (d1 > d2);
break;
case 2:
c = (d1 >= d2);
break;
case 3:
c = (d1 < d2);
break;
case 4:
c = (d1 <= d2);
break;
case 5:
c = (d1 == d2);
break;
case 6:
c = (d1 != d2);
break;
};
break;
}
else
{
unsigned short d1 = (unsigned short)(c1 & 0xffff);
unsigned short d2 = (unsigned short)(c2 & 0xffff);
switch (test_no) EXHAUSTIVE {
case 1:
c = (d1 > d2);
break;
case 2:
c = (d1 >= d2);
break;
case 3:
c = (d1 < d2);
break;
case 4:
c = (d1 <= d2);
break;
case 5:
c = (d1 == d2);
break;
case 6:
c = (d1 != d2);
break;
};
break;
};
case 32:
if (is_signed(sha))
{
int d1 = c1;
int d2 = c2;
switch (test_no) EXHAUSTIVE {
case 1:
c = (d1 > d2);
break;
case 2:
c = (d1 >= d2);
break;
case 3:
c = (d1 < d2);
break;
case 4:
c = (d1 <= d2);
break;
case 5:
c = (d1 == d2);
break;
case 6:
c = (d1 != d2);
break;
};
break;
}
else
{
unsigned int d1 = (unsigned int)c1;
unsigned int d2 = (unsigned int)c2;
switch (test_no) EXHAUSTIVE {
case 1:
c = (d1 > d2);
break;
case 2:
c = (d1 >= d2);
break;
case 3:
c = (d1 < d2);
break;
case 4:
c = (d1 <= d2);
break;
case 5:
c = (d1 == d2);
break;
case 6:
c = (d1 != d2);
break;
};
break;
};
};
return (c);
}
int docmp_f
PROTO_N ( (test_no, a, b) )
PROTO_T ( int test_no X exp a X exp b )
{
shape sha = sh(a);
flt64 xa, xb;
int sg = is_signed(sha);
int eq = 0;
int less = 0;
int gr = 0;
int c;
if (shape_size(sh(a)) <= 32)
return docmp(sha, (unsigned char)test_no, no(a), no(b));
xa = exp_to_f64(a);
xb = exp_to_f64(b);
if (xa.big == xb.big && xa.small == xb.small)
eq = 1;
if (sg && !eq) {
if (xa.big < xb.big)
less = 1;
else
if (xa.big > xb.big)
gr = 1;
else {
if (xa.small < xb.small)
less = 1;
else
gr = 1;
};
}
else
if (!eq) {
if ((unsigned int)xa.big < (unsigned int)xb.big)
less = 1;
else
if ((unsigned int)xa.big > (unsigned int)xb.big)
gr = 1;
else {
if (xa.small < xb.small)
less = 1;
else
gr = 1;
};
};
switch (test_no) EXHAUSTIVE {
case 1:
c = gr;
break;
case 2:
c = gr | eq;
break;
case 3:
c = less;
break;
case 4:
c = less | eq;
break;
case 5:
c = eq;
break;
case 6:
c = !eq;
break;
};
return c;
}
/* main bottom-to-top optimise routine
Optimises e. No change propagates
outside scope */
int check
PROTO_N ( (e, scope) )
PROTO_T ( exp e X exp scope )
{
if (is_a (name (e))) {/* main op non-side effect */
unsigned char n = name(e);
if (son(e) != nilexp && n != name_tag && n != env_offset_tag &&
n != general_env_offset_tag &&
n != proc_tag && n != general_proc_tag) {
exp temp = son(e);
while (1) {
if (name(sh(temp)) == bothd) {
/* unordered; temp can be first, iwc all siblings unreachable */
#ifdef NEWDIAGS
if (diagnose) {
exp sib = son(e);
for (;;) {
if (sib != temp)
dg_dead_code (sib, temp);
if (last(sib))
break;
sib = bro(sib);
}
dg_whole_comp (e, temp);
}
#endif
replace(e, temp, scope);
retcell(e);
return 1;
};
if (last(temp))
break;
temp = bro(temp);
}
}
switch (name (e)) {
case component_tag:
{
exp v = son(e);
exp a = bro(v);
if (name(a) == val_tag)
{
exp res;
if (no(a) == 0 && shape_size(sh(v)) == shape_size(sh(e))
#if dont_unpad_apply
&& name(v) != apply_tag
#endif
) { /* remove the operation if the offset
is zero and the size is the same.
This typically happens in selecting
from a union if the component has
the maximum size in the union */
sh(v) = sh(e);
#ifdef NEWDIAGS
if (diagnose)
dg_whole_comp (e, v);
#endif
replace(e, v, scope);
retcell(a);
retcell(e);
return 1;
};
/* otherwise use field_tag */
res = getexp(sh(e), nilexp, 0, v, nilexp,
0, no(a), field_tag);
setfather(res, son(res));
#ifdef NEWDIAGS
dgf(res) = dgf(e);
#endif
replace(e, hold_check(res), scope);
retcell(e);
retcell(a);
return 1;
};
if (name(v) == cont_tag) /* replace selecting from contents
by taking contents of reff selection
*/
{
exp ap = hold_check(f_add_to_ptr(son(v), a));
ap = hold_check(f_contents(sh(e), ap));
#ifdef NEWDIAGS
if (diagnose) {
dg_whole_comp (v, ap);
dg_whole_comp (e, ap);
}
#endif
replace(e, ap, scope);
retcell(v);
retcell(e);
return 1;
};
{ /* always remove component_tag: use a declaration */
exp var = me_startid(sh(e), v, 1);
exp ap, c;
exp ob;
ob = me_obtain(var);
ap = hold_check(f_add_to_ptr(ob, a));
c = hold_check(f_contents(sh(e), ap));
var = me_complete_id(var, c);
#ifdef NEWDIAGS
if (diagnose)
dg_whole_comp (e, var);
#endif
replace(e, var, scope);
retcell(e);
return 1;
};
};
case offset_pad_tag:
if (name(son(e)) == val_tag && !isbigval(son(e)))
{
/* constant evaluation */
int al = al2(sh(e));
if (al == 0)
al = 1;
if (al2_of(sh(e))->al.sh_hd > nofhd)
al = shape_align(f_pointer(al2_of(sh(e))));
#if ishppa
if ((al1_of(sh(e))->al.al_val.al_frame & 4)!=0) {
no(son(e)) = -rounder(-no(son(e)),al);
}
else
#endif
no(son(e)) = rounder(no(son(e)), al);
sh(son(e)) = sh(e);
#ifdef NEWDIAGS
if (diagnose)
dg_whole_comp (e, son(e));
#endif
replace(e, son(e), scope);
retcell(e);
return 1;
};
return 0;
case offset_add_tag:
{
if (name (son (e)) == val_tag &&
name (bro (son (e))) == val_tag &&
!isbigval(son(e)) && !isbigval(bro(son(e)))) {
/* both arguments constant */
int n;
exp a = son(e);
exp b = bro(a);
n = no(a) + no(b);
no (a) = n;
sh (a) = sh (e);
retcell (b);
replace (e, a, scope);
retcell (e);
return (1);
};
return 0;
};
case offset_subtract_tag:
{
if (name (son (e)) == val_tag &&
name (bro (son (e))) == val_tag &&
!isbigval(son(e)) && !isbigval(bro(son(e)))) {
/* both arguments constant */
no (son (e)) -= no(bro(son(e)));
sh (son (e)) = sh (e);
retcell (bro (son (e)));
replace (e, son (e), scope);
retcell (e);
return (1);
};
return 0;
};
case offset_negate_tag:
{
if (name (son (e)) == val_tag && !isbigval(son(e))) {
/* argument constant */
no (son (e)) = - no(son(e));
sh (son (e)) = sh (e);
#ifdef NEWDIAGS
if (diagnose)
dg_whole_comp (e, son(e));
#endif
replace (e, son (e), scope);
retcell (e);
return (1);
};
return 0;
};
case offset_max_tag:
{
if (name (son (e)) == val_tag &&
name (bro (son (e))) == val_tag &&
!isbigval(son(e)) && !isbigval(bro(son(e)))) {
/* both arguments constant */
int n1 = no(son(e));
int n2 = no(bro(son(e)));
no (son (e)) = (n1 > n2) ? n1 : n2;
sh (son (e)) = sh (e);
retcell (bro (son (e)));
replace (e, son (e), scope);
retcell (e);
return (1);
};
return 0;
};
case offset_mult_tag:
{
if (name (son (e)) == val_tag &&
name (bro (son (e))) == val_tag &&
!isbigval(son(e)) && !isbigval(bro(son(e)))) {
/* both arguments constant */
int n1 = no(son(e));
int n2 = no(bro(son(e)));
no (son (e)) = n1 * n2;
sh (son (e)) = sh (e);
retcell (bro (son (e)));
replace (e, son (e), scope);
retcell (e);
return (1);
};
if (name(son(e)) == val_tag && !isbigval(son(e))&&
no(son(e)) == 1)
{ /* multiply by 1 */
sh(bro(son(e))) = sh(e);
replace(e, bro(son(e)), scope);
retcell(e);
return (1);
};
if (name(son(e)) == val_tag && !isbigval(son(e)) && no(son(e)) == 0)
{ /* multiply by 0 - replace by sequence - side-effects!*/
exp_list el;
el.start = bro(son(e));
el.end = bro(son(e));
el.number = 1;
sh(son(e)) = sh(e);
replace(e, f_sequence(el, son(e)), scope);
retcell(e);
return (1);
};
if (name(bro(son(e))) == val_tag &&
name(son(e)) == plus_tag)
{ /* distribute offset_mult over plus (giving
offset_adds) */
exp pl = son(e); /* the plus operation */
exp b = bro(pl); /* the offset constant */
exp x = son(pl); /* the first plus operand */
exp bx = bro(x);
exp res = hold_check(me_b3(sh(e), x, copy(b),
offset_mult_tag));
exp temp;
while (bx != pl) {
x = bx;
bx = bro(x);
temp = hold_check(me_b3(sh(e), x, copy(b),
offset_mult_tag));
res = hold_check(me_b3(sh(e), res, temp, offset_add_tag));
};
retcell(b);
replace(e, res, scope);
retcell(e);
return 1;
};
return 0;
};
case offset_div_by_int_tag:
case offset_div_tag:
{
if (name (son (e)) == val_tag &&
name (bro (son (e))) == val_tag &&
!isbigval(son(e)) && !isbigval(bro(son(e)))) {
/* both arguments constant */
int n1 = no(son(e));
int n2 = no(bro(son(e)));
no (son (e)) = n1 / n2;
sh (son (e)) = sh (e);
retcell (bro (son (e)));
replace (e, son (e), scope);
retcell (e);
return (1);
};
return 0;
};
#if has_setcc
case absbool_tag:
{
exp arg1 = son(e);
exp arg2 = bro(arg1);
ntest nt = test_number(e);
if ((name (arg1) == val_tag || name (arg1) == null_tag) &&
(name (arg2) == val_tag ||
name (arg2) == null_tag)) {
/* argument constant */
no (arg1) = docmp_f ((int)nt, arg1, arg2);
setname (arg1, val_tag);
sh (arg1) = sh (e);
clearbigval(arg1);
retcell (arg2);
replace (e, arg1, scope);
retcell (e);
return (1);
};
if (name(arg1) == val_tag || name(arg1) == real_tag ||
name(arg1) == null_tag) {
/* constant argument always second */
son(e) = arg2;
bro(arg2) = arg1;
bro(arg1) = e;
setlast(arg1);
clearlast(arg2);
nt = exchange_ntest[nt];
settest_number(e, nt);
};
return 0;
};
#endif
case plus_tag: /* apply commutative and associative laws
*/
#if is80x86
{
exp arg1 = son(e);
exp arg2 = bro(arg1);
if (!optop(e))
return 0;
if (name(arg1) == val_tag && name(arg2) == val_tag)
{
plus_fn(arg1, arg2, errhandle(e));
sh(arg1) = sh(e);
#ifdef NEWDIAGS
if (diagnose) {
if (dgf(arg1))
dg_detach_const (arg1, e);
if (dgf(arg2))
dg_detach_const (arg2, e);
dgf(arg1) = dgf(e);
}
#endif
replace(e, arg1, scope);
retcell(e);
return 1;
};
if (name(arg1) == val_tag)
{
exp q = hold_check(f_plus(f_impossible, arg2, arg1));
#ifdef NEWDIAGS
if (diagnose)
dg_whole_comp (e, q);
#endif
replace(e, q, scope);
retcell(e);
return 1;
};
if (name(arg2) == plus_tag && name(bro(son(arg2))) == val_tag &&
optop(arg2))
{
exp con = bro(son(arg2));
exp x = hold_check(f_plus(f_impossible,
hold_check(f_plus(f_impossible, arg1,
son(arg2))),
con));
#ifdef NEWDIAGS
if (diagnose)
dg_whole_comp (e, x);
#endif
replace(e, x, scope);
retcell(e);
return 1;
};
if (name(arg1) == plus_tag && name(bro(son(arg1))) == val_tag &&
optop(arg1))
{
exp x = hold_check(f_plus(f_impossible,
son(arg1),
hold_check(f_plus(f_impossible,
arg2,
bro(son(arg1))))));
#ifdef NEWDIAGS
if (diagnose)
dg_whole_comp (e, x);
#endif
replace(e, x, scope);
retcell(e);
return 1;
};
if (name(arg2) == plus_tag && name(arg1) != plus_tag &&
optop(arg2))
{
exp t = bro(son(arg2));
exp x = hold_check(f_plus(f_impossible,
hold_check(f_plus(f_impossible, arg1,
son(arg2))),
t));
#ifdef NEWDIAGS
if (diagnose)
dg_whole_comp (e, x);
#endif
replace(e, x, scope);
retcell(e);
return 1;
};
return seq_distr(e, scope);
};
#else
return (comm_ass (e, plus_tag, plus_fn,
0, 0, 0, scope, 1, 0));
#endif
case fplus_tag: /* apply zero, unit and constant
evaluation.
NB dive MUST be false, because
floating point is not really
commutative and associative
*/
return (comm_ass (e, fplus_tag, fplus_fn,
fzero_no, 0, 0, scope, 0, 1));
case addptr_tag:
{
if ((name (son (e)) == null_tag ||
name (son (e)) == val_tag) && !isbigval(son(e)) &&
no (son (e)) == 0) {
if (name (bro (son (e))) == val_tag &&
!isbigval(bro(son(e))) &&
al2(sh(bro(son(e)))) > 1) { /* constant evaluation */
sh (bro (son (e))) = sh (e);
no (bro (son (e))) /= 8;
#ifdef NEWDIAGS
if (diagnose)
dg_whole_comp (e, bro(son(e)));
#endif
replace (e, bro (son (e)), scope);
retcell (son (e));
retcell (e);
return (1);
};
};
#if isAlpha
{ exp ptr = son(e);
exp off = bro(ptr);
if ((al1_of(sh(off))->al.al_val.al_frame & 4) != 0 &&
!is_floating(al2_of(sh(off))->al.sh_hd)) {
exp r = getexp (sh(ptr), off, 0, ptr, nilexp,
0, 6*64, reff_tag);
sh(off) = f_offset(al1_of(sh(off)), long_to_al(al2(sh(off))));
bro(ptr)=r; setlast(ptr);
son(e) = r;
}
}
#endif
if (name (bro (son (e))) == val_tag &&
!isbigval(bro (son (e)))) {
/* replace addptr(x, const) by refffield operation */
exp p = son (e);
int k = no (bro (p));
exp r;
r = getexp (sh (e), nilexp, 0, p, nilexp,
0, k, reff_tag);
#ifdef NEWDIAGS
dgf(r) = dgf(e);
#endif
replace (e, hc (r, p), scope);
retcell (e);
return (1);
};
if (name (son (e)) == reff_tag &&
shape_size(sh(e)) == 32) {
/* replace addptr(reff[n](a), b) by reff[n](addptr(a, b)) */
exp p = son (son (e));
exp a = bro (son (e));
exp ap1 = getexp (sh (e), nilexp, 0, p, nilexp,
0, 0, addptr_tag);
exp ap, r;
bro (p) = a;
clearlast (p);
#if NEWDIAGS
if (diagnose)
dg_whole_comp (son(e), p);
#endif
ap = hc (ap1, a);
r = hc (getexp (sh (e), nilexp, 0, ap, nilexp,
0, no (son (e)), reff_tag),
ap);
#if NEWDIAGS
if (diagnose)
dg_whole_comp (e, r);
#endif
replace (e, r, scope);
retcell (son (e));
retcell (e);
return (1);
};
if (name(bro(son(e))) == offset_add_tag)
{
exp p = son(e);
exp a = son(bro(p));
exp c = bro(a);
if (name(c) == val_tag && !isbigval(c)) {
exp ap =
hold_check(me_b3(f_pointer(long_to_al(al2(sh(a)))),
p, a, addptr_tag));
exp r = getexp(sh(e), nilexp, 0, ap, nilexp, 0,
no(c), reff_tag);
setfather(r, ap);
#ifdef NEWDIAGS
dgf(r) = dgf(e);
#endif
replace(e, hold_check(r), scope);
retcell(e);
return 1;
};
if (al1(sh(p)) == al2(sh(c))) {
exp inner, outer;
inner = hold_check(me_b3(sh(e), p, a, addptr_tag));
#ifdef NEWDIAGS
if (diagnose)
dg_whole_comp (bro(p), inner);
#endif
outer = hold_check(me_b3(sh(e), inner, c, addptr_tag));
#ifdef NEWDIAGS
if (diagnose)
dg_whole_comp (e, outer);
/* also represent movement of c !!!!!!!!!!!!!!!!!!!!!!!!! */
#endif
replace(e, outer, scope);
retcell(e);
return 1;
};
};
return 0;
};
case chvar_tag: {
#ifdef value_of_null
if (name(son(e))==null_tag) {
setname(son(e), val_tag);
no(son(e))= value_of_null;
clearbigval(son(e));
sh (son (e)) = sh(e);
#ifdef NEWDIAGS
if (diagnose)
dg_whole_comp (e, son(e));
#endif
replace (e, son (e), scope);
retcell (e);
return (1);
};
#endif
if (name (son (e)) == val_tag && optop(e)) {
/* evaluate chvar(const) */
int bg;
flt64 x;
shape sha = sh(e);
x = exp_to_f64(son(e));
/*
#if has64bits
int sg = is_signed(sha);
if (extra_checks && sg && !in_proc_def &&
shape_size(sha) <= 32 && check_size(x, sg, 32)) {
failer("Change_variety out of range");
exit(EXIT_FAILURE);
};
#endif
*/
dochvar_f (&x, sha);
no(son(e)) = f64_to_flpt(x, is_signed(sha), &bg,
shape_size(sha));
if (bg)
setbigval(son(e));
else
clearbigval(son(e));
sh (son (e)) = sha;
#ifdef NEWDIAGS
if (diagnose)
dg_whole_comp (e, son(e));
#endif
replace (e, son (e), scope);
retcell (e);
return (1);
};
if (eq_shape (sh (e), sh (son (e)))) {
/* replace identity chvar by argument */
#ifdef NEWDIAGS
if (diagnose)
dg_whole_comp (e, son(e));
#endif
replace (e, son (e), scope);
retcell (e);
return (1);
};
if (name(son(e)) == chvar_tag &&
shape_size(sh(e)) == shape_size(sh(son(son(e)))) &&
name(sh(son(e))) == bitfhd) {
exp res = hold_check(me_u3(sh(e), son(son(e)), chvar_tag));
replace(e, res, scope);
retcell(e);
return 1;
};
if (name(son(e)) == chvar_tag && !is_signed(sh(e)) &&
shape_size(sh(e)) == shape_size(sh(son(e)))) {
replace(e, hold_check(me_u3(sh(e), son(son(e)), chvar_tag)),
scope);
retcell(e);
return 1;
};
if (name(son(e)) == chvar_tag && !is_signed(sh(e)) &&
shape_size(sh(e)) < shape_size(sh(son(e))) &&
shape_size(sh(e)) == shape_size(sh(son(son(e))))) {
replace(e, hold_check(me_u3(sh(e), son(son(e)), chvar_tag)),
scope);
retcell(e);
return 1;
};
#if little_end & has_byte_regs
/* only for little enders which have byte registers */
if ((shape_size(sh(e)) <= shape_size(sh(son(e)))) && optop(e) &&
(name (son (e)) == name_tag ||
name (son (e)) == cont_tag ||
name (son (e)) == cond_tag
)) {
/* if the chvar operation never needs any action for a little
end machine, eliminate it */
#if is80x86
if (shape_size(sh(e)) == 8) {
if (name (son (e)) == name_tag)
setvis(son(son(e)));
if (name (son (e)) == cont_tag &&
name(son(son(e))) == name_tag )
setvis(son(son(son(e))));
};
#endif
sh (son (e)) = sh (e);
replace (e, son (e), scope);
/* should this retcell(e) ? */
return (1);
};
/* only for little enders which have byte registers */
if (name (son (e)) == chvar_tag &&
shape_size(sh(e)) <= shape_size(sh (son (e)))) {
/* if the chvar operation never needs any action for a little
end machine, eliminate it */
exp w;
sh (son (e)) = sh (e);
w = hold (son (e));
IGNORE check (son (w), son (w));
replace (e, son (w), scope);
retcell (e);
retcell (w);
return (1);
};
#endif
#if little_end & has_byte_ops
/* only for little enders with byte and short operations */
if (shape_size(sh(e)) <= shape_size(sh (son (e))) && optop(e) &&
name(sh(e)) != bitfhd &&
(name (son (e)) == plus_tag ||
name (son (e)) == minus_tag ||
name (son (e)) == and_tag ||
name (son (e)) == or_tag ||
name (son (e)) == neg_tag
)
) {
/* replace chvar(op(a ...)) by op(chvar(a)...) if the
changevar requires no action on a little end machine */
#if only_lengthen_ops
exp p = son (e);
exp r;
exp a = son (p);
exp n = bro (a);
int l = (int)last (a);
/*
if (shape_size(sh(e)) >= 16)
*/
/* this is to avoid allocating bytes to edi/esi in 80386 !!! bad
*/
#endif
{
exp sha = sh (e);
exp t = varchange (sha, a);
exp q = t;
while (!l) {
l = (int)last (n);
a = n;
n = bro (n);
setbro (q, varchange (sha, a));
clearlast (q);
q = bro (q);
};
r = getexp (sha, nilexp, 0, t, pt (p), 0, no (p),
name (p));
seterrhandle(r, errhandle(e));
replace (e, hc (r, q), scope);
retcell (e);
return (1);
};
};
#endif
if (name (son (e)) == ident_tag && isvar (son (e))) {
/* distribute chvar into variable declaration of simple form
*/
exp vardec = son (e);
exp def = son (vardec);
exp body = bro (def);
exp res;
bool go = 1;
exp t, u, v;
if (name (body) != seq_tag)
return (0);
res = bro (son (body));
if (name (res) != cont_tag || name (son (res)) != name_tag ||
son (son (res)) != vardec)
return (0);
t = pt (vardec);
while (t != nilexp && go) {
if (t == son (res) || (!last (t) &&
name (bro (bro (t))) == ass_tag))
t = pt (t);
else
go = 0;
};
if (!go)
return (0);
if (name(def) == clear_tag) {
u = copy(def);
sh(u) = sh(e);
}
else
u = varchange (sh (e), copy (def));
replace (def, u, u);
kill_exp (def, def);
sh (res) = sh (e);
sh (body) = sh(e);
t = pt (vardec);
while (t != nilexp) {
if (t != son (res)) {
v = bro (t);
u = varchange (sh (e), copy (v));
replace (v, u, u);
kill_exp (v, def);
};
t = pt (t);
};
sh (vardec) = sh (e);
replace (e, vardec, scope);
retcell (e);
return (1);
};
return 0;
};
case bitf_to_int_tag:
{
if (newcode) {
exp temp = son(e);
int szbf = shape_size(sh(temp));
shape sha;
int sg = is_signed(sh(temp));
int s;
if (szbf <= 8)
sha = (sg) ? scharsh : ucharsh;
else
if (szbf <= 16)
sha = (sg) ? swordsh : uwordsh;
else
if (szbf <= 32)
sha = (sg) ? slongsh : ulongsh;
else
sha = (sg) ? s64sh : u64sh;
if (name(sh(temp)) == bitfhd && name(temp) == chvar_tag) {
exp st = son(temp);
int n = name(st);
if ((n == cont_tag && szbf == shape_size(sh(st))) ||
( n==and_tag && name(bro(son(st)))== val_tag &&
no(bro(son(st))) == (1<<szbf)-1 ) ||
( n==shr_tag && name(bro(son(st)))== val_tag &&
no(bro(son(st))) == shape_size(sh(st))-szbf) ) {
/* arises from bfcont_tag */
replace(e, hold_check(me_u3(sh(e), st, chvar_tag)),
scope);
retcell(e);
retcell(temp);
return 1;
}
};
sh(temp) = sha;
if (sg) {
#if isAlpha
s = shape_size(s64sh) - szbf;
if (s != 0) {
temp = hold_check(me_u3(s64sh, temp, chvar_tag));
temp =
hold_check(me_b3(s64sh, temp,
me_shint(s64sh, s), shl_tag));
temp =
hold_check(me_b3(s64sh, temp,
me_shint(s64sh, s), shr_tag));
};
#else
s = shape_size(sha) - szbf;
if (s != 0) {
temp =
hold_check(me_b3(sha, temp, me_shint(sha, s),
shl_tag));
temp =
hold_check(me_b3(sha, temp, me_shint(sha, s),
shr_tag));
};
#endif
}
else {
int mask = (szbf == 32) ? -1 : (1 << szbf) - 1;
temp = hold_check(me_b3(sha, temp,
me_shint(sha, mask), and_tag));
};
replace(e, hold_check(me_u3(sh(e), temp, chvar_tag)), scope);
retcell(e);
return 1;
};
return 0;
};
case int_to_bitf_tag:
{
if (newcode) {
exp temp = son(e);
shape sha = sh(temp);
int szbf = shape_size(sh(e));
int sg = is_signed(sh(e));
if (shape_size(sh(son(e))) < szbf) {
if (szbf <= 32)
sha = (sg) ? slongsh : ulongsh;
else
sha = (sg) ? s64sh : u64sh;
temp = hold_check(me_u3(sha, temp, chvar_tag));
}
else {
UNUSED(sha);
};
temp = hold_check(me_u3(sh(e), temp, chvar_tag));
replace(e, temp, scope);
retcell(e);
return 1;
};
return 0;
};
case minptr_tag:
{
exp s = son(e);
exp b = bro(s);
if (name (s) == val_tag &&
name (b) == null_tag) {
sh (s) = sh (e);
no(s) -= no(b);
no (s) *= 8;
replace (e, s, scope);
retcell (e);
return (1);
};
if (name (s) == val_tag &&
name (b) == val_tag) {/* both constants */
sh (s) = sh (e);
no (s) -= no (bro (son (e)));
no (s) *= 8;
replace (e, s, scope);
retcell (e);
return (1);
};
if (name(b) == null_tag && no(b) == 0) {
sh (s) = sh (e);
replace(e, s, scope);
retcell(e);
return 1;
};
if (name(s) == name_tag && name(b) == name_tag &&
son(s) == son(b)) {
int n = no(s) - no(b);
exp r;
r = getexp(sh(e), nilexp, 0, nilexp, nilexp,
0, n, val_tag);
kill_exp(s, s);
kill_exp(b, b);
replace(e, r, scope);
retcell(e);
return 1;
};
return 0;
};
case minus_tag: {
exp z, a2, r;
exp arg1 = son(e);
exp arg2 = bro(arg1);
if (!optop(e))
return 0;
if (name(arg1) == val_tag && name(arg2) == val_tag)
{
minus_fn(arg1, arg2, errhandle(e));
sh(arg1) = sh(e);
replace(e, arg1, scope);
retcell(e);
return 1;
};
/* replace a-b by a+(-b) */
z = getexp (sh (e), nilexp, 0, bro (son (e)), pt(e),
0, 0,
neg_tag);
seterrhandle(z, errhandle(e));
a2 = hc (z, bro (son (e)));
r = getexp (sh (e), nilexp, 0, son (e), pt(e),
0, 0, plus_tag);
seterrhandle(r, errhandle(e));
#ifdef NEWDIAGS
dgf(r) = dgf(e);
#endif
bro (son (e)) = a2;
replace (e, hc (r, a2), scope);
retcell (e);
return (1);
};
case mult_tag: {
if (!optop(e))
return 0;
if (name (bro (son (e))) == val_tag &&
last (bro (son (e))) &&
name (son (e)) == plus_tag &&
name (bro (son (son (e)))) == val_tag) {
/* replace mult(plus(a,const1), const2) by plus(mult(a,
const2), const1*const2) */
int k = no (bro (son (e))) * no (bro (son (son (e))));
exp ke = me_shint(sh(e), k);
exp m = getexp (sh (e), nilexp, 0, son (son (e)),
nilexp, 0, 0, mult_tag);
exp m1, pa;
setbro (son (m), copy (bro (son (e))));
clearlast (son (m));
m1 = hc (m, bro (son (m)));
pa = getexp (sh (e), nilexp, 0, m1, nilexp, 0, 0, plus_tag);
bro (m1) = ke;
clearlast (m1);
replace (e, hc (pa, ke), scope);
retcell (e);
return (1);
};
/* apply commutative and associative laws */
#if is80x86
return (comm_ass (e, mult_tag, mult_fn,
1, 1, 0, scope, 0, 0));
#else
return (comm_ass (e, mult_tag, mult_fn,
1, 1, 0, scope, 1, 0));
#endif
};
case subptr_tag: {
/* replace subptr(a, b) by addptr(a, (-b)) */
exp z = getexp (sh (e), nilexp, 0, bro (son (e)), nilexp,
0, 0, neg_tag);
exp a2 = hc (z, bro (son (e)));
exp r = getexp (sh (e), nilexp, 0, son (e), nilexp, 0,
0, addptr_tag);
bro (son (e)) = a2;
#ifdef NEWDIAGS
if (diagnose)
dgf(r) = dgf(e);
#endif
replace (e, hc (r, a2), scope);
retcell (e);
return (1);
};
case neg_tag: {
if (!optop(e))
return 0;
if (name (son (e)) == val_tag) {/* eval for const */
neg_fn (son (e));
sh(son(e)) = sh(e);
#ifdef NEWDIAGS
if (diagnose)
dg_whole_comp (e, son(e));
#endif
replace (e, son (e), scope);
retcell (e);
return (1);
};
if (name (son (e)) == neg_tag &&
optop(e) && optop (son (e))) {
/* replace --a by a if errtreat is impossible or ignore */
sh(son(son(e))) = sh(e);
#ifdef NEWDIAGS
if (diagnose) {
dg_whole_comp (son(e), son(son(e)));
dg_whole_comp (e, son(son(e)));
}
#endif
replace (e, son (son (e)), scope);
retcell (son (e));
retcell (e);
return (1);
};
if (name (son (e)) == plus_tag &&
optop(e) &&
optop (son (e))) {
/* replace negate(plus(a,b ..)) by plus(negate(a), negate(b)
..)) */
exp r = getexp (sh (e), nilexp, 0, nilexp, nilexp,
0,
0, plus_tag);
exp t = son (son (e));
exp p = r;
int lst;
do {
exp q = hold (getexp (sh (e), nilexp, 0, t,
nilexp, 0, 0, neg_tag));
exp next = bro (t);
lst = (int)last (t);
bro (t) = son (q);
setlast (t);
IGNORE check (son (q), scope);
bro (p) = son (q);
retcell (q);
p = bro (p);
clearlast (p);
t = next;
}
while (!lst);
son (r) = bro (r);
#ifdef NEWDIAGS
if (diagnose)
dg_whole_comp (e, r);
#endif
replace (e, hc (r, p), scope);
retcell (e);
return (1);
};
return 0;
};
case shl_tag:
case shr_tag: {
if (name (bro (son (e))) == val_tag && no (bro (son (e))) == 0) {
/* remove zero place shift */
sh(son(e)) = sh(e);
replace (e, son (e), scope);
retcell (e);
return (1);
};
if (name (son (e)) == val_tag &&
name (bro (son (e))) == val_tag) {
/* evaluate if both args constant */
doshl(e);
sh(son(e)) = sh(e);
replace (e, son (e), scope);
retcell (e);
return (1);
};
#if ismips
if (name(bro (son (e))) == val_tag &&
no (bro (son (e))) == shape_size(sh(e)) ) {
exp s1 = copy(e);
no(bro (son (s1)))--;
if (name(e)==shl_tag) {
s1 = f_shift_left(f_continue, s1,
me_shint(sh(bro(son(e))), 1));
}
else {
s1 = f_shift_right(s1, me_shint(sh(bro(son(e))), 1));
}
replace(e, s1, scope);
kill_exp(e, scope);
return 1;
}
#endif
#if has_neg_shift
/* only use if the shift left and shift right operations are
performed by the same instruction, distinguished by the sign
of the number of places */
if (name (e) == shr_tag) {
exp places = bro (son (e));
exp r;
exp neg = getexp (sh (places), nilexp, 0, places, nilexp, 0,
0, neg_tag);
neg = hc (neg, places);
r = getexp (sh (e), nilexp, 0, son (e), nilexp, 0, 0, shl_tag);
bro (son (e)) = neg;
r = hc (r, neg);
replace (e, r, scope);
retcell (e);
return (1);
};
#endif
if (name(e) == shr_tag && name(son(e)) == shl_tag &&
name(bro(son(e))) == val_tag) {
exp arg1 = son(e);
int r = no(bro(arg1));
if (name(son(arg1)) == shr_tag &&
name(bro(son(arg1))) == val_tag) {
exp arg11 = son(arg1);
int q = no(bro(arg11));
if (r >= q && name(bro(son(arg11))) == val_tag) {
exp x = son(arg11);
int p = no(bro(x));
if (q >= p) {
exp temp = hold_check(me_b3(sh(arg1), x,
me_shint(sh(arg1), q - p), shl_tag));
replace(son(e), temp, temp);
/* DELIBERATE FALL THROUGH */
};
};
}
else {
if (name(bro(son(arg1))) == val_tag) {
int q = no(bro(son(arg1)));
int se = shape_size(sh(e));
if ( q == r && (q == (se - 16) || q == (se-8)) &&
is_signed(sh(arg1))) {
shape sc = (q == se-16) ? swordsh : scharsh;
exp temp1 = me_u3(sc, son(arg1), chvar_tag);
exp temp2 = me_u3(sh(e), temp1, chvar_tag);
replace(e, hold_check(temp2), scope);
retcell(e);
return 1;
};
};
};
};
if (name(e) == shl_tag && name(son(e)) == and_tag &&
name(bro(son(e))) == val_tag) {
exp arg1 = son(e);
exp arg2 = bro(arg1); /* left_places */
if (name(arg1) == and_tag &&
name(bro(son(arg1))) == val_tag) {
exp arg11 = son(arg1);
exp arg12 = bro(arg11); /* mask */
if (name(arg11) == shr_tag &&
name(bro(son(arg11))) == val_tag) {
exp arg111 = son(arg11);
exp arg112 = bro(arg111); /* right places */
shape sha = sh(e);
{
exp a = hold_check(me_b3(sha, arg111,
me_shint(sha,
no(arg12) << no(arg112)),
and_tag));
exp res;
if (no(arg2) >= no(arg112))
res = me_b3(sha, a,
me_shint(sha, no(arg2) - no(arg112)), shl_tag);
else
res = me_b3(sha, a,
me_shint(sha, no(arg112) - no(arg2)), shr_tag);
replace(e, hold_check(res), scope);
retcell(e);
return 1;
};
};
};
};
return seq_distr(e, scope);
};
case mod_tag:
{
if (name (son (e)) == val_tag &&
name (bro (son (e))) == val_tag) {
/* evaluate if both args constant */
if (is_signed(sh(e)) && no(bro(son(e)))== -1) {
replace(e, me_shint(sh(e), 0), scope);
retcell (e);
return (1);
}
if (no (bro (son (e))) != 0) {
domod (son(e), bro(son(e)));
sh(son(e)) = sh(e);
replace (e, son(e), scope);
retcell (e);
return (1);
};
};
return 0;
};
case rem0_tag:
case rem2_tag:
{
if (name (son (e)) == val_tag &&
name (bro (son (e))) == val_tag) {
/* evaluate if both args constant */
/* some compilers get the rem2 wrong */
if (is_signed(sh(e)) && no(bro(son(e)))== -1) {
replace(e, me_shint(sh(e), 0), scope);
retcell (e);
return (1);
}
if (no (bro (son (e))) != 0) {
dorem2 (son(e), bro(son(e)));
sh(son(e)) = sh(e);
replace (e, son(e), scope);
retcell (e);
return (1);
};
};
return 0;
};
case div1_tag:
{
if (name (bro (son (e))) == val_tag && no (bro (son (e))) == 1) {
/* remove divide by 1 */
sh(son(e)) = sh(e);
replace (e, son (e), scope);
retcell (e);
return (1);
};
if (optop(e) && name (son (e)) == val_tag &&
name (bro (son (e))) == val_tag &&
no(bro(son(e))) != 0) {
/* evaluate if both args constant */
dodiv1 (son(e), bro(son(e)));
sh(son(e)) = sh(e);
replace (e, son(e), scope);
retcell (e);
return (1);
};
return 0;
};
case div0_tag:
case div2_tag:
{
if (name (bro (son (e))) == val_tag && no (bro (son (e))) == 1) {
/* remove divide by 1 */
sh(son(e)) = sh(e);
replace (e, son (e), scope);
retcell (e);
return (1);
};
if (optop(e) && name (son (e)) == val_tag &&
name (bro (son (e))) == val_tag &&
no(bro(son(e))) != 0) {
/* evaluate if both args constant */
dodiv2 (son(e), bro(son(e)));
sh(son(e)) = sh(e);
replace (e, son(e), scope);
retcell (e);
return (1);
};
return 0;
};
case max_tag:
case min_tag:
{
exp arg1 = son(e);
exp arg2 = bro(arg1);
if (name(arg1) == val_tag && name(arg2) == val_tag) {
domaxmin(arg1, arg2, name(e) == max_tag);
replace(e, son(e), scope);
retcell(e);
return 1;
};
return 0;
};
case chfl_tag: {
if (!optop(e))
return 0;
if (name (sh (e)) == name (sh (son (e)))) {
/* eliminate redundant chfl */
sh (son (e)) = sh (e);
replace (e, son (e), scope);
retcell (e);
return (1);
};
#if FBASE == 10
if (name (son (e)) == real_tag &&
name(sh(e)) < name(sh(son(e)))) {
sh (son (e)) = sh (e);
replace (e, son (e), scope);
retcell (e);
return (1);
};
#else
if (name (son (e)) == real_tag) {
if (name(sh(e)) < name(sh(son(e)))) {
flpt_round((int)f_to_nearest,
flpt_bits((floating_variety)(name(sh(e)) -
shrealhd)),
&flptnos[no(son(e))]);
};
sh (son (e)) = sh (e);
replace (e, son (e), scope);
retcell (e);
return (1);
};
#endif
if (name (son (e)) == chfl_tag &&
name (sh (son (son (e)))) == name (sh (e)) &&
name (sh (e)) < name (sh (son (e)))) {
/* chfl(flsh1, chfl(flsh2, exp of shape flsh1)) to internal
exp iff flsh2 includes flsh1 */
sh(son(son(e))) = sh(e);
replace (e, son (son (e)), scope);
retcell (son (e));
retcell (e);
return (1);
};
return 0;
};
case round_tag:
{
if (!optop(e))
return 0;
#if FBASE == 10
if (name (son (e)) == real_tag) {
/* apply if arg constant */
flpt f = no (son (e));
exp iexp = me_shint(sh(e), 0);
int i,
val = 0;
flt res;
if (round_number (e) == f_to_nearest)
flt_round (flptnos[f], &res);
else
flt_trunc (flptnos[f], &res);
for (i = 0; i <= res.exp; ++i)
val = (10 * val + res.mant[i]);
no (iexp) = val * res.sign;
replace (e, iexp, scope);
kill_exp (e, scope);
return (1);
};
#else
if (name (son (e)) == real_tag) {
/* apply if arg constant */
flpt f = no (son (e));
flt64 x;
int ov, pr;
int sg = is_signed(sh(e));
exp iexp;
IGNORE flpt_round_to_integer(round_number(e), &flptnos[f]);
x = flt_to_f64(f, sg, &ov);
iexp = me_shint(sh(e), f64_to_flpt(x, sg, &pr,
shape_size(sh(e))));
if (pr)
setbigval(iexp);
replace (e, iexp, scope);
kill_exp (e, scope);
return (1);
};
#endif
return 0;
};
case float_tag:
{
if (!optop(e))
return 0;
#if FBASE == 10
if (name (son (e)) == val_tag) {
/* apply if arg constant */
shape sha = sh (son (e));
int k = no (son (e));
int sz = shape_size(sha);
if (PIC_code)
proc_externs = 1;
if (sz == 8)
no(son(e)) = floatrep(k & 0xff);
else
if (sz == 16)
no(son(e)) = floatrep(k & 0xffff);
else {
/* watch out for 64bits */
no (son (e)) = floatrep (k);
if (shape_size(sh(son(e))) == 32 && !is_signed(sh(son(e)))
&& (k & 0x80000000) != 0) {
flt flongmaxr;
int i;
flt r;
flongmaxr.sign = 1;
flongmaxr.exp = 9;
for (i = 0; i < MANT_SIZE; i++) {
(flongmaxr.mant)[i] = (i < 10) ?
(maxdigs[i] - '0') : 0;
};
flt_add (flptnos[no (son (e))], flongmaxr, &r);
flptnos[no (son (e))] = r;
};
};
flpt_round((int)f_to_nearest,
flpt_bits((floating_variety)(name(sh(e))-shrealhd)),
&flptnos[no(son(e))]);
setname (son (e), real_tag);
sh (son (e)) = sh (e);
replace (e, son (e), scope);
retcell (e);
return (1);
};
#else
if (name (son (e)) == val_tag) {
/* apply if arg constant */
exp arg = son(e);
shape sha = sh (arg);
int k = no (arg);
int sz = shape_size(sha);
int sg = is_signed(sha);
if (PIC_code)
proc_externs = 1;
if (sz == 8) {
k = k & 0xff;
if (sg && k >= 0x80)
k = (k | (int)0xffffff00);
no(arg) = floatrep(k);
}
else
if (sz == 16) {
k = k & 0xffff;
if (sg && k >= 0x8000)
k = (k | (int)0xffff0000);
no(arg) = floatrep(k);
}
else
if (sz == 32) {
/* watch out for 64bits */
if (sg)
no(arg) = floatrep(k);
else
no(arg) = floatrep_unsigned(uno(arg));
/* use unsigned selector for k */
}
else {
if (!isbigval(arg))
no(arg) = f64_to_flt(exp_to_f64(arg), is_signed(sha));
clearbigval(arg);
};
flpt_round((int)f_to_nearest,
flpt_bits((floating_variety)(name(sh(e))-shrealhd)),
&flptnos[no(arg)]);
setname (arg, real_tag);
sh (arg) = sh (e);
replace (e, arg, scope);
retcell (e);
return (1);
};
#endif
return 0;
};
case fmult_tag: /* apply zero, unit and constant
evaluation.
NB dive MUST be false, because
floating point is not really
commutative and associative
*/
return (comm_ass (e, fmult_tag, fmult_fn,
fone_no, 1, fzero_no, scope, 0, 1));
case fminus_tag:
if (!optop(e))
return 0;
if (check_fp2 (e, scope)) /* constant evaluation */
return 1;
return 0;
case fdiv_tag:
if (!optop(e))
return 0;
if (check_fp2 (e, scope)) /* constant evaluation */
return 1;
if (name(bro(son(e))) == real_tag &&
flptnos[no(bro(son(e)))].sign != 0 &&
(!strict_fl_div || flpt_power_of_2(no(bro(son(e)))))) {
shape sha = sh(e);
exp one;
exp temp;
flpt f = new_flpt ();
flt_copy (flptnos[fone_no], &flptnos[f]);
one = getexp (sha, nilexp, 0, nilexp, nilexp,
0, f, real_tag);
temp = hold_check(me_b3(sha, one, bro(son(e)), fdiv_tag));
temp = hold_check(me_b3(sha, son(e), temp, fmult_tag));
seterrhandle(temp, errhandle(e));
replace(e, temp, scope);
retcell(e);
return 1;
};
return 0;
case fneg_tag:
{
if (!optop(e))
return 0;
if (name (son (e)) == real_tag) {
/* apply if arg constant */
int fn = no (son (e));
flptnos[fn].sign = -flptnos[fn].sign;
replace (e, son (e), scope);
retcell (e);
return (1);
}
else
if (name (son (e)) == fneg_tag) {
/* --a = a (should check ignore overflow) */
replace (e, son (son (e)), scope);
retcell (son (e));
retcell (e);
return (1);
}
return 0;
};
case fabs_tag:
if (name (son (e)) == real_tag) {
/* apply if arg constant */
int fn = no (son (e));
if (flptnos[fn].sign == -1)
flptnos[fn].sign = 1;
replace (e, son (e), scope);
retcell (e);
return (1);
};
return 0;
case and_tag:
#if has_byte_ops
if (name(bro(son(e))) == val_tag &&
no(bro(son(e))) == 0xff &&
name(son(e)) == shr_tag &&
name(son(son(e))) == cont_tag
) {
exp a1 = bro(son(son(e)));
if (name(a1) == val_tag && !isbigval(a1) &&
(no(a1) & 0x7) == 0) {
exp t = son(son(son(e)));
exp r = me_u3(sh(t), t, reff_tag);
exp c, v;
#if little_end
no(r) = no(a1);
#else
no(r) = shape_size(sh(e)) - no(a1) - 8;
#endif
r = hold_check(r);
c = hold_check(me_u3(ucharsh, r, cont_tag));
v = hold_check(me_u3(sh(e), c, chvar_tag));
replace(e, v, scope);
retcell(e);
return 1;
};
};
#endif
if (name(son(e)) == and_tag && name(bro(son(e))) == val_tag &&
name(bro(son(son(e)))) == val_tag
&& !isbigval(bro(son(e))) && !isbigval(bro(son(son(e))))) {
int mask = no(bro(son(e))) & no(bro(son(son(e))));
exp res = hold_check(me_b3(sh(e), son(son(e)),
me_shint(sh(e), mask), and_tag));
replace(e, res, scope);
retcell(e);
return 1;
};
if (name(son(e)) == shr_tag && name(bro(son(e))) == val_tag &&
!isbigval(bro(son(e)))) {
exp arg1 = son(e);
exp arg2 = bro(arg1); /* mask */
int m = no(arg2);
int sz = shape_size(sh(arg1));
if (m > 0 && name(bro(son(arg1))) == val_tag &&
!isbigval(bro(son(arg1))) &&
m <= ((1 << (sz - no(bro(son(arg1))))) - 1)) {
exp arg11 = son(arg1);
exp arg12 = bro(arg11); /* right shift places */
if (name(arg11) == shl_tag &&
name(bro(son(arg11))) == val_tag &&
!isbigval(bro(son(arg11)))) {
exp arg111 = son(arg11);
exp arg112 = bro(arg111); /* left shift places */
if (no(arg112) <= no(arg12)) {
exp res = hold_check(me_b3(sh(arg1), arg111,
me_shint(sh(arg1), no(arg12) - no(arg112)),
shr_tag));
replace(arg1, res, res);
return check(e, scope);
};
};
};
};
/* apply commutative and associative laws */
return (comm_ass (e, and_tag, and_fn, all_ones (son(e)),
1, 0, scope, 1, 0));
case or_tag:
/* apply commutative and associative laws */
if (name(son(e)) == and_tag &&
name(bro(son(e))) == val_tag &&
!isbigval(bro(son(e))) &&
name(bro(son(son(e))))) {
exp arg1 = son(e);
int q = no(bro(arg1));
exp arg11 = son(arg1);
int p = no(bro(arg11));
if ((q | p) == (int)0xffffffff) {
exp res = me_b3(sh(e), arg11, bro(arg1), or_tag);
replace(e, hold_check(res), scope);
retcell(e);
return 1;
};
};
return (comm_ass (e, or_tag, or_fn, 0, shape_size(sh(e)) <= 32,
all_ones (son(e)),
scope, 1, 0));
case xor_tag:
/* apply commutative and associative laws */
return (comm_ass (e, xor_tag, xor_fn, 0, 0,
0, scope, 1, 0));
case not_tag: {
if (name (son (e)) == val_tag) {/* eval for const */
not_fn (son (e));
sh(son(e)) = sh(e);
replace (e, son (e), scope);
retcell (e);
return (1);
};
if (name (son (e)) == not_tag) {/* not(not(x)) -> x */
sh(son(son(e))) = sh(e);
replace (e, son (son (e)), scope);
retcell (son (e));
retcell (e);
return (1);
};
return 0;
};
case cont_tag:
#ifdef promote_pars
{ int x = al1_of(sh(son(e)))->al.sh_hd;
if (x >= scharhd && x <= uwordhd && !little_end) {
int disp = shape_size(ulongsh)-((x>=swordhd)?16:8);
exp r = getexp(f_pointer(f_alignment(sh(e))), nilexp,
1, son(e), nilexp, 0, disp, reff_tag);
bro(son(r)) = r;
son(e) = hold_check(r);
bro(son(e)) = e; setlast(son(e));
return 1;
}
}
#endif
#ifndef NEWDIAGS
if (name(son(e)) == diagnose_tag)
{
exp diag = son(e);
exp p = son(diag);
exp r = getexp(sh(e), nilexp, 0, p, nilexp, 0,
0, cont_tag);
exp d;
r = hc(r, p);
d = getexp(sh(e), nilexp, 0, r, pt(diag), props(diag),
no(diag), diagnose_tag);
setfather(d, r);
replace(e, d, scope);
retcell(son(e));
retcell(e);
return 1;
};
#endif
return 0;
case field_tag:
if (name(son(e)) == compound_tag && nos (son(e))) {
exp s = son(son(e));
for(;;) {
if ( no(s)==no(e)
&& eq_shape(sh(e), sh(bro(s)))) {
replace(e, copy(bro(s)), scope);
kill_exp(e, scope);
return 1;
}
if (last(bro(s))) break;
s = bro(bro(s));
}
}
if (name(son(e)) == nof_tag && nos (son(e))
&& eq_shape(sh(e), sh(son(son(e)))) ) {
exp s = son(son(e));
int sz = rounder(shape_size(sh(s)), shape_align(sh(s)));
int n = 0;
for(; no(e)<=n; n+=sz) {
if (no(e)==n) {
replace(e, copy(s), scope);
kill_exp(e, scope);
return 1;
}
if (last(s)) break;
s = bro(s);
}
}
if (name (son (e)) == name_tag) {
/* replace field on name by name with offset in no */
no (son (e)) += no (e);
sh (son (e)) = sh (e);
replace (e, son (e), scope);
retcell (e);
return (1);
};
if (name (son (e)) == cont_tag) {
/* replace field[n](cont(x)) by cont(reff[n](x)) */
exp arg = son (son (e));
exp rf1 = getexp (sh (arg), nilexp, 0, arg, nilexp, 0,
no (e), reff_tag);
exp rf = hc (rf1, arg);
exp c = getexp (sh (e), nilexp, 0, rf, nilexp, 0, 0, cont_tag);
replace (e, hc (c, rf), scope);
retcell (son (e));
retcell (e);
return (1);
};
if (name(son(e)) == ident_tag && isvar(son(e)) &&
name(son(son(e))) == clear_tag &&
name(bro(son(son(e)))) == seq_tag) {
exp var = son(e);
exp sq = bro(son(var));
if (name(bro(son(sq))) == cont_tag &&
name(son(bro(son(sq)))) == name_tag &&
son(son(bro(son(sq)))) == var) {
int count = 0;
int good = 0;
exp p = son(son(sq));
exp q;
exp res;
while (p != son(sq)) {
if (name(p) != ass_tag || name(son(p)) != name_tag ||
son(son(p)) != var)
return 0;
++count;
if (no(son(p)) == no(e))
good = 1;
p = bro(p);
}
if ((count+1) != no(var) || !good)
return 0;
p = son(son(sq));
while (p != son(sq)) {
q = bro(p);
if (no(son(p)) == no(e)) {
exp tp = f_make_top();
res = bro(son(p));
replace(p, tp, tp);
}
else {
exp w = bro(son(p));
replace(p, w, w);
}
p = q;
}
SET(res);
replace(bro(son(sq)), res, res);
replace(e, hold_check(sq), scope);
return 1;
}
return 0;
}
return (0);
case reff_tag:
if (name (son (e)) == name_tag &&
isvar (son (son (e))) && al1(sh(e)) > 1) {
/* replace reff on name of var by name with offset in no */
no (son (e)) += no (e);
sh (son (e)) = sh (e);
#ifdef NEWDIAGS
if (diagnose)
dg_whole_comp (e, son(e));
#endif
replace (e, son (e), scope);
retcell (e);
return (1);
};
if (name (son (e)) == val_tag) {
no (son (e)) += (no (e) / 8);
sh (son (e)) = sh (e);
#ifdef NEWDIAGS
if (diagnose)
dg_whole_comp (e, son(e));
#endif
replace (e, son (e), scope);
retcell (e);
return (1);
};
#if !temp_mips
/* confirm mips doesnt need this */
if (name (son (e)) == reff_tag) {
/* combine reff selections */
sh (son (e)) = sh (e);
no (son (e)) += no (e);
#ifdef NEWDIAGS
if (diagnose)
dg_whole_comp (e, son(e));
#endif
replace (e, son (e), scope);
retcell (e);
return (1);
};
#endif
#if remove_zero_offsets
if (no(e) == 0 && al1(sh(e)) > 1)
{
sh(son(e)) = sh(e);
#ifdef NEWDIAGS
if (diagnose)
dg_whole_comp (e, son(e));
#endif
replace(e, son(e), scope);
retcell(e);
return 1;
};
#endif
return (0);
case bfcont_tag:
case bfcontvol_tag:
{
exp p = son(e);
int bsz = shape_size(sh(e));
int rsz = al1(sh(p));
int rsh;
int sg = is_signed(sh(e));
int off = no(e);
exp ref;
exp cont;
exp eshift;
shape ptr_sha;
shape msh;
int temp = off + bsz - 1;
if (rsz>BF_STORE_UNIT) rsz = BF_STORE_UNIT;
if (((off/8) == (temp/8)) &&
(bsz == 8 &&
((little_end && (off%8 == 0)) ||
(!little_end && ((8 - (off % 8) - bsz) == 0))))) {
rsz = 8;
}
else
if (((off/16) == (temp/16)) &&
(bsz == 16 &&
((little_end && (off%16 == 0)) ||
(!little_end && ((16 - (off % 16) - bsz) == 0))))) {
rsz = 16;
}
#if isAlpha
else
if (((off/32) == (temp/32)) &&
(!sg || (al1(sh(p)) < 64) ||
(bsz == 32 &&
((little_end && (off%32 == 0)) ||
(!little_end && ((32 - (off % 32) - bsz) == 0)))))) {
rsz = 32;
}
#endif
else {
/* all of bitfield must be within same integer variety */
while ((off/rsz) != (temp/rsz)) { rsz = rsz<<1; }
}
msh = containedshape(rsz, sg);
ptr_sha = f_pointer(long_to_al(rsz));
if ((off / rsz) != 0) {
ref = me_u3(ptr_sha, p, reff_tag);
no(ref) = (off / rsz) * rsz;
ref = hold_check(ref);
}
else
ref = p;
#if little_end
rsh = off % rsz;
#else
rsh = rsz - (off % rsz) - bsz;
#endif
cont = me_u3(msh, ref,
(name(e) == bfcont_tag)
? (unsigned char)cont_tag
: (unsigned char)contvol_tag);
if (rsh==0 && !sg && bsz != rsz) {
eshift = me_b3(msh, cont,
me_shint(slongsh, (1<<bsz)-1), and_tag);
}
else {
if (rsz - bsz - rsh != 0) {
cont = me_b3(msh, cont, me_shint(slongsh,rsz - bsz - rsh),
shl_tag);
}
if (rsz - bsz != 0)
eshift = me_b3(msh, cont, me_shint(slongsh, rsz-bsz),
shr_tag);
else
eshift = cont;
}
eshift = me_u3(sh(e), eshift, chvar_tag);
replace(e, eshift , scope);
retcell(e);
return 1;
};
case abs_tag:
if (name (son (e)) == val_tag) {
if (is_signed(sh(e)) &&
((isbigval(son(e)) && flptnos[no(son(e))].sign) ||
(!isbigval(son(e)) && no(son(e)) < 0))) {/* eval for const */
if (!optop(e)) return 0;
neg_fn (son (e));
}
sh(son(e)) = sh(e);
#ifdef NEWDIAGS
if (diagnose)
dg_whole_comp (e, son(e));
#endif
replace (e, son (e), scope);
retcell (e);
return (1);
};
return 0;
case fmax_tag:
case fmin_tag:
{
bool fmin = (name(e)==fmin_tag);
exp arg1 = son(e);
exp arg2 = bro(arg1);
exp id1 = me_startid(sh(arg1),arg1,0);/* identify arg1 */
exp id2 = me_startid(sh(arg2),arg2,0);/* identify arg2 */
exp seq;
exp cond;
exp zero;
exp lab;
exp clear;
exp test;
clear = getexp(f_bottom,nilexp,0,nilexp,nilexp,0,0,clear_tag);
lab = me_b3(sh(arg2),clear,me_obtain(id2),labst_tag);
test = me_q2(no_nat_option,
f_impossible,
fmin?f_less_than:f_greater_than,
&lab,
me_obtain(id1),
me_obtain(id2),
test_tag);
zero = me_u3(sh(test),test,0);
seq = me_b3(sh(arg1),zero,me_obtain(id1),seq_tag);
cond = me_b3(sh(arg1),seq,lab,cond_tag);
id2 = me_complete_id(id2,cond);
id1 = me_complete_id(id1,id2);
replace(e,id1,scope);
retcell(e);
return 1;
}
case name_tag: {
exp s = son(e);
if (!isvar(s) && isglob(s) && son(s) != nilexp
&& name(sh(e)) == name(sh(son(s)))
&& (name(son(s)) == val_tag || name(son(s))==real_tag)) {
exp c = copy(son(s));
replace(e,c,scope);
kill_exp(e,scope);
return 1;
}
else return 0;
}
case fpower_tag:
case imag_tag:
case make_complex_tag:
return 0;
case rotl_tag:
case rotr_tag:
case env_offset_tag:
case general_env_offset_tag:
case proc_tag:
case general_proc_tag:
case top_tag:
case val_tag:
case real_tag:
case current_env_tag:
case make_lv_tag:
case clear_tag:
case null_tag:
case string_tag:
case power_tag:
case contvol_tag:
return 0;
default:
return 0;
};
};
switch (name (e)) { /* side effecting ops */
case compound_tag:
{
exp bse = bro(son(e));
unsigned char shn = name(sh(bse));
if (last(bse) && name(son(e)) == val_tag &&
no(son(e)) == 0 &&
shape_size(sh(e)) == shape_size(sh(bse)) &&
shn != prokhd && (shn < shrealhd || shn > doublehd)
#if dont_unpad_apply
&& name(bse) != apply_tag
#endif
)
{ /* remove the creation of a compound if it consists of a
single value of the same size and provided that the
component is not real (because it might be in the wrong
place. */
if (name(bse) == name_tag && isvar(son(bse)) &&
!isglob(son(bse)) &&
name(sh(son(son(bse)))) >= shrealhd &&
name(sh(son(son(bse)))) <= doublehd) {
setvis(son(bse));
props(e) = (prop)(props(e) & ~0x08);
};
sh(bse) = sh(e);
#ifdef NEWDIAGS
if (diagnose)
dg_whole_comp (e, bse);
#endif
replace(e, bse, scope);
retcell(son(e));
retcell(e);
return 1;
};
};
#if replace_compound
if (in_proc_def)
{ /* Provided that the exp is inside a procedure definition we
always remove compound creation and replace it by a
variable declaration for the compound, assignments to
the components, and deliver the compound. */
shape she = sh(e);
exp var = me_start_clearvar(she, she);
exp cont = getexp(she, nilexp, 0, nilexp, nilexp, 0, 0, cont_tag);
exp_list el;
exp obt;
exp t = son(e);
exp seq;
obt = me_obtain(var);
son(cont) = obt;
setfather(cont, obt);
el = new_exp_list(0);
while (1)
{
exp q = bro(t); /* expression being assigned */
exp n = bro(q);
int end = (int)last(q);
exp ass, p, ap;
p = me_obtain(var);
if (name(sh(q)) != bitfhd || !newcode) {
ap = hold_check(f_add_to_ptr(p, t)); /* destination */
ass = hold_check(f_assign(ap, q));
}
else {
ass = hold_check(f_bitfield_assign(p, t, q));
};
el = add_exp_list(el, ass, 0);
if (end)
break;
t = n;
};
seq = f_sequence(el, cont);
#ifdef NEWDIAGS
if (diagnose)
dg_whole_comp (e, var);
#endif
replace(e, me_complete_id(var, seq), scope);
retcell(e);
return 1;
};
#endif
return 0;
#ifndef NEWDIAGS
case diagnose_tag:
#endif
case prof_tag:
return 0;
case ident_tag:
if (name(sh(son(e))) == bothd)
{
exp s = son(e);
exp b = bro(s);
#ifdef NEWDIAGS
if (diagnose) {
dg_dead_code (b, s);
dg_whole_comp (e, s);
}
#endif
kill_exp(b, b);
replace(e, s, scope);
retcell(e);
return 1;
};
#if has_setcc
/* use if target has setcc instruction */
if (!is80x86 || is80586) {
exp abst = absbool (e);
if (abst != nilexp &&
(!is80x86 || name(sh(son(abst))) <= u64hd)) {
/* check if we can use setcc */
exp a = copy (abst);
setname (a, absbool_tag);
pt (a) = nilexp;
sh (a) = sh (e);
#ifdef NEWDIAGS
if (diagnose)
dg_whole_comp (e, a);
#endif
replace (e, a, a);
kill_exp (e, e);
return (0);
};
};
#endif
if (name(sh(bro(son(e)))) != name(sh(e))) {
sh(e) = sh(bro(son(e)));
IGNORE check_id(e,scope);
return 1;
}
return (check_id (e, scope));/* see check_id.c */
case seq_tag:
if (son (son (e)) == nilexp) {/* remove empty seq */
exp s = son(e);
sh(bro(s)) = sh(e); /* unless bottom ???????????????????????????? */
#ifdef NEWDIAGS
if (diagnose)
dg_whole_comp (e, bro(s));
#endif
replace (e, bro (s), scope);
retcell(s);
return (1);
};
return (check_seq (e, scope));
case cond_tag:
if (no (son (bro (son (e)))) == 0) {
/* remove inaccessible statements */
exp bs = bro(son(e));
#ifdef NEWDIAGS
if (diagnose) {
dg_dead_code (bro(son(bs)), son(e));
dg_whole_comp (e, son(e));
}
#endif
replace (e, son (e), scope);
kill_exp(bs, scope);
retcell(e);
return (1);
};
if (name (son (e)) == goto_tag &&
pt (son (e)) == bro (son (e))) {
/* replace cond which has first a simple goto to the alt by the
alt (removing the label) */
exp x = bro (son (bro (son (e))));
#ifdef NEWDIAGS
if (diagnose) {
dg_rdnd_code (son(e), x);
dg_whole_comp (e, x);
}
#endif
replace (e, x, scope);
retcell(son (bro (son (e))));
retcell(bro (son (e)));
if (son(son(e)) != nilexp) { retcell(son(son(e))); }
retcell(son(e));
retcell(e);
return (1);
};
if (name (son (e)) == seq_tag && no (son (bro (son (e)))) == 1 &&
name (bro (son (son (e)))) == goto_tag) {
/* is e = cond(seq(..;goto m), l: x) and is only 1 use of l */
exp t = son (son (son (e)));
while (!last (t))
t = bro (t);
#ifndef NEWDIAGS
if (name(t) == diagnose_tag)
t = son(t);
#endif
if ((name (t) == test_tag || name (t) == testbit_tag) &&
pt (t) == bro (son (e)) && test_number(t) <= 6) {
/* look at last element of sequence before goto m to see if it
is a conditional jump to l. If so reverse the test, make it
jump to m and remove the goto */
settest_number (t, revtest[test_number (t) - 1]);
pt (t) = pt (bro (son (son (e))));
sh (son (e)) = sh (bro (son (bro (son (e)))));
replace (bro (son (son (e))),
bro (son (bro (son (e)))),
son (e));
replace (e, son (e), scope);
retcell (e);
return (1);
};
};
#if maxmin_implemented
{
exp t;
int bl = is_maxop(e, &t);
int ismax = 0;
int ismin = 0;
ntest nt;
if (bl) {
nt = test_number(t);
if (nt == f_greater_than || nt == f_greater_than_or_equal) {
ismax = 1;
};
if (nt == f_less_than || nt == f_less_than_or_equal)
ismin = 1;
}
else {
bl = is_minop(e, &t);
if (bl) {
nt = test_number(t);
if (nt == f_greater_than || nt == f_greater_than_or_equal)
ismin = 1;
if (nt == f_less_than || nt == f_less_than_or_equal)
ismax = 1;
};
};
if (ismax || ismin) {
exp tq = me_b2(copy(son(t)), copy(bro(son(t))),
(ismax)
? (unsigned char)max_tag
: (unsigned char)min_tag);
replace(e, hold_check(tq), scope);
kill_exp(e, e);
return 1;
};
};
#endif
#if condassign_implemented
{
exp to_test;
exp to_ass;
if (is_condassign(e, &to_test, &to_ass) &&
is_floating(name(sh(son(to_test)))) ==
is_floating(name(sh(bro(son(to_ass)))))) {
exp res = me_b3(sh(e), to_test, to_ass, condassign_tag);
replace(e, res, scope);
retcell(e);
return 1;
};
};
#endif
if (name(bro(son(bro(son(e))))) == top_tag) {
exp first = son(e);
exp alt = bro(first);
int in_repeat = 0;
if (crt_repeat != nilexp && (int)(props(crt_repeat)) == 1)
in_repeat = 1;
if (take_out_of_line(first, alt, in_repeat, 1.0)) {
exp t = son(son(first));
exp tst = (is_tester(t, 0)) ? t : bro(son(t));
if (no(tst) == 1000)
no(tst) = 25;
}
}
return (0);
#if condassign_implemented
case condassign_tag:
if (name(bro(son(e))) != ass_tag &&
(name(son(e)) == test_tag || name(son(e)) == testbit_tag)) {
exp sqz = me_b3(f_top, son(son(e)), bro(son(son(e))), 0);
exp sq = me_b3(sh(e), sqz, bro(son(e)), seq_tag);
replace(e, hold_check(sq), scope);
retcell(e);
return 1;
};
if (name(son(e)) == goto_tag) {
replace(e, getexp(f_top, nilexp, 0, nilexp,
nilexp, 0, 0, top_tag),
scope);
retcell(e);
return 1;
};
if (name(son(e)) == top_tag) {
replace(e, bro(son(e)), scope);
retcell(e);
return 1;
};
#endif
case goto_tag: case return_to_label_tag: case trap_tag:
return (0);
case ass_tag:
#if 0
if (0 && redo_structfns && !reg_result(sh(bro(son(e)))) &&
name (bro (son (e))) == ident_tag &&
isvar (bro (son (e)))) { /* prepare to replace the assignment
of structure results of procedures.
If it decides to do so it will
put the destination in as the first
parameter of the procedure */
exp id = bro (son (e));
exp def = son (id);
exp body = bro (def);
if (name (def) == clear_tag && name (body) == seq_tag) {
if (name (son (son (body))) == apply_tag &&
last (son (son (body))) &&
name (bro (son (body))) == cont_tag &&
name (son (bro (son (body)))) == name_tag &&
son (son (bro (son (body)))) == id) {
exp ap = son (son (body));
exp p1 = bro (son (ap));
if (name (p1) == name_tag && son (p1) == id &&
last (ap)) {
/* this is the assignment of a struct result of a proc */
exp p2 = bro (son (ap));
exp se = son(e);
if (last(p2))
setlast (se);
bro(se) = bro(p2);
bro(son(ap)) = se;
if (name(se) == name_tag && isvar(son(se)) &&
!isglob(son(se)) &&
shape_size(sh(id)) == shape_size(sh(son(son(se)))))
setreallyass(se);
replace (e, ap, scope);
return (1);
};
};
};
};
#endif
#ifdef promote_pars
{ int x = al1_of(sh(son(e)))->al.sh_hd;
if (x >= scharhd && x <= uwordhd && !little_end) {
exp b = bro(son(e));
int disp = shape_size(ulongsh)-((x>=swordhd)?16:8);
exp r = getexp(f_pointer(f_alignment(sh(b))), nilexp,
1, son(e), nilexp, 0, disp, reff_tag);
bro(son(r)) = r; setlast(son(r));
r = hold_check(r);
bro(r) = b; clearlast(r);
son(e) = r;
return 1;
}
}
#endif
return (seq_distr (e, scope));
case testbit_tag:
{
exp arg1 = son(e);
exp arg2 = bro(arg1);
if (name (arg1) == val_tag && name (arg2) == val_tag &&
!isbigval(arg1) && !isbigval(arg2)) {
/* evaluate if args constant */
int k = no (arg1) & no (arg2);
if ((k != 0 && test_number (e) == 5) ||
(k == 0 && test_number (e) == 6))
repbygo (e, pt (e), scope);
else
repbycont (e, 1, scope);
return (1);
};
if (name(arg1) == shr_tag && name(arg2) == val_tag &&
name(bro(son(arg1))) == val_tag &&
!isbigval(arg2) && !isbigval(bro(son(arg1)))) {
exp x = son(arg1);
exp nsh = bro(x);
int places = no(nsh);
exp res;
sh(x) = sh(arg2);
res = me_b3(sh(e), x, me_shint(sh(arg2), no(arg2) << places),
testbit_tag);
no(res) = no(e);
pt(res) = pt(e);
settest_number(res, test_number(e));
replace(e, hold_check(res), scope);
retcell(e);
return 1;
};
return (0);
};
case test_tag: {
exp arg1, arg2;
int n;
int bl;
unsigned char nt = test_number(e);
arg1 = son (e);
arg2 = bro (arg1);
if (flpt_always_comparable ||
(name(sh(arg1)) < shrealhd || name(sh(arg1)) > doublehd)) {
switch (nt) {
case 7: nt = f_greater_than;
break;
case 8: nt = f_greater_than_or_equal;
break;
case 9: nt = f_less_than;
break;
case 10: nt = f_less_than_or_equal;
break;
case 11: nt = f_not_equal;
break;
case 12: nt = f_equal;
break;
case 13: repbycont (e, 1, scope);
return 1;
case 14: repbygo (e, pt (e), scope);
return 1;
default: break;
};
};
settest_number(e, nt);
/* evaluate constant expressions */
if ((name (arg1) == val_tag || name (arg1) == null_tag) &&
(name (arg2) == val_tag || name (arg2) == null_tag)) {
/* see if we know which way to jump and replace by unconditional
goto or nop. For integers. */
int c = docmp_f ((int)test_number (e), arg1, arg2);
if (c)
repbycont (e, 1, scope);
else
repbygo (e, pt (e), scope);
return (1);
};
if (test_number (e) >= 5 &&
((name(arg1) == null_tag && no(arg1) == 0 &&
name(arg2) == name_tag &&
isvar(son(arg2))) ||
(name(arg2) == null_tag && no(arg2) == 0 &&
name(arg1) == name_tag &&
isvar(son(arg1))))) {
/* if we are comparing null with a variable we
know the way to jump. */
if (test_number(e) == 6)
repbycont(e, 1, scope);
else
repbygo(e, pt(e), scope);
return 1;
};
if (name (arg1) == real_tag && name (arg2) == real_tag &&
test_number(e) <= 6) {
/* similar for reals */
if (cmpflpt (no (arg1), no (arg2), (int)(test_number (e))))
repbycont (e, 1, scope);
else
repbygo (e, pt (e), scope);
return (1);
};
/* end of constant expression evaluation */
if (name(arg1) == val_tag || name(arg1) == real_tag ||
name(arg1) == null_tag) {
/* constant argument always second */
son(e) = arg2;
bro(arg2) = arg1;
bro(arg1) = e;
setlast(arg1);
clearlast(arg2);
arg2 = arg1;
arg1 = son(e);
nt = exchange_ntest[nt];
settest_number(e, nt);
};
if (name (arg1) == chvar_tag && name (arg2) == chvar_tag &&
name (sh (son (arg1))) == name (sh (son (arg2))) &&
shape_size (sh (son (arg1))) <= shape_size (sh (arg1)) &&
#if only_lengthen_ops
shape_size(sh (arg1)) >= 16 &&
#endif
(is_signed(sh (son (arg1))) == is_signed(sh (arg1)))
) {
exp ee;
#if is80x86 || ishppa
/* optimise if both args are result of sign extension removal */
if ((test_number(e) == f_equal ||
test_number(e) == f_not_equal) &&
name(sh(arg1)) == slonghd &&
name(son(arg1)) == cont_tag &&
name(son(arg2)) == cont_tag &&
shape_size(sh (son(arg1))) == 16 &&
name(son(son(arg1))) == name_tag &&
name(son(son(arg2))) == name_tag) {
exp dec1 = son(son(son(arg1)));
exp dec2 = son(son(son(arg2)));
if (isse_opt(dec1) && isse_opt(dec2)) {
son(e) = son(arg1);
sh(son(arg1)) = slongsh;
clearlast(son(arg1));
bro(son(arg1)) = son(arg2);
sh(son(arg2)) = slongsh;
setlast(son(arg2));
bro(son(arg2)) = e;
return 0;
};
};
#endif
/* arrange to do test in smallest size integers by removing
chvar and altering shape of test args */
ee = copyexp (e);
son (ee) = son (arg1);
bro (son (arg1)) = son (arg2);
clearlast (son (arg1));
replace (e, hc (ee, bro (son (ee))), scope);
retcell (arg1);
retcell (arg2);
retcell (e);
return (1);
};
#if little_end & has_byte_ops
/* only for little enders with byte and short operations */
if (name (arg2) == val_tag && !isbigval(arg2) && no (arg2) == 0 &&
name (arg1) == and_tag &&
test_number (e) >= 5) {
/* e = test(val, and(a,b)) and test is == or != */
exp r, t, q;
if (last (bro (son (arg1)))) {
if (name (son (arg1)) == chvar_tag &&
name (bro (son (arg1))) == val_tag) {
/* e = test(val, and(chvar(x),val)) */
exp v = bro (son (arg1));
sh (v) = sh (son (son (arg1)));
son (arg1) = son (son (arg1));
clearlast (son (arg1));
bro (son (arg1)) = v;
};
r = getexp (f_top, nilexp, 0, son (arg1), pt (e), 0,
0, testbit_tag);
no(r) = no(e);
settest_number(r, test_number(e));
replace (e, hc (r, bro (son (r))), scope);
retcell (e);
return (1);
};
t = son (arg1);
while (!last (bro (t)))
t = bro (t);
q = bro (t);
setlast (t);
bro (t) = arg1;
r = getexp (f_top, nilexp, 0, q, pt (e), 0,
0, testbit_tag);
no(r) = no(e);
settest_number(r, test_number(e));
clearlast (q);
bro (q) = arg1;
setlast (arg1);
bro (arg1) = r;
replace (e, r, scope);
retcell (e);
return (1);
};
/* use if little end machine */
if (
name (arg2) == val_tag && !isbigval(arg2) &&
((name (arg1) == chvar_tag &&
name (sh (arg1)) > name (sh (son (arg1))) &&
is_signed (sh (arg1)) == is_signed (sh (son (arg1)))) ||
(name (arg1) == bitf_to_int_tag &&
name (son (arg1)) == cont_tag &&
(shape_size(sh (son (arg1))) == 8 ||
shape_size(sh (son (arg1))) == 16) &&
name (son (son (arg1))) == reff_tag &&
(no (son (son (arg1))) & 7) == 0
))
) {
/* e = test(chvar(x), val) and chvar lengthens */
n = no (arg2);
switch (shape_size(sh (son (arg1)))) {
case 8:
if (is_signed(sh(son(arg1)))) {
bl = (n >= -128) & (n <= 127);
break;
}
else {
bl = (n >= 0) & (n <= 255);
break;
};
case 16:
if (is_signed(sh(son(arg1)))) {
bl = (n >= -32768) & (n <= 32767);
break;
}
else
{
bl = (n >= 0) & (n <= 65536);
break;
};
default:
bl = 0;
break;
};
if (bl) {
exp ee = copyexp (e);
son (ee) = son (arg1);
bro (son (arg1)) = arg2;
clearlast (son (arg1));
sh (arg2) = sh (son (arg1));
replace (e, hc (ee, bro (son (ee))), scope);
retcell (arg1);
retcell (e);
return (1);
};
return (0);
};
if (name(arg2) == val_tag && !isbigval(arg2) && no(arg2) == 0 &&
test_number (e) >= 5 &&
name(arg1) == bitf_to_int_tag && shape_size(sh(arg1)) == 32 &&
name(son(arg1)) == cont_tag &&
name(son(son(arg1))) == reff_tag) {
exp rf = son(son(arg1));
if (al1(sh(son(rf))) >=32) {
int pos = no(rf) % 32;
exp c = son(arg1);
int nbits = shape_size(sh(c));
exp r;
no(rf) -= pos;
sh(rf) = getshape(0, const_al32, const_al32, PTR_ALIGN,
PTR_SZ, ptrhd);
sh(c) = slongsh;
if (no(rf) == 0)
{
sh(son(rf)) = sh(rf);
son(c) = son(rf);
setfather(c, son(c));
};
sh(arg2) = slongsh;
no(arg2) = ~(-(1 << nbits)) << pos;
r = getexp (f_top, nilexp, 0, c, pt (e), 0,
0, testbit_tag);
no(r) = no(e);
settest_number(r, test_number(e));
clearlast(c);
bro(c) = arg2;
replace(e, hc(r, arg2), scope);
retcell(e);
return 1;
};
};
if (name(arg1) == shr_tag && name(arg2) == val_tag &&
no(arg2) == 0 && nt >= 5) {
exp arg11 = son(arg1);
exp arg12 = bro(arg11); /* no of places shifted right */
if (name(arg11) == shl_tag && name(arg12) == val_tag) {
exp arg111 = son(arg11);
exp arg112 = bro(arg111); /* no places shifted left */
if (name(arg112) == val_tag && no(arg112) <= no(arg12)) {
int n2 = no(arg12); /* right shift */
int n12 = no(arg112); /* left shift */
int sz = shape_size(sh(arg1));
int mask = ((1 << (sz - n2)) - 1) << (n2 - n12);
exp res = me_b3(sh(arg1), arg111,
me_shint(sh(arg1), mask), and_tag);
res = hold_check(res);
replace(arg1, res, res);
return check(e, scope);
};
};
};
if (name(arg1) == chvar_tag && name(arg2) == val_tag &&
!isbigval(arg2) &&
shape_size(sh(arg1)) > shape_size(sh(son(arg1))) &&
name(son(arg1)) == cont_tag &&
(name(son(son(arg1))) != name_tag ||
!isvar(son(son(son(arg1)))))) {
exp q = son(arg1);
shape sha = sh(q);
int shsz = shape_size(sha);
int n = no(arg2);
if (n >= 0 &&
is_signed(sha) == is_signed(sh(arg1)) &&
((shsz == 16 && n <= 32768) ||
(shsz == 8 && n <= 128))) {
sh(arg2) = sha;
son(e) = q;
clearlast(q);
bro(q) = arg2;
retcell(arg1);
return 1;
};
};
#endif
return (seq_distr (e, scope));
};
case solve_tag: { /* eliminate dead code */
exp t = son (e);
exp q;
int changed = 0;
int looping;
if (last (t)) {
#ifdef NEWDIAGS
if (diagnose)
dg_whole_comp (e, t);
#endif
replace (e, copy(t), scope);
kill_exp(e, e);
return (1);
};
if (name(t) == goto_tag && no(son(pt(t))) == 1) {
exp lab = pt(t);
q = bro(t);
while (q != e) {
if (q == lab)
break;
q = bro(q);
};
if (q != e) {
exp rep = copy(bro(son(lab)));
#ifdef NEWDIAGS
/* note copy, in case original is removed !!!!!!!!!!!!!!!!!!!!!!!!!!! */
#endif
replace(t, rep, rep);
kill_exp(t, t);
t = rep;
};
};
do {
if (no (son (bro (t))) == 0) {
changed = 1;
q = bro (t);
bro (t) = bro (q);
if (last (q))
setlast (t);
else
clearlast (t);
#ifdef NEWDIAGS
if (diagnose)
dg_dead_code (bro(son(q)), t);
#endif
kill_exp (q, q);
looping = !last(t);
}
else {
looping = !last (bro (t));
t = bro (t);
};
}
while (looping);
if (last (son (e))) {
#ifdef NEWDIAGS
if (diagnose)
dg_whole_comp (e, son(e));
#endif
replace (e, copy(son (e)), scope);
kill_exp(e,e);
return (1);
};
if (changed)
return (1);
return (0);
};
case case_tag:
if (name (son (e)) == val_tag ) {
/* if we know the case argument select the right case branch and
replace by goto. Knock on effect will be to eliminate dead
code. */
exp n = son (e);
int changed = 0;
exp t = son (e);
exp z;
do {
exp up;
t = bro (t);
if (son (t) == nilexp)
up = t;
else
up = son (t);
if (docmp_f((int)f_less_than_or_equal, t, n) &&
docmp_f((int)f_less_than_or_equal, n, up)) {
changed = 1;
z = pt(t);
}
/* else
--no (son (pt (t)));
*/
}
while (!last (t));
if (!changed)
repbycont (e, 0, scope);
else {
SET(z);
repbygo (e, z, scope);
};
return (1);
};
return (0);
case rep_tag:
case apply_general_tag:
case set_stack_limit_tag:
case give_stack_limit_tag:
case env_size_tag:
case apply_tag:
case res_tag:
case goto_lv_tag:
case assvol_tag:
case local_free_all_tag:
case local_free_tag:
case last_local_tag:
case long_jump_tag:
case movecont_tag:
return (0);
case alloca_tag:
if (name(son(e)) == chvar_tag && name(sh(son(son(e)))) == ulonghd) {
replace(son(e), son(son(e)), son(e));
};
return (0);
case nof_tag:
case labst_tag:
return 0;
case concatnof_tag:
{
exp a1 = son (e);
exp a2 = bro (a1);
exp r;
nat n;
if (name (a1) == string_tag &&
name (a2) == string_tag) {
/* apply if args constant */
char *s1 = nostr(son(e));
char *s2 = nostr(bro(son(e)));
/* note NOT zero termination convention !! */
int sz1,
sz2,
i;
char * newstr;
char * p2;
shape newsh;
sz1 = shape_size(sh(son(e)))/8;
sz2 = shape_size(sh(bro (son (e))))/8;
newstr = (char *) xcalloc ( (sz1 + sz2), sizeof (char));
p2 = &newstr[sz1];
nat_issmall(n) = 1;
natint(n) = sz1+sz2;
newsh = f_nof (n, scharsh);
for (i = 0; i < sz1; ++i)
newstr[i] = s1[i];
for (i = 0; i < sz2; ++i)
p2[i] = s2[i];
r = getexp (newsh, nilexp, 0, nilexp,
nilexp, 0, 0, string_tag);
nostr(r) = newstr;
replace (e, r, scope);
kill_exp (e, scope);
return (1);
};
return 0;
};
case ncopies_tag:
case ignorable_tag:
return 0;
case bfass_tag:
case bfassvol_tag:
{
exp p = son(e);
exp val = bro(p);
int bsz = shape_size(sh(val));
int rsz;
int rsh;
int sg = is_signed(sh(val));
int posmask;
int negmask;
int off = no(e);
exp ref;
exp cont;
exp eshift;
exp res;
exp id;
exp idval;
shape ptr_sha;
shape msh;
int temp = off + bsz - 1;
if (((off/8) == (temp/8)) && bsz<=8
#if 0
(bsz == 8 &&
((little_end && (off%8 == 0)) ||
(!little_end && ((8 - (off % 8) - bsz) == 0))))
#endif
) {
rsz = 8;
if (sg)
msh = scharsh;
else
msh = ucharsh;
}
else
if (((off/16) == (temp/16)) && bsz <= 16
#if 0
(bsz == 16 &&
((little_end && (off%16 == 0)) ||
(!little_end && ((16 - (off % 16) - bsz) == 0))))
#endif
) {
rsz = 16;
if (sg)
msh = swordsh;
else
msh = uwordsh;
}
else
if ((off/32) == (temp/32)) {
rsz = 32;
if (sg)
msh = slongsh;
else
msh = ulongsh;
}
else {
rsz = 64;
if (sg)
msh = s64sh;
else
msh = u64sh;
};
ptr_sha = f_pointer(long_to_al(rsz));
if ((off / rsz) != 0) {
ref = me_u3(ptr_sha, p, reff_tag);
no(ref) = (off / rsz) * rsz;
ref = hold_check(ref);
}
else
ref = p;
id = me_startid(f_top, ref, 0);
#if little_end
rsh = off % rsz;
#else
rsh = rsz - (off % rsz) - bsz;
#endif
posmask = (bsz == 32) ? -1 : (1 << bsz) -1;
negmask = ~(posmask << rsh);
cont = me_u3(msh, me_obtain(id),
(name(e) == bfass_tag)
? (unsigned char)cont_tag
: (unsigned char)contvol_tag);
val = hold_check(me_u3(msh, val, chvar_tag));
val = hold_check(me_b3(msh, val,
me_shint(msh, posmask), and_tag));
if (rsh != 0)
eshift =
hold_check(me_b3(msh, val, me_shint(slongsh, rsh), shl_tag));
else {
eshift = val;
sh(eshift) = msh;
};
idval = me_startid(f_top, eshift, 0);
if (rsz != bsz) {
cont = me_b3(msh, cont, me_shint(msh, negmask), and_tag);
cont = hold_check(me_b3(msh, cont, me_obtain(idval), or_tag));
}
else {
kill_exp(cont, cont);
cont = me_obtain(idval);
};
res = me_b3(f_top, me_obtain(id), cont,
(name(e) == bfass_tag)
? (unsigned char)ass_tag
: (unsigned char)assvol_tag);
res = hold_check(me_complete_id(idval, res));
replace(e, hold_check(me_complete_id(id, res)), scope);
retcell(e);
return 1;
};
default:
return (0);
}
}