Logo Search packages:      
Sourcecode: tendra version File versions  Download package

foralls.c

/*
             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:55:47 $
$Revision: 1.1.1.1 $
$Log: foralls.c,v $
 * Revision 1.1.1.1  1998/01/17  15:55:47  release
 * First version to be checked into rolling release.
 *
 * Revision 1.4  1997/02/18  12:56:25  currie
 * NEW DIAG STRUCTURE
 *
 * Revision 1.3  1996/12/19  14:28:35  currie
 * Foralls - using two counters
 *
Revision 1.2  1995/06/26 13:04:35  currie
make_stack_limit, env_size etc

 * Revision 1.1  1995/04/06  10:44:05  currie
 * Initial revision
 *
***********************************************************************/



#include "config.h"
#include "common_types.h"
#include "tags.h"
#include "expmacs.h"
#include "exp.h"
#include "check.h"
#include "shapemacs.h"
#include "check_id.h"
#include "install_fns.h"
#include "const.h"
#include "constmacs.h"
#include "flags.h"
#include "me_fns.h"
#include "basicread.h"
#include "xalloc.h"
#include "externs.h"
#include "foralls.h"

#define subvar 0x100

#define false 0
#define true  1

#define topsh f_top

#ifndef Assert
#if FS_STDC_HASH
#define Assert(x) if(!(x)) failer(#x)
#else
#define Assert(x) if(!(x)) failer("x")
#endif
#endif

exp * ifc_ptr_position
    PROTO_N ( (e) )
    PROTO_T ( exp e )
{
      exp * a;
      exp dad = father(e);
      if (son(dad)==e) {
            a = &son(dad);
      }
      else {
            exp sib = son(dad);
            while (bro(sib)!=e) { sib = bro(sib); }
            a = &bro(sib);
      }
      return a;
}

static exp * position
    PROTO_N ( (e) )
    PROTO_T ( exp e )
{
      exp dad = father(e);
      exp *res = &son(dad);
      while (*res != e) res = &bro(*res);
      return res;
}

int incr_var
    PROTO_N ( (e) )
    PROTO_T ( exp e )
{
      /* is e  var = var + val; */
      exp dest;
      exp src;
      if(name(e) != ass_tag) return false;
      dest = son(e);
      src = bro(dest);
      return (name(dest)==name_tag &&
                name(src)==plus_tag &&
                name(son(src))==name_tag &&
            name(bro(son(src)))==val_tag &&
                last(bro(son(src))) &&
            son(dest)==son(son(src)) &&
                no(dest) == no(son(src))
               );
}

exp alteredset = nilexp;

void isaltered
    PROTO_N ( (ld, always) )
    PROTO_T ( exp ld X int always )
{
      /* make copy of name!! - can be killed later */
      exp z ;
      exp nld;
      for (z = alteredset; z!=nilexp; z=bro(z)) {
           if (son(ld)==son(son(z)) &&
                (name(son(ld))!=proc_tag || no(ld) == no(son(z)) ) ){
            props(z) &= (prop)always;
            return;
           }
      }
      nld = getexp(sh(ld), alteredset, 1, son(ld), nilexp,
                                             props(ld), no(ld), name(ld));
      alteredset = getexp(nilexp, alteredset, alteredset==nilexp,
                                                nld, nilexp, (prop)always,0,0);
}

int assign_alias;
int jump_out;

void scan_for_incr
    PROTO_N ( (e, piece, f) )
    PROTO_T ( exp e X exp piece X void (*f) PROTO_S ((exp,int)) )
{
      /* applies f to all (var = var + val) done  in piece with bool set if
                  always done.
            where var is non-local of piece but non-global and not
            aliased and all other uses in piece are cont(var)
         also applies altered to  named variables (name_tag) which are
            assigned to, either in toto or by indexing.
         if there are any other assign_alias is set true
      */
    static int everytime = true;
    switch (name(e)){
      case name_tag: case env_offset_tag: return;
      case ass_tag:{
         exp dest = son(e);
         exp src = bro(son(e));
         if (name(dest)== name_tag  &&
               isvar(son(dest)) &&
               !isglob(son(dest)) &&
             iscaonly(son(dest)) &&
               name(src) == plus_tag )
             {exp la = son(src);
            exp ra = bro(son(src));
            if (last(ra) && name(ra)==val_tag &&
                    name(la) == cont_tag &&
                  name(son(la)) == name_tag &&
                    son(son(la))== son(dest) &&
                  no(dest) == no(son(la)) &&
                    !intnl_to(piece, son(dest)) )
                {exp p = pt(son(dest)); /*uses of var */
                 for(; p!=nilexp; p = pt(p))
#ifdef NEWDIAGS
                  {if (isdiaginfo(p) || p==dest || p == son(la) ||
#else
                  {if (p==dest || p == son(la) ||
#endif
                         (last(p) && name(bro(p))==cont_tag) ||
                         incr_var(father(p)) ||
                         !intnl_to(piece, p))
                       {continue;}
                   goto tryalias;
                    }
                 f(e, everytime); return;
                }
            }
      tryalias:
         if (name(dest) == name_tag && isvar(son(dest)) ) {
            isaltered(dest, everytime);
         }
         else
         if (name(dest) == addptr_tag && name(son(dest))==name_tag
            && isvar(son(son(dest))) ){
            isaltered(son(dest), everytime);
         }
         else
         if (name(dest)==reff_tag &&
               name(son(dest))== addptr_tag &&
             name(son(son(dest))) == name_tag &&
               isvar(son(son(son(dest)))) )
            {isaltered(son(son(dest)), everytime);}
         else
         if (name(dest) == name_tag &&
            ( props(son(dest)) & 0x10) !=0 /* const in some loop */ ) {
            exp def = son(son(dest));
            if (name(def) == reff_tag) def = son(def);
            if (name(def) == addptr_tag && name(son(def)) == name_tag &&
                  isvar(son(son(def))) ) {
                  isaltered(dest, everytime);
            }
            else assign_alias = true;
         }
         else assign_alias = true;
         scan_for_incr(dest, piece, f);
         scan_for_incr(src, piece, f);
         return ;
      }

      case case_tag: {
            scan_for_incr(son(e), piece, f);
            everytime = false;
            return;
      }

      case goto_tag: case testbit_tag:
      case test_tag: {
            int x = intnl_to(piece, pt(e));
            if (!x) jump_out = true;
            if (son(e)!=nilexp) scan_for_incr(son(e), piece, f);
            everytime = (everytime && !x);
            return;
      }
      case res_tag: {
            jump_out = true;
            scan_for_incr(son(e), piece, f);
            return;
      }
      case solve_tag: case rep_tag: case cond_tag: {
              exp z = son(e);
            int et = everytime;
            for(;;) {
                  scan_for_incr(z, piece, f);
                  everytime = false;
                  if (last(z)) break;
                  z=bro(z);
            }
            everytime = et;
            return;
      }

      case apply_tag: assign_alias = true; /* and do default */
      default: {
          exp z = son(e);
          if (z==nilexp) return;
          for(;;) {
            scan_for_incr(z, piece, f);
            if (last(z)) return;
            z = bro(z);
          }
      }
    }
}


int good_val
    PROTO_N ( (a, piece) )
    PROTO_T ( exp a X exp piece )
{
      /* result ((a is name external to piece)
           || (a is cont(name) where all uses of name in piece is cont))
      */
     if (name(a)==name_tag) {
      return (!intnl_to(piece, son(a)));
     }
     else
     if (name(a)==cont_tag && name(son(a))==name_tag &&
            !intnl_to(piece, son(son(a))) && !isvis(son(son(a)))) {
      exp lda = son(a);
      exp pa = pt(son(lda));
      for(; pa!=nilexp; pa = pt(pa)) {
#ifdef NEWDIAGS
           if (isdiaginfo(pa) || pa==lda || no(pa) != no(lda) ||
#else
           if (pa==lda || no(pa) != no(lda) ||
#endif
               (last(pa) && name(bro(pa))==cont_tag) ||
                  !intnl_to(piece, pa) ) continue;
           break;
      }
      return (pa==nilexp);
     }
     return false;
}

int usage_in
    PROTO_N ( (whole, part) )
    PROTO_T ( exp whole X exp part )
{
  exp q = part;
  int res = 1;
  int n = (int)name(q);
  while (q != whole && q != nilexp &&
      (n != ident_tag || (props (q) & 0x40) == 0)) {
    q = father (q);
    n = (int)name(q);
    if(n==cond_tag || n==rep_tag || n==solve_tag) res=2;
  }


  return (q == whole)?res:0;
}

int stride;
/* 0 initially, -1 either no common stride or non-constant stride,
               otherwise contains common stride. */

int find_common_index
    PROTO_N ( (ldname, piece, f) )
    PROTO_T ( exp ldname X exp piece X void (*f) PROTO_S ((exp,int)) )
{

      /* applies f to all addptr(x, cont(varid)) in piece
                  where good_index_factor(1)
                 and all addptr(x, mult(cont(varid), mval))
                  where good_index_factor(mval) and
                 and all test(cont(varid), val -> outside piece)
               with bool if it is done exactly once.
                   if different multiply facters are detected or
                   a multiplying factor is not good then stride is
                   set to -1 and the procedure returned from.
                stride holds the common multiplying factor, initially
                being 0.
            where x is  name external to piece
            or x is cont(name) where name is external to piece and
                all uses in piece are cont(name) NB no alias check
            result is no of other uses of varid in piece
      */
     exp p = pt(son(ldname));
     int otheruses = 0;
     for(; p!=nilexp; p = pt(p)) { /* examine each use of loop variable */
      int usagex;
#ifdef NEWDIAGS
      if (isdiaginfo(p)) continue;
#endif
      if (no(p)!=no(ldname)) continue;
      usagex = usage_in(piece, p);
      if (usagex==0) continue;
      otheruses++;
      if (last(p) && name(bro(p))==cont_tag ) {
           exp dad = father(bro(p));
             if (!good_index_factor(1))
                {stride = -1; UNUSED(dad); UNUSED(f); return 0;}
           if (name(dad) == addptr_tag &&
                 bro(son(dad))==bro(p) &&
                 last(bro(p))
              ) {
            if(good_val(son(dad), piece))
                   { f(dad,usagex==1);
                     otheruses--;
                     if (stride==0) stride=1;
                     else if (stride>1) stride = -1; UNUSED(f); return 0;
                   }
           }
           else
           if (name(dad)==offset_mult_tag &&
                 son(dad)==bro(p) &&
                 name(bro(son(dad)))==val_tag &&
               last(dad)
                )
             {exp grandad = father(dad);
                if (!good_index_factor(no(bro(son(dad)))/8))
                    {stride = -1; UNUSED(grandad); return 0;}
            if (name(grandad)==addptr_tag &&
                    bro(son(grandad)) == dad &&
                    last(dad))
                {if(good_val(son(grandad), piece))
                   {f(grandad,usagex==1);
                          otheruses--;
                          if (stride==0) stride=no(bro(son(dad)))/8;
                          else if (stride!=no(bro(son(dad)))/8)
                              {stride = -1; return 0;}
                           /*printf("stride=%d\n",stride);*/
                         }
                }
             }
           else
           if ((name(dad)==test_tag || name(dad)==testbit_tag)
                   && piece == bro(son(pt(dad))) )
            {f(dad, usagex==1); otheruses--;}
      }
     }
      return otheruses;
}

int find_pointer_opt
    PROTO_N ( (ldname, piece, f) )
    PROTO_T ( exp ldname X exp piece X void (*f) PROTO_S ((exp,int)) )
{

      /* applies f to all addptr(x, cont(varid)) in piece
                  where good_pointer_factor(1)
                 and all addptr(x, mult(cont(varid), mval))
                  where good_pointer_factor(mval) and
                 and all test(cont(varid), val -> outside piece)
               with bool if it is done exactly once.
            where x is  name external to piece
            or x is cont(name) where name is external to piece and
                all uses in piece are cont(name) NB no alias check
            result is no of other uses of varid in piece
      */
     exp p = pt(son(ldname));
     int otheruses = 0;
     for(; p!=nilexp; p = pt(p)) { /* examine each use of loop variable */
      int usagex;
#ifdef NEWDIAGS
      if (isdiaginfo(p)) continue;
#endif
      if (no(p)!=no(ldname)) continue;
      usagex = usage_in(piece, p);
      if (usagex==0) continue;
      otheruses++;
      if (last(p) && name(bro(p))==cont_tag ) {
           exp dad = father(bro(p));
           if (name(dad) == addptr_tag &&
                 bro(son(dad))==bro(p) &&
                 last(bro(p)) &&
               good_pointer_factor(1)) {
            if(good_val(son(dad), piece))
                   { f(dad,usagex==1);
                     otheruses--;
                 if (stride==0){ stride=1;}
                 else
                 if (stride>1) {stride = -1;}
                   }
           }
           else
           if (name(dad)==offset_mult_tag &&
                 son(dad)==bro(p) &&
                 simple_const(piece,bro(son(dad)),false,!assign_alias) &&
               last(dad) &&
                 (name(bro(son(dad)))!=val_tag ||
                  good_pointer_factor(no(bro(son(dad)))/8)
                 )
                )
             {exp grandad = father(dad);
            if (name(grandad)==addptr_tag &&
                    bro(son(grandad)) == dad &&
                    last(dad))
                {if(good_val(son(grandad), piece))
                   {int n =  -1;
                    f(grandad,usagex==1);
                          otheruses--;
                    if (name(bro(son(dad)))==val_tag) {
                        n = no(bro(son(dad)))/8;
                    }
                    else
                    if (name(bro(son(dad))) == name_tag) {
                        exp id = son(bro(son(dad)));
                        if (name(son(id))==val_tag) {
                              n = no(son(id));
                        }
                    }

                    if (stride==0) { stride = n; }
                    else if (stride != n) { stride = -1; }
                         }
                }
             }
           else
           if (name(dad)==test_tag && piece == bro(son(pt(dad))) )
            {f(dad, usagex==1); otheruses--;}
      }
     }
      return otheruses;
}

exp addptrs;
/* nilexp  initially */
      /* son = addptr exp;
         pt = [holder with son = different occurence of addptr exp]**(no-1)
                  chained through ptr
         props =1 if done exactly once
         other addptrs chained similarly through bro
      */

exp tests;
/* nilexp initially */
      /* son = test
         pt = [holder with son = different occurence of test]**(no-1)
         props = 1 if done exactly once
         other tests chained similarly through bro
      */

void collect_loopthings
    PROTO_N ( (ind, everytime) )
    PROTO_T ( exp ind X int everytime )
{
      /* builds addptrs and tests*/
      exp z;
      exp * loopthing = (name(ind)==test_tag)? &tests: &addptrs;
      for(z= *loopthing; z!=nilexp; z= bro(z)) {
            if (eq_exp(son(z), ind)) {
                  exp n = getexp(topsh, nilexp, 0, ind, pt(z),0,0, 0);
                  pt(z) =n;
                  no(z)++;
                  props(z) &= (prop)everytime;
                  return;
            }
      }
      *loopthing = getexp(topsh, *loopthing, *loopthing==nilexp, ind,
                         nilexp, (prop)everytime, 1, 0);

}


exp incrs;
/* nilexp initially */
      /* son = (v=v+val) exp;
         pt = [holder with son = different occurence with same v]**(no-1)
                  chained through pt
         props = 1 if done exactly once
         other (v=v+val)s chained similarly through bro
      */

int maybe_incr
    PROTO_N ( (e) )
    PROTO_T ( exp e )
{
      exp incs = incrs;
      if (name(e) == cont_tag) {
            e = son(e);
      }
      if (name(e) != name_tag) return 1;
      while (incs != nilexp) {
            exp dest = son(son(incs));
            Assert(name(dest) == name_tag);
            if (son(dest)==son(e)) return 1;
            incs = bro(incs);
      }
      return 0;
}

void collect_incrs
    PROTO_N ( (incr, everytime) )
    PROTO_T ( exp incr X int everytime )
{
      /* builds incrs */
      exp z;
      for(z=incrs; z!=nilexp; z= bro(z)) {
            if (son(son(son(z))) == son(son(incr))
                  && no(son(son(z)))==no(son(incr))  ) {
                  exp n = getexp(topsh, nilexp, 0, incr, pt(z), 0,0, 0);
                  pt(z) =n;
                  no(z)++;
                  props(z) &= (prop)everytime;
                  return;
            }
      }

      incrs = getexp(topsh, incrs, incrs==nilexp, incr,
                         nilexp, (prop)everytime, 1, 0);

}


/* transforms:

      strength reduction
            addptr(x, y) if x is invariant of loop
                        ie x = simple var
                        or x = cont(z) and z not altered in loop
                  NB difference between invariant and not altered


*/


/* incr is only incrementer
   addptrset is holder of addptr
   loop is rep l:body
   exp * looppos = position(loop)


always construct
      Var X = add_ptr(x,y)
            replace all add_ptrs by cont(X) in addptrset and loopbpdy
            replace incr by {X = reff(inc)c(X); incr}
                                               retaining handle on incr
            shift looppos to body

      if always done and x not altered
            look for cont( ..reff(s) reff(s+inc) ...reff(s+n*inc) )
            replace loop by:
               Var Ci[0..n-1] = cont(ref(s+i*inc)cont(X))
               in loop with newbody:
                  var Cn = cont(ref(s+n*inc)cont(X)) in
                        body(reffn/Cn,  incr/{ Ci=C[i+1]; incr})

*/

static void extract_addptrs
    PROTO_N ( ( incr, addptrset, loop, inc, inci, cons ) )
    PROTO_T ( exp incr X exp addptrset X exp loop X exp inc X int inci X int cons )
{
      /* replace loop by :
      Var X = add_ptr(x,y) in newbody :
            replace all add_ptrs by cont(X) in addptrset and loopbpdy
            replace incr by {X = reff(inc)c(X); incr}
                                                 retaining handle on incr
            inc is in bytes.

      */
      shape shvar = f_pointer(long_to_al(shape_align(sh(son(addptrset)))));
      exp id = getexp(sh(loop), bro(loop), last(loop), son(addptrset),
                     nilexp, 1 /*var*/, 0, ident_tag);
                  /* setsib(son(id), loop); setdad(loop, id) later */
      int i;
      exp z = addptrset;
      exp * pos;
      exp ld, ass, reff, cont, seq, dest;
        exp incr_2, prod_2, neg_prod_2, mult_2;
      setcaonly(id);
      for(i=0; i<no(addptrset); i++) {
            /* replace addptrs by cont(ld(id)) */
           exp sz = son(z) /*the addptr */;
           cont = getexp(sh(son(id)), bro(sz), last(sz), nilexp, nilexp,
                        0,0, cont_tag);
             ld = getexp(shvar, cont, 1, id, pt(id), 0, 0, name_tag);
           pos = position(sz);
           son(cont) = ld;
           pt(id) = ld; no(id)++;
           *pos = cont;
             son(z) = cont;
           if (i!=0) { kill_exp(sz, nilexp); }
           z = pt(z);

      }

      bro(son(id))= loop; clearlast(son(id));
      pos = position(loop);
        bro(loop) = id; setlast(loop);
      *pos = id;
if (cons || no(inc)!=0)
      {int mult = no(inc)*inci;
         if (cons) mult = inci*8;
         ld = getexp(shvar, nilexp, 1, id, pt(id), 0, 0, name_tag);
      pt(id) = ld; no(id)++;
      cont = getexp(sh(son(id)), nilexp, 1, ld, nilexp, 0,0, cont_tag);
      bro(ld) = cont;
      reff = getexp(sh(cont), nilexp, 1, cont, nilexp, 0, mult, reff_tag);
      bro(cont) = reff;
      dest = getexp(shvar, reff, 0, id, pt(id), 0, 0, name_tag);
      pt(id) = dest; no(id)++;
      ass = getexp(topsh, nilexp, 1, dest, nilexp, 0, 0, ass_tag);
      bro(reff) = ass;
      z = getexp(topsh, incr, 0, ass, nilexp, 0,0, 0);
      bro(ass) = z;
      seq = getexp(topsh, bro(incr), last(incr), z, nilexp, 0,0, seq_tag);
      pos = position(incr);
      bro(incr) = seq; setlast(incr);
      *pos = seq;}

else{        mult_2 = copy(inc);
        if (inci < 0)
         {incr_2 = getexp(sh(inc),nilexp,1,nilexp,nilexp,0,-inci,val_tag);
          bro(incr_2) = mult_2;
          clearlast(incr_2);
          neg_prod_2 = getexp(sh(inc), nilexp, 1, incr_2, nilexp,0,
                                                       0,offset_mult_tag);
          neg_prod_2 = hc(neg_prod_2,mult_2);
          prod_2 = getexp(sh(inc),nilexp,1,neg_prod_2,nilexp,0,0,neg_tag);
          bro(neg_prod_2) = prod_2;
         }
        else
         {incr_2 = getexp(sh(inc),nilexp,1,nilexp,nilexp,0,inci,val_tag);
          bro(incr_2) = mult_2;
          clearlast(incr_2);
          prod_2 = getexp(sh(inc),nilexp,0,incr_2,nilexp,0,0,offset_mult_tag);
          prod_2 = hc(prod_2,mult_2);
         }
        ld = getexp(shvar, nilexp, 1, id, pt(id), 0, 0, name_tag);
      pt(id) = ld; no(id)++;
      cont = getexp(sh(son(id)), nilexp, 0, ld, nilexp, 0,0, cont_tag);
      bro(ld) = cont;
      reff = getexp(sh(son(id)), nilexp, 1, cont, nilexp, 0, 0, addptr_tag);
        bro(cont) = prod_2;
      reff = hc(reff,prod_2);
      dest = getexp(shvar, reff, 0, id, pt(id), 0, 0, name_tag);
      pt(id) = dest; no(id)++;
      ass = getexp(topsh, nilexp, 1, dest, nilexp, 0, 0, ass_tag);
      bro(reff) = ass;
      z = getexp(topsh, incr, 0, ass, nilexp, 0,0, 0);
      bro(ass) = z;
      seq = getexp(topsh, bro(incr), last(incr), z, nilexp, 0,0, seq_tag);
      pos = position(incr);
      bro(incr) = seq; setlast(incr);
      *pos = seq;
    }
}

static void scale_loopid
    PROTO_N ( ( loop, addptrset, incrset) )
    PROTO_T ( exp loop X exp addptrset X exp incrset )
{
      /* replace loop body by :
      Var X = loopid*stride in newbody :
            replace all offset_mults by cont(X) in addptrset and loopbody
            replace incr by {X = c(X)+stride; incr}
                                                 retaining handle on incr
            inc is in bytes.

      */
      exp id = getexp(sh(loop), bro(loop), last(loop), bro(son(son(addptrset))),
                     nilexp, 1 /*var*/, 0, ident_tag);
                  /* setsib(son(id), loop); setdad(loop, id) later */

      exp * pos;
        exp incr = son(incrset);
        shape shvar = sh(son(bro(son(incr))));
      exp ld, ass, plus, cont, seq, dest, inc, z, next;
        while (addptrset != nilexp)
      {int i;
      z = addptrset;
        next = bro(addptrset);
      setcaonly(id);
      for(i=0; i<no(addptrset); i++) {
            /* replace addptrs by cont(ld(id)) */
           exp sz = bro(son(son(z))) /* the offset_mult */;
           cont = getexp(sh(son(id)), bro(sz), last(sz), nilexp, nilexp,
                        0,0, cont_tag);
             ld = getexp(shvar, cont, 1, id, pt(id), 0, 0, name_tag);
           pos = position(sz);
           son(cont) = ld;
           pt(id) = ld; no(id)++;
           *pos = cont;
             bro(son(son(z))) = cont;
           if (i!=0) { kill_exp(sz, nilexp); }
           z = pt(z);

      }
        retcell(addptrset);
        addptrset = next;
        }

      bro(son(id))= loop; clearlast(son(id));
      pos = position(loop);
        bro(loop) = id; setlast(loop);
      *pos = id;

        inc = getexp(sh(son(id)),nilexp,1,nilexp,nilexp,0,
                  stride*8*no(bro(son(bro(son(son(incrset)))))),val_tag);
        ld = getexp(shvar, nilexp, 1, id, pt(id), 0, 0, name_tag);
      pt(id) = ld; no(id)++;
      cont = getexp(sh(son(id)), nilexp, 0, ld, nilexp, 0,0, cont_tag);
      bro(ld) = cont;
      plus = getexp(sh(cont), nilexp, 1, cont, nilexp, 0, 0, plus_tag);
      bro(cont) = inc;
        bro(inc) = plus;
      dest = getexp(shvar, plus, 0, id, pt(id), 0, 0, name_tag);
      pt(id) = dest; no(id)++;
      ass = getexp(topsh, nilexp, 1, dest, nilexp, 0, 0, ass_tag);
      bro(plus) = ass;
      z = getexp(topsh, incr, 0, ass, nilexp, 0,0, 0);
      bro(ass) = z;
      seq = getexp(topsh, bro(incr), last(incr), z, nilexp, 0,0, seq_tag);
      pos = position(incr);
      bro(incr) = seq; setlast(incr);
      *pos = seq;
}


exp inner_cont
    PROTO_N ( (loopbody, contset) )
    PROTO_T ( exp loopbody X exp contset )
{

/*
      son contset = cont(X); pt = next instance
      replace loopbody by Var Z = cont(X) in loopbody(cont(X)/cont(Z))

*/

      exp z = contset;
      exp *pos;
      int i;
      exp id = getexp(sh(loopbody), bro(loopbody), last(loopbody),
                       son(contset), nilexp, 1/*var*/, 0, ident_tag);
      setcaonly(id);

      for(i=0; z!=nilexp; i++) {
          exp ld = getexp(sh(son(son(id))), nilexp, 1, id,
                                                   pt(id), 0, 0, name_tag);
          exp cont = getexp(sh(son(id)), bro(son(z)), last(son(z)),
                                       ld, nilexp, 0,0, cont_tag);
          bro(ld)=cont;
          pt(id) = ld; no(id)++;
          pos = position(son(z));
          *pos = cont;
          if(i!=0) kill_exp(son(z), nilexp);
          son(z) = cont;
          z = pt(z);
      }

      pos = position(loopbody);
      bro(son(id)) = loopbody; clearlast(son(id));
      bro(loopbody) = id; setlast(loopbody);
      *pos = id;
      return id;
}

exp outer_cont
    PROTO_N ( ( loop, contset, lastid, incr) )
    PROTO_T ( exp loop X exp contset X exp lastid X exp incr )
{

/*
      son contset = cont(X); pt = next instance
      replace loop by Var Z = cont(x) in
                  loop(cont(x)/cont(Z), incr/{Z=cont(lasttid); incr})
      returning new iddec
*/

      exp z = contset;
      exp seq, ld, cont, dest, ass;
      exp *pos;
      int i;
      exp id = getexp(sh(loop), bro(loop), last(loop), son(contset),
                  nilexp, 1/*var*/, 0, ident_tag);
      setcaonly(id);
      for(i=0; z!=nilexp; i++) {
          ld = getexp(sh(son(son(id))), nilexp, 1, id,
                                                 pt(id), 0, 0, name_tag);
          cont = getexp(sh(son(id)), bro(son(z)), last(son(z)),
                                   ld, nilexp, 0,0, cont_tag);
          bro(ld)=cont;
          pt(id) = ld; no(id)++;
          pos = position(son(z));
          *pos = cont;
          if(i!=0) kill_exp(son(z), nilexp);
          son(z) = cont;
          z = pt(z);
      }

      pos = position(loop);
      bro(son(id)) = loop; clearlast(son(id));
      bro(loop) = id; setlast(loop);
      *pos = id;


      ld = getexp(sh(son(son(id))), nilexp, 1, lastid,
                                            pt(lastid), 0, 0, name_tag);
      pt(lastid)=ld; no(lastid)++;
      cont = getexp(sh(son(id)), nilexp, 1, ld, nilexp, 0,0,cont_tag);
      bro(ld) = cont;
      dest = getexp(sh(son(son(id))), cont, 0, id, pt(id), 0, 0, name_tag);
      pt(id) = dest; no(id)++;
      ass = getexp(topsh, nilexp, 1, dest, nilexp, 0, 0, ass_tag);
      bro(cont)=ass;
      z = getexp(sh(incr), incr, 0, ass, nilexp, 0,0, 0);
      bro(ass) = z;
      seq = getexp(sh(incr), bro(incr), last(incr),z, nilexp, 0,0,seq_tag);
      pos = position(incr);
      bro(incr) = seq; setlast(incr);
      *pos = seq;

      return id;
}


int unaltered
    PROTO_N ( ( e, assign_alias) )
    PROTO_T ( exp e X int assign_alias )
{
      exp z = alteredset;
      if (name(e) == name_tag && isvar(son(e))) {
           for(; z!=nilexp; z = bro(z) ) {
            exp dest = son(z);
            Assert(name(dest)==name_tag);
                        if (!isvar(son(dest)) ) {
                  dest = son(son(dest));
                  if (name(dest) == reff_tag) dest = son(dest);
                  Assert(name(dest) == addptr_tag);
                  dest = son(dest);
            }
            if (son(e) == son(dest) &&
                  (name(son(e)) != proc_tag || no(e) == no(dest) ) ) {
                  return false;
            }
           }
           return (iscaonly(son(e)) || !assign_alias);
      }
      return false;
}



int invariant
    PROTO_N ( ( e, assign_alias) )
    PROTO_T ( exp e X int assign_alias )
{
      return ((name(e) == name_tag  )   ||
            (name(e) == cont_tag && unaltered(son(e), assign_alias) )  ) ;
}


static int multiplier;  /*part of answer to weaken */
static int arraystep;   /*part of answer to weaken */

int weaken
    PROTO_N ( (loop, addptrset, incrset) )
    PROTO_T ( exp loop X exp addptrset X exp incrset )
{
      /* applies strength reduction to addptrs in addptrset and
            delivers the multiplying factor if suitable for unwinding
                  otherwise 0
      */
      exp incr = son(incrset);
      exp addptr = son(addptrset);
      int inci = no(bro(son(bro(son(incr)))));
      exp minc = bro(son(addptr));
        int simple_c = 0;
      int res = -1;
      if (name(minc)==cont_tag) {
            multiplier = inci;
            arraystep = 1;
                simple_c = 1;
      }
      else {
            arraystep = no(bro(son(minc)))>>3;
            multiplier = inci*arraystep;
      }




      if (!invariant(son(addptr), assign_alias) || no(incrset)!=1)
        return 0;
      if (props(addptrset) && unaltered(son(addptr), assign_alias) )
            res= 1;

      extract_addptrs(incr, addptrset, loop,
                                bro(son(minc)),inci,simple_c);
      return res;
}

struct en{ exp e;
int disp;
};

int unwind
    PROTO_N ( (loop, contset, incr, incval) )
    PROTO_T ( exp loop X exp contset X exp incr X int incval )
{
      exp body = bro(son(bro(son(loop))));
      int i,j;
      exp z = contset;
      int n = no(contset);
      int insts = 0;
      struct en * s = (struct en*)xcalloc(n, sizeof(struct en));
      for(i=0; i<n; i++) {
          /* sort cont([reff (disp) cont(X)) into s */
          exp c = son(z);
          exp w;
          int n;
          exp next = pt(z);
          Assert(name(c)==cont_tag);
          if (!last(c)) { z= next; continue; }
          if (name(bro(c))==cont_tag) { n =0; w = bro(c);}
          else
          if (name(bro(c))==reff_tag && last(bro(c)) &&
                   name(bro(bro(c)))==cont_tag ) {
                n= no(bro(c)); w = bro(bro(c));
          }
            else { z= next; continue; }

          son(z)= w;

          for(j=0; j <insts; j++) {
            int d = s[j].disp;
            if (d==n) break;
            if ((incval>0 && d<n) || (incval <0 && d > n) ) {
                  /*make a hole  at jth position */
                  int k;
                  for(k=insts-1; k>=j; k--) {
                        s[k+1] = s[k];
                  }
                  s[j].e = nilexp;
                  insts++;
                  break;
            }
          }
          if (j==insts) { /* add another */
            insts++;
            s[j].e = nilexp;
          };
          pt(z) = s[j].e;
          s[j].e = z;
          s[j].disp= n;
          z = next;
      }
      if (insts==0) return false;
      z = nilexp;

      for (i = 0; i < insts; i++) {
            if (no(s[i].e) >1 ) z = inner_cont(body, s[i].e);
            for (; i < insts-1 && s[i].disp-incval*8 ==  s[i+1].disp; i++) {
            if (z==nilexp) z = inner_cont(body, s[i].e);
            z = outer_cont(loop, s[i+1].e, z, son(incr));
            }
            z= nilexp;
      }


      return true;
}

int all_before
    PROTO_N ( ( addptrset, inc, body) )
    PROTO_T ( exp addptrset X exp inc X exp body )
{
      exp z=inc;
      exp w;
      while ( z != body) {
          exp b = bro(z);
          if (!last(z) ) {
               for (w=addptrset; w!=nilexp; w= pt(w)) {
            /* son(w) is internal to body - is it in bro(z) ? ie after z*/
            exp s = son(w);
            while(s!=body && s !=b) s = father(s);
            if (s == b) return false;
              }
          }
          z = b;
      }
                  return true;
}


void replace_var
    PROTO_N ( (ldcpy, loop, shcont) )
    PROTO_T ( exp ldcpy X exp loop X shape shcont )
{
      /* ld is copy of the name(id) assigned to safely in loop
            (see do_one_rep)
          replace loop(id) by Var x := cont(id) in loop(x); id = cont(x) ni;
      */
      exp z;
      exp * pos;
      exp ld = getexp(sh(ldcpy), nilexp, 1, son(ldcpy),pt(son(ldcpy)),
                                  props(ldcpy), no(ldcpy), name(ldcpy));
      exp def = getexp(shcont, nilexp, 0, ld, nilexp, 0, 0, cont_tag);
      exp varid = getexp(sh(loop), bro(loop), last(loop),
                                def, nilexp, subvar |1/*var*/, 1, ident_tag);
      exp ldvar = getexp(sh(ld), nilexp, 1, varid, nilexp, 0, 0, name_tag);
      exp contvar = getexp(shcont, nilexp, 1, ldvar, nilexp, 0, 0,cont_tag);
      exp nld = getexp(sh(ld), contvar, 0, son(ld), ld, 0, no(ld),name_tag);
      exp ass = getexp(topsh, nilexp, 1, nld , nilexp, 0, 0, ass_tag);
      exp seqh = getexp(topsh, ass, 0, loop, nilexp, 0, 0, 0);
      exp seq = getexp(topsh, varid, 1, seqh, nilexp, 0, 0, seq_tag);
      bro(ass) = seq; /*father*/
      bro(contvar) = ass;/*father*/
      bro(ldvar) = contvar;/*father*/
      bro(ld) = def; /* father */
      pt(son(ld)) = nld; no(son(ld))+=2;  /* two new used of id */
      bro(def) = seq;
      pt(varid) = ldvar;
      setcaonly(varid);

      /* now relpace all old uses of ld in loop by varid */
      for( z = pt(ld); z != nilexp; z = pt(z)) {
            if (no(z) == no(ld) && intnl_to(loop, z) ) {
/* ALTERATION #1 */
            exp lu = getexp(sh(z), bro(z), last(z), varid, pt(varid), 0,
                              0, name_tag);
            pos = position(z);
            pt(varid) = lu; no(varid)++;
            kill_exp(z, nilexp); /* this should not kill the def of ld! */
            *pos = lu;
            }
      }
      pos = position(loop);
      *pos = varid;
      bro(loop) = seqh; setlast(loop);
}


exp limexp
    PROTO_N ( ( test, ld) )
    PROTO_T ( exp test X exp ld )
{
      exp lh = son(test);
      exp rh = bro(lh);
      if (name(lh) == cont_tag && name(son(lh) )== name_tag
            && son(son(lh))==son(ld) && no(son(lh))==no(ld) ) return rh;

      if (name(rh) == cont_tag && name(son(rh) )== name_tag
            && son(son(rh))==son(ld) && no(son(rh))==no(ld) ) return lh;
      return nilexp;
}

exp limaddptr
    PROTO_N ( (arr, val, m) )
    PROTO_T ( exp arr X exp val X int m )
{
      exp naddptr = getexp(sh(arr), nilexp, 0, copy(arr), nilexp, 0, 0,
                  addptr_tag);
      exp z, v;
        shape s;
      if (m==1 ) {
          z = copy(val);
          bro(z) = naddptr; setlast(z);
      }
      else {
            s = f_offset(al1_of(sh(naddptr)),al1_of(sh(naddptr)));
          z = getexp(s, naddptr, 1, copy(val), nilexp, 0,0,offset_mult_tag);
          v = getexp(s, z, 1, nilexp, nilexp, 0, m*8, val_tag);
          bro(son(z)) = v; clearlast(son(z));
      }
      bro(son(naddptr)) = z; clearlast(son(naddptr));
      return naddptr;
            /* a new addptr with index replaced by val - used in limdec*/
}

exp limmult
    PROTO_N ( (arr, val, m) )
    PROTO_T ( exp arr X exp val X int m )
{
      exp naddptr = getexp(sh(son(arr)), nilexp, 0, copy(val), nilexp, 0, 0,
                  mult_tag);
      exp v = getexp(sh(son(arr)), nilexp, 1, nilexp, nilexp, 0, m, val_tag);
      bro(v) = naddptr;
      bro(son(naddptr)) = v; clearlast(son(naddptr));
      return naddptr;
            /* a new addptr with index replaced by val - used in limdec*/
}

exp limreff
    PROTO_N ( (arr, bytedisp) )
    PROTO_T ( exp arr X int bytedisp )
{
        if (bytedisp != 0) {
      exp nreff = getexp(sh(arr), nilexp, 0, copy(arr),
                                              nilexp, 0, bytedisp*8, reff_tag);
      bro(son(nreff)) = nreff; setlast(son(nreff));
      return nreff;
        }
        else return copy(arr);
}

exp limconst
    PROTO_N ( (arr, bytedisp) )
    PROTO_T ( exp arr X int bytedisp )
{
      exp nreff = getexp(/*sh(son(arr))*/slongsh, nilexp, 1, nilexp,
                                              nilexp, 0, bytedisp, val_tag);
      UNUSED(arr);
      bro(nreff) = nreff;
      return nreff;
}

exp limdec
    PROTO_N ( ( adec, val, mult) )
    PROTO_T ( exp adec X exp val X int mult )
{
      exp init = son(adec);
      exp bdy = bro(init);
      exp ninit =  (name(val)!=val_tag) ?
                      limaddptr(son(init), val, mult):
                      limreff(son(init), mult*no(val)
                     );
      exp nb = getexp(sh(bdy), adec, 1, ninit, nilexp, 0, 0, ident_tag);
      bro(ninit) = bdy; clearlast(ninit);
      bro(bdy) = nb; setlast(bdy);
      bro(init) = nb;
      return nb; /* the declaration of the limit value */
}

exp limdec2
    PROTO_N ( ( adec, val, mult) )
    PROTO_T ( exp adec X exp val X int mult )
{
      exp init = son(adec);
      exp bdy = bro(init);
      exp ninit =  (name(val)!=val_tag) ?
                      limmult(son(init), val, mult):
                      limconst(son(init), mult*no(val)
                     );
      exp nb = getexp(sh(bdy), adec, 1, ninit, nilexp, 0, 0, ident_tag);
      bro(ninit) = bdy; clearlast(ninit);
      bro(bdy) = nb; setlast(bdy);
      bro(init) = nb;
      return nb; /* the declaration of the limit value */
}


void remove_incr
    PROTO_N ( (adec, test, incr, mult) )
    PROTO_T ( exp adec X exp test X exp incr X int mult )
{
      exp le = limexp(test, son(incr));
      exp * pos;
      exp ndec = limdec(adec, le, mult);
      exp lda = getexp(f_pointer(long_to_al(shape_align(sh(son(adec))))),
                                   nilexp, 1, adec, pt(adec), 0, 0, name_tag);
      exp clda = getexp(sh(son(adec)), nilexp, 0, lda,
                                              nilexp, 0, 0, cont_tag);
      exp ldn = getexp(sh(son(ndec)), nilexp, 0, ndec,
                                              pt(ndec), 0, 0, name_tag);
      exp ntestx = getexp(sh(test), bro(test), last(test),
                       nilexp, pt(test), props(test), no(test), name(test));
      bro(lda) = clda;   pt(adec) = lda; no(adec)++;
      pt(ndec) = ldn; no(ndec)++;
      if (last(le)) {
             son(ntestx) = clda;
             bro(clda) = ldn; clearlast(clda);
             bro(ldn) = ntestx; setlast(ldn);
      }
      else {
             son(ntestx) = ldn;
             bro(ldn) = clda; clearlast(ldn);
             bro(clda) = ntestx; setlast(clda);
      };
      pos = position(test);
      *pos = ntestx;
      kill_exp(test, nilexp);
      setname(incr, top_tag);
      kill_exp(bro(son(incr)), nilexp);
      kill_exp(son(incr), nilexp);
      son(incr) = nilexp;
}

void remove_incr2
    PROTO_N ( (adec, test, incr, mult) )
    PROTO_T ( exp adec X exp test X exp incr X int mult )
{
      exp le = limexp(test, son(incr));
      exp * pos;
      exp init = son(adec);
      exp bdy = bro(init);
      exp ninit,ldn,ntestx,lda,clda;
        if (name(le)!=val_tag && !remove_unused_index_counters)
           return;
      lda = getexp(f_pointer(long_to_al(shape_align(sh(son(adec))))),
                                   nilexp, 1, adec, pt(adec), 0, 0, name_tag);
      clda = getexp(/*sh(son(adec))*/slongsh, nilexp, 0, lda,
                                              nilexp, 0, 0, cont_tag);
        if  (name(le)==val_tag)
             {ninit = limconst(son(init), mult*no(le));
              ldn = ninit;
             }
        else {exp nb;
              ninit =  limmult(son(init), le, mult);
              nb = getexp(sh(bdy), adec, 1, ninit, nilexp, 0, 0, ident_tag);
            bro(ninit) = bdy; clearlast(ninit);
            bro(bdy) = nb; setlast(bdy);
            bro(init) = nb;
              ninit = nb;
              ldn = getexp(sh(son(ninit)), nilexp, 0, ninit,
                                              pt(ninit), 0, 0, name_tag);
              pt(ninit) = ldn; no(ninit)++;
             }
      ntestx = getexp(sh(test), bro(test), last(test),
                       nilexp, pt(test), props(test), no(test), name(test));
      bro(lda) = clda;   pt(adec) = lda; no(adec)++;
      if (last(le)) {
             son(ntestx) = clda;
             bro(clda) = ldn; clearlast(clda);
             bro(ldn) = ntestx; setlast(ldn);
      }
      else {
             son(ntestx) = ldn;
             bro(ldn) = clda; clearlast(ldn);
             bro(clda) = ntestx; setlast(clda);
      };
      pos = position(test);
      *pos = ntestx;
      kill_exp(test, nilexp);
      setname(incr, top_tag);
      kill_exp(bro(son(incr)), nilexp);
      kill_exp(son(incr), nilexp);
      son(incr) = nilexp;
}

int  use_in
    PROTO_N ( (w, ld) )
    PROTO_T ( exp w X exp ld )
{
      switch (name(w)) {
      case name_tag: {
            return (son(w)==son(ld) && no(w)==no(ld) ) ;
      }
      case ass_tag: {
            int z = use_in(bro(son(w)), ld) ;
            if (z!=0 ) return z;
            if (name(son(w)) == name_tag &&
                  son(son(w))==son(ld) &&
                  no(son(w))==no(ld))
              { return -1;}
            return use_in(son(w), ld);
      }
      case goto_tag:
        case case_tag:
        case test_tag: case testbit_tag:
        case labst_tag:{ return 1; }
      default: {
           exp z = son(w);
           if (z==nilexp) return 0;
           for(;;) {
            int a = use_in(z, ld);
            if (a !=0 || last(z)) return a;
            z = bro(z);
           }
      }
     }
}



int suitable_test
    PROTO_N ( (tests, incrld, loop) )
    PROTO_T ( exp tests X exp incrld X exp loop )
{
      /* is test such that one can remove the increment ? */
      exp t, p;
      exp decx = son(incrld);
      exp v;
      if (tests == nilexp || no(tests)!=1 || bro(tests) != nilexp )
          return 0;
      t = son(tests);
      v = limexp(t, incrld);
      if (name(v) != val_tag && (!invariant(v, assign_alias)|| maybe_incr(v)) )
          return 0;
      while(t!=loop && last(t)) t= bro(t);
      if (t!=loop) return 0;
      while (name(t) !=proc_tag && t != decx) {
           exp b = bro(t);
           if (!last(t)) {
            for (p=pt(decx); p!=nilexp; p=pt(p)) {
                  if (intnl_to(b, p)  && use_in(b, incrld) == 1)
                           return 0;
            }
           }
           t = b;
      }
      return 1;
}



int do_one_rep
    PROTO_N ( (loop) )
    PROTO_T ( exp loop )
{
      exp body = bro(son(bro(son(loop))));
      exp z ;
      int res =0;
      exp xincrs;
      Assert(name(loop)==rep_tag);
      incrs=nilexp; alteredset=nilexp;
        assign_alias = false; jump_out = false;
      scan_for_incr(body,loop, collect_incrs);
      if (  !jump_out && name(sh(loop)) == tophd) {
           for (z=alteredset;   z != nilexp; z = bro(z)) {
      /* look to see if var assigned to in loop can be locally declared
            ie Rep f(z) => Var x := cont(z) in Rep f(x); z = cont x ni;
                ? only worth while if z is global
            if z is local only worthwhile if it isnt being allocated
                in reg anyway
      */
            exp a = son(z);

            if (name(a)==name_tag &&
                   (isglob(son(a)) || !isvar(son(a)) ) &&
                 (props(son(a)) & subvar) == 0 &&
               (!assign_alias || (isvar(son(a)) && iscaonly(son(a)))) &&
                 !intnl_to(body, son(a)) ){
                exp p ;
                exp dc = son(a);
                shape shcont;
                int const_init = !isglob(dc) &&
                              (name(son(dc)) == clear_tag ||
                                       name(son(dc)) == val_tag ||
                               name(son(dc)) == real_tag ||
                               (name(son(dc)) == name_tag &&
                                        !isvar(son(son(dc)))
                                       )
                                      );
                for ( p = pt(son(a)); p != nilexp; p = pt(p)) {
#ifdef NEWDIAGS
                  int inb;
                  if (isdiaginfo(p)) continue;
                  inb = intnl_to(body,p);
#else
                  int inb = intnl_to(body,p);
#endif
                  if (!inb) { const_init = 0; continue; }
                  if (no(a) != no(p)) break;
                  if (last(p) && name(bro(p))==cont_tag)
                        { shcont = sh(bro(p)); continue; }
                  if (!last(p) && last(bro(p))  &&
                           name(bro(bro(p)))==ass_tag)
                        { shcont = sh(bro(p)); continue; }
                  break;
                }
                if (p!=nilexp) continue;
                /* only uses of this id is cont or assign in body */
                if (!isvar(son(a)) ){
                  /*check to see whether underlying id is used in loop*/
                  exp w = son(son(a));
                  const_init = 0;
                  if (name(w)==reff_tag) w=son(w);
                  Assert(name(w)==addptr_tag);
                  w = pt(son(son(w))); /* uses of underlying var */
                  for (; w!=nilexp; w= pt(w)) {
                      if (intnl_to(body, w)) break;
                  }
                  if ( w != nilexp)  continue;
                }
                if (const_init)
                      { /* can reduce scope of altered variable */
                  exp dc= son(a);
                  exp bd = bro(son(dc));
                        if ( bd != loop && name(dc) == ident_tag) {
                        exp brodc = bro(dc);
                        int ldc = last(dc);
                        exp broloop = bro(loop);
                        int lloop = last(loop);
                        exp * pos = position(dc);
                        *pos = bd;
                                      /* replace original dec with its body... */
                        bro(bd) = brodc;
                              if(ldc) { setlast(bd); } else { clearlast(bd); }
                                    /* ... and set  bro to that of dec */
                        pos = position(loop);
                        *pos = dc;  /* replace loop by dec ... */
                        bro(dc) = broloop;
                              if(lloop) {setlast(dc); } else {clearlast(dc); }
                                    /* ... set bro to that of loop, ... */
                        bro(son(dc)) = loop;
                              bro(loop) = dc;
                              setlast(loop);
                              /* ... and make loop be body of dec */
                  }

                }
                else {
                  SET(shcont); /* CHECK THIS: why is it set? */
                  replace_var(a, loop, shcont);
                };
                res = true;
            }
          }
      }
      xincrs = incrs;
      while (xincrs!=nilexp) {
           exp incrld = son(son(xincrs));
           exp nincr = bro(xincrs);
           int ou; exp adec = nilexp;
           int elsize;
           exp incrdec = son(incrld);
           tests=nilexp; addptrs=nilexp; stride = 0;
           ou=find_common_index(incrld, body, collect_loopthings);
             if (stride<1)
                {exp t;
             int i; int nap = 0;
             tests=nilexp;
                 addptrs=nilexp;
             stride = 0;
               ou=find_pointer_opt(incrld, body,
                         collect_loopthings);
            for(i=0, t=addptrs; t != nilexp; i++, t=bro(t)) {
                  nap += no(t);
            }
            if (i>=3 && i==nap) {
                  /* don't replace all addptrs if too many vars required
                    ... */
                  if (stride>1) {
                    /* ... but can still scale index */
                    scale_loopid(loop,addptrs,xincrs);
                    if (ou==2 /* only other uses besides addptr &
                        test are in increment */ &&
                              suitable_test(tests,son(son(xincrs)),loop)) {
                              remove_incr2(bro(loop),
                                   son(tests),
                                   son(xincrs),
                                   stride
                                  );
                    }
                  }
                  ou+=nap; addptrs = nilexp;

            }
              while (addptrs != nilexp)
              {int rw = weaken(loop, addptrs, xincrs);
               exp next = bro(addptrs);
               if (rw != 0)
                   {res = true;
                  adec = bro(loop); /* really father put in by weaken */
                  elsize = arraystep;
                   }
               else {SET(elsize); ou+=no(addptrs);}
               if (rw > 0)  /* there is only one incr and it is safe to
                   replace conts; however don't know whether increment
                   is before uses  - could make store-exception if
                         it isn't*/
                {if ( all_before(addptrs, son(xincrs), body) &&
                         multiplier!=0 )
                        IGNORE unwind(loop, addptrs, xincrs, multiplier);
                }
               retcell(addptrs);
               addptrs=next;
               };

              if ( ou == 2 /* only other uses (besides addptr & test)
                                              of loop var is in increment */
                && adec != nilexp && suitable_test(tests, incrld, loop)
                    && multiplier!=0
                    && remove_unused_counters)
              {remove_incr(adec, son(tests), son(xincrs), elsize);}

                 }
             else if (stride>1)
               {scale_loopid(loop,addptrs,xincrs);
                if (ou==2 /* only other uses besides addptr & test are in increment */ &&
                    suitable_test(tests,son(son(xincrs)),loop))
                      remove_incr2(bro(loop),
                                   son(tests),
                                   son(xincrs),
                                   stride
                                  );
               }

           if(res && no(incrdec)<10 /* avoid n-squared factor */)
                  IGNORE check_id( incrdec, bro(son(incrdec)) );

           xincrs=nincr;
      }
      while (incrs != nilexp){
            exp z = bro(incrs);
            retcell(incrs);
            incrs = z;
      }
      while (alteredset !=nilexp)
            { exp z = bro(alteredset);
              retcell(son(alteredset));
                  retcell(alteredset);
                  alteredset = z; }
      return res;
}

void order_loops
    PROTO_N ( (reps) )
    PROTO_T ( exp reps )
{
      /* start at outer loop ?! */
      if ( (props(reps) & 0x80) == 0 ){
            if (bro(reps)!=nilexp) order_loops(bro(reps));
            if (son(reps) != nilexp &&
                    name(son(reps))==rep_tag &&
                    no(reps) < max_loop_depth)
              { exp loop = son(reps);
/* ALTERATION #2 - does not effect C */
                if (name(son(loop)) != top_tag) {
                  /* make loop(st,b) into seq((st), loop(make_top, b))
                        analysis assumes son(loop) = top!
                  */
                  exp st = son(loop);
                  exp b = bro(st);
                  exp * pos = ifc_ptr_position(loop);
                  exp mt = getexp(f_top, b,0, nilexp,
                                    nilexp, 0, 0, top_tag);
                  exp sl = getexp(f_top, loop, 0 ,st, nilexp, 0,0,0);
                  exp s = getexp(sh(loop), bro(loop), last(loop), sl,
                              nilexp, 0, 0, seq_tag);

                    bro(st) = sl; setlast(st);
                    son(loop) = mt;
                    bro(loop) = s; setlast(loop);
                    *pos = s;

                }
                IGNORE do_one_rep(loop);
              }
            props(reps) |=0x80;
      }
}

void forall_opt
    PROTO_Z ()
{
      exp reps =get_repeats();
      while (reps != nilexp) {
            order_loops(reps);
            reps = pt(reps);
      }
  if (do_loopconsts) {
    do_foralls = false;
    repeat_consts ();         /* try constant extraction again */
  }
}

Generated by  Doxygen 1.6.0   Back to index