Patchwork [Fortran] PR56845 - Fix setting of vptr of CLASS(...),SAVE,ALLOCATABLE

login
register
mail settings
Submitter Tobias Burnus
Date April 7, 2013, 6:03 p.m.
Message ID <5161B4E2.1030206@net-b.de>
Download mbox | patch
Permalink /patch/234515/
State New
Headers show

Comments

Tobias Burnus - April 7, 2013, 6:03 p.m.
An unallocated polymorphic variable has the declared type; however, for 
static (SAVE) variables, the current code didn't set the value.

(That the end of scope deallocation/_gfortran_caf_deregister is gone for 
coarrays (declared in the main program) was a side effect. The 
sync/deregistering will still happen via the _gfortran_caf_finalize 
call. But that's fine and in the line of the Fortran standard; in fact, 
due to the FINAL handling, the automatic deallocation of the main 
program will be also removed for nonpolymorphic allocatables.)

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

Tobias
Tobias Burnus - April 10, 2013, 2:25 p.m.
* PING *

Tobias Burnus:
> An unallocated polymorphic variable has the declared type; however, 
> for static (SAVE) variables, the current code didn't set the value.
>
> (That the end of scope deallocation/_gfortran_caf_deregister is gone 
> for coarrays (declared in the main program) was a side effect. The 
> sync/deregistering will still happen via the _gfortran_caf_finalize 
> call. But that's fine and in the line of the Fortran standard; in 
> fact, due to the FINAL handling, the automatic deallocation of the 
> main program will be also removed for nonpolymorphic allocatables.)
>
> Build and regtested on x86-64-gnu-linux.
> OK for the trunk?
>
> Tobias
Janus Weil - April 11, 2013, 10:05 p.m.
Hi Tobias,

> An unallocated polymorphic variable has the declared type; however, for
> static (SAVE) variables, the current code didn't set the value.
>
> (That the end of scope deallocation/_gfortran_caf_deregister is gone for
> coarrays (declared in the main program) was a side effect. The
> sync/deregistering will still happen via the _gfortran_caf_finalize call.
> But that's fine and in the line of the Fortran standard; in fact, due to the
> FINAL handling, the automatic deallocation of the main program will be also
> removed for nonpolymorphic allocatables.)
>
> Build and regtested on x86-64-gnu-linux.
> OK for the trunk?

Looks basically alright.

Just one minor nit:

+      if (sym->ts.type == BT_CLASS && TREE_STATIC (sym->backend_decl)
+      && CLASS_DATA (sym)->attr.allocatable)

I'd find it somewhat clearer to check for "sym->attr.save" instead of
"TREE_STATIC (sym->backend_decl)", but that may be a matter of taste.

Oh, and can you remind me why this does not need to be done for pointers?

Cheers,
Janus
Tobias Burnus - April 11, 2013, 10:29 p.m.
Am 12.04.2013 00:05, schrieb Janus Weil:
> Just one minor nit:
>
> +      if (sym->ts.type == BT_CLASS && TREE_STATIC (sym->backend_decl)
> +      && CLASS_DATA (sym)->attr.allocatable)
>
> I'd find it somewhat clearer to check for "sym->attr.save" instead of
> "TREE_STATIC (sym->backend_decl)", but that may be a matter of taste.

I think there was a test-suite failure when I tried it. In any case, 
variables might be in static memory even if attr.save is not set:

- Module variables
- Variables of the main program
- Local variables of constant size (instead of allocating them on the 
stack), depending on their size
- All local variables with -fno-automatic, which implies SAVE
- If "SAVE" has been specified for the scoping unit

(For the first three items, a static initialization is not required, it 
could also be done after the declaration.) Instead of taking care of all 
those, I think it is simpler to use TREE_STATIC ;-)

> Oh, and can you remind me why this does not need to be done for pointers?

They are in undefined state. Thus, they need to be nullified, pointer 
associated or allocated before they can be used. All those actions will 
set both the data and the vptr component.

With the new array descriptor, one actually should (could?) set some 
elements, e.g. attribute = pointer, version = 1, and  (at least for 
non-CLASS) "type = ...". Then, one does not touch those components for 
ptr-assoc/allocate.

OK as is?

Tobias
Janus Weil - April 12, 2013, 6:41 a.m.
2013/4/12 Tobias Burnus <burnus@net-b.de>:
> Am 12.04.2013 00:05, schrieb Janus Weil:
>
>> Just one minor nit:
>>
>> +      if (sym->ts.type == BT_CLASS && TREE_STATIC (sym->backend_decl)
>> +      && CLASS_DATA (sym)->attr.allocatable)
>>
>> I'd find it somewhat clearer to check for "sym->attr.save" instead of
>> "TREE_STATIC (sym->backend_decl)", but that may be a matter of taste.
>
> I think there was a test-suite failure when I tried it. In any case,
> variables might be in static memory even if attr.save is not set:
>
> - Module variables
> - Variables of the main program
> - Local variables of constant size (instead of allocating them on the
> stack), depending on their size
> - All local variables with -fno-automatic, which implies SAVE
> - If "SAVE" has been specified for the scoping unit

Yes, but for most of them one should have attr.save=SAVE_IMPLICIT (at
least for #1, #4 and #5?).

And for those that do not have attr.save set, gfc_trans_deferred_vars
should take care of initializing the vptr already, right? Do we have a
double initlialization for these cases now?


> (For the first three items, a static initialization is not required, it
> could also be done after the declaration.) Instead of taking care of all
> those, I think it is simpler to use TREE_STATIC ;-)
>
>
>> Oh, and can you remind me why this does not need to be done for pointers?
>
> They are in undefined state. Thus, they need to be nullified, pointer
> associated or allocated before they can be used. All those actions will set
> both the data and the vptr component.

Ok, I guess one could argue that it could not hurt to do the
initialization for pointers, too. But since the standard does not
seems to require it, let's forget about it.


> OK as is?

Yes, after answering the double-initialization question above ;)

Thanks for the patch ...

Cheers,
Janus

Patch

2013-04-07  Tobias Burnus  <burnus@net-b.de>

	PR fortran/56845
	* trans-decl.c (gfc_trans_deferred_vars): Set _vptr for
	allocatable static BT_CLASS.
	* trans-expr.c (gfc_class_set_static_fields): New function.
	* trans.h (gfc_class_set_static_fields): New prototype.

2013-04-07  Tobias Burnus  <burnus@net-b.de>

	PR fortran/56845
	* gfortran.dg/class_allocate_14.f90: New.
	* gfortran.dg/coarray_lib_alloc_2.f90: Update scan-tree-dump-times.
	* gfortran.dg/coarray_lib_alloc_3.f90: New.

diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index fafde89..779df16 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -3649,7 +3649,36 @@  gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 				NULL_TREE);
 	}
 
-      if (sym->attr.dimension || sym->attr.codimension)
+      if (sym->ts.type == BT_CLASS && TREE_STATIC (sym->backend_decl)
+	  && CLASS_DATA (sym)->attr.allocatable)
+	{
+	  tree vptr;
+
+          if (UNLIMITED_POLY (sym))
+	    vptr = null_pointer_node;
+	  else
+	    {
+	      gfc_symbol *vsym;
+	      vsym = gfc_find_derived_vtab (sym->ts.u.derived);
+	      vptr = gfc_get_symbol_decl (vsym);
+	      vptr = gfc_build_addr_expr (NULL, vptr);
+	    }
+
+	  if (CLASS_DATA (sym)->attr.dimension
+	      || (CLASS_DATA (sym)->attr.codimension
+		  && gfc_option.coarray != GFC_FCOARRAY_LIB))
+	    {
+	      tmp = gfc_class_data_get (sym->backend_decl);
+	      tmp = gfc_build_null_descriptor (TREE_TYPE (tmp));
+	    }
+	  else
+	    tmp = null_pointer_node;
+
+	  DECL_INITIAL (sym->backend_decl)
+		= gfc_class_set_static_fields (sym->backend_decl, vptr, tmp);
+	  TREE_CONSTANT (DECL_INITIAL (sym->backend_decl)) = 1;
+	}
+      else if (sym->attr.dimension || sym->attr.codimension)
 	{
           /* Assumed-size Cray pointees need to be treated as AS_EXPLICIT.  */
           array_type tmp = sym->as->type;
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 454755b..de851a2 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -97,6 +97,24 @@  gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
 
 
 tree
+gfc_class_set_static_fields (tree decl, tree vptr, tree data)
+{
+  tree tmp;
+  tree field;
+  vec<constructor_elt, va_gc> *init = NULL;
+
+  field = TYPE_FIELDS (TREE_TYPE (decl));
+  tmp = gfc_advance_chain (field, CLASS_DATA_FIELD);
+  CONSTRUCTOR_APPEND_ELT (init, tmp, data);
+
+  tmp = gfc_advance_chain (field, CLASS_VPTR_FIELD);
+  CONSTRUCTOR_APPEND_ELT (init, tmp, vptr);
+
+  return build_constructor (TREE_TYPE (decl), init);
+}
+
+
+tree
 gfc_class_data_get (tree decl)
 {
   tree data;
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 03adfdd..ad6a105 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -341,6 +341,7 @@  gfc_wrapped_block;
 /* Class API functions.  */
 tree gfc_class_data_get (tree);
 tree gfc_class_vptr_get (tree);
+tree gfc_class_set_static_fields (tree, tree, tree);
 tree gfc_vtable_hash_get (tree);
 tree gfc_vtable_size_get (tree);
 tree gfc_vtable_extends_get (tree);
diff --git a/gcc/testsuite/gfortran.dg/class_allocate_14.f90 b/gcc/testsuite/gfortran.dg/class_allocate_14.f90
new file mode 100644
index 0000000..0c7aeb4
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_allocate_14.f90
@@ -0,0 +1,31 @@ 
+! { dg-do run }
+! { dg-options "-fdump-tree-original" }
+!
+! PR fortran/56845
+!
+module m
+type t
+integer ::a
+end type t
+contains
+subroutine sub
+  type(t), save, allocatable :: x
+  class(t), save,allocatable :: y
+  if (.not. same_type_as(x,y)) call abort()
+end subroutine sub
+subroutine sub2
+  type(t), save, allocatable :: a(:)
+  class(t), save,allocatable :: b(:)
+  if (.not. same_type_as(a,b)) call abort()
+end subroutine sub2
+end module m
+
+use m
+call sub()
+call sub2()
+end
+
+! { dg-final { scan-tree-dump-times "static struct __class_m_T_1_0a b = {._data={.data=0B}, ._vptr=&__vtab_m_T};" 1 "original" } }
+! { dg-final { scan-tree-dump-times "static struct __class_m_T_a y = {._data=0B, ._vptr=&__vtab_m_T};" 1 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }
+
diff --git a/gcc/testsuite/gfortran.dg/coarray_lib_alloc_2.f90 b/gcc/testsuite/gfortran.dg/coarray_lib_alloc_2.f90
index 3aaff1e..a41be79 100644
--- a/gcc/testsuite/gfortran.dg/coarray_lib_alloc_2.f90
+++ b/gcc/testsuite/gfortran.dg/coarray_lib_alloc_2.f90
@@ -18,6 +18,6 @@ 
 ! { dg-final { scan-tree-dump-times "_gfortran_caf_register .1, 1, &yy._data.token, &stat.., &errmsg, 200.;" 1 "original" } }
 ! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx._data.token, &stat.., &errmsg, 200.;" 1 "original" } }
 ! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy._data.token, &stat.., &errmsg, 200.;" 1 "original" } }
-! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy._data.token, 0B, 0B, 0.;" 1 "original" } }
-! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx._data.token, 0B, 0B, 0.;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy._data.token, 0B, 0B, 0.;" 0 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx._data.token, 0B, 0B, 0.;" 0 "original" } }
 ! { dg-final { cleanup-tree-dump "original" } }
diff --git a/gcc/testsuite/gfortran.dg/coarray_lib_alloc_3.f90 b/gcc/testsuite/gfortran.dg/coarray_lib_alloc_3.f90
new file mode 100644
index 0000000..bec7ee2
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray_lib_alloc_3.f90
@@ -0,0 +1,25 @@ 
+! { dg-do compile }
+! { dg-options "-fcoarray=lib -fdump-tree-original" }
+!
+! Allocate/deallocate with libcaf.
+!
+! As coarray_lib_alloc_2.f90 but for a subroutine instead of the PROGRAM
+!
+subroutine test
+ type t
+ end type t
+ class(t), allocatable :: xx[:], yy(:)[:]
+ integer :: stat
+ character(len=200) :: errmsg
+ allocate(xx[*], stat=stat, errmsg=errmsg)
+ allocate(yy(2)[*], stat=stat, errmsg=errmsg)
+ deallocate(xx,yy,stat=stat, errmsg=errmsg)
+ end
+
+! { dg-final { scan-tree-dump-times "_gfortran_caf_register .1, 1, &xx._data.token, &stat.., &errmsg, 200.;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_register .1, 1, &yy._data.token, &stat.., &errmsg, 200.;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx._data.token, &stat.., &errmsg, 200.;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy._data.token, &stat.., &errmsg, 200.;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy._data.token, 0B, 0B, 0.;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx._data.token, 0B, 0B, 0.;" 1 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }