Patchwork [Fortran] Coarrays: Don't (free)/alloc LHS coarray components on assignment

login
register
mail settings
Submitter Tobias Burnus
Date June 26, 2013, 9 p.m.
Message ID <51CB565B.7000405@net-b.de>
Download mbox | patch
Permalink /patch/254868/
State New
Headers show

Comments

Tobias Burnus - June 26, 2013, 9 p.m.
Tobias Burnus wrote:
> With coarrays, allocation/deallocation of coarrays requires a 
> synchronization with all other images. Thus, the standard restricts 
> changing the allocation status to: ALLOCATE and DEALLOCATE statements 
> plus end-of-scope deallocation.
>
> In particular, with intrinsic assignment the allocation status does 
> not change. Hence, there is no realloc on assignment. But also (this 
> patch!) no deallocation/allocation of allocatable components during 
> intrinsic assignment of derived types. [This implies that the LHS 
> componet has to have the same allocation status, shape, 
> type-parameters and actual type as the RHS.]
>
> The patch additionally checks whether end-of-scope deallocation of 
> coarrays properly calls the deregister function (it did/does).
>
> Build and regtested on x86-64-gnu-linux.
> OK for the trunk?

Update: I forgot to copy the back the address of the allocated CAF - 
which lead to an unwanted address sharing between the RHS and LHS.

Note: structure_alloc_comps also contains bits from 
http://gcc.gnu.org/ml/fortran/2013-06/msg00131.html

Build and regtested on x86-64-gnu-linux.
OK for the trunk?

Tobias
Tejas Belagod - July 16, 2013, 4:17 p.m.
Tobias Burnus wrote:
> Tobias Burnus wrote:
>> With coarrays, allocation/deallocation of coarrays requires a 
>> synchronization with all other images. Thus, the standard restricts 
>> changing the allocation status to: ALLOCATE and DEALLOCATE statements 
>> plus end-of-scope deallocation.
>>
>> In particular, with intrinsic assignment the allocation status does 
>> not change. Hence, there is no realloc on assignment. But also (this 
>> patch!) no deallocation/allocation of allocatable components during 
>> intrinsic assignment of derived types. [This implies that the LHS 
>> componet has to have the same allocation status, shape, 
>> type-parameters and actual type as the RHS.]
>>
>> The patch additionally checks whether end-of-scope deallocation of 
>> coarrays properly calls the deregister function (it did/does).
>>
>> Build and regtested on x86-64-gnu-linux.
>> OK for the trunk?
> 
> Update: I forgot to copy the back the address of the allocated CAF - 
> which lead to an unwanted address sharing between the RHS and LHS.
> 
> Note: structure_alloc_comps also contains bits from 
> http://gcc.gnu.org/ml/fortran/2013-06/msg00131.html
> 
> Build and regtested on x86-64-gnu-linux.
> OK for the trunk?
> 
> Tobias
> 

2013-06-26  Tobias Burnus  <burnus@net-b.de>

	* trans-array.h (gfc_deallocate_alloc_comp_no_caf,
	gfc_reassign_alloc_comp_caf): New prototype.
	* trans-array.c (enum): Add DEALLOCATE_ALLOC_COMP_NO_CAF
	and COPY_ALLOC_COMP_CAF.
	(structure_alloc_comps): Handle it.
	(gfc_reassign_alloc_comp_caf,
	gfc_deallocate_alloc_comp_no_caf): New function.
	(gfc_alloc_allocatable_for_assignment): Call it.
	* trans-expr.c (gfc_trans_scalar_assign,
	gfc_trans_arrayfunc_assign, gfc_trans_assignment_1): Ditto.
	* parse.c (parse_derived): Correctly set coarray_comp.
	* resolve.c (resolve_symbol): Improve error wording.

2013-06-26  Tobias Burnus  <burnus@net-b.de>

	* gfortran.dg/coarray_lib_realloc_1.f90: New.
	* gfortran.dg/coarray/lib_realloc_1.f90: New.
	* gfortran.dg/coarray_6.f90: Add dg-error.

Hi,

I observed that this patch causes an ICE with one of the fortran tests. I've 
filed a bug report here: http://gcc.gnu.org/bugzilla/show_bug.cgi?id=57912.

Thanks,
Tejas Belagod.
ARM.

Patch

2013-06-26  Tobias Burnus  <burnus@net-b.de>

	* trans-array.h (gfc_deallocate_alloc_comp_no_caf,
	gfc_reassign_alloc_comp_caf): New prototype.
	* trans-array.c (enum): Add DEALLOCATE_ALLOC_COMP_NO_CAF
	and COPY_ALLOC_COMP_CAF.
	(structure_alloc_comps): Handle it.
	(gfc_reassign_alloc_comp_caf,
	gfc_deallocate_alloc_comp_no_caf): New function.
	(gfc_alloc_allocatable_for_assignment): Call it.
	* trans-expr.c (gfc_trans_scalar_assign,
	gfc_trans_arrayfunc_assign, gfc_trans_assignment_1): Ditto.
	* parse.c (parse_derived): Correctly set coarray_comp.
	* resolve.c (resolve_symbol): Improve error wording.

2013-06-26  Tobias Burnus  <burnus@net-b.de>

	* gfortran.dg/coarray_lib_realloc_1.f90: New.
	* gfortran.dg/coarray/lib_realloc_1.f90: New.
	* gfortran.dg/coarray_6.f90: Add dg-error.

diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index f98a213..737f3d6 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -2228,11 +2228,11 @@  endType:
 	  sym->attr.coarray_comp = 1;
 	}
      
-      if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp)
+      if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp
+	  && !c->attr.pointer)
 	{
 	  coarray = true;
-	  if (!pointer && !allocatable)
-	    sym->attr.coarray_comp = 1;
+	  sym->attr.coarray_comp = 1;
 	}
 
       /* Looking for lock_type components.  */
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index ce68401..0c0804b 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -13125,8 +13125,8 @@  resolve_symbol (gfc_symbol *sym)
       && (class_attr.codimension || class_attr.pointer || class_attr.dimension
 	  || class_attr.allocatable))
     {
-      gfc_error ("Variable '%s' at %L with coarray component "
-		 "shall be a nonpointer, nonallocatable scalar",
+      gfc_error ("Variable '%s' at %L with coarray component shall be a "
+		 "nonpointer, nonallocatable scalar, which is not a coarray",
 		 sym->name, &sym->declared_at);
       return;
     }
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 39bf0dd..452becf 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -7445,8 +7445,9 @@  gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank)
    deallocate, nullify or copy allocatable components.  This is the work horse
    function for the functions named in this enum.  */
 
-enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP,
-      COPY_ONLY_ALLOC_COMP};
+enum {DEALLOCATE_ALLOC_COMP = 1, DEALLOCATE_ALLOC_COMP_NO_CAF,
+      NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP, COPY_ONLY_ALLOC_COMP,
+      COPY_ALLOC_COMP_CAF};
 
 static tree
 structure_alloc_comps (gfc_symbol * der_type, tree decl,
@@ -7577,6 +7578,7 @@  structure_alloc_comps (gfc_symbol * der_type, tree decl,
       switch (purpose)
 	{
 	case DEALLOCATE_ALLOC_COMP:
+	case DEALLOCATE_ALLOC_COMP_NO_CAF:
 
 	  /* gfc_deallocate_scalar_with_status calls gfc_deallocate_alloc_comp
 	     (i.e. this function) so generate all the calls and suppress the
@@ -7584,19 +7586,37 @@  structure_alloc_comps (gfc_symbol * der_type, tree decl,
 	  called_dealloc_with_status = false;
 	  gfc_init_block (&tmpblock);
 
-	  if (c->attr.allocatable && (c->attr.dimension || c->attr.codimension)
-	      && !c->attr.proc_pointer)
+	  if ((c->ts.type == BT_DERIVED && !c->attr.pointer)
+	      || (c->ts.type == BT_CLASS && !CLASS_DATA (c)->attr.class_pointer))
 	    {
 	      comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
 				      decl, cdecl, NULL_TREE);
+
+	      /* The finalizer frees allocatable components.  */
+	      called_dealloc_with_status
+		= gfc_add_comp_finalizer_call (&tmpblock, comp, c,
+					       purpose == DEALLOCATE_ALLOC_COMP);
+	    }
+	  else
+	    comp = NULL_TREE;
+
+	  if (c->attr.allocatable && !c->attr.proc_pointer
+	      && (c->attr.dimension
+		  || (c->attr.codimension
+		      && purpose != DEALLOCATE_ALLOC_COMP_NO_CAF)))
+	    {
+	      if (comp == NULL_TREE)
+		comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+					decl, cdecl, NULL_TREE);
 	      tmp = gfc_trans_dealloc_allocated (comp, c->attr.codimension, NULL);
 	      gfc_add_expr_to_block (&tmpblock, tmp);
 	    }
-	  else if (c->attr.allocatable)
+	  else if (c->attr.allocatable && !c->attr.codimension)
 	    {
 	      /* Allocatable scalar components.  */
-	      comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
-				      decl, cdecl, NULL_TREE);
+	      if (comp == NULL_TREE)
+		comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+					decl, cdecl, NULL_TREE);
 
 	      tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
 						       c->ts);
@@ -7608,13 +7628,16 @@  structure_alloc_comps (gfc_symbol * der_type, tree decl,
 				     build_int_cst (TREE_TYPE (comp), 0));
 	      gfc_add_expr_to_block (&tmpblock, tmp);
 	    }
-	  else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
+	  else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable
+		   && (!CLASS_DATA (c)->attr.codimension
+		       || purpose != DEALLOCATE_ALLOC_COMP_NO_CAF))
 	    {
 	      /* Allocatable CLASS components.  */
-	      comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
-				      decl, cdecl, NULL_TREE);
 
 	      /* Add reference to '_data' component.  */
+	      if (comp == NULL_TREE)
+		comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+					decl, cdecl, NULL_TREE);
 	      tmp = CLASS_DATA (c)->backend_decl;
 	      comp = fold_build3_loc (input_location, COMPONENT_REF,
 				      TREE_TYPE (tmp), comp, tmp, NULL_TREE);
@@ -7705,6 +7728,28 @@  structure_alloc_comps (gfc_symbol * der_type, tree decl,
 	    }
 	  break;
 
+	case COPY_ALLOC_COMP_CAF:
+	  if (!c->attr.codimension
+	      && (c->ts.type != BT_CLASS || CLASS_DATA (c)->attr.coarray_comp)
+	      && (c->ts.type != BT_DERIVED
+		  || !c->ts.u.derived->attr.coarray_comp))
+	    continue;
+
+	  comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl,
+				  cdecl, NULL_TREE);
+	  dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, dest,
+				  cdecl, NULL_TREE);
+	  if (c->attr.codimension)
+	    gfc_add_modify (&fnblock, dcmp, comp);
+	  else
+	    {
+	      tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
+					   rank, purpose);
+	      gfc_add_expr_to_block (&fnblock, tmp);
+
+	    }
+	  break;
+
 	case COPY_ALLOC_COMP:
 	  if (c->attr.pointer)
 	    continue;
@@ -7736,18 +7781,30 @@  structure_alloc_comps (gfc_symbol * der_type, tree decl,
 					  size_type_node, size,
 					  fold_convert (size_type_node,
 							nelems));
-		  src_data = gfc_conv_descriptor_data_get (src_data);
-		  dst_data = gfc_conv_descriptor_data_get (dst_data);
 		}
 	      else
 		nelems = build_int_cst (size_type_node, 1);
 
+	      if (CLASS_DATA (c)->attr.dimension
+		  || CLASS_DATA (c)->attr.codimension)
+		{
+		  src_data = gfc_conv_descriptor_data_get (src_data);
+		  dst_data = gfc_conv_descriptor_data_get (dst_data);
+		}
+
 	      gfc_init_block (&tmpblock);
 
-	      ftn_tree = builtin_decl_explicit (BUILT_IN_MALLOC);
-	      tmp = build_call_expr_loc (input_location, ftn_tree, 1, size);
-	      gfc_add_modify (&tmpblock, dst_data,
-			      fold_convert (TREE_TYPE (dst_data), tmp));
+	      /* Coarray component have to have the same allocation status and
+		 shape/type-parameter/effective-type on the LHS and RHS of an
+		 intrinsic assignment. Hence, we did not deallocated them - and
+		 do not allocate them here.  */
+	      if (!CLASS_DATA (c)->attr.codimension)
+		{
+		  ftn_tree = builtin_decl_explicit (BUILT_IN_MALLOC);
+		  tmp = build_call_expr_loc (input_location, ftn_tree, 1, size);
+		  gfc_add_modify (&tmpblock, dst_data,
+				  fold_convert (TREE_TYPE (dst_data), tmp));
+		}
 
 	      tmp = gfc_copy_class_to_class (comp, dcmp, nelems);
 	      gfc_add_expr_to_block (&tmpblock, tmp);
@@ -7772,7 +7829,10 @@  structure_alloc_comps (gfc_symbol * der_type, tree decl,
 	      && !cmp_has_alloc_comps)
 	    {
 	      rank = c->as ? c->as->rank : 0;
-	      tmp = gfc_duplicate_allocatable (dcmp, comp, ctype, rank);
+	      if (c->attr.codimension)
+		tmp = gfc_copy_allocatable_data (dcmp, comp, ctype, rank);
+	      else
+		tmp = gfc_duplicate_allocatable (dcmp, comp, ctype, rank);
 	      gfc_add_expr_to_block (&fnblock, tmp);
 	    }
 
@@ -7819,6 +7879,26 @@  gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
 
 
 /* Recursively traverse an object of derived type, generating code to
+   deallocate allocatable components.  But do not deallocate coarrays.
+   To be used for intrinsic assignment, which may not change the allocation
+   status of coarrays.  */
+
+tree
+gfc_deallocate_alloc_comp_no_caf (gfc_symbol * der_type, tree decl, int rank)
+{
+  return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
+				DEALLOCATE_ALLOC_COMP_NO_CAF);
+}
+
+
+tree
+gfc_reassign_alloc_comp_caf (gfc_symbol *der_type, tree decl, tree dest)
+{
+  return structure_alloc_comps (der_type, decl, dest, 0, COPY_ALLOC_COMP_CAF);
+}
+
+
+/* Recursively traverse an object of derived type, generating code to
    copy it and its allocatable components.  */
 
 tree
@@ -8251,8 +8331,8 @@  gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
   if ((expr1->ts.type == BT_DERIVED)
 	&& expr1->ts.u.derived->attr.alloc_comp)
     {
-      tmp = gfc_deallocate_alloc_comp (expr1->ts.u.derived, old_desc,
-				       expr1->rank);
+      tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, old_desc,
+					      expr1->rank);
       gfc_add_expr_to_block (&realloc_block, tmp);
     }
 
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 2d2b45d..e8f207e 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -51,6 +51,8 @@  tree gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank);
 tree gfc_nullify_alloc_comp (gfc_symbol *, tree, int);
 
 tree gfc_deallocate_alloc_comp (gfc_symbol *, tree, int);
+tree gfc_deallocate_alloc_comp_no_caf (gfc_symbol *, tree, int);
+tree gfc_reassign_alloc_comp_caf (gfc_symbol *, tree, tree);
 
 tree gfc_copy_alloc_comp (gfc_symbol *, tree, tree, int);
 
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 0eef2b2..e1ed9d9 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -6824,6 +6824,7 @@  gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
     }
   else if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
     {
+      tree tmp_var = NULL_TREE;
       cond = NULL_TREE;
 
       /* Are the rhs and the lhs the same?  */
@@ -6841,8 +6842,8 @@  gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
 	 expression.  */
       if (!l_is_temp && dealloc)
 	{
-	  tmp = gfc_evaluate_now (lse->expr, &lse->pre);
-	  tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
+	  tmp_var = gfc_evaluate_now (lse->expr, &lse->pre);
+	  tmp = gfc_deallocate_alloc_comp_no_caf (ts.u.derived, tmp_var, 0);
 	  if (deep_copy)
 	    tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
 			    tmp);
@@ -6855,6 +6856,16 @@  gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
       gfc_add_modify (&block, lse->expr,
 			   fold_convert (TREE_TYPE (lse->expr), rse->expr));
 
+      /* Restore pointer address of coarray components.  */
+      if (ts.u.derived->attr.coarray_comp && deep_copy)
+	{
+	  gcc_assert (tmp_var != NULL_TREE);
+	  tmp = gfc_reassign_alloc_comp_caf (ts.u.derived, tmp_var, lse->expr);
+	  tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
+			  tmp);
+	  gfc_add_expr_to_block (&block, tmp);
+	}
+
       /* Do a deep copy if the rhs is a variable, if it is not the
 	 same as the lhs.  */
       if (deep_copy)
@@ -7196,8 +7207,8 @@  gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
 	&& expr1->ts.u.derived->attr.alloc_comp)
     {
       tree tmp;
-      tmp = gfc_deallocate_alloc_comp (expr1->ts.u.derived, se.expr,
-				       expr1->rank);
+      tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, se.expr,
+					      expr1->rank);
       gfc_add_expr_to_block (&se.pre, tmp);
     }
 
@@ -7762,7 +7773,7 @@  gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
 		       && expr1->rank && !expr2->rank);
   if (scalar_to_array && dealloc)
     {
-      tmp = gfc_deallocate_alloc_comp (expr2->ts.u.derived, rse.expr, 0);
+      tmp = gfc_deallocate_alloc_comp_no_caf (expr2->ts.u.derived, rse.expr, 0);
       gfc_add_expr_to_block (&loop.post, tmp);
     }
 
--- /dev/null	2013-06-26 08:23:53.976189029 +0200
+++ gcc/gcc/testsuite/gfortran.dg/coarray_lib_realloc_1.f90	2013-06-26 19:28:32.786634679 +0200
@@ -0,0 +1,35 @@ 
+! { dg-do compile }
+! { dg-options "-fdump-tree-original -fcoarray=lib" }
+!
+! PR fortran/52052
+!
+! Test that for CAF components _gfortran_caf_deregister is called
+! Test that norealloc happens for CAF components during assignment
+!
+module m
+type t
+  integer, allocatable :: CAF[:]
+  integer, allocatable :: ii
+end type t
+end module m
+
+subroutine foo()
+use m
+type(t) :: x,y
+if (allocated(x%caf)) call abort()
+x = y
+end
+
+! For comp%ii: End of scope of x + y (2x) and for the LHS of the assignment (1x)
+! { dg-final { scan-tree-dump-times "__builtin_free" 3 "original" } }
+
+! For comp%CAF:  End of scope of x + y (2x); no LHS freeing for the CAF in assignment
+! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister" 2 "original" } }
+
+! Only malloc "ii":
+! { dg-final { scan-tree-dump-times "__builtin_malloc" 1 "original" } }
+
+! But copy "ii" and "CAF":
+! { dg-final { scan-tree-dump-times "__builtin_memcpy" 2 "original" } }
+
+! { dg-final { cleanup-tree-dump "original" } }
--- /dev/null	2013-06-26 08:23:53.976189029 +0200
+++ gcc/gcc/testsuite/gfortran.dg/coarray/lib_realloc_1.f90	2013-06-26 19:57:48.418908565 +0200
@@ -0,0 +1,30 @@ 
+! { dg-do run }
+! { dg-options "-O0" }
+!
+! Test that for CAF components _gfortran_caf_deregister is called
+! Test that norealloc happens for CAF components during assignment
+!
+module m
+type t
+  integer, allocatable :: CAF[:]
+end type t
+end module m
+
+program main
+use m
+type(t), target :: x,y
+integer, pointer :: ptr
+allocate(x%caf[*], y%caf[*])
+ptr => y%caf
+ptr = 6
+if (.not.allocated(x%caf)) call abort()
+if (.not.allocated(y%caf)) call abort()
+if (y%caf /= 6) call abort ()
+x = y
+if (x%caf /= 6) call abort ()
+if (.not. associated (ptr,y%caf)) call abort()
+if (associated (ptr,x%caf)) call abort()
+ptr = 123
+if (y%caf /= 123) call abort ()
+if (x%caf /= 6) call abort ()
+end program main
diff --git a/gcc/testsuite/gfortran.dg/coarray_6.f90 b/gcc/testsuite/gfortran.dg/coarray_6.f90
index 9fb06d4..f44ac01 100644
--- a/gcc/testsuite/gfortran.dg/coarray_6.f90
+++ b/gcc/testsuite/gfortran.dg/coarray_6.f90
@@ -75,7 +75,7 @@  subroutine valid(a)
   type t2
     type(t) :: b
   end type t2
-  type(t2), save :: xt2[*]
+  type(t2), save :: xt2[*] ! { dg-error "nonpointer, nonallocatable scalar, which is not a coarray" }
 end subroutine valid
 
 program main