Re: [Patch, Fortran, pr70397, gcc-5, v1] [5/6 Regression] ice while allocating ultimate polymorphic

Re: [Patch, Fortran, pr70397, gcc-5, v1] [5/6 Regression] ice while allocating ultimate polymorphic

[Dominique d'Humières]

Andre,

In order to apply the patch on a recent trunk

@@ -1070,7 +1089,7 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
   if (unlimited)
     {
       if (from_class_base != NULL_TREE)
-	from_len = gfc_class_len_get (from_class_base);
+	from_len = gfc_class_len_or_zero_get (from_class_base);
       else
 	from_len = integer_zero_node;
     }
should be something such as

@@ -1120,7 +1142,7 @@ gfc_copy_class_to_class (tree from, tree
   if (unlimited)
     {
       if (from != NULL_TREE && unlimited)
-	from_len = gfc_class_len_get (from);
+	from_len = gfc_class_len_or_zero_get (from);
       else
 	from_len = integer_zero_node;
     }

With my patched tree I also see the regression

FAIL: gfortran.dg/coarray_allocate_4.f08  * (internal compiler error)

/opt/gcc/work/gcc/testsuite/gfortran.dg/coarray_allocate_4.f08:39:0:

    allocate (z, source=x)
 
internal compiler error: tree check: expected record_type or union_type or qual_union_type, have void_type in gfc_class_len_or_zero_get, at fortran/trans-expr.c:186

Dominique

[Patch, Fortran, pr70397, v1] [5/6 Regression] ice while allocating ultimate polymorphic

[Andre Vehreschild]

[-- Attachment #1: Type: text/plain, Size: 982 bytes --]

Hi all,

here is the trunk version of the patch for the regression reported in
pr70397. Applying the gcc-5 patch to trunk lead to a regression, which
the modified patch resolves now. The technique to solve the ice is
the same as for gcc-5:

> The routine gfc_copy_class_to_class() assumed that both the source
> and destination object's type is unlimited polymorphic, but in this
> case it is true for the destination only, which made gfortran look
> for a non-existent _len component in the source object and therefore
> ICE. This is fixed by the patch by adding a function to return either
> the _len component, when it exists, or a constant zero node to init
> the destination object's _len component with.

Bootstrapped and regtested on x86_64-linux-gnu/F23. Ok for trunk?

Regards,
	Andre

PS: Yes, Paul, I know you accepted the patch for gcc-5 for trunk
also, but I feel safer when the changes made get additional approval.
-- 
Andre Vehreschild * Email: vehre ad gmx dot de 

[-- Attachment #2: pr70397_1.clog --]
[-- Type: text/plain, Size: 592 bytes --]

gcc/fortran/ChangeLog:

2016-03-27  Andre Vehreschild  <vehre@gcc.gnu.org>

	PR fortran/70397
	* trans-expr.c (gfc_class_len_or_zero_get): Add function to return a
	constant zero tree, when the class to get the _len component from is
	not unlimited polymorphic.
	(gfc_copy_class_to_class): Use the new function.
	* trans.h: Added interface of new function gfc_class_len_or_zero_get.

gcc/testsuite/ChangeLog:

2016-03-27  Andre Vehreschild  <vehre@gcc.gnu.org>

	PR fortran/70397
	* gfortran.dg/unlimited_polymorphic_25.f90: New test.
	* gfortran.dg/unlimited_polymorphic_26.f90: New test.



[-- Attachment #3: pr70397_gcc6_1.patch --]
[-- Type: text/x-patch, Size: 4681 bytes --]

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 4baadc8..8d039a6 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -173,6 +173,29 @@ gfc_class_len_get (tree decl)
 }
 
 
+/* Try to get the _len component of a class.  When the class is not unlimited
+   poly, i.e. no _len field exists, then return a zero node.  */
+
+tree
+gfc_class_len_or_zero_get (tree decl)
+{
+  tree len;
+  /* For class arrays decl may be a temporary descriptor handle, the vptr is
+     then available through the saved descriptor.  */
+  if (TREE_CODE (decl) == VAR_DECL && DECL_LANG_SPECIFIC (decl)
+      && GFC_DECL_SAVED_DESCRIPTOR (decl))
+    decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
+  if (POINTER_TYPE_P (TREE_TYPE (decl)))
+    decl = build_fold_indirect_ref_loc (input_location, decl);
+  len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
+			   CLASS_LEN_FIELD);
+  return len != NULL_TREE ? fold_build3_loc (input_location, COMPONENT_REF,
+					     TREE_TYPE (len), decl, len,
+					     NULL_TREE)
+			  : integer_zero_node;
+}
+
+
 /* Get the specified FIELD from the VPTR.  */
 
 static tree
@@ -250,6 +273,7 @@ gfc_vptr_size_get (tree vptr)
 
 #undef CLASS_DATA_FIELD
 #undef CLASS_VPTR_FIELD
+#undef CLASS_LEN_FIELD
 #undef VTABLE_HASH_FIELD
 #undef VTABLE_SIZE_FIELD
 #undef VTABLE_EXTENDS_FIELD
@@ -1120,7 +1144,7 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
   if (unlimited)
     {
       if (from != NULL_TREE && unlimited)
-	from_len = gfc_class_len_get (from);
+	from_len = gfc_class_len_or_zero_get (from);
       else
 	from_len = integer_zero_node;
     }
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index add0cea..512615a 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -365,6 +365,7 @@ tree gfc_class_set_static_fields (tree, tree, tree);
 tree gfc_class_data_get (tree);
 tree gfc_class_vptr_get (tree);
 tree gfc_class_len_get (tree);
+tree gfc_class_len_or_zero_get (tree);
 gfc_expr * gfc_find_and_cut_at_last_class_ref (gfc_expr *);
 /* Get an accessor to the class' vtab's * field, when a class handle is
    available.  */
diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_25.f90 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_25.f90
new file mode 100644
index 0000000..d0b2a2e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_25.f90
@@ -0,0 +1,40 @@
+! { dg-do run }
+!
+! Test contributed by Valery Weber  <valeryweber@hotmail.com>
+
+module mod
+
+  TYPE, PUBLIC :: base_type
+  END TYPE base_type
+
+  TYPE, PUBLIC :: dict_entry_type
+     CLASS( * ), ALLOCATABLE :: key
+     CLASS( * ), ALLOCATABLE :: val
+  END TYPE dict_entry_type
+
+
+contains
+
+  SUBROUTINE dict_put ( this, key, val )
+    CLASS(dict_entry_type), INTENT(INOUT)     :: this
+    CLASS(base_type), INTENT(IN)             :: key, val
+    INTEGER                                  :: istat
+    ALLOCATE( this%key, SOURCE=key, STAT=istat )
+  end SUBROUTINE dict_put
+end module mod
+
+program test
+  use mod
+  type(dict_entry_type) :: t
+  type(base_type) :: a, b
+  call dict_put(t, a, b)
+
+  if (.NOT. allocated(t%key)) call abort()
+  select type (x => t%key)
+    type is (base_type)
+    class default
+      call abort()
+  end select
+  deallocate(t%key)
+end
+
diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_26.f90 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_26.f90
new file mode 100644
index 0000000..1300069
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_26.f90
@@ -0,0 +1,47 @@
+! { dg-do run }
+!
+! Test contributed by Valery Weber  <valeryweber@hotmail.com>
+
+module mod
+
+  TYPE, PUBLIC :: dict_entry_type
+     CLASS( * ), ALLOCATABLE :: key
+     CLASS( * ), ALLOCATABLE :: val
+  END TYPE dict_entry_type
+
+
+contains
+
+  SUBROUTINE dict_put ( this, key, val )
+    CLASS(dict_entry_type), INTENT(INOUT)     :: this
+    CLASS(*), INTENT(IN)                     :: key, val
+    INTEGER                                  :: istat
+    ALLOCATE( this%key, SOURCE=key, STAT=istat )
+    ALLOCATE( this%val, SOURCE=val, STAT=istat )
+  end SUBROUTINE dict_put
+end module mod
+
+program test
+  use mod
+  type(dict_entry_type) :: t
+  call dict_put(t, "foo", 42)
+
+  if (.NOT. allocated(t%key)) call abort()
+  select type (x => t%key)
+    type is (CHARACTER(*))
+      if (x /= "foo") call abort()
+    class default
+      call abort()
+  end select
+  deallocate(t%key)
+
+  if (.NOT. allocated(t%val)) call abort()
+  select type (x => t%val)
+    type is (INTEGER)
+      if (x /= 42) call abort()
+    class default
+      call abort()
+  end select
+  deallocate(t%val)
+end
+

Re: [Patch, Fortran, pr70397, v1] [5/6 Regression] ice while allocating ultimate polymorphic

[Paul Richard Thomas]

Hi Andre,

Yes, it is better to play safe :-) OK for trunk.

Thanks

Paul

On 29 March 2016 at 14:55, Andre Vehreschild <vehre@gmx.de> wrote:
> Hi all,
>
> here is the trunk version of the patch for the regression reported in
> pr70397. Applying the gcc-5 patch to trunk lead to a regression, which
> the modified patch resolves now. The technique to solve the ice is
> the same as for gcc-5:
>
>> The routine gfc_copy_class_to_class() assumed that both the source
>> and destination object's type is unlimited polymorphic, but in this
>> case it is true for the destination only, which made gfortran look
>> for a non-existent _len component in the source object and therefore
>> ICE. This is fixed by the patch by adding a function to return either
>> the _len component, when it exists, or a constant zero node to init
>> the destination object's _len component with.
>
> Bootstrapped and regtested on x86_64-linux-gnu/F23. Ok for trunk?
>
> Regards,
>         Andre
>
> PS: Yes, Paul, I know you accepted the patch for gcc-5 for trunk
> also, but I feel safer when the changes made get additional approval.
> --
> Andre Vehreschild * Email: vehre ad gmx dot de



-- 
The difference between genius and stupidity is; genius has its limits.

Albert Einstein

Re: [Patch, Fortran, pr70397, v1] [5/6 Regression] ice while allocating ultimate polymorphic

[Andre Vehreschild]

[-- Attachment #1: Type: text/plain, Size: 1516 bytes --]

Hi Paul, hi Dominique

thanks for the fast review and error check, respectively. Committed as
r234528.

Regards,
	Andre

On Tue, 29 Mar 2016 15:34:13 +0200
Paul Richard Thomas <paul.richard.thomas@gmail.com> wrote:

> Hi Andre,
> 
> Yes, it is better to play safe :-) OK for trunk.
> 
> Thanks
> 
> Paul
> 
> On 29 March 2016 at 14:55, Andre Vehreschild <vehre@gmx.de> wrote:
> > Hi all,
> >
> > here is the trunk version of the patch for the regression reported in
> > pr70397. Applying the gcc-5 patch to trunk lead to a regression, which
> > the modified patch resolves now. The technique to solve the ice is
> > the same as for gcc-5:
> >  
> >> The routine gfc_copy_class_to_class() assumed that both the source
> >> and destination object's type is unlimited polymorphic, but in this
> >> case it is true for the destination only, which made gfortran look
> >> for a non-existent _len component in the source object and therefore
> >> ICE. This is fixed by the patch by adding a function to return either
> >> the _len component, when it exists, or a constant zero node to init
> >> the destination object's _len component with.  
> >
> > Bootstrapped and regtested on x86_64-linux-gnu/F23. Ok for trunk?
> >
> > Regards,
> >         Andre
> >
> > PS: Yes, Paul, I know you accepted the patch for gcc-5 for trunk
> > also, but I feel safer when the changes made get additional approval.
> > --
> > Andre Vehreschild * Email: vehre ad gmx dot de  
> 
> 
> 


-- 
Andre Vehreschild * Email: vehre ad gmx dot de 

[-- Attachment #2: submit.diff --]
[-- Type: text/x-patch, Size: 5795 bytes --]

Index: gcc/fortran/ChangeLog
===================================================================
--- gcc/fortran/ChangeLog	(Revision 234523)
+++ gcc/fortran/ChangeLog	(Arbeitskopie)
@@ -1,3 +1,12 @@
+2016-03-29  Andre Vehreschild  <vehre@gcc.gnu.org>
+
+	PR fortran/70397
+	* trans-expr.c (gfc_class_len_or_zero_get): Add function to return a
+	constant zero tree, when the class to get the _len component from is
+	not unlimited polymorphic.
+	(gfc_copy_class_to_class): Use the new function.
+	* trans.h: Added interface of new function gfc_class_len_or_zero_get.
+
 2016-03-28  Alessandro Fanfarillo  <fanfarillo.gcc@gmail.com>
 
 	* trans-decl.c (gfc_build_builtin_function_decls):
Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c	(Revision 234523)
+++ gcc/fortran/trans-expr.c	(Arbeitskopie)
@@ -173,6 +173,29 @@
 }
 
 
+/* Try to get the _len component of a class.  When the class is not unlimited
+   poly, i.e. no _len field exists, then return a zero node.  */
+
+tree
+gfc_class_len_or_zero_get (tree decl)
+{
+  tree len;
+  /* For class arrays decl may be a temporary descriptor handle, the vptr is
+     then available through the saved descriptor.  */
+  if (TREE_CODE (decl) == VAR_DECL && DECL_LANG_SPECIFIC (decl)
+      && GFC_DECL_SAVED_DESCRIPTOR (decl))
+    decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
+  if (POINTER_TYPE_P (TREE_TYPE (decl)))
+    decl = build_fold_indirect_ref_loc (input_location, decl);
+  len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
+			   CLASS_LEN_FIELD);
+  return len != NULL_TREE ? fold_build3_loc (input_location, COMPONENT_REF,
+					     TREE_TYPE (len), decl, len,
+					     NULL_TREE)
+			  : integer_zero_node;
+}
+
+
 /* Get the specified FIELD from the VPTR.  */
 
 static tree
@@ -250,6 +273,7 @@
 
 #undef CLASS_DATA_FIELD
 #undef CLASS_VPTR_FIELD
+#undef CLASS_LEN_FIELD
 #undef VTABLE_HASH_FIELD
 #undef VTABLE_SIZE_FIELD
 #undef VTABLE_EXTENDS_FIELD
@@ -1120,7 +1144,7 @@
   if (unlimited)
     {
       if (from != NULL_TREE && unlimited)
-	from_len = gfc_class_len_get (from);
+	from_len = gfc_class_len_or_zero_get (from);
       else
 	from_len = integer_zero_node;
     }
Index: gcc/fortran/trans.h
===================================================================
--- gcc/fortran/trans.h	(Revision 234523)
+++ gcc/fortran/trans.h	(Arbeitskopie)
@@ -365,6 +365,7 @@
 tree gfc_class_data_get (tree);
 tree gfc_class_vptr_get (tree);
 tree gfc_class_len_get (tree);
+tree gfc_class_len_or_zero_get (tree);
 gfc_expr * gfc_find_and_cut_at_last_class_ref (gfc_expr *);
 /* Get an accessor to the class' vtab's * field, when a class handle is
    available.  */
Index: gcc/testsuite/ChangeLog
===================================================================
--- gcc/testsuite/ChangeLog	(Revision 234523)
+++ gcc/testsuite/ChangeLog	(Arbeitskopie)
@@ -1,3 +1,9 @@
+2016-03-29  Andre Vehreschild  <vehre@gcc.gnu.org>
+
+	PR fortran/70397
+	* gfortran.dg/unlimited_polymorphic_25.f90: New test.
+	* gfortran.dg/unlimited_polymorphic_26.f90: New test.
+
 2016-03-29  Thomas Schwinge  <thomas@codesourcery.com>
 
 	PR testsuite/64177
Index: gcc/testsuite/gfortran.dg/unlimited_polymorphic_25.f90
===================================================================
--- gcc/testsuite/gfortran.dg/unlimited_polymorphic_25.f90	(nicht existent)
+++ gcc/testsuite/gfortran.dg/unlimited_polymorphic_25.f90	(Arbeitskopie)
@@ -0,0 +1,40 @@
+! { dg-do run }
+!
+! Test contributed by Valery Weber  <valeryweber@hotmail.com>
+
+module mod
+
+  TYPE, PUBLIC :: base_type
+  END TYPE base_type
+
+  TYPE, PUBLIC :: dict_entry_type
+     CLASS( * ), ALLOCATABLE :: key
+     CLASS( * ), ALLOCATABLE :: val
+  END TYPE dict_entry_type
+
+
+contains
+
+  SUBROUTINE dict_put ( this, key, val )
+    CLASS(dict_entry_type), INTENT(INOUT)     :: this
+    CLASS(base_type), INTENT(IN)             :: key, val
+    INTEGER                                  :: istat
+    ALLOCATE( this%key, SOURCE=key, STAT=istat )
+  end SUBROUTINE dict_put
+end module mod
+
+program test
+  use mod
+  type(dict_entry_type) :: t
+  type(base_type) :: a, b
+  call dict_put(t, a, b)
+
+  if (.NOT. allocated(t%key)) call abort()
+  select type (x => t%key)
+    type is (base_type)
+    class default
+      call abort()
+  end select
+  deallocate(t%key)
+end
+
Index: gcc/testsuite/gfortran.dg/unlimited_polymorphic_26.f90
===================================================================
--- gcc/testsuite/gfortran.dg/unlimited_polymorphic_26.f90	(nicht existent)
+++ gcc/testsuite/gfortran.dg/unlimited_polymorphic_26.f90	(Arbeitskopie)
@@ -0,0 +1,47 @@
+! { dg-do run }
+!
+! Test contributed by Valery Weber  <valeryweber@hotmail.com>
+
+module mod
+
+  TYPE, PUBLIC :: dict_entry_type
+     CLASS( * ), ALLOCATABLE :: key
+     CLASS( * ), ALLOCATABLE :: val
+  END TYPE dict_entry_type
+
+
+contains
+
+  SUBROUTINE dict_put ( this, key, val )
+    CLASS(dict_entry_type), INTENT(INOUT)     :: this
+    CLASS(*), INTENT(IN)                     :: key, val
+    INTEGER                                  :: istat
+    ALLOCATE( this%key, SOURCE=key, STAT=istat )
+    ALLOCATE( this%val, SOURCE=val, STAT=istat )
+  end SUBROUTINE dict_put
+end module mod
+
+program test
+  use mod
+  type(dict_entry_type) :: t
+  call dict_put(t, "foo", 42)
+
+  if (.NOT. allocated(t%key)) call abort()
+  select type (x => t%key)
+    type is (CHARACTER(*))
+      if (x /= "foo") call abort()
+    class default
+      call abort()
+  end select
+  deallocate(t%key)
+
+  if (.NOT. allocated(t%val)) call abort()
+  select type (x => t%val)
+    type is (INTEGER)
+      if (x /= 42) call abort()
+    class default
+      call abort()
+  end select
+  deallocate(t%val)
+end
+