Patchwork [Fortran] PR57697 - Fix an issue with defined assignment

login
register
mail settings
Submitter Tobias Burnus
Date Sept. 10, 2013, 6:11 a.m.
Message ID <522EB7F5.10606@net-b.de>
Download mbox | patch
Permalink /patch/273766/
State New
Headers show

Comments

Tobias Burnus - Sept. 10, 2013, 6:11 a.m.
Dear all,

in Fortran 2003, it can happen that for an intrinisic assignment of a 
derived type, the component fits to a defined assignment; in that case, 
the latter is invoked. gfortran implements this since GCC 4.8 (December).

However, it turned out that the current algorithm doesn't work if the 
LHS is allocatable and unallocated as it generated the following code:

       if (_F.DA0 != 0B) goto L.1;
       _F.DA0 = (struct parent *) __builtin_malloc (4);
       L.1:;
       *_F.DA0 = *left;
       if (left != 0B) goto L.3;
       left = (struct parent *) __builtin_malloc (4);
       L.3:;
       *left = right;

The line "*_F.DA0 = *left;" will fail due to the NULL-pointer deref.


With the attached patch, one generates the code:

       if (left != 0B)
         {
           if (_F.DA0 != 0B) goto L.2;
           _F.DA0 = (struct parent *) __builtin_malloc (4);
           L.2:;
           *_F.DA0 = *left;
         }
       L.1:;
       if (left != 0B) goto L.4;
       left = (struct parent *) __builtin_malloc (4);
       L.4:;
       *left = right;
       if (_F.DA0 == 0B)
           _F.DA0 = left;  // Note: That's a pointer assignment


Built and regtested on x86-64-gnu-linux. OK for the trunk? What about 
GCC 4.8? It's not a true regression (as defined assignments are new), 
but it causes segfaults with code which worked before GCC 4.8 [Dec 2012] 
(albeit with intrinsic instead of defined assignment).

Tobias

PS: One code which exposes the problem is a test case shipping with 
ForTrilinos.
Thomas Koenig - Sept. 15, 2013, 9:41 a.m.
Hi Tobias,

the patch is OK, also for 4.8.  Thanks a lot for fixing this.

Just a couple of nits:

- You may want to remove the output from the test case.

- The two consecutive ifs in

> 
>       if (left != 0B)
>         {
>           if (_F.DA0 != 0B) goto L.2;
>           _F.DA0 = (struct parent *) __builtin_malloc (4);
>           L.2:;
>           *_F.DA0 = *left;
>         }
>       L.1:;
>       if (left != 0B) goto L.4;

are a little bit inelegant.  It is not really important, because
they will be merged on optimization, but if you find an easy
way to do this in the FE code, you might want to consider doing
so.  I would advise against spending a lot of work on this, though :-)

	Thomas
Thomas Koenig - Sept. 16, 2013, 6:23 a.m.
Hi Tobias,

> As testing showed, it didn't fix the real-world code: ForTrilinos's
> ForTrilinos_ADT_3D_Burgers_6th_Pade did still fail as it has:
> 
>          *_F.DA65 = matrix_diff_x (&parm.621);
>        _F.DA66 = ax->epetra_rowmatrix.universal; // Deref of "ax"!
> 

> Build and regtested on x86-64-gnu-linux.
> OK?

The patch is OK, also for 4.8.  Please add a test case which also
checks for the ForTrilinos failure.

	Thomas
Tobias Burnus - Sept. 16, 2013, 6:45 a.m.
Thomas Koenig wrote:
>> Build and regtested on x86-64-gnu-linux.
>> OK?
> The patch is OK, also for 4.8.  Please add a test case which also
> checks for the ForTrilinos failure.

Thanks for the review. I have now committed the current patch as Rev. 
202609.

I will later try to create a test case, which fails before 202609 and 
works with it. Additionally, I will work on the 4.8 backport. 
(Unfortunately, it does not simply apply on gcc-4_8-branch has the 
gfc_build_intrinsic_call has slightly changed.)

Tobias

Patch

2013-09-10  Tobias Burnus  <burnus@net-b.de>

	PR fortran/57697
	* resolve.c (generate_component_assignments): Handle unallocated
	LHS with defined assignment of components.

2013-09-10  Tobias Burnus  <burnus@net-b.de>

	PR fortran/57697
	* gfortran.dg/defined_assignment_10.f90: New.

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 2929679..f2892e2 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -9546,6 +9546,21 @@  generate_component_assignments (gfc_code **code, gfc_namespace *ns)
 		  temp_code = build_assignment (EXEC_ASSIGN,
 						t1, (*code)->expr1,
 				NULL, NULL, (*code)->loc);
+
+		  /* For allocatable LHS, check whether it is allocated.  */
+		  if (gfc_expr_attr((*code)->expr1).allocatable)
+		    {
+		      gfc_code *block;
+		      block = gfc_get_code (EXEC_IF);
+		      block->block = gfc_get_code (EXEC_IF);
+		      block->block->expr1
+			  = gfc_build_intrinsic_call (ns,
+				    GFC_ISYM_ASSOCIATED, "allocated",
+				    (*code)->loc, 2,
+				    gfc_copy_expr ((*code)->expr1), NULL);
+		      block->block->next = temp_code;
+		      temp_code = block;
+		    }
 		  add_code_to_chain (&temp_code, &tmp_head, &tmp_tail);
 		}
 
@@ -9554,6 +9569,31 @@  generate_component_assignments (gfc_code **code, gfc_namespace *ns)
 	      gfc_free_expr (this_code->ext.actual->expr);
 	      this_code->ext.actual->expr = gfc_copy_expr (t1);
 	      add_comp_ref (this_code->ext.actual->expr, comp1);
+
+	      /* If the LHS is not allocated, we pointer-assign the LHS address
+		 to the temporary - after the LHS has been allocated.  */
+	      if (gfc_expr_attr((*code)->expr1).allocatable)
+		{
+		  gfc_code *block;
+                  gfc_expr *cond;
+                  cond = gfc_get_expr ();
+		  cond->ts.type = BT_LOGICAL;
+		  cond->ts.kind = gfc_default_logical_kind;
+		  cond->expr_type = EXPR_OP;
+		  cond->where = (*code)->loc;
+		  cond->value.op.op = INTRINSIC_NOT;
+		  cond->value.op.op1 = gfc_build_intrinsic_call (ns,
+					  GFC_ISYM_ASSOCIATED, "allocated",
+					  (*code)->loc, 2,
+					  gfc_copy_expr (t1), NULL);
+		  block = gfc_get_code (EXEC_IF);
+		  block->block = gfc_get_code (EXEC_IF);
+		  block->block->expr1 = cond;
+		  block->block->next = build_assignment (EXEC_POINTER_ASSIGN,
+					t1, (*code)->expr1,
+					NULL, NULL, (*code)->loc);
+		  add_code_to_chain (&block, &head, &tail);
+		}
 	    }
 	  }
       else if (this_code->op == EXEC_ASSIGN && !this_code->next)
diff --git a/gcc/testsuite/gfortran.dg/defined_assignment_10.f90 b/gcc/testsuite/gfortran.dg/defined_assignment_10.f90
new file mode 100644
index 0000000..c802118
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/defined_assignment_10.f90
@@ -0,0 +1,35 @@ 
+! { dg-do run }
+!
+! PR fortran/57697
+!
+! Further test of typebound defined assignment
+!
+module m0
+  implicit none
+  type component
+    integer :: i = 42
+  contains
+    procedure :: assign0
+    generic :: assignment(=) => assign0
+  end type
+  type parent
+    type(component) :: foo
+  end type
+contains
+  elemental subroutine assign0(lhs,rhs)
+    class(component), intent(INout) :: lhs
+    class(component), intent(in) :: rhs
+    lhs%i = 20
+  end subroutine
+end module
+
+program main
+  use m0
+  implicit none
+  type(parent), allocatable :: left
+  type(parent) :: right
+  print *, right%foo
+  left = right
+  print *, left%foo
+  if (left%foo%i /= 20) call abort()
+end