File gcc41-fortran-where-opt.patch of Package gcc41

Index: gcc-4.1.2-20070115/gcc/fortran/Make-lang.in
===================================================================
--- gcc-4.1.2-20070115.orig/gcc/fortran/Make-lang.in	2009-11-20 13:42:11.000000000 +0100
+++ gcc-4.1.2-20070115/gcc/fortran/Make-lang.in	2009-11-20 13:42:12.000000000 +0100
@@ -287,7 +287,7 @@ fortran/trans-types.o: $(GFORTRAN_TRANS_
   real.h toplev.h $(TARGET_H)
 fortran/trans-const.o: $(GFORTRAN_TRANS_DEPS)
 fortran/trans-expr.o: $(GFORTRAN_TRANS_DEPS) fortran/dependency.h
-fortran/trans-stmt.o: $(GFORTRAN_TRANS_DEPS)
+fortran/trans-stmt.o: $(GFORTRAN_TRANS_DEPS) fortran/dependency.h
 fortran/trans-io.o: $(GFORTRAN_TRANS_DEPS) gt-fortran-trans-io.h \
   fortran/ioparm.def
 fortran/trans-array.o: $(GFORTRAN_TRANS_DEPS)
Index: gcc-4.1.2-20070115/gcc/fortran/dependency.c
===================================================================
--- gcc-4.1.2-20070115.orig/gcc/fortran/dependency.c	2009-11-20 13:42:11.000000000 +0100
+++ gcc-4.1.2-20070115/gcc/fortran/dependency.c	2009-11-20 13:42:12.000000000 +0100
@@ -259,10 +259,10 @@ gfc_check_argument_var_dependency (gfc_e
     {
     case EXPR_VARIABLE:
       return (gfc_ref_needs_temporary_p (expr->ref)
-	      || gfc_check_dependency (var, expr, NULL, 0));
+	      || gfc_check_dependency (var, expr, 1));
 
     case EXPR_ARRAY:
-      return gfc_check_dependency (var, expr, NULL, 0);
+      return gfc_check_dependency (var, expr, 1);
 
     case EXPR_FUNCTION:
       if (intent != INTENT_IN && expr->inline_noncopying_intrinsic)
@@ -384,15 +384,14 @@ return 0;
 
 /* Return true if the statement body redefines the condition.  Returns
    true if expr2 depends on expr1.  expr1 should be a single term
-   suitable for the lhs of an assignment.  The symbols listed in VARS
-   must be considered to have all possible values. All other scalar
-   variables may be considered constant.  Used for forall and where
+   suitable for the lhs of an assignment.  The IDENTICAL flag indicates
+   whether array references to the same symbol with identical range
+   references count as a dependency or not.  Used for forall and where
    statements.  Also used with functions returning arrays without a
    temporary.  */
 
 int
-gfc_check_dependency (gfc_expr * expr1, gfc_expr * expr2, gfc_expr ** vars,
-		      int nvars)
+gfc_check_dependency (gfc_expr * expr1, gfc_expr * expr2, bool identical)
 {
   gfc_ref *ref;
   int n;
@@ -412,11 +411,11 @@ gfc_check_dependency (gfc_expr * expr1,
   switch (expr2->expr_type)
     {
     case EXPR_OP:
-      n = gfc_check_dependency (expr1, expr2->value.op.op1, vars, nvars);
+      n = gfc_check_dependency (expr1, expr2->value.op.op1, identical);
       if (n)
 	return n;
       if (expr2->value.op.op2)
-	return gfc_check_dependency (expr1, expr2->value.op.op2, vars, nvars);
+	return gfc_check_dependency (expr1, expr2->value.op.op2, identical);
       return 0;
 
     case EXPR_VARIABLE:
@@ -436,15 +435,25 @@ gfc_check_dependency (gfc_expr * expr1,
       if (expr1->symtree->n.sym != expr2->symtree->n.sym)
 	return 0;
 
-      for (ref = expr2->ref; ref; ref = ref->next)
-	{
-	  /* Identical ranges return 0, overlapping ranges return 1.  */
-	  if (ref->type == REF_ARRAY)
-	    return 1;
-	}
+      if (identical)
+	return 1;
+
+      /* Identical ranges return 0, overlapping ranges return 1.  */
+
+      /* Return zero if we refer to the same full arrays.  */
+      if (expr1->ref->type == REF_ARRAY
+	  && expr2->ref->type == REF_ARRAY
+	  && expr1->ref->u.ar.type == AR_FULL
+	  && expr2->ref->u.ar.type == AR_FULL
+	  && !expr1->ref->next
+	  && !expr2->ref->next)
+	return 0;
+
       return 1;
 
     case EXPR_FUNCTION:
+      if (expr2->inline_noncopying_intrinsic)
+	identical = 1;
       /* Remember possible differences between elemental and
          transformational functions.  All functions inside a FORALL
          will be pure.  */
@@ -453,7 +462,7 @@ gfc_check_dependency (gfc_expr * expr1,
 	{
 	  if (!actual->expr)
 	    continue;
-	  n = gfc_check_dependency (expr1, actual->expr, vars, nvars);
+	  n = gfc_check_dependency (expr1, actual->expr, identical);
 	  if (n)
 	    return n;
 	}
Index: gcc-4.1.2-20070115/gcc/fortran/dependency.h
===================================================================
--- gcc-4.1.2-20070115.orig/gcc/fortran/dependency.h	2009-11-20 13:42:11.000000000 +0100
+++ gcc-4.1.2-20070115/gcc/fortran/dependency.h	2009-11-20 13:42:12.000000000 +0100
@@ -25,7 +25,7 @@ bool gfc_ref_needs_temporary_p (gfc_ref
 gfc_expr *gfc_get_noncopying_intrinsic_argument (gfc_expr *);
 int gfc_check_fncall_dependency (gfc_expr *, sym_intent, gfc_symbol *,
 				 gfc_actual_arglist *);
-int gfc_check_dependency (gfc_expr *, gfc_expr *, gfc_expr **, int);
+int gfc_check_dependency (gfc_expr *, gfc_expr *, bool);
 int gfc_is_same_range (gfc_array_ref *, gfc_array_ref *, int, int);
 int gfc_expr_is_one (gfc_expr *, int);
 
Index: gcc-4.1.2-20070115/gcc/fortran/trans-array.h
===================================================================
--- gcc-4.1.2-20070115.orig/gcc/fortran/trans-array.h	2009-11-20 13:42:11.000000000 +0100
+++ gcc-4.1.2-20070115/gcc/fortran/trans-array.h	2009-11-20 13:42:12.000000000 +0100
@@ -116,9 +116,6 @@ tree gfc_conv_descriptor_stride (tree, t
 tree gfc_conv_descriptor_lbound (tree, tree);
 tree gfc_conv_descriptor_ubound (tree, tree);
 
-/* Dependency checking for WHERE and FORALL.  */
-int gfc_check_dependency (gfc_expr *, gfc_expr *, gfc_expr **, int);
-
 /* Add pre-loop scalarization code for intrinsic functions which require
    special handling.  */
 void gfc_add_intrinsic_ss_code (gfc_loopinfo *, gfc_ss *);
Index: gcc-4.1.2-20070115/gcc/fortran/trans-stmt.c
===================================================================
--- gcc-4.1.2-20070115.orig/gcc/fortran/trans-stmt.c	2006-11-07 18:33:22.000000000 +0100
+++ gcc-4.1.2-20070115/gcc/fortran/trans-stmt.c	2009-11-20 13:42:12.000000000 +0100
@@ -37,6 +37,7 @@ Software Foundation, 51 Franklin Street,
 #include "trans-array.h"
 #include "trans-const.h"
 #include "arith.h"
+#include "dependency.h"
 
 typedef struct iter_info
 {
@@ -48,13 +49,6 @@ typedef struct iter_info
 }
 iter_info;
 
-typedef  struct temporary_list
-{
-  tree temporary;
-  struct temporary_list *next;
-}
-temporary_list;
-
 typedef struct forall_info
 {
   iter_info *this_loop;
@@ -68,8 +62,7 @@ typedef struct forall_info
 }
 forall_info;
 
-static void gfc_trans_where_2 (gfc_code *, tree, tree, forall_info *,
-                               stmtblock_t *, temporary_list **temp);
+static void gfc_trans_where_2 (gfc_code *, tree, forall_info *, stmtblock_t *);
 
 /* Translate a F95 label number to a LABEL_EXPR.  */
 
@@ -258,7 +251,7 @@ gfc_conv_elemental_dependencies (gfc_se
 	    && fsym->attr.intent == INTENT_OUT
 	    && arg->next->expr
 	    && arg->next->expr->expr_type ==  EXPR_VARIABLE
-	    && gfc_check_dependency (e, arg->next->expr, NULL, 0))
+	    && gfc_check_dependency (e, arg->next->expr, 1))
 	{
 	  /* Make a local loopinfo for the temporary creation, so that
 	     none of the other ss->info's have to be renormalized.  */
@@ -2446,7 +2439,6 @@ gfc_trans_forall_1 (gfc_code * code, for
   gfc_saved_var *saved_vars;
   iter_info *this_forall, *iter_tmp;
   forall_info *info, *forall_tmp;
-  temporary_list *temp;
 
   gfc_start_block (&block);
 
@@ -2633,7 +2625,7 @@ gfc_trans_forall_1 (gfc_code * code, for
 	{
 	case EXEC_ASSIGN:
           /* A scalar or array assignment.  */
-	  need_temp = gfc_check_dependency (c->expr, c->expr2, varexpr, nvar);
+	  need_temp = gfc_check_dependency (c->expr, c->expr2, 0);
           /* Temporaries due to array assignment data dependencies introduce
              no end of problems.  */
 	  if (need_temp)
@@ -2652,31 +2644,13 @@ gfc_trans_forall_1 (gfc_code * code, for
 	  break;
 
         case EXEC_WHERE:
-
 	  /* Translate WHERE or WHERE construct nested in FORALL.  */
-          temp = NULL;
-	  gfc_trans_where_2 (c, NULL, NULL, nested_forall_info, &block, &temp);
-
-          while (temp)
-            {
-              tree args;
-              temporary_list *p;
-
-              /* Free the temporary.  */
-              args = gfc_chainon_list (NULL_TREE, temp->temporary);
-              tmp = gfc_build_function_call (gfor_fndecl_internal_free, args);
-              gfc_add_expr_to_block (&block, tmp);
-
-              p = temp;
-              temp = temp->next;
-              gfc_free (p);
-            }
-
-          break;
+	  gfc_trans_where_2 (c, NULL, nested_forall_info, &block);
+	  break;
 
         /* Pointer assignment inside FORALL.  */
 	case EXEC_POINTER_ASSIGN:
-          need_temp = gfc_check_dependency (c->expr, c->expr2, varexpr, nvar);
+          need_temp = gfc_check_dependency (c->expr, c->expr2, 0);
           if (need_temp)
             gfc_trans_pointer_assign_need_temp (c->expr, c->expr2,
                                                 nested_forall_info, &block);
@@ -2751,62 +2725,27 @@ tree gfc_trans_forall (gfc_code * code)
    needed by the WHERE mask expression multiplied by the iterator number of
    the nested forall.
    ME is the WHERE mask expression.
-   MASK is the temporary which value is mask's value.
-   NMASK is another temporary which value is !mask.
-   TEMP records the temporary's address allocated in this function in order to
-   free them outside this function.
-   MASK, NMASK and TEMP are all OUT arguments.  */
+   MASK is the current execution mask upon input.
+   CMASK is the updated execution mask on output, or NULL if not required.
+   PMASK is the pending execution mask on output, or NULL if not required.
+   BLOCK is the block in which to place the condition evaluation loops.  */
 
-static tree
+static void
 gfc_evaluate_where_mask (gfc_expr * me, forall_info * nested_forall_info,
-                         tree * mask, tree * nmask, temporary_list ** temp,
-                         stmtblock_t * block)
+			 tree mask, tree cmask, tree pmask,
+			 tree mask_type, stmtblock_t * block)
 {
   tree tmp, tmp1;
   gfc_ss *lss, *rss;
   gfc_loopinfo loop;
-  tree ptemp1, ntmp, ptemp2;
-  tree inner_size, size;
-  stmtblock_t body, body1, inner_size_body;
+  stmtblock_t body, body1;
+  tree count, cond, mtmp;
   gfc_se lse, rse;
-  tree count;
-  tree tmpexpr;
 
   gfc_init_loopinfo (&loop);
 
-  /* Calculate the size of temporary needed by the mask-expr.  */
-  gfc_init_block (&inner_size_body);
-  inner_size = compute_inner_temp_size (me, me, &inner_size_body, &lss, &rss);
-
-  /* Calculate the total size of temporary needed.  */
-  size = compute_overall_iter_number (nested_forall_info, inner_size,
-				      &inner_size_body, block);
-
-  /* Allocate temporary for where mask.  */
-  tmp = allocate_temp_for_forall_nest_1 (boolean_type_node, size, block,
-					 &ptemp1);
-  /* Record the temporary address in order to free it later.  */
-  if (ptemp1)
-    {
-      temporary_list *tempo;
-      tempo = (temporary_list *) gfc_getmem (sizeof (temporary_list));
-      tempo->temporary = ptemp1;
-      tempo->next = *temp;
-      *temp = tempo;
-    }
-
-  /* Allocate temporary for !mask.  */
-  ntmp = allocate_temp_for_forall_nest_1 (boolean_type_node, size, block,
-					  &ptemp2);
-  /* Record the temporary  in order to free it later.  */
-  if (ptemp2)
-    {
-      temporary_list *tempo;
-      tempo = (temporary_list *) gfc_getmem (sizeof (temporary_list));
-      tempo->temporary = ptemp2;
-      tempo->next = *temp;
-      *temp = tempo;
-    }
+  lss = gfc_walk_expr (me);
+  rss = gfc_walk_expr (me);
 
   /* Variable to index the temporary.  */
   count = gfc_create_var (gfc_array_index_type, "count");
@@ -2843,19 +2782,46 @@ gfc_evaluate_where_mask (gfc_expr * me,
       rse.ss = rss;
       gfc_conv_expr (&rse, me);
     }
-  /* Form the expression of the temporary.  */
-  lse.expr = gfc_build_array_ref (tmp, count);
-  tmpexpr = gfc_build_array_ref (ntmp, count);
-
-  /* Use the scalar assignment to fill temporary TMP.  */
-  tmp1 = gfc_trans_scalar_assign (&lse, &rse, me->ts.type);
-  gfc_add_expr_to_block (&body1, tmp1);
-
-  /* Fill temporary NTMP.  */
-  tmp1 = build1 (TRUTH_NOT_EXPR, TREE_TYPE (lse.expr), lse.expr);
-  gfc_add_modify_expr (&body1, tmpexpr, tmp1);
 
- if (lss == gfc_ss_terminator)
+  /* Variable to evalate mask condition.  */
+  cond = gfc_create_var (mask_type, "cond");
+  if (mask && (cmask || pmask))
+    mtmp = gfc_create_var (mask_type, "mask");
+  else mtmp = NULL_TREE;
+
+  gfc_add_block_to_block (&body1, &lse.pre);
+  gfc_add_block_to_block (&body1, &rse.pre);
+
+  gfc_add_modify_expr (&body1, cond, fold_convert (mask_type, rse.expr));
+
+  if (mask && (cmask || pmask))
+    {
+      tmp = gfc_build_array_ref (mask, count);
+      gfc_add_modify_expr (&body1, mtmp, tmp);
+    }
+
+  if (cmask)
+    {
+      tmp1 = gfc_build_array_ref (cmask, count);
+      tmp = cond;
+      if (mask)
+	tmp = build2 (TRUTH_AND_EXPR, mask_type, mtmp, tmp);
+      gfc_add_modify_expr (&body1, tmp1, tmp);
+    }
+
+  if (pmask)
+    {
+      tmp1 = gfc_build_array_ref (pmask, count);
+      tmp = build1 (TRUTH_NOT_EXPR, mask_type, cond);
+      if (mask)
+	tmp = build2 (TRUTH_AND_EXPR, mask_type, mtmp, tmp);
+      gfc_add_modify_expr (&body1, tmp1, tmp);
+    }
+
+  gfc_add_block_to_block (&body1, &lse.post);
+  gfc_add_block_to_block (&body1, &rse.post);
+
+  if (lss == gfc_ss_terminator)
     {
       gfc_add_block_to_block (&body, &body1);
     }
@@ -2883,11 +2849,6 @@ gfc_evaluate_where_mask (gfc_expr * me,
     tmp1 = gfc_trans_nested_forall_loop (nested_forall_info, tmp1, 1, 1);
 
   gfc_add_expr_to_block (block, tmp1);
-
-  *mask = tmp;
-  *nmask = ntmp;
-
-  return tmp1;
 }
 
 
@@ -2909,7 +2870,7 @@ gfc_trans_where_assign (gfc_expr *expr1,
   tree tmp;
   stmtblock_t block;
   stmtblock_t body;
-  tree index, maskexpr, tmp1;
+  tree index, maskexpr;
 
 #if 0
   /* TODO: handle this special case.
@@ -3004,21 +2965,10 @@ gfc_trans_where_assign (gfc_expr *expr1,
   else
     gfc_conv_expr (&lse, expr1);
 
-  /* Form the mask expression according to the mask tree list.  */
+  /* Form the mask expression according to the mask.  */
   index = count1;
-  tmp = mask;
-  if (tmp != NULL)
-    maskexpr = gfc_build_array_ref (tmp, index);
-  else
-    maskexpr = NULL;
-
-  tmp = TREE_CHAIN (tmp);
-  while (tmp)
-    {
-      tmp1 = gfc_build_array_ref (tmp, index);
-      maskexpr = build2 (TRUTH_AND_EXPR, TREE_TYPE (tmp1), maskexpr, tmp1);
-      tmp = TREE_CHAIN (tmp);
-    }
+  maskexpr = gfc_build_array_ref (mask, index);
+
   /* Use the scalar assignment as is.  */
   tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
   tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
@@ -3067,20 +3017,8 @@ gfc_trans_where_assign (gfc_expr *expr1,
 
           /* Form the mask expression according to the mask tree list.  */
           index = count2;
-          tmp = mask;
-          if (tmp != NULL)
-            maskexpr = gfc_build_array_ref (tmp, index);
-          else
-            maskexpr = NULL;
+          maskexpr = gfc_build_array_ref (mask, index);
 
-          tmp = TREE_CHAIN (tmp);
-          while (tmp)
-            {
-              tmp1 = gfc_build_array_ref (tmp, index);
-              maskexpr = build2 (TRUTH_AND_EXPR, TREE_TYPE (tmp1),
-				 maskexpr, tmp1);
-              tmp = TREE_CHAIN (tmp);
-            }
           /* Use the scalar assignment as is.  */
           tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
           tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
@@ -3115,65 +3053,93 @@ gfc_trans_where_assign (gfc_expr *expr1,
 /* Translate the WHERE construct or statement.
    This function can be called iteratively to translate the nested WHERE
    construct or statement.
-   MASK is the control mask, and PMASK is the pending control mask.
-   TEMP records the temporary address which must be freed later.  */
+   MASK is the control mask.  */
 
 static void
-gfc_trans_where_2 (gfc_code * code, tree mask, tree pmask,
-                   forall_info * nested_forall_info, stmtblock_t * block,
-                   temporary_list ** temp)
+gfc_trans_where_2 (gfc_code * code, tree mask,
+		   forall_info * nested_forall_info, stmtblock_t * block)
 {
+  stmtblock_t inner_size_body;
+  tree inner_size, size;
+  gfc_ss *lss, *rss;
+  tree mask_type;
   gfc_expr *expr1;
   gfc_expr *expr2;
   gfc_code *cblock;
   gfc_code *cnext;
-  tree tmp, tmp1, tmp2;
+  tree tmp;
   tree count1, count2;
-  tree mask_copy;
   int need_temp;
+  tree pcmask = NULL_TREE;
+  tree ppmask = NULL_TREE;
+  tree cmask = NULL_TREE;
+  tree pmask = NULL_TREE;
 
   /* the WHERE statement or the WHERE construct statement.  */
   cblock = code->block;
+
+  /* Calculate the size of temporary needed by the mask-expr.  */
+  gfc_init_block (&inner_size_body);
+  inner_size = compute_inner_temp_size (cblock->expr, cblock->expr,
+					&inner_size_body, &lss, &rss);
+
+  /* Calculate the total size of temporary needed.  */
+  size = compute_overall_iter_number (nested_forall_info, inner_size,
+				      &inner_size_body, block);
+
+  /* As the mask array can be very big, prefer compact boolean types.  */
+  mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind);
+
+  /* Allocate temporary for WHERE mask.  We only need a "cmask" if
+     there are statements to be executed.  The following test only
+     checks the first ELSEWHERE to catch the F90 cases.  */
+  if (cblock->next
+      || (cblock->block && cblock->block->next && cblock->block->expr)
+      || (cblock->block && cblock->block->block))
+    {
+      cmask = allocate_temp_for_forall_nest_1 (mask_type, size, block,
+					       &pcmask);
+    }
+  else
+    {
+      pcmask = NULL_TREE;
+      cmask = NULL_TREE;
+    }
+
+  /* Allocate temporary for !mask.  We only need a "pmask" if there 
+     is an ELSEWHERE clause containing executable statements.  Again
+     we only lookahead a single ELSEWHERE to catch the F90 cases.  */
+  if ((cblock->block && cblock->block->next)
+      || (cblock->block && cblock->block->block))
+    {
+      pmask = allocate_temp_for_forall_nest_1 (mask_type, size, block,
+					       &ppmask);
+    }
+  else
+    {
+      ppmask = NULL_TREE;
+      pmask = NULL_TREE;
+    }
+
   while (cblock)
     {
       /* Has mask-expr.  */
       if (cblock->expr)
         {
-          /* Ensure that the WHERE mask be evaluated only once.  */
-          tmp2 = gfc_evaluate_where_mask (cblock->expr, nested_forall_info,
-                                          &tmp, &tmp1, temp, block);
-
-          /* Set the control mask and the pending control mask.  */
-          /* It's a where-stmt.  */
-          if (mask == NULL)
-            {
-              mask = tmp;
-              pmask = tmp1;
-            }
-          /* It's a nested where-stmt.  */
-          else if (mask && pmask == NULL)
-            {
-              tree tmp2;
-              /* Use the TREE_CHAIN to list the masks.  */
-              tmp2 = copy_list (mask);
-              pmask = chainon (mask, tmp1);
-              mask = chainon (tmp2, tmp);
-            }
-          /* It's a masked-elsewhere-stmt.  */
-          else if (mask && cblock->expr)
-            {
-              tree tmp2;
-              tmp2 = copy_list (pmask);
+          /* Ensure that the WHERE mask will be evaluated exactly once.
+	     If there are no statements in this WHERE/ELSEWHERE clause,
+	     then we don't need to update the control mask (cmask).
+	     If this is the last clause of the WHERE construct, then
+	     we don't need to update the pending control mask (pmask).  */
+          gfc_evaluate_where_mask (cblock->expr, nested_forall_info, mask,
+				   cblock->next ? cmask : NULL_TREE,
+				   cblock->block ? pmask : NULL_TREE,
+				   mask_type, block);
 
-              mask = pmask;
-              tmp2 = chainon (tmp2, tmp);
-              pmask = chainon (mask, tmp1);
-              mask = tmp2;
-            }
         }
-      /* It's a elsewhere-stmt. No mask-expr is present.  */
+      /* It's a final elsewhere-stmt. No mask-expr is present.  */
       else
-        mask = pmask;
+        cmask = mask;
 
       /* Get the assignment statement of a WHERE statement, or the first
          statement in where-body-construct of a WHERE construct.  */
@@ -3188,16 +3154,9 @@ gfc_trans_where_2 (gfc_code * code, tree
               expr2 = cnext->expr2;
               if (nested_forall_info != NULL)
                 {
-                  int nvar;
-                  gfc_expr **varexpr;
-
-                  nvar = nested_forall_info->nvar;
-                  varexpr = (gfc_expr **)
-                            gfc_getmem (nvar * sizeof (gfc_expr *));
-                  need_temp = gfc_check_dependency (expr1, expr2, varexpr,
-                                                    nvar);
+                  need_temp = gfc_check_dependency (expr1, expr2, 0);
                   if (need_temp)
-                    gfc_trans_assign_need_temp (expr1, expr2, mask,
+                    gfc_trans_assign_need_temp (expr1, expr2, cmask,
                                                 nested_forall_info, block);
                   else
                     {
@@ -3207,8 +3166,8 @@ gfc_trans_where_2 (gfc_code * code, tree
                       gfc_add_modify_expr (block, count1, gfc_index_zero_node);
                       gfc_add_modify_expr (block, count2, gfc_index_zero_node);
 
-                      tmp = gfc_trans_where_assign (expr1, expr2, mask, count1,
-                                                    count2);
+                      tmp = gfc_trans_where_assign (expr1, expr2, cmask,
+						    count1, count2);
 
                       tmp = gfc_trans_nested_forall_loop (nested_forall_info,
                                                           tmp, 1, 1);
@@ -3223,8 +3182,8 @@ gfc_trans_where_2 (gfc_code * code, tree
                   gfc_add_modify_expr (block, count1, gfc_index_zero_node);
                   gfc_add_modify_expr (block, count2, gfc_index_zero_node);
 
-                  tmp = gfc_trans_where_assign (expr1, expr2, mask, count1,
-                                                count2);
+                  tmp = gfc_trans_where_assign (expr1, expr2, cmask,
+						count1, count2);
                   gfc_add_expr_to_block (block, tmp);
 
                 }
@@ -3232,11 +3191,9 @@ gfc_trans_where_2 (gfc_code * code, tree
 
             /* WHERE or WHERE construct is part of a where-body-construct.  */
             case EXEC_WHERE:
-              /* Ensure that MASK is not modified by next gfc_trans_where_2.  */
-              mask_copy = copy_list (mask);
-              gfc_trans_where_2 (cnext, mask_copy, NULL, nested_forall_info,
-                                 block, temp);
-              break;
+	      /* Ensure that MASK is not modified by next gfc_trans_where_2.  */
+	      gfc_trans_where_2 (cnext, cmask, nested_forall_info, block);
+	      break;
 
             default:
               gcc_unreachable ();
@@ -3247,9 +3204,157 @@ gfc_trans_where_2 (gfc_code * code, tree
        }
     /* The next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt.  */
     cblock = cblock->block;
+    mask = pmask;
   }
+
+  /* If we allocated a pending mask array, deallocate it now.  */
+  if (ppmask)
+    {
+      tree args = gfc_chainon_list (NULL_TREE, ppmask);
+      tmp = build_function_call_expr (gfor_fndecl_internal_free, args);
+      gfc_add_expr_to_block (block, tmp);
+    }
+
+  /* If we allocated a current mask array, deallocate it now.  */
+  if (pcmask)
+    {
+      tree args = gfc_chainon_list (NULL_TREE, pcmask);
+      tmp = build_function_call_expr (gfor_fndecl_internal_free, args);
+      gfc_add_expr_to_block (block, tmp);
+    }
 }
 
+/* Translate a simple WHERE construct or statement without dependencies.
+   CBLOCK is the "then" clause of the WHERE statement, where CBLOCK->EXPR
+   is the mask condition, and EBLOCK if non-NULL is the "else" clause.
+   Currently both CBLOCK and EBLOCK are restricted to single assignments.  */
+
+static tree
+gfc_trans_where_3 (gfc_code * cblock, gfc_code * eblock)
+{
+  stmtblock_t block, body;
+  gfc_expr *cond, *tdst, *tsrc, *edst, *esrc;
+  tree tmp, cexpr, tstmt, estmt;
+  gfc_ss *css, *tdss, *tsss;
+  gfc_se cse, tdse, tsse, edse, esse;
+  gfc_loopinfo loop;
+  gfc_ss *edss = 0;
+  gfc_ss *esss = 0;
+
+  cond = cblock->expr;
+  tdst = cblock->next->expr;
+  tsrc = cblock->next->expr2;
+  edst = eblock ? eblock->next->expr : NULL;
+  esrc = eblock ? eblock->next->expr2 : NULL;
+
+  gfc_start_block (&block);
+  gfc_init_loopinfo (&loop);
+
+  /* Handle the condition.  */
+  gfc_init_se (&cse, NULL);
+  css = gfc_walk_expr (cond);
+  gfc_add_ss_to_loop (&loop, css);
+
+  /* Handle the then-clause.  */
+  gfc_init_se (&tdse, NULL);
+  gfc_init_se (&tsse, NULL);
+  tdss = gfc_walk_expr (tdst);
+  tsss = gfc_walk_expr (tsrc);
+  if (tsss == gfc_ss_terminator)
+    {
+      tsss = gfc_get_ss ();
+      tsss->next = gfc_ss_terminator;
+      tsss->type = GFC_SS_SCALAR;
+      tsss->expr = tsrc;
+    }
+  gfc_add_ss_to_loop (&loop, tdss);
+  gfc_add_ss_to_loop (&loop, tsss);
+
+  if (eblock)
+    {
+      /* Handle the else clause.  */
+      gfc_init_se (&edse, NULL);
+      gfc_init_se (&esse, NULL);
+      edss = gfc_walk_expr (edst);
+      esss = gfc_walk_expr (esrc);
+      if (esss == gfc_ss_terminator)
+	{
+	  esss = gfc_get_ss ();
+	  esss->next = gfc_ss_terminator;
+	  esss->type = GFC_SS_SCALAR;
+	  esss->expr = esrc;
+	}
+      gfc_add_ss_to_loop (&loop, edss);
+      gfc_add_ss_to_loop (&loop, esss);
+    }
+
+  gfc_conv_ss_startstride (&loop);
+  gfc_conv_loop_setup (&loop);
+
+  gfc_mark_ss_chain_used (css, 1);
+  gfc_mark_ss_chain_used (tdss, 1);
+  gfc_mark_ss_chain_used (tsss, 1);
+  if (eblock)
+    {
+      gfc_mark_ss_chain_used (edss, 1);
+      gfc_mark_ss_chain_used (esss, 1);
+    }
+
+  gfc_start_scalarized_body (&loop, &body);
+
+  gfc_copy_loopinfo_to_se (&cse, &loop);
+  gfc_copy_loopinfo_to_se (&tdse, &loop);
+  gfc_copy_loopinfo_to_se (&tsse, &loop);
+  cse.ss = css;
+  tdse.ss = tdss;
+  tsse.ss = tsss;
+  if (eblock)
+    {
+      gfc_copy_loopinfo_to_se (&edse, &loop);
+      gfc_copy_loopinfo_to_se (&esse, &loop);
+      edse.ss = edss;
+      esse.ss = esss;
+    }
+
+  gfc_conv_expr (&cse, cond);
+  gfc_add_block_to_block (&body, &cse.pre);
+  cexpr = cse.expr;
+
+  gfc_conv_expr (&tsse, tsrc);
+  if (tdss != gfc_ss_terminator && loop.temp_ss != NULL)
+    {
+      gfc_conv_tmp_array_ref (&tdse);
+      gfc_advance_se_ss_chain (&tdse);
+    }
+  else
+    gfc_conv_expr (&tdse, tdst);
+
+  if (eblock)
+    {
+      gfc_conv_expr (&esse, esrc);
+      if (edss != gfc_ss_terminator && loop.temp_ss != NULL)
+        {
+          gfc_conv_tmp_array_ref (&edse);
+          gfc_advance_se_ss_chain (&edse);
+        }
+      else
+        gfc_conv_expr (&edse, edst);
+    }
+
+  tstmt = gfc_trans_scalar_assign (&tdse, &tsse, tdst->ts.type);
+  estmt = eblock ? gfc_trans_scalar_assign (&edse, &esse, edst->ts.type)
+		 : build_empty_stmt ();
+  tmp = build3_v (COND_EXPR, cexpr, tstmt, estmt);
+  gfc_add_expr_to_block (&body, tmp);
+  gfc_add_block_to_block (&body, &cse.post);
+
+  gfc_trans_scalarizing_loops (&loop, &body);
+  gfc_add_block_to_block (&block, &loop.pre);
+  gfc_add_block_to_block (&block, &loop.post);
+  gfc_cleanup_loop (&loop);
+
+  return gfc_finish_block (&block);
+}
 
 /* As the WHERE or WHERE construct statement can be nested, we call
    gfc_trans_where_2 to do the translation, and pass the initial
@@ -3259,26 +3364,57 @@ tree
 gfc_trans_where (gfc_code * code)
 {
   stmtblock_t block;
-  temporary_list *temp, *p;
-  tree args;
-  tree tmp;
+  gfc_code *cblock;
+  gfc_code *eblock;
 
-  gfc_start_block (&block);
-  temp = NULL;
+  cblock = code->block;
+  if (cblock->next
+      && cblock->next->op == EXEC_ASSIGN
+      && !cblock->next->next)
+    {
+      eblock = cblock->block;
+      if (!eblock)
+	{
+          /* A simple "WHERE (cond) x = y" statement or block is
+	     dependence free if cond is not dependent upon writing x,
+	     and the source y is unaffected by the destination x.  */
+	  if (!gfc_check_dependency (cblock->next->expr,
+				     cblock->expr, 0)
+	      && !gfc_check_dependency (cblock->next->expr,
+					cblock->next->expr2, 0))
+	    return gfc_trans_where_3 (cblock, NULL);
+	}
+      else if (!eblock->expr
+	       && !eblock->block
+	       && eblock->next
+	       && eblock->next->op == EXEC_ASSIGN
+	       && !eblock->next->next)
+	{
+          /* A simple "WHERE (cond) x1 = y1 ELSEWHERE x2 = y2 ENDWHERE"
+	     block is dependence free if cond is not dependent on writes
+	     to x1 and x2, y1 is not dependent on writes to x2, and y2
+	     is not dependent on writes to x1, and both y's are not
+	     dependent upon their own x's.  */
+	  if (!gfc_check_dependency(cblock->next->expr,
+				    cblock->expr, 0)
+	      && !gfc_check_dependency(eblock->next->expr,
+				       cblock->expr, 0)
+	      && !gfc_check_dependency(cblock->next->expr,
+				       eblock->next->expr2, 0)
+	      && !gfc_check_dependency(eblock->next->expr,
+				       cblock->next->expr2, 0)
+	      && !gfc_check_dependency(cblock->next->expr,
+				       cblock->next->expr2, 0)
+	      && !gfc_check_dependency(eblock->next->expr,
+				       eblock->next->expr2, 0))
+	    return gfc_trans_where_3 (cblock, eblock);
+	}
+    }
 
-  gfc_trans_where_2 (code, NULL, NULL, NULL, &block, &temp);
+  gfc_start_block (&block);
 
-  /* Add calls to free temporaries which were dynamically allocated.  */
-  while (temp)
-    {
-      args = gfc_chainon_list (NULL_TREE, temp->temporary);
-      tmp = gfc_build_function_call (gfor_fndecl_internal_free, args);
-      gfc_add_expr_to_block (&block, tmp);
+  gfc_trans_where_2 (code, NULL, NULL, &block);
 
-      p = temp;
-      temp = temp->next;
-      gfc_free (p);
-    }
   return gfc_finish_block (&block);
 }
openSUSE Build Service is sponsored by