re PR fortran/36932 (unneeded temporary (2x))

2010-02-20  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/36932
	PR fortran/36933
	PR fortran/43072
	PR fortran/43111
	* dependency.c (gfc_check_argument_var_dependency): Use enum
	value instead of arithmetic vaue for 'elemental'.
	(check_data_pointer_types): New function.
	(gfc_check_dependency): Call check_data_pointer_types.
	* trans-array.h : Change fourth argument of
	gfc_conv_array_parameter to boolean.
	* trans-array.c (gfc_conv_array_parameter): A contiguous array
	can be a dummy but it must not be assumed shape or deferred.
	Change fourth argument to boolean. Array constructor exprs will
	always be contiguous and do not need packing and unpacking.
	* trans-expr.c (gfc_conv_procedure_call): Clean up some white
	space and change fourth argument of gfc_conv_array_parameter
	to boolean.
	(gfc_trans_arrayfunc_assign): Change fourth argument of
	gfc_conv_array_parameter to boolean.
	* trans-io.c (gfc_convert_array_to_string): The same.
	* trans-intrinsic.c (gfc_conv_intrinsic_loc): The same.

2010-02-20  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/36932
	PR fortran/36933
	* gfortran.dg/dependency_26.f90: New test.

	PR fortran/43072
	* gfortran.dg/internal_pack_7.f90: New test.

	PR fortran/43111
	* gfortran.dg/internal_pack_8.f90: New test.

From-SVN: r156926

gcc/fortran/ChangeLog

+2010-02-20  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/36932
+	PR fortran/36933
+	PR fortran/43072
+	PR fortran/43111
+	* dependency.c (gfc_check_argument_var_dependency): Use enum
+	value instead of arithmetic vaue for 'elemental'.
+	(check_data_pointer_types): New function.
+	(gfc_check_dependency): Call check_data_pointer_types.
+	* trans-array.h : Change fourth argument of
+	gfc_conv_array_parameter to boolean.
+	* trans-array.c (gfc_conv_array_parameter): A contiguous array
+	can be a dummy but it must not be assumed shape or deferred.
+	Change fourth argument to boolean. Array constructor exprs will
+	always be contiguous and do not need packing and unpacking.
+	* trans-expr.c (gfc_conv_procedure_call): Clean up some white
+	space and change fourth argument of gfc_conv_array_parameter
+	to boolean.
+	(gfc_trans_arrayfunc_assign): Change fourth argument of
+	gfc_conv_array_parameter to boolean.
+	* trans-io.c (gfc_convert_array_to_string): The same.
+	* trans-intrinsic.c (gfc_conv_intrinsic_loc): The same.
+
 2010-02-20  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/42958

gcc/fortran/dependency.c

@@ -467,7 +467,7 @@ gfc_check_argument_var_dependency (gfc_expr *var, sym_intent intent,
       /* In case of elemental subroutines, there is no dependency 
          between two same-range array references.  */
       if (gfc_ref_needs_temporary_p (expr->ref)
-	  || gfc_check_dependency (var, expr, !elemental))
+	  || gfc_check_dependency (var, expr, elemental == NOT_ELEMENTAL))
 	{
 	  if (elemental == ELEM_DONT_CHECK_VARIABLE)
 	    {
@@ -677,6 +677,78 @@ gfc_are_equivalenced_arrays (gfc_expr *e1, gfc_expr *e2)
 }
 
 
+/* Return true if there is no possibility of aliasing because of a type
+   mismatch between all the possible pointer references and the
+   potential target.  Note that this function is asymmetric in the
+   arguments and so must be called twice with the arguments exchanged.  */
+
+static bool
+check_data_pointer_types (gfc_expr *expr1, gfc_expr *expr2)
+{
+  gfc_component *cm1;
+  gfc_symbol *sym1;
+  gfc_symbol *sym2;
+  gfc_ref *ref1;
+  bool seen_component_ref;
+
+  if (expr1->expr_type != EXPR_VARIABLE
+	|| expr1->expr_type != EXPR_VARIABLE)
+    return false;
+
+  sym1 = expr1->symtree->n.sym;
+  sym2 = expr2->symtree->n.sym;
+
+  /* Keep it simple for now.  */
+  if (sym1->ts.type == BT_DERIVED && sym2->ts.type == BT_DERIVED)
+    return false;
+
+  if (sym1->attr.pointer)
+    {
+      if (gfc_compare_types (&sym1->ts, &sym2->ts))
+	return false;
+    }
+
+  /* This is a conservative check on the components of the derived type
+     if no component references have been seen.  Since we will not dig
+     into the components of derived type components, we play it safe by
+     returning false.  First we check the reference chain and then, if
+     no component references have been seen, the components.  */
+  seen_component_ref = false;
+  if (sym1->ts.type == BT_DERIVED)
+    {
+      for (ref1 = expr1->ref; ref1; ref1 = ref1->next)
+	{
+	  if (ref1->type != REF_COMPONENT)
+	    continue;
+
+	  if (ref1->u.c.component->ts.type == BT_DERIVED)
+	    return false;
+
+	  if ((sym2->attr.pointer || ref1->u.c.component->attr.pointer)
+		&& gfc_compare_types (&ref1->u.c.component->ts, &sym2->ts))
+	    return false;
+
+	  seen_component_ref = true;
+	}
+    }
+
+  if (sym1->ts.type == BT_DERIVED && !seen_component_ref)
+    {
+      for (cm1 = sym1->ts.u.derived->components; cm1; cm1 = cm1->next)
+	{
+	  if (cm1->ts.type == BT_DERIVED)
+	    return false;
+
+	  if ((sym2->attr.pointer || cm1->attr.pointer)
+		&& gfc_compare_types (&cm1->ts, &sym2->ts))
+	    return false;
+	}
+    }
+
+  return true;
+}
+
+
 /* 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 IDENTICAL flag indicates
@@ -726,7 +798,13 @@ gfc_check_dependency (gfc_expr *expr1, gfc_expr *expr2, bool identical)
 	  /* If either variable is a pointer, assume the worst.  */
 	  /* TODO: -fassume-no-pointer-aliasing */
 	  if (gfc_is_data_pointer (expr1) || gfc_is_data_pointer (expr2))
-	    return 1;
+	    {
+	      if (check_data_pointer_types (expr1, expr2)
+		    && check_data_pointer_types (expr2, expr1))
+		return 0;
+
+	      return 1;
+	    }
 
 	  /* Otherwise distinct symbols have no dependencies.  */
 	  return 0;

gcc/fortran/trans-array.c

@@ -5459,7 +5459,7 @@ array_parameter_size (tree desc, gfc_expr *expr, tree *size)
 /* TODO: Optimize passing g77 arrays.  */
 
 void
-gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77,
+gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
 			  const gfc_symbol *fsym, const char *proc_name,
 			  tree *size)
 {
@@ -5471,6 +5471,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77,
   bool full_array_var;
   bool this_array_result;
   bool contiguous;
+  bool no_pack;
   gfc_symbol *sym;
   stmtblock_t block;
   gfc_ref *ref;
@@ -5519,8 +5520,10 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77,
 	  return;
 	}
 
-      if (!sym->attr.pointer && sym->as->type != AS_ASSUMED_SHAPE 
-          && !sym->attr.allocatable)
+      if (!sym->attr.pointer
+	    && sym->as
+	    && sym->as->type != AS_ASSUMED_SHAPE 
+            && !sym->attr.allocatable)
         {
 	  /* Some variables are declared directly, others are declared as
 	     pointers and allocated on the heap.  */
@@ -5547,8 +5550,32 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77,
         }
     }
 
-  if (contiguous && g77 && !this_array_result
-	&& !expr->symtree->n.sym->attr.dummy)
+  /* There is no need to pack and unpack the array, if it is an array
+     constructor or contiguous and not deferred or assumed shape.  */
+  no_pack = ((sym && sym->as
+		  && !sym->attr.pointer
+		  && sym->as->type != AS_DEFERRED
+		  && sym->as->type != AS_ASSUMED_SHAPE)
+		      ||
+	     (ref && ref->u.ar.as
+		  && ref->u.ar.as->type != AS_DEFERRED
+		  && ref->u.ar.as->type != AS_ASSUMED_SHAPE));
+
+  no_pack = g77 && !this_array_result
+		&& (expr->expr_type == EXPR_ARRAY || (contiguous && no_pack));
+
+  if (no_pack)
+    {
+      gfc_conv_expr_descriptor (se, expr, ss);
+      if (expr->ts.type == BT_CHARACTER)
+	se->string_length = expr->ts.u.cl->backend_decl;
+      if (size)
+	array_parameter_size (se->expr, expr, size);
+      se->expr = gfc_conv_array_data (se->expr);
+      return;
+    }
+
+  if (expr->expr_type == EXPR_ARRAY && g77)
     {
       gfc_conv_expr_descriptor (se, expr, ss);
       if (expr->ts.type == BT_CHARACTER)
@@ -5601,7 +5628,6 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77,
     {
       desc = se->expr;
       /* Repack the array.  */
-
       if (gfc_option.warn_array_temp)
 	{
 	  if (fsym)

gcc/fortran/trans-array.h

@@ -111,7 +111,7 @@ void gfc_conv_tmp_ref (gfc_se *);
 /* Evaluate an array expression.  */
 void gfc_conv_expr_descriptor (gfc_se *, gfc_expr *, gfc_ss *);
 /* Convert an array for passing as an actual function parameter.  */
-void gfc_conv_array_parameter (gfc_se *, gfc_expr *, gfc_ss *, int,
+void gfc_conv_array_parameter (gfc_se *, gfc_expr *, gfc_ss *, bool,
 			       const gfc_symbol *, const char *, tree *);
 /* Evaluate and transpose a matrix expression.  */
 void gfc_conv_array_transpose (gfc_se *, gfc_expr *);

gcc/fortran/trans-expr.c

@@ -2827,18 +2827,18 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
       if (!sym->attr.elemental)
 	{
 	  gcc_assert (se->ss->type == GFC_SS_FUNCTION);
-          if (se->ss->useflags)
-            {
+	  if (se->ss->useflags)
+	    {
 	      gcc_assert ((!comp && gfc_return_by_reference (sym)
 			   && sym->result->attr.dimension)
 			  || (comp && comp->attr.dimension));
-              gcc_assert (se->loop != NULL);
+	      gcc_assert (se->loop != NULL);
 
-              /* Access the previously obtained result.  */
-              gfc_conv_tmp_array_ref (se);
-              gfc_advance_se_ss_chain (se);
-              return 0;
-            }
+	      /* Access the previously obtained result.  */
+	      gfc_conv_tmp_array_ref (se);
+	      gfc_advance_se_ss_chain (se);
+	      return 0;
+	    }
 	}
       info = &se->ss->data.info;
     }
@@ -2872,9 +2872,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
       e = arg->expr;
       fsym = formal ? formal->sym : NULL;
       parm_kind = MISSING;
+
       if (e == NULL)
 	{
-
 	  if (se->ignore_optional)
 	    {
 	      /* Some intrinsics have already been resolved to the correct
@@ -2883,15 +2883,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	    }
 	  else if (arg->label)
 	    {
-              has_alternate_specifier = 1;
-              continue;
+	      has_alternate_specifier = 1;
+	      continue;
 	    }
 	  else
 	    {
 	      /* Pass a NULL pointer for an absent arg.  */
 	      gfc_init_se (&parmse, NULL);
 	      parmse.expr = null_pointer_node;
-              if (arg->missing_arg_type == BT_CHARACTER)
+	      if (arg->missing_arg_type == BT_CHARACTER)
 		parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
 	    }
 	}
@@ -2906,8 +2906,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
       else if (se->ss && se->ss->useflags)
 	{
 	  /* An elemental function inside a scalarized loop.  */
-          gfc_init_se (&parmse, se);
-          gfc_conv_expr_reference (&parmse, e);
+	  gfc_init_se (&parmse, se);
+	  gfc_conv_expr_reference (&parmse, e);
 	  parm_kind = ELEMENTAL;
 	}
       else
@@ -2917,7 +2917,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	  argss = gfc_walk_expr (e);
 
 	  if (argss == gfc_ss_terminator)
-            {
+	    {
 	      if (e->expr_type == EXPR_VARIABLE
 		    && e->symtree->n.sym->attr.cray_pointee
 		    && fsym && fsym->attr.flavor == FL_PROCEDURE)
@@ -3028,7 +3028,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
                  ALLOCATABLE or assumed shape, we do not use g77's calling
                  convention, and pass the address of the array descriptor
                  instead. Otherwise we use g77's calling convention.  */
-	      int f;
+	      bool f;
 	      f = (fsym != NULL)
 		  && !(fsym->attr.pointer || fsym->attr.allocatable)
 		  && fsym->as->type != AS_ASSUMED_SHAPE;
@@ -5036,7 +5036,7 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
   gfc_start_block (&se.pre);
   se.want_pointer = 1;
 
-  gfc_conv_array_parameter (&se, expr1, ss, 0, NULL, NULL, NULL);
+  gfc_conv_array_parameter (&se, expr1, ss, false, NULL, NULL, NULL);
 
   if (expr1->ts.type == BT_DERIVED
 	&& expr1->ts.u.derived->attr.alloc_comp)

gcc/fortran/trans-intrinsic.c

@@ -4997,7 +4997,7 @@ gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
   if (ss == gfc_ss_terminator)
     gfc_conv_expr_reference (se, arg_expr);
   else
-    gfc_conv_array_parameter (se, arg_expr, ss, 1, NULL, NULL, NULL);
+    gfc_conv_array_parameter (se, arg_expr, ss, true, NULL, NULL, NULL);
   se->expr= convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
    
   /* Create a temporary variable for loc return value.  Without this, 

gcc/fortran/trans-io.c

@@ -620,7 +620,7 @@ gfc_convert_array_to_string (gfc_se * se, gfc_expr * e)
       return;
     }
 
-  gfc_conv_array_parameter (se, e, gfc_walk_expr (e), 1, NULL, NULL, &size);
+  gfc_conv_array_parameter (se, e, gfc_walk_expr (e), true, NULL, NULL, &size);
   se->string_length = fold_convert (gfc_charlen_type_node, size);
 }
 

gcc/testsuite/ChangeLog

+2010-02-20  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/36932
+	PR fortran/36933
+	* gfortran.dg/dependency_26.f90: New test.
+
+	PR fortran/43072
+	* gfortran.dg/internal_pack_7.f90: New test.
+
+	PR fortran/43111
+	* gfortran.dg/internal_pack_8.f90: New test.
+
 2010-02-20  Manuel López-Ibáñez  <manu@gcc.gnu.org>
 
 	PR 43128

gcc/testsuite/gfortran.dg/dependency_26.f90

+! { dg-do compile }
+! { dg-options "-fdump-tree-original" }
+!
+! Test the fix for PR36932 and PR36933, in which unnecessary
+! temporaries were being generated.  The module m2 tests the
+! additional testcase in comment #3 of PR36932.
+!
+! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
+!
+MODULE M2
+  IMPLICIT NONE
+  TYPE particle
+   REAL :: r(3)
+  END TYPE
+CONTAINS
+  SUBROUTINE S1(p)
+     TYPE(particle), POINTER, DIMENSION(:) :: p
+     REAL :: b(3)
+     INTEGER :: i
+     b=pbc(p(i)%r)
+  END SUBROUTINE S1
+  FUNCTION pbc(b)
+     REAL :: b(3)
+     REAL :: pbc(3)
+     pbc=b
+  END FUNCTION
+END MODULE M2
+
+MODULE M1
+  IMPLICIT NONE
+  TYPE cell_type
+     REAL :: h(3,3)
+  END TYPE
+CONTAINS
+  SUBROUTINE S1(cell)
+     TYPE(cell_type), POINTER :: cell
+     REAL :: a(3)
+     REAL :: b(3) = [1, 2, 3]
+     a=MATMUL(cell%h,b)
+     if (ANY (INT (a) .ne. [30, 36, 42])) call abort
+  END SUBROUTINE S1
+END MODULE M1
+
+  use M1
+  TYPE(cell_type), POINTER :: cell
+  allocate (cell)
+  cell%h = reshape ([(real(i), i = 1, 9)], [3, 3])
+  call s1 (cell)
+end
+! { dg-final { cleanup-modules "M1" } }
+! { dg-final { scan-tree-dump-times "&a" 1 "original" } }
+! { dg-final { scan-tree-dump-times "pack" 0 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }

gcc/testsuite/gfortran.dg/internal_pack_7.f90

+! { dg-do compile }
+! { dg-options "-fdump-tree-original" }
+!
+! Test the fix for PR43072, in which unnecessary calls to
+! internal PACK/UNPACK were being generated.
+!
+! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
+!
+MODULE M1
+  PRIVATE
+  REAL, PARAMETER :: c(2)=(/(i,i=1,2)/)
+CONTAINS
+  ! WAS OK
+  SUBROUTINE S0
+    real :: r
+     r=0
+     r=S2(c)
+     r=S2((/(real(i),i=1,2)/)) ! See comment #1 of the PR
+  END SUBROUTINE S0
+  ! WAS NOT OK
+  SUBROUTINE S1
+    real :: r
+     r=0
+     r=r+S2(c)
+     r=r+S2((/(real(i),i=1,2)/)) ! See comment #1 of the PR
+  END SUBROUTINE S1
+
+  FUNCTION S2(c)
+     REAL, INTENT(IN) :: c(2)
+     s2=0
+  END FUNCTION S2
+END MODULE M1
+! { dg-final { cleanup-modules "M1" } }
+! { dg-final { scan-tree-dump-times "pack" 0 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }

gcc/testsuite/gfortran.dg/internal_pack_8.f90

+! { dg-do run }
+!
+! Test the fix for PR43111, in which necessary calls to
+! internal PACK/UNPACK were not being generated because
+! of an over agressive fix to PR41113/7.
+!
+! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
+!
+SUBROUTINE S2(I)
+ INTEGER :: I(4)
+ !write(6,*) I
+ IF (ANY(I.NE.(/3,5,7,9/))) CALL ABORT()
+END SUBROUTINE S2
+
+MODULE M1
+ TYPE T1
+  INTEGER, POINTER, DIMENSION(:) :: data
+ END TYPE T1
+CONTAINS
+ SUBROUTINE S1()
+   TYPE(T1) :: d
+   INTEGER, TARGET, DIMENSION(10) :: scratch=(/(i,i=1,10)/)
+   INTEGER :: i=2
+   d%data=>scratch(1:9:2)
+!   write(6,*) d%data(i:)
+   CALL S2(d%data(i:))
+ END SUBROUTINE S1
+END MODULE M1
+
+USE M1
+CALL S1
+END
+! { dg-final { cleanup-modules "M1" } }