diff mbox

[Fortran] Fix an issue with CLASS and -fcoarray=lib on the trunk

Message ID 535D52EC.4060308@net-b.de
State New
Headers show

Commit Message

Tobias Burnus April 27, 2014, 6:56 p.m. UTC 
First, I would be really delighted if someone could review my coarray 
patches for the trunk as it makes simpler to develop patches on top of it:
* http://gcc.gnu.org/ml/fortran/2014-04/msg00087.html
* http://gcc.gnu.org/ml/fortran/2014-04/msg00091.html
* http://gcc.gnu.org/ml/fortran/2014-04/msg00092.html

Secondly, attached is a patch which fixes an ICE - and prepares for some 
additional class-related coarray patches. In particular, the patch 
ensures that for nonallocatable *polymorphic* coarrays, the coarray 
token and offset are passed.

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

Tobias

PS: There is still something wrong (for both -fcoarray=single and 
-fcoarray=lib) with lcobound/ucobounds and polymorphic coarrays and with 
using them with select type and associated. That's something I would 
like to tackle next. If that's done, I probably should really 
concentrate on reviewing a few patches and doing some other bug fixes 
before continue working on coarrays.

Comments

Paul Richard Thomas April 30, 2014, 8:18 a.m. UTC | #1 
Dear Tobias,

On 27 April 2014 20:56, Tobias Burnus <burnus@net-b.de> wrote:
> First, I would be really delighted if someone could review my coarray
> patches for the trunk as it makes simpler to develop patches on top of it:
> * http://gcc.gnu.org/ml/fortran/2014-04/msg00087.html

This is OK for trunk.

> * http://gcc.gnu.org/ml/fortran/2014-04/msg00091.html

"dg2final" ???? Surely this is a typo?  Although I note that getting
it wrong on a German keyboard should produce a 4. Therefore it might
well be a command that i do not know about.

Otherwise, OK for trunk.

> * http://gcc.gnu.org/ml/fortran/2014-04/msg00092.html
>

This is OK for trunk

> Secondly, attached is a patch which fixes an ICE - and prepares for some
> additional class-related coarray patches. In particular, the patch ensures
> that for nonallocatable *polymorphic* coarrays, the coarray token and offset
> are passed.

This is also OK for trunk.
>
> Build and regtested on x86-64-gnu-linux.
> OK for the trunk?
>
> Tobias
>
> PS: There is still something wrong (for both -fcoarray=single and
> -fcoarray=lib) with lcobound/ucobounds and polymorphic coarrays and with
> using them with select type and associated. That's something I would like to
> tackle next. If that's done, I probably should really concentrate on
> reviewing a few patches and doing some other bug fixes before continue
> working on coarrays.

Thank you truly for the effort that you are putting into co-arrays.
It is highly gratifying that gfortran seems to perform so well
compared with another product.  Frankly, if I were you I would
continue working on co-arrays, whilst you have the wind in your sails
:-)

Best regards

Paul
diff mbox

Patch

2014-04-27  Tobias Burnus  <burnus@net-b.de>

	* trans-decl.c (create_function_arglist): Add hidden coarray arguments
	also for polymorphic coarrays.
	* trans-expr.c (gfc_conv_procedure_call): Pass hidden coarray arguments
	also for polymorphic coarrays.

2014-04-27  Tobias Burnus  <burnus@net-b.de>

	* gfortran.dg/coarray_poly_7.f90
	* gfortran.dg/coarray_poly_8.f90
	* gfortran.dg/coarray_poly_9.f90

diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index c835a3b..ee6c7e3 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -2234,9 +2234,12 @@  create_function_arglist (gfc_symbol * sym)
 
       /* Coarrays which are descriptorless or assumed-shape pass with
 	 -fcoarray=lib the token and the offset as hidden arguments.  */
-      if (f->sym->attr.codimension
-	  && gfc_option.coarray == GFC_FCOARRAY_LIB
-	  && !f->sym->attr.allocatable)
+      if (gfc_option.coarray == GFC_FCOARRAY_LIB
+	  && ((f->sym->ts.type != BT_CLASS && f->sym->attr.codimension
+	       && !f->sym->attr.allocatable)
+	      || (f->sym->ts.type == BT_CLASS
+		  && CLASS_DATA (f->sym)->attr.codimension
+		  && !CLASS_DATA (f->sym)->attr.allocatable)))
 	{
 	  tree caf_type;
 	  tree token;
@@ -2244,13 +2247,18 @@  create_function_arglist (gfc_symbol * sym)
 
 	  gcc_assert (f->sym->backend_decl != NULL_TREE
 		      && !sym->attr.is_bind_c);
-	  caf_type = TREE_TYPE (f->sym->backend_decl);
+	  caf_type = f->sym->ts.type == BT_CLASS
+		     ? TREE_TYPE (CLASS_DATA (f->sym)->backend_decl)
+		     : TREE_TYPE (f->sym->backend_decl);
 
 	  token = build_decl (input_location, PARM_DECL,
 			      create_tmp_var_name ("caf_token"),
 			      build_qualified_type (pvoid_type_node,
 						    TYPE_QUAL_RESTRICT));
-	  if (f->sym->as->type == AS_ASSUMED_SHAPE)
+	  if ((f->sym->ts.type != BT_CLASS
+	       && f->sym->as->type != AS_DEFERRED)
+	      || (f->sym->ts.type == BT_CLASS
+		  && CLASS_DATA (f->sym)->as->type != AS_DEFERRED))
 	    {
 	      gcc_assert (DECL_LANG_SPECIFIC (f->sym->backend_decl) == NULL
 			  || GFC_DECL_TOKEN (f->sym->backend_decl) == NULL_TREE);
@@ -2275,7 +2283,10 @@  create_function_arglist (gfc_symbol * sym)
 			       create_tmp_var_name ("caf_offset"),
 			       gfc_array_index_type);
 
-	  if (f->sym->as->type == AS_ASSUMED_SHAPE)
+	  if ((f->sym->ts.type != BT_CLASS
+	       && f->sym->as->type != AS_DEFERRED)
+	      || (f->sym->ts.type == BT_CLASS
+		  && CLASS_DATA (f->sym)->as->type != AS_DEFERRED))
 	    {
 	      gcc_assert (GFC_DECL_CAF_OFFSET (f->sym->backend_decl)
 					       == NULL_TREE);
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index f0e5b7d..6b93537 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -4783,19 +4783,24 @@  gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 
       /* For descriptorless coarrays and assumed-shape coarray dummies, we
 	 pass the token and the offset as additional arguments.  */
-      if (fsym && fsym->attr.codimension
-	  && gfc_option.coarray == GFC_FCOARRAY_LIB
-	  && !fsym->attr.allocatable
-	  && e == NULL)
+      if (fsym && e == NULL && gfc_option.coarray == GFC_FCOARRAY_LIB
+	  && ((fsym->ts.type != BT_CLASS && fsym->attr.codimension
+	       && !fsym->attr.allocatable)
+	      || (fsym->ts.type == BT_CLASS
+		  && CLASS_DATA (fsym)->attr.codimension
+		  && !CLASS_DATA (fsym)->attr.allocatable)))
 	{
 	  /* Token and offset. */
 	  vec_safe_push (stringargs, null_pointer_node);
 	  vec_safe_push (stringargs, build_int_cst (gfc_array_index_type, 0));
 	  gcc_assert (fsym->attr.optional);
 	}
-      else if (fsym && fsym->attr.codimension
-	       && !fsym->attr.allocatable
-	       && gfc_option.coarray == GFC_FCOARRAY_LIB)
+      else if (fsym && gfc_option.coarray == GFC_FCOARRAY_LIB
+	       && ((fsym->ts.type != BT_CLASS && fsym->attr.codimension
+		    && !fsym->attr.allocatable)
+		   || (fsym->ts.type == BT_CLASS
+		       && CLASS_DATA (fsym)->attr.codimension
+		       && !CLASS_DATA (fsym)->attr.allocatable)))
 	{
 	  tree caf_decl, caf_type;
 	  tree offset, tmp2;
@@ -4837,22 +4842,30 @@  gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	      tmp = caf_decl;
 	    }
 
-          if (fsym->as->type == AS_ASSUMED_SHAPE
-	      || (fsym->as->type == AS_ASSUMED_RANK && !fsym->attr.pointer
-		  && !fsym->attr.allocatable))
+          tmp2 = fsym->ts.type == BT_CLASS
+		 ? gfc_class_data_get (parmse.expr) : parmse.expr;
+          if ((fsym->ts.type != BT_CLASS
+	       && (fsym->as->type == AS_ASSUMED_SHAPE
+		   || fsym->as->type == AS_ASSUMED_RANK))
+	      || (fsym->ts.type == BT_CLASS
+		  && (CLASS_DATA (fsym)->as->type == AS_ASSUMED_SHAPE
+		      || CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)))
 	    {
-	      gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse.expr)));
-	      gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE
-						   (TREE_TYPE (parmse.expr))));
-	      tmp2 = build_fold_indirect_ref_loc (input_location, parmse.expr);
+	      if (fsym->ts.type == BT_CLASS)
+		gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2)));
+	      else
+		{
+		  gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
+		  tmp2 = build_fold_indirect_ref_loc (input_location, tmp2);
+		}
+	      gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)));
 	      tmp2 = gfc_conv_descriptor_data_get (tmp2);
 	    }
-	  else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse.expr)))
-	    tmp2 = gfc_conv_descriptor_data_get (parmse.expr);
+	  else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)))
+	    tmp2 = gfc_conv_descriptor_data_get (tmp2);
 	  else
 	    {
-	      gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse.expr)));
-	      tmp2 = parmse.expr;
+	      gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
 	    }
 
 	  tmp = fold_build2_loc (input_location, MINUS_EXPR,
--- /dev/null	2014-04-23 17:58:54.386702372 +0200
+++ gcc/gcc/testsuite/gfortran.dg/coarray_poly_6.f90	2014-04-27 20:32:43.452474762 +0200
@@ -0,0 +1,22 @@ 
+! { dg-do compile }
+! { dg-options "-fcoarray=lib -fdump-tree-original" }
+!
+  implicit none
+  type t
+  end type t
+  class(t), allocatable :: y[:]
+  call bar()
+  call foo(y)
+contains
+  subroutine bar(x)
+    class(t), optional :: x[*]
+  end subroutine bar
+  subroutine foo(x)
+    class(t) :: x[*]
+  end subroutine foo
+end
+! { dg-final { scan-tree-dump-times "foo \\(struct __class_MAIN___T_0_1t & restrict x, void \\* restrict caf_token.., integer\\(kind=8\\) caf_offset..\\)" 1 "original" } }
+! { dg-final { scan-tree-dump-times "bar \\(struct __class_MAIN___T_0_1t \\* x, void \\* restrict caf_token.., integer\\(kind=8\\) caf_offset..\\)" 1 "original" } }
+! { dg-final { scan-tree-dump-times "bar \\(0B, 0B, 0\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "foo \\(&class.., y._data._data.token, \\(integer\\(kind=8\\)\\) class..._data.data - \\(integer\\(kind=8\\)\\) y._data._data.data\\);" 1 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }
--- /dev/null	2014-04-23 17:58:54.386702372 +0200
+++ gcc/gcc/testsuite/gfortran.dg/coarray_poly_7.f90	2014-04-27 20:33:37.856904369 +0200
@@ -0,0 +1,22 @@ 
+! { dg-do compile }
+! { dg-options "-fcoarray=lib -fdump-tree-original" }
+!
+  implicit none
+  type t
+  end type t
+  class(t), allocatable :: y(:)[:]
+  call bar()
+  call foo(y)
+contains
+  subroutine bar(x)
+    class(t), optional :: x(:)[*]
+  end subroutine bar
+  subroutine foo(x)
+    class(t) :: x(:)[*]
+  end subroutine foo
+end
+! { dg-final { scan-tree-dump-times "foo \\(struct __class_MAIN___T_1_1t & restrict x, void \\* restrict caf_token.., integer\\(kind=8\\) caf_offset..\\)" 1 "original" } }
+! { dg-final { scan-tree-dump-times "bar \\(struct __class_MAIN___T_1_1t \\* x, void \\* restrict caf_token.., integer\\(kind=8\\) caf_offset..\\)" 1 "original" } }
+! { dg-final { scan-tree-dump-times "bar \\(0B, 0B, 0\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "foo \\(&class.., y._data._data.token, \\(integer\\(kind=8\\)\\) class..._data.data - \\(integer\\(kind=8\\)\\) y._data._data.data\\);" 1 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }
--- /dev/null	2014-04-23 17:58:54.386702372 +0200
+++ gcc/gcc/testsuite/gfortran.dg/coarray_poly_8.f90	2014-04-27 20:33:46.073969253 +0200
@@ -0,0 +1,22 @@ 
+! { dg-do compile }
+! { dg-options "-fcoarray=lib -fdump-tree-original" }
+!
+  implicit none
+  type t
+  end type t
+  class(t), allocatable :: y(:)[:]
+  call bar()
+  call foo(y)
+contains
+  subroutine bar(x)
+    class(t), optional :: x(2)[*]
+  end subroutine bar
+  subroutine foo(x)
+    class(t) :: x(2)[*]
+  end subroutine foo
+end
+! { dg-final { scan-tree-dump-times "foo \\(struct __class_MAIN___T_1_1t & restrict x, void \\* restrict caf_token.., integer\\(kind=8\\) caf_offset..\\)" 1 "original" } }
+! { dg-final { scan-tree-dump-times "bar \\(struct __class_MAIN___T_1_1t \\* x, void \\* restrict caf_token.., integer\\(kind=8\\) caf_offset..\\)" 1 "original" } }
+! { dg-final { scan-tree-dump-times "bar \\(0B, 0B, 0\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "foo \\(&class.., y._data._data.token, \\(integer\\(kind=8\\)\\) class..._data.data - \\(integer\\(kind=8\\)\\) y._data._data.data\\);" 1 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }