Subversion Repositories openrisc

/* Pass manager for Fortran front end.

   Copyright (C) 2010, 2011 Free Software Foundation, Inc.

   Contributed by Thomas König.

This file is part of GCC.

GCC is free software; you can redistribute it and/or modify it under

the terms of the GNU General Public License as published by the Free

Software Foundation; either version 3, or (at your option) any later

version.

GCC is distributed in the hope that it will be useful, but WITHOUT ANY

WARRANTY; without even the implied warranty of MERCHANTABILITY or

FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License

for more details.

You should have received a copy of the GNU General Public License

along with GCC; see the file COPYING3.  If not see

<http://www.gnu.org/licenses/>.  */

#include "config.h"

#include "system.h"

#include "gfortran.h"

#include "arith.h"

#include "flags.h"

#include "dependency.h"

#include "constructor.h"

#include "opts.h"

/* Forward declarations.  */

static void strip_function_call (gfc_expr *);

static void optimize_namespace (gfc_namespace *);

static void optimize_assignment (gfc_code *);

static bool optimize_op (gfc_expr *);

static bool optimize_comparison (gfc_expr *, gfc_intrinsic_op);

static bool optimize_trim (gfc_expr *);

static bool optimize_lexical_comparison (gfc_expr *);

static void optimize_minmaxloc (gfc_expr **);

/* How deep we are inside an argument list.  */

static int count_arglist;

/* Pointer to an array of gfc_expr ** we operate on, plus its size

   and counter.  */

static gfc_expr ***expr_array;

static int expr_size, expr_count;

/* Pointer to the gfc_code we currently work on - to be able to insert

   a block before the statement.  */

static gfc_code **current_code;

/* Pointer to the block to be inserted, and the statement we are

   changing within the block.  */

static gfc_code *inserted_block, **changed_statement;

/* The namespace we are currently dealing with.  */

static gfc_namespace *current_ns;

/* If we are within any forall loop.  */

static int forall_level;

/* Keep track of whether we are within an OMP workshare.  */

static bool in_omp_workshare;

/* Entry point - run all passes for a namespace.  So far, only an

   optimization pass is run.  */

void

gfc_run_passes (gfc_namespace *ns)

{

  if (gfc_option.flag_frontend_optimize)

    {

      expr_size = 20;

      expr_array = XNEWVEC(gfc_expr **, expr_size);

      optimize_namespace (ns);

      if (gfc_option.dump_fortran_optimized)

        gfc_dump_parse_tree (ns, stdout);

      XDELETEVEC (expr_array);

    }

}

/* Callback for each gfc_code node invoked through gfc_code_walker

   from optimize_namespace.  */

static int

optimize_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,

               void *data ATTRIBUTE_UNUSED)

{

  gfc_exec_op op;

  op = (*c)->op;

  if (op == EXEC_CALL || op == EXEC_COMPCALL || op == EXEC_ASSIGN_CALL

      || op == EXEC_CALL_PPC)

    count_arglist = 1;

  else

    count_arglist = 0;

  if (op == EXEC_ASSIGN)

    optimize_assignment (*c);

  return 0;

}

/* Callback for each gfc_expr node invoked through gfc_code_walker

   from optimize_namespace.  */

static int

optimize_expr (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,

               void *data ATTRIBUTE_UNUSED)

{

  bool function_expr;

  if ((*e)->expr_type == EXPR_FUNCTION)

    {

      count_arglist ++;

      function_expr = true;

    }

  else

    function_expr = false;

  if (optimize_trim (*e))

    gfc_simplify_expr (*e, 0);

  if (optimize_lexical_comparison (*e))

    gfc_simplify_expr (*e, 0);

  if ((*e)->expr_type == EXPR_OP && optimize_op (*e))

    gfc_simplify_expr (*e, 0);

  if ((*e)->expr_type == EXPR_FUNCTION && (*e)->value.function.isym)

    switch ((*e)->value.function.isym->id)

      {

      case GFC_ISYM_MINLOC:

      case GFC_ISYM_MAXLOC:

        optimize_minmaxloc (e);

        break;

      default:

        break;

      }

  if (function_expr)

    count_arglist --;

  return 0;

}

/* Callback function for common function elimination, called from cfe_expr_0.

   Put all eligible function expressions into expr_array.  */

static int

cfe_register_funcs (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,

          void *data ATTRIBUTE_UNUSED)

{

  if ((*e)->expr_type != EXPR_FUNCTION)

    return 0;

  /* We don't do character functions with unknown charlens.  */

  if ((*e)->ts.type == BT_CHARACTER

      && ((*e)->ts.u.cl == NULL || (*e)->ts.u.cl->length == NULL

          || (*e)->ts.u.cl->length->expr_type != EXPR_CONSTANT))

    return 0;

  /* We don't do function elimination within FORALL statements, it can

     lead to wrong-code in certain circumstances.  */

  if (forall_level > 0)

    return 0;

  /* If we don't know the shape at compile time, we create an allocatable

     temporary variable to hold the intermediate result, but only if

     allocation on assignment is active.  */

  if ((*e)->rank > 0 && (*e)->shape == NULL && !gfc_option.flag_realloc_lhs)

    return 0;

  /* Skip the test for pure functions if -faggressive-function-elimination

     is specified.  */

  if ((*e)->value.function.esym)

    {

      /* Don't create an array temporary for elemental functions.  */

      if ((*e)->value.function.esym->attr.elemental && (*e)->rank > 0)

        return 0;

      /* Only eliminate potentially impure functions if the

         user specifically requested it.  */

      if (!gfc_option.flag_aggressive_function_elimination

          && !(*e)->value.function.esym->attr.pure

          && !(*e)->value.function.esym->attr.implicit_pure)

        return 0;

    }

  if ((*e)->value.function.isym)

    {

      /* Conversions are handled on the fly by the middle end,

         transpose during trans-* stages and TRANSFER by the middle end.  */

      if ((*e)->value.function.isym->id == GFC_ISYM_CONVERSION

          || (*e)->value.function.isym->id == GFC_ISYM_TRANSFER

          || gfc_inline_intrinsic_function_p (*e))

        return 0;

      /* Don't create an array temporary for elemental functions,

         as this would be wasteful of memory.

         FIXME: Create a scalar temporary during scalarization.  */

      if ((*e)->value.function.isym->elemental && (*e)->rank > 0)

        return 0;

      if (!(*e)->value.function.isym->pure)

        return 0;

    }

  if (expr_count >= expr_size)

    {

      expr_size += expr_size;

      expr_array = XRESIZEVEC(gfc_expr **, expr_array, expr_size);

    }

  expr_array[expr_count] = e;

  expr_count ++;

  return 0;

}

/* Returns a new expression (a variable) to be used in place of the old one,

   with an an assignment statement before the current statement to set

   the value of the variable. Creates a new BLOCK for the statement if

   that hasn't already been done and puts the statement, plus the

   newly created variables, in that block.  */

static gfc_expr*

create_var (gfc_expr * e)

{

  char name[GFC_MAX_SYMBOL_LEN +1];

  static int num = 1;

  gfc_symtree *symtree;

  gfc_symbol *symbol;

  gfc_expr *result;

  gfc_code *n;

  gfc_namespace *ns;

  int i;

  /* If the block hasn't already been created, do so.  */

  if (inserted_block == NULL)

    {

      inserted_block = XCNEW (gfc_code);

      inserted_block->op = EXEC_BLOCK;

      inserted_block->loc = (*current_code)->loc;

      ns = gfc_build_block_ns (current_ns);

      inserted_block->ext.block.ns = ns;

      inserted_block->ext.block.assoc = NULL;

      ns->code = *current_code;

      inserted_block->next = (*current_code)->next;

      changed_statement = &(inserted_block->ext.block.ns->code);

      (*current_code)->next = NULL;

      /* Insert the BLOCK at the right position.  */

      *current_code = inserted_block;

      ns->parent = current_ns;

    }

  else

    ns = inserted_block->ext.block.ns;

  sprintf(name, "__var_%d",num++);

  if (gfc_get_sym_tree (name, ns, &symtree, false) != 0)

    gcc_unreachable ();

  symbol = symtree->n.sym;

  symbol->ts = e->ts;

  if (e->rank > 0)

    {

      symbol->as = gfc_get_array_spec ();

      symbol->as->rank = e->rank;

      if (e->shape == NULL)

        {

          /* We don't know the shape at compile time, so we use an

             allocatable. */

          symbol->as->type = AS_DEFERRED;

          symbol->attr.allocatable = 1;

        }

      else

        {

          symbol->as->type = AS_EXPLICIT;

          /* Copy the shape.  */

          for (i=0; i<e->rank; i++)

            {

              gfc_expr *p, *q;

              p = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,

                                         &(e->where));

              mpz_set_si (p->value.integer, 1);

              symbol->as->lower[i] = p;

              q = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,

                                         &(e->where));

              mpz_set (q->value.integer, e->shape[i]);

              symbol->as->upper[i] = q;

            }

        }

    }

  symbol->attr.flavor = FL_VARIABLE;

  symbol->attr.referenced = 1;

  symbol->attr.dimension = e->rank > 0;

  gfc_commit_symbol (symbol);

  result = gfc_get_expr ();

  result->expr_type = EXPR_VARIABLE;

  result->ts = e->ts;

  result->rank = e->rank;

  result->shape = gfc_copy_shape (e->shape, e->rank);

  result->symtree = symtree;

  result->where = e->where;

  if (e->rank > 0)

    {

      result->ref = gfc_get_ref ();

      result->ref->type = REF_ARRAY;

      result->ref->u.ar.type = AR_FULL;

      result->ref->u.ar.where = e->where;

      result->ref->u.ar.as = symbol->ts.type == BT_CLASS

                             ? CLASS_DATA (symbol)->as : symbol->as;

      if (gfc_option.warn_array_temp)

        gfc_warning ("Creating array temporary at %L", &(e->where));

    }

  /* Generate the new assignment.  */

  n = XCNEW (gfc_code);

  n->op = EXEC_ASSIGN;

  n->loc = (*current_code)->loc;

  n->next = *changed_statement;

  n->expr1 = gfc_copy_expr (result);

  n->expr2 = e;

  *changed_statement = n;

  return result;

}

/* Warn about function elimination.  */

static void

warn_function_elimination (gfc_expr *e)

{

  if (e->expr_type != EXPR_FUNCTION)

    return;

  if (e->value.function.esym)

    gfc_warning ("Removing call to function '%s' at %L",

                 e->value.function.esym->name, &(e->where));

  else if (e->value.function.isym)

    gfc_warning ("Removing call to function '%s' at %L",

                 e->value.function.isym->name, &(e->where));

}

/* Callback function for the code walker for doing common function

   elimination.  This builds up the list of functions in the expression

   and goes through them to detect duplicates, which it then replaces

   by variables.  */

static int

cfe_expr_0 (gfc_expr **e, int *walk_subtrees,

          void *data ATTRIBUTE_UNUSED)

{

  int i,j;

  gfc_expr *newvar;

  /* Don't do this optimization within OMP workshare. */

  if (in_omp_workshare)

    {

      *walk_subtrees = 0;

      return 0;

    }

  expr_count = 0;

  gfc_expr_walker (e, cfe_register_funcs, NULL);

  /* Walk through all the functions.  */

  for (i=1; i<expr_count; i++)

    {

      /* Skip if the function has been replaced by a variable already.  */

      if ((*(expr_array[i]))->expr_type == EXPR_VARIABLE)

        continue;

      newvar = NULL;

      for (j=0; j<i; j++)

        {

          if (gfc_dep_compare_functions(*(expr_array[i]),

                                        *(expr_array[j]), true) == 0)

            {

              if (newvar == NULL)

                newvar = create_var (*(expr_array[i]));

              if (gfc_option.warn_function_elimination)

                warn_function_elimination (*(expr_array[j]));

              free (*(expr_array[j]));

              *(expr_array[j]) = gfc_copy_expr (newvar);

            }

        }

      if (newvar)

        *(expr_array[i]) = newvar;

    }

  /* We did all the necessary walking in this function.  */

  *walk_subtrees = 0;

  return 0;

}

/* Callback function for common function elimination, called from

   gfc_code_walker.  This keeps track of the current code, in order

   to insert statements as needed.  */

static int

cfe_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,

          void *data ATTRIBUTE_UNUSED)

{

  current_code = c;

  inserted_block = NULL;

  changed_statement = NULL;

  return 0;

}

/* Dummy function for expression call back, for use when we

   really don't want to do any walking.  */

static int

dummy_expr_callback (gfc_expr **e ATTRIBUTE_UNUSED, int *walk_subtrees,

                     void *data ATTRIBUTE_UNUSED)

{

  *walk_subtrees = 0;

  return 0;

}

/* Code callback function for converting

   do while(a)

   end do

   into the equivalent

   do

     if (.not. a) exit

   end do

   This is because common function elimination would otherwise place the

   temporary variables outside the loop.  */

static int

convert_do_while (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,

                  void *data ATTRIBUTE_UNUSED)

{

  gfc_code *co = *c;

  gfc_code *c_if1, *c_if2, *c_exit;

  gfc_code *loopblock;

  gfc_expr *e_not, *e_cond;

  if (co->op != EXEC_DO_WHILE)

    return 0;

  if (co->expr1 == NULL || co->expr1->expr_type == EXPR_CONSTANT)

    return 0;

  e_cond = co->expr1;

  /* Generate the condition of the if statement, which is .not. the original

     statement.  */

  e_not = gfc_get_expr ();

  e_not->ts = e_cond->ts;

  e_not->where = e_cond->where;

  e_not->expr_type = EXPR_OP;

  e_not->value.op.op = INTRINSIC_NOT;

  e_not->value.op.op1 = e_cond;

  /* Generate the EXIT statement.  */

  c_exit = XCNEW (gfc_code);

  c_exit->op = EXEC_EXIT;

  c_exit->ext.which_construct = co;

  c_exit->loc = co->loc;

  /* Generate the IF statement.  */

  c_if2 = XCNEW (gfc_code);

  c_if2->op = EXEC_IF;

  c_if2->expr1 = e_not;

  c_if2->next = c_exit;

  c_if2->loc = co->loc;

  /* ... plus the one to chain it to.  */

  c_if1 = XCNEW (gfc_code);

  c_if1->op = EXEC_IF;

  c_if1->block = c_if2;

  c_if1->loc = co->loc;

  /* Make the DO WHILE loop into a DO block by replacing the condition

     with a true constant.  */

  co->expr1 = gfc_get_logical_expr (gfc_default_integer_kind, &co->loc, true);

  /* Hang the generated if statement into the loop body.  */

  loopblock = co->block->next;

  co->block->next = c_if1;

  c_if1->next = loopblock;

  return 0;

}

/* Code callback function for converting

   if (a) then

   ...

   else if (b) then

   end if

   into

   if (a) then

   else

     if (b) then

     end if

   end if

   because otherwise common function elimination would place the BLOCKs

   into the wrong place.  */

static int

convert_elseif (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,

                void *data ATTRIBUTE_UNUSED)

{

  gfc_code *co = *c;

  gfc_code *c_if1, *c_if2, *else_stmt;

  if (co->op != EXEC_IF)

    return 0;

  /* This loop starts out with the first ELSE statement.  */

  else_stmt = co->block->block;

  while (else_stmt != NULL)

    {

      gfc_code *next_else;

      /* If there is no condition, we're done.  */

      if (else_stmt->expr1 == NULL)

        break;

      next_else = else_stmt->block;

      /* Generate the new IF statement.  */

      c_if2 = XCNEW (gfc_code);

      c_if2->op = EXEC_IF;

      c_if2->expr1 = else_stmt->expr1;

      c_if2->next = else_stmt->next;

      c_if2->loc = else_stmt->loc;

      c_if2->block = next_else;

      /* ... plus the one to chain it to.  */

      c_if1 = XCNEW (gfc_code);

      c_if1->op = EXEC_IF;

      c_if1->block = c_if2;

      c_if1->loc = else_stmt->loc;

      /* Insert the new IF after the ELSE.  */

      else_stmt->expr1 = NULL;

      else_stmt->next = c_if1;

      else_stmt->block = NULL;

      else_stmt = next_else;

    }

  /*  Don't walk subtrees.  */

  return 0;

}

/* Optimize a namespace, including all contained namespaces.  */

static void

optimize_namespace (gfc_namespace *ns)

{

  current_ns = ns;

  forall_level = 0;

  in_omp_workshare = false;

  gfc_code_walker (&ns->code, convert_do_while, dummy_expr_callback, NULL);

  gfc_code_walker (&ns->code, convert_elseif, dummy_expr_callback, NULL);

  gfc_code_walker (&ns->code, cfe_code, cfe_expr_0, NULL);

  gfc_code_walker (&ns->code, optimize_code, optimize_expr, NULL);

  /* BLOCKs are handled in the expression walker below.  */

  for (ns = ns->contained; ns; ns = ns->sibling)

    {

      if (ns->code == NULL || ns->code->op != EXEC_BLOCK)

        optimize_namespace (ns);

    }

}

/* Replace code like

   a = matmul(b,c) + d

   with

   a = matmul(b,c) ;   a = a + d

   where the array function is not elemental and not allocatable

   and does not depend on the left-hand side.

*/

static bool

optimize_binop_array_assignment (gfc_code *c, gfc_expr **rhs, bool seen_op)

{

  gfc_expr *e;

  e = *rhs;

  if (e->expr_type == EXPR_OP)

    {

      switch (e->value.op.op)

        {

          /* Unary operators and exponentiation: Only look at a single

             operand.  */

        case INTRINSIC_NOT:

        case INTRINSIC_UPLUS:

        case INTRINSIC_UMINUS:

        case INTRINSIC_PARENTHESES:

        case INTRINSIC_POWER:

          if (optimize_binop_array_assignment (c, &e->value.op.op1, seen_op))

            return true;

          break;

        default:

          /* Binary operators.  */

          if (optimize_binop_array_assignment (c, &e->value.op.op1, true))

            return true;

          if (optimize_binop_array_assignment (c, &e->value.op.op2, true))

            return true;

          break;

        }

    }

  else if (seen_op && e->expr_type == EXPR_FUNCTION && e->rank > 0

           && ! (e->value.function.esym

                 && (e->value.function.esym->attr.elemental

                     || e->value.function.esym->attr.allocatable

                     || e->value.function.esym->ts.type != c->expr1->ts.type

                     || e->value.function.esym->ts.kind != c->expr1->ts.kind))

           && ! (e->value.function.isym

                 && (e->value.function.isym->elemental

                     || e->ts.type != c->expr1->ts.type

                     || e->ts.kind != c->expr1->ts.kind))

           && ! gfc_inline_intrinsic_function_p (e))

    {

      gfc_code *n;

      gfc_expr *new_expr;

      /* Insert a new assignment statement after the current one.  */

      n = XCNEW (gfc_code);

      n->op = EXEC_ASSIGN;

      n->loc = c->loc;

      n->next = c->next;

      c->next = n;

      n->expr1 = gfc_copy_expr (c->expr1);

      n->expr2 = c->expr2;

      new_expr = gfc_copy_expr (c->expr1);

      c->expr2 = e;

      *rhs = new_expr;

      return true;

    }

  /* Nothing to optimize.  */

  return false;

}

/* Remove unneeded TRIMs at the end of expressions.  */

static bool

remove_trim (gfc_expr *rhs)

{

  bool ret;

  ret = false;