Blame | 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: release $
$Date: 1998/01/17 15:56:05 $
$Revision: 1.1.1.1 $
$Log: dump_distr.c,v $
* Revision 1.1.1.1 1998/01/17 15:56:05 release
* First version to be checked into rolling release.
*
* Revision 1.2 1995/09/12 10:59:17 currie
* gcc pedanttry
*
* Revision 1.1 1995/04/13 09:08:06 currie
* Initial revision
*
***********************************************************************/
/* dump_distr.c
Idea is to avoid dumping of s-registers and register parameters
if there is a simple route through a procedure which only uses the values
of its parameters, constants, globals or t-registers.
Applied to rscopes after registers have been allocated .
Mechanism is to insert a new exp with name dump_tag in the
appropriate place where son is exp after dump, pt is next dump starting
at pt of original rscope with no and prop fields telling which regs to dump.
Main proc is dump_opt; if dump_opt_flag is off then dump is placed in at highest
level, dumping all the required registers.
*/
#include "config.h"
#include "common_types.h"
#include "exptypes.h"
#include "exp.h"
#include "expmacs.h"
#include "tags.h"
#include "bitsmacs.h"
#include "new_tags.h"
#include "procrectypes.h"
#include "common_types.h"
#include "shapemacs.h"
#include "frames.h"
#include "regable.h"
#include "dump_distr.h"
bool do_dump_opt = 1; /* may be unset by -d flag */
static space zsp = {
0, 0
}; /* long fixed, long flt */
void maxsp
PROTO_N ( (a, b) )
PROTO_T ( space * a X space b )
{
a -> fixed |= b.fixed;
a -> flt |= b.flt;
}
space suses
PROTO_N ( (e, pars, incpars) )
PROTO_T ( exp e X space * pars X int incpars )
{
/* accumulate s regs used in e; pars gives bits indicating which s-regs
are used for the parameters of current proc; incpars says dont ignore
pars in registers */
space ans;
ans = zsp;
if (e == nilexp)
return ans;
switch (name(e)) {
case name_tag: {
exp id = son (e);
if (name (id) == ident_tag) {
if (isglob (id) || (props (id) & inanyreg) == 0)
return ans /* global or not in register */ ;
if ((props (id) & defer_bit) != 0)
return suses (son (id), pars, incpars) /* dec does not take space */ ;
if (isparam(id) && no(id) !=0 &&
((!incpars && props(son(id)) != 0) || no(id)==props(son(id)) ) )
/* par in original reg (perhaps destined for sreg) */
return ans;
if ((props(id) & infreg_bits)!=0 ) {
if (no (id) != 16 && no (id) != 0) {/* uses floating s-reg */
ans.flt = 3 << ((no (id)) << 1);
}
}
else
if (no (id) != 0 && no (id) != 2) {
/* in s seg */
if (isparam(id) && props(son(id)) !=0 &&
props(son(id)) >= incpars) return ans;
ans.fixed = 1 << (no (id));
}
}
break;
}
case case_tag:
{
return suses (son (e), pars, incpars);
}
case seq_tag: {
exp t = son (son (e));
ans = suses (bro (son (e)), pars, incpars);
for (;;) {
maxsp (&ans, suses (t, pars,incpars));
if (last (t)) {
return ans;
}
t = bro (t);
}
}
case 0:
case goto_tag:
case val_tag:
case null_tag:
case real_tag:
case string_tag:
case clear_tag:
case top_tag:
case env_offset_tag:
{
break;
}
case apply_general_tag: case tail_call_tag:{
maxsp(&ans, *pars);
goto default1;
}
case caller_tag: return suses(son(e), pars, incpars);
case apply_tag: {
/* proc call preserves s-regs; however must make sure that any
pars destined for s-regs get there */
exp dad = father(e);
if (name(dad)==res_tag && props(dad)) {
/* tl recursion - don't have to dump link or later regs */
int i;
exp p = bro(son(e));
if (last(son(e)) || name(p)==top_tag) return ans;
for(i=(incpars>4)?incpars:4; ; i++) {
if (!valregable(sh(p))) i=8;
maxsp(&ans, suses(p, pars, i));
if(last(p)) return ans;
p = bro(p);
}
} else maxsp (&ans, *pars);
} /* else cont to default */
default: default1:{
exp t = son (e);
maxsp (&ans, suses (t, pars,incpars));
while (t!=nilexp && !last (t)) {
t = bro (t);
maxsp (&ans, suses (t, pars,incpars));
}
}
}
return ans;
}
bool sameregs
PROTO_N ( (a, b) )
PROTO_T ( space * a X space * b )
{
/* regs a <= regs b */
return ((a -> fixed | b -> fixed) == b -> fixed && (a -> flt | b -> flt) == b -> flt);
}
space remd
PROTO_N ( (tobd, dmpd) )
PROTO_T ( space * tobd X space * dmpd )
{
/* any regs left out of tobd after dmpd has been done */
space ans;
ans.fixed = tobd -> fixed & ~dmpd -> fixed;
ans.flt = tobd -> flt & ~dmpd -> flt;
return ans;
}
bool placedump
PROTO_N ( (pe, dmpd, tobd, nds) )
PROTO_T ( exp * pe X space * dmpd X space * tobd X space * nds )
{
/* replace exp in pe by new dump with props = fixeds and no = flts to be
dumped ; thread different dumps to same rsc via pt; delivers bool to
say whether all sregs have been dumped */
exp e = *pe;
exp dflt = getexp(nilexp, nilexp, 1, nilexp,nilexp, 0, nds->flt & ~dmpd->flt, dump_tag);
exp dump = getexp (sh (e), bro (e), last (e), e, dflt, 0, (nds -> fixed & ~dmpd -> fixed),
dump_tag);
bro (e) = dump;
setlast (e);
*(pe) = dump;
(dmpd -> fixed) |= nds -> fixed;
(dmpd -> flt) |= nds -> flt;
return sameregs (tobd, dmpd);
}
exp goodcond
PROTO_N ( (first, second, beforeb, pars) )
PROTO_T ( exp first X exp second X space * beforeb X space * pars )
{
/* delivers last exp in seq first after all tests (to second) ;
beforeb is space upto end of tests; second only use beforeb;
otherwise nilexp */
exp t;
space nds;
int n = no (son (second)); /* no of uses of labst second */
if (name (first) != seq_tag)
return nilexp;
t = son (son (first));
*beforeb = zsp;
for (;;) {
maxsp(beforeb, suses(t, pars, 0));
if (name (t) == test_tag) {
if (pt (t) != second)
return nilexp;
if (--n == 0) break;
}
if (last (t)) {
return nilexp;
}
t = bro (t);
}
nds = suses (second, pars, 0);
if (sameregs (&nds, beforeb))
return t;
return nilexp;
}
bool alljumps
PROTO_N ( (e, slv, nol) )
PROTO_T ( exp e X exp slv X int * nol )
{
/* all all branches to labsts of slove_tag slv in e ? */
recurse:
switch (name(e)) {
case case_tag: {
exp z = bro(son(e));
for(;;) {
if (father(pt(z))==slv) {
if (--(*nol)==0) return 1;
}
if (last(z)) { e = son(e); goto recurse; }
z = bro(z);
}
}
case goto_tag: case test_tag: {
if (father(pt(e))==slv) {
if (--(*nol)==0) return 1;
}
if (name(e)== goto_tag) return 0;
/* and continue */
}
case name_tag: case val_tag: case float_tag: case string_tag:
return 0;
default: {
exp se = son(e);
if (se==nilexp) return 0;
for(;;) {
if (last(se)) { e = se; goto recurse; }
if (alljumps(se, slv, nol)) return 1;
se = bro(se);
}
}
}
}
bool goodsolve
PROTO_N ( (e) )
PROTO_T ( exp e )
{
exp m = bro(son(e));
int nol;
for(nol=0;;nol++) {
if (no(son(m))!=1) return 0; /* more than one branch to labst */
if (last(m)) break;
m = bro(m);
}
return alljumps(son(e), e, &nol);
}
static int notregs;
static int notfregs;
/* use to make sure of enough t-regs which are not par regs; I reuse any
par registers whose pars are put in s-regs as t-regs */
void pushdumps
PROTO_N ( (pe, dmpd, tobd, pars) )
PROTO_T ( exp * pe X space * dmpd X space * tobd X space * pars )
{
/* tries to delay the dumps of the s-regs as late as possible
; pe is the place in the tree to insert any dump found
necessary in this recursion; dmpd gives the sregs already dumped and
tobd is all which may have to be dumped; pars give the registers
containing the initial position of any parameters */
space nds;
exp e = *(pe);
exp *arg;
switch (name (e)) {
case ident_tag: {
nds = suses (son (e), pars,0);
if ((props (e) & inanyreg) != 0 && no (e) == 0) {
/* This definition will be allocated into a t-reg so make sure
of enough t-regs which are not par regs; I reuse any par
registers whose pars are put in s-regs as t-regs */
if (is_floating (name (sh (son (e))))) {
if (notfregs-- < 0) {
nds = remd (tobd, dmpd);
placedump ( pe, dmpd, tobd, &nds);
return;
}
}
else {
if (notregs-- < 0) {
nds = remd (tobd, dmpd);
placedump ( pe, dmpd, tobd, &nds);
return;
}
}
}
if (name (son (e)) != clear_tag ||
(isparam(e) && props(son(e))==0 /* ie initially on stack */) ) {
/* id could be in s-reg; find from use */
maxsp (&nds, suses (pt (e), pars, 0));
}
if (sameregs (&nds, dmpd) ||
!placedump ( pe, dmpd, tobd, &nds)) {
/* not all regs have been dumped - continue with body */
arg = &bro(son (e));
pushdumps ( arg, dmpd, tobd, pars);
}
return;
}
case seq_tag: {
exp prev;
exp list = son (son (e));
if (last(list) ) {
nds = suses(bro(son(e)), pars, 8);
if (nds.fixed==0 && nds.flt==0) {
/* seq consists of two exps with last not using regs */
pushdumps(&son(son(e)), dmpd, tobd, pars);
return;
}
}
nds = suses (list, pars, 0);
if (!sameregs (&nds, dmpd)) {
/* first statement uses undumped s-regs */
if (placedump ( pe, dmpd, tobd, &nds)) {
return;
}
}
prev = list;
while (!last (list)) {
prev = list;
list = bro (list);
nds = suses (list, pars, 0);
if (!sameregs (&nds, dmpd)) {
/* uses undumped s-regs; construct new seq as result of this
one .... */
exp s_hold = getexp (sh (e), bro (son (e)), 0, list, nilexp, 0, 0,
name (son (e)));
exp seq = getexp (sh (e), e, 1, s_hold, nilexp, 0, 0, seq_tag);
bro (prev) = son (e);
setlast (prev);
bro (son (e)) = seq;
bro (bro (s_hold)) = seq;
while (!last (list)) {
list = bro (list);
}
bro (list) = s_hold;
/* .... and continue with new result */
arg = &bro(son (e));
if (!placedump ( arg, dmpd, tobd, &nds)) {
pushdumps ( arg, dmpd, tobd, pars);
}
return;
}
}
/* no new s-regs used - carry on with result */
arg = &bro(son (e));
pushdumps ( arg, dmpd, tobd, pars);
return;
}
case cond_tag: {
exp first = son (e);
exp second = bro (first);
exp t;
bool same;
space beforeb;
nds = suses (first, pars, 0);
same = sameregs (&nds, dmpd);
if (!same && (t = goodcond (first, second, &beforeb, pars)) != nilexp) {
/* worth looking further into first part */
if (!sameregs(&beforeb, dmpd) ) {
if (placedump ( pe, dmpd, tobd, &beforeb)) {
return;
}
}
if (!last (t)) {
exp seq_hold =
getexp (sh (first), bro (son (first)), 0, bro (t), nilexp, 0, 0,
name (son (first)));
exp new =
getexp (sh (first), first, 1, seq_hold, nilexp, 0, 0, seq_tag);
exp x = son (seq_hold);
while (!last (x)) {
x = bro (x);
}
bro (x) = seq_hold; /* set dad son seq_hold */
bro (bro (seq_hold)) = new;
setlast (bro (seq_hold));/* set dad of seq_hold */
bro (son (first)) = new;
setlast (t);
bro (t) = son (first);
/* first is now (t; (rest of first)) */
}
arg = &bro(son (first));
pushdumps ( arg, dmpd, tobd, pars);
return;
}
if (!same) { /* new s-regs used in first part */
if (placedump ( pe, dmpd, tobd, &nds)) {
return;
}
}
arg = &bro(son (e));
pushdumps ( arg, dmpd, tobd, pars);
return;
}
/* case diag_tag:
case fscope_tag:
case cscope_tag: {
arg= &son(e);
pushdumps ( arg, dmpd, tobd, pars);
return;
}
*/
case labst_tag: { /* can only arrive here from cond */
arg = &bro(son (e));
pushdumps ( arg, dmpd, tobd, pars);
return;
}
case solve_tag: {
if (goodsolve(e)) {
exp m = bro(son(e));
space old_dmpd;
nds = suses(son(e), pars, 0);
if (!sameregs(&nds, dmpd)) {
if (placedump(pe, dmpd,tobd, &nds) ) return;
}
old_dmpd = *dmpd;
for(;;) {
pushdumps(&bro(son(m)), dmpd, tobd, pars);
if (last(m)) return;
m = bro(m);
*dmpd = old_dmpd;
}
} /* else continue ... */
}
default: {
nds = suses(e, pars, 0);
if (!sameregs(&nds, dmpd)) {
placedump ( pe, dmpd, tobd, &nds);
}
}
}
}
void dump_opt
PROTO_N ( (rscope, tobd, pars) )
PROTO_T ( exp rscope X space * tobd X space * pars )
{
/* rscope is proc-tag exp; tobd is set of s-regs to be dumped; pars is
subset of tobd which will be used as parameters of proc */
exp * arg;
space dmpd;
dmpd = zsp; /* those regs already dumped */
arg = &son(rscope);
notregs = 10;
notfregs = 8; /* no of t-regs != par regs */
if (!do_dump_opt || No_S || sameregs (tobd, &dmpd) ||
name(rscope)!=proc_tag) {
placedump ( arg, &dmpd, tobd, tobd);
}
else {
pushdumps ( arg, &dmpd, tobd, pars);
}
return;
}