Patchwork [Fortran] MOVE_ALLOC fixes

login
register
mail settings
Submitter Tobias Burnus
Date Nov. 28, 2011, 12:47 p.m.
Message ID <4ED382CE.9040205@net-b.de>
Download mbox | patch
Permalink /patch/127978/
State New
Headers show

Comments

Tobias Burnus - Nov. 28, 2011, 12:47 p.m.
Dear all,

attached is an updated patch, I hadn't considered that the declared type 
of polymorphic arguments could be different. The middle end was not 
happy about:
   to = from
where "to" and "from" where different class containers. I was 
considering to force the assignment (via VIEW_CONVERT_EXPR), but Jakub 
warns that this might confuse tree-sra while the produced code will 
anyway consists of two pointer assignments. Hence, I now directly 
generate two pointer assignments (for _data and _vptr). (The patch only 
affects scalar polymorphic variables; for arrays, there were already two 
pointer  assignments.)

Build and regtested on x86-64-linux (trunk and trunk + Paul's patch).
OK?

Tobias

On 11/26/2011 02:50 PM, Tobias Burnus wrote:
> Dear all,
>
> (First, this is *not* for the 4.6/4.7 rejects-valid regression, which 
> is related to intent(in) pointers with allocatable components.)
>
> When debugging an issue with with polymorphic arrays and MOVE_ALLOC, I 
> got lost in the code generation of move_alloc - and didn't like the 
> generated code. Thus, I have rewritten the trans*.c part of it. (It 
> turned out that the issue, we had, was unrelated to move_alloc.)
>
> Changes:
> * Replace call to libgfortran by inline code (much faster and shorter 
> code)
> * For arrays: Deallocate "from" (deep freeing)
> * For polymorphic arrays: set _vptr.
>
> Actually, the required code is rather simple: For move_alloc(from, 
> to), one just needs to do:
>
> a) Deallocate "to", taking allocatable components and the polymorphic 
> types into account (the latter is a to-do item, cf. PR 46174).
>
> b) Do a simple assignment:
>    to = from
> namely: If both are scalar variables, those are pointers and one does 
> a pointer assignment. If they are polymorphic and/or an array, one 
> does a (nonpointer) assignment to the class container or the array 
> descriptor.
>
> c) Setting "from = NULL" (nonpolymorphic scalars) or "from.data = 
> NULL" (nonpolymorphic arrays) or "from._data = NULL" (polymorphic 
> scalars) or "from._data.data = NULL" (polymorphic arrays).
>
> For (b) the current expr-ref-walking function for polymorphic arrays 
> either give access to class._data or to class._vptr. It is extremly 
> difficult to access "class" itself. Thus, I now do two assignments: 
> One nonpointer one to array descriptor and one pointer assignment to 
> the _vptr.
>
> Build and regtested with the trunk with Paul's polymorphic array patch 
> applied. (I will do a bootstrap and regtest with a clean trunk before 
> committal.)
> OK for the trunk?
>
> Tobias
>
> PS: I'll add _gfortran_move_alloc to the list of functions which can 
> be removed after the ABI breakage.
Paul Richard Thomas - Nov. 29, 2011, 9:46 a.m.
Dear Tobias,

> Build and regtested on x86-64-linux (trunk and trunk + Paul's patch).
> OK?

Many thanks for the patch - it's OK for trunk.

Cheers

Paul

Patch

2011-11-28  Tobias Burnus  <burnus@net-b.de>

	PR fortran/51306
	PR fortran/48700 
	* check.c (gfc_check_move_alloc): Make sure that from/to
	are both polymorphic or neither.
	* trans-intrinsic.c (conv_intrinsic_move_alloc): Cleanup,
	generate inline code.

2011-11-28  Tobias Burnus  <burnus@net-b.de>

	PR fortran/51306
	PR fortran/48700 
	* gfortran.dg/move_alloc_5.f90: Add dg-error.
	* gfortran.dg/select_type_23.f03: Add dg-error.
	* gfortran.dg/move_alloc_6.f90: New.
	* gfortran.dg/move_alloc_7.f90: New.

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index d9b9a9c..e2b0d66 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -2691,6 +2709,14 @@  gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
   if (same_type_check (to, 1, from, 0) == FAILURE)
     return FAILURE;
 
+  if (to->ts.type != from->ts.type)
+    {
+      gfc_error ("The FROM and TO arguments in MOVE_ALLOC call at %L must be "
+		 "either both polymorphic or both nonpolymorphic",
+		 &from->where);
+      return FAILURE;
+    }
+
   if (to->rank != from->rank)
     {
       gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 4244570..77c065e 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -5892,7 +5892,7 @@ 
 }
 
 
-/* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function.  */
+/* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function.  */
 
 static void
 gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr)
@@ -7182,50 +7190,123 @@  conv_intrinsic_atomic_ref (gfc_code *code)
 static tree
 conv_intrinsic_move_alloc (gfc_code *code)
 {
-  if (code->ext.actual->expr->rank == 0)
-    {
-      /* Scalar arguments: Generate pointer assignments.  */
-      gfc_expr *from, *to, *deal;
-      stmtblock_t block;
-      tree tmp;
-      gfc_se se;
+  stmtblock_t block;
+  gfc_expr *from_expr, *to_expr;
+  gfc_expr *to_expr2, *from_expr2;
+  gfc_se from_se, to_se;
+  gfc_ss *from_ss, *to_ss;
+  tree tmp;
 
-      from = code->ext.actual->expr;
-      to = code->ext.actual->next->expr;
+  gfc_start_block (&block);
 
-      gfc_start_block (&block);
+  from_expr = code->ext.actual->expr;
+  to_expr = code->ext.actual->next->expr;
 
-      /* Deallocate 'TO' argument.  */
-      gfc_init_se (&se, NULL);
-      se.want_pointer = 1;
-      deal = gfc_copy_expr (to);
-      if (deal->ts.type == BT_CLASS)
-	gfc_add_data_component (deal);
-      gfc_conv_expr (&se, deal);
-      tmp = gfc_deallocate_scalar_with_status (se.expr, NULL, true,
-					       deal, deal->ts);
-      gfc_add_expr_to_block (&block, tmp);
-      gfc_free_expr (deal);
+  gfc_init_se (&from_se, NULL);
+  gfc_init_se (&to_se, NULL);
 
-      if (to->ts.type == BT_CLASS)
-	tmp = gfc_trans_class_assign (to, from, EXEC_POINTER_ASSIGN);
+  if (from_expr->rank == 0)
+    {
+      if (from_expr->ts.type != BT_CLASS)
+	{
+	  from_expr2 = to_expr;
+	  to_expr2 = to_expr;
+	}
       else
-	tmp = gfc_trans_pointer_assignment (to, from);
-      gfc_add_expr_to_block (&block, tmp);
+	{
+	  to_expr2 = gfc_copy_expr (to_expr);
+	  from_expr2 = gfc_copy_expr (from_expr);
+	  gfc_add_data_component (from_expr2);
+	  gfc_add_data_component (to_expr2);
+	}
 
-      if (from->ts.type == BT_CLASS)
-	tmp = gfc_trans_class_assign (from, gfc_get_null_expr (NULL),
-				      EXEC_POINTER_ASSIGN);
-      else
-	tmp = gfc_trans_pointer_assignment (from,
-					    gfc_get_null_expr (NULL));
+      from_se.want_pointer = 1;
+      to_se.want_pointer = 1;
+      gfc_conv_expr (&from_se, from_expr2);
+      gfc_conv_expr (&to_se, to_expr2);
+      gfc_add_block_to_block (&block, &from_se.pre);
+      gfc_add_block_to_block (&block, &to_se.pre);
+
+      /* Deallocate "to".  */
+      tmp = gfc_deallocate_scalar_with_status (to_se.expr, NULL_TREE, true,
+					       to_expr2, to_expr->ts);
       gfc_add_expr_to_block (&block, tmp);
 
+      /* Assign (_data) pointers.  */
+      gfc_add_modify_loc (input_location, &block, to_se.expr,
+			  fold_convert (TREE_TYPE (to_se.expr), from_se.expr));
+
+      /* Set "from" to NULL.  */
+      gfc_add_modify_loc (input_location, &block, from_se.expr,
+			  fold_convert (TREE_TYPE (from_se.expr), null_pointer_node));
+
+      gfc_add_block_to_block (&block, &from_se.post);
+      gfc_add_block_to_block (&block, &to_se.post);
+
+      /* Set _vptr.  */
+      if (from_expr->ts.type == BT_CLASS)
+	{
+	  gfc_free_expr (from_expr2);
+          gfc_free_expr (to_expr2);
+
+	  gfc_init_se (&from_se, NULL);
+	  gfc_init_se (&to_se, NULL);
+	  from_se.want_pointer = 1;
+	  to_se.want_pointer = 1;
+	  gfc_add_vptr_component (from_expr);
+	  gfc_add_vptr_component (to_expr);
+
+	  gfc_conv_expr (&from_se, from_expr);
+	  gfc_conv_expr (&to_se, to_expr);
+	  gfc_add_modify_loc (input_location, &block, to_se.expr,
+			      fold_convert (TREE_TYPE (to_se.expr), from_se.expr));
+	}
+
       return gfc_finish_block (&block);
     }
-  else
-    /* Array arguments: Generate library code.  */
-    return gfc_trans_call (code, false, NULL_TREE, NULL_TREE, false);
+
+  /* Update _vptr component.  */
+  if (from_expr->ts.type == BT_CLASS)
+    {
+      from_se.want_pointer = 1;
+      to_se.want_pointer = 1;
+
+      from_expr2 = gfc_copy_expr (from_expr);
+      to_expr2 = gfc_copy_expr (to_expr);
+      gfc_add_vptr_component (from_expr2);
+      gfc_add_vptr_component (to_expr2);
+
+      gfc_conv_expr (&from_se, from_expr2);
+      gfc_conv_expr (&to_se, to_expr2);
+
+      gfc_add_modify_loc (input_location, &block, to_se.expr,
+			  fold_convert (TREE_TYPE (to_se.expr), from_se.expr));
+      gfc_free_expr (to_expr2);
+      gfc_free_expr (from_expr2);
+
+      gfc_init_se (&from_se, NULL);
+      gfc_init_se (&to_se, NULL);
+    }
+
+  /* Deallocate "to".  */
+  to_ss = gfc_walk_expr (to_expr);
+  from_ss = gfc_walk_expr (from_expr);
+  gfc_conv_expr_descriptor (&to_se, to_expr, to_ss);
+  gfc_conv_expr_descriptor (&from_se, from_expr, from_ss);
+
+  tmp = gfc_conv_descriptor_data_get (to_se.expr);
+  tmp = gfc_deallocate_with_status (tmp, NULL_TREE, true, to_expr);
+  gfc_add_expr_to_block (&block, tmp);
+
+  /* Move the pointer and update the array descriptor data.  */
+  gfc_add_modify_loc (input_location, &block, to_se.expr, from_se.expr);
+
+  /* Set "to" to NULL.  */
+  tmp = gfc_conv_descriptor_data_get (from_se.expr);
+  gfc_add_modify_loc (input_location, &block, tmp,
+		      fold_convert (TREE_TYPE (tmp), null_pointer_node));
+
+  return gfc_finish_block (&block);
 }
 
 
diff --git a/gcc/testsuite/gfortran.dg/move_alloc_5.f90 b/gcc/testsuite/gfortran.dg/move_alloc_5.f90
index b2759de..7663275 100644
--- a/gcc/testsuite/gfortran.dg/move_alloc_5.f90
+++ b/gcc/testsuite/gfortran.dg/move_alloc_5.f90
@@ -1,4 +1,4 @@ 
-! { dg-do run }
+! { dg-do compile }
 !
 ! PR 48699: [4.6/4.7 Regression] [OOP] MOVE_ALLOC inside SELECT TYPE
 !
@@ -16,7 +16,7 @@  program testmv1
   type(bar2), allocatable :: sm2
 
   allocate (sm2)
-  call move_alloc (sm2,sm)
+  call move_alloc (sm2,sm) ! { dg-error "must be either both polymorphic or both nonpolymorphic" }
 
   if (allocated(sm2)) call abort()
   if (.not. allocated(sm)) call abort()
diff --git a/gcc/testsuite/gfortran.dg/select_type_23.f03 b/gcc/testsuite/gfortran.dg/select_type_23.f03
index d7788d2..2479f1d 100644
--- a/gcc/testsuite/gfortran.dg/select_type_23.f03
+++ b/gcc/testsuite/gfortran.dg/select_type_23.f03
@@ -3,6 +3,10 @@ 
 ! PR 48699: [OOP] MOVE_ALLOC inside SELECT TYPE
 !
 ! Contributed by Salvatore Filippone <sfilippone@uniroma2.it>
+!
+! Note that per Fortran 2008, 8.1.9.2, "within the block following
+! a TYPE IS type guard statement, the associating entity (16.5.5) is not polymorphic"
+!
 
 program testmv2
 
@@ -16,7 +20,7 @@  program testmv2
 
   select type(sm2) 
   type is (bar)
-    call move_alloc(sm2,sm)
+    call move_alloc(sm2,sm) ! { dg-error "must be either both polymorphic or both nonpolymorphic" }
   end select
 
 end program testmv2
--- /dev/null	2011-11-28 07:33:54.995528670 +0100
+++ gcc/gcc/testsuite/gfortran.dg/move_alloc_6.f90	2011-11-26 14:14:27.000000000 +0100
@@ -0,0 +1,80 @@ 
+! { dg-do run }
+!
+! Test move_alloc for polymorphic scalars
+!
+!
+module myalloc
+  implicit none
+
+  type :: base_type
+     integer :: i  =2
+  end type base_type
+
+  type, extends(base_type) :: extended_type
+     integer :: j = 77
+  end type extended_type
+contains
+  subroutine myallocate (a)
+    class(base_type), allocatable, intent(inout) :: a
+    class(base_type), allocatable :: tmp
+
+    allocate (extended_type :: tmp)
+
+    select type(tmp)
+      type is(base_type)
+        call abort ()
+      type is(extended_type)
+        if (tmp%i /= 2 .or. tmp%j /= 77) call abort()
+        tmp%i = 5
+        tmp%j = 88
+    end select
+
+    select type(a)
+      type is(base_type)
+        if (a%i /= -44) call abort()
+        a%i = -99
+      class default
+        call abort ()
+    end select
+
+    call move_alloc (from=tmp, to=a)
+
+    select type(a)
+      type is(extended_type)
+        if (a%i /= 5) call abort()
+        if (a%j /= 88) call abort()
+        a%i = 123
+        a%j = 9498
+      class default
+        call abort ()
+    end select
+
+    if (allocated (tmp)) call abort()
+  end subroutine myallocate
+end module myalloc
+
+program main
+  use myalloc
+  implicit none
+  class(base_type), allocatable :: a
+
+  allocate (a)
+
+  select type(a)
+    type is(base_type)
+      if (a%i /= 2) call abort()
+      a%i = -44
+    class default
+      call abort ()
+  end select
+
+  call myallocate (a)
+
+  select type(a)
+    type is(extended_type)
+      if (a%i /= 123) call abort()
+      if (a%j /= 9498) call abort()
+    class default
+      call abort ()
+  end select
+end program main
--- /dev/null	2011-11-28 07:33:54.995528670 +0100
+++ gcc/gcc/testsuite/gfortran.dg/move_alloc_7.f90	2011-11-28 10:50:46.000000000 +0100
@@ -0,0 +1,15 @@ 
+! { dg-do compile }
+!
+! Check that move alloc handles different, type compatible
+! declared types
+!
+type t
+end type t
+type, extends(t) :: t2
+end type t2
+
+class(t), allocatable :: x
+class(t2), allocatable :: y
+allocate(y)
+call move_alloc (y, x)
+end