[Patch, Fortran, OOP] PR 64209: runtime segfault with CLASS(*), INTENT(OUT) dummy argument

[Patch, Fortran, OOP] PR 64209: runtime segfault with CLASS(*), INTENT(OUT) dummy argument

[Janus Weil]

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

Hi all,

the attached patch fixes a wrong-code issue with unlimited poylmorphic
INTENT(OUT) arguments.

We default-initialize all polymorphic INTENT(OUT) arguments via the
_def_init component of the vtable. The problem is that the intrinsic
types don't have a default initialization. Therefore their _def_init
is NULL and we simply failed to check for that condition. That's what
the patch does. It regtests cleanly on x86_64-unknown-linux-gnu.

Ok for trunk?

Cheers,
Janus



2014-12-19  Janus Weil  <janus@gcc.gnu.org>

    PR fortran/64209
    * trans-expr.c (gfc_trans_class_array_init_assign): Check if _def_init
    component is non-NULL.
    (gfc_trans_class_init_assign): Ditto.

2014-12-19  Janus Weil  <janus@gcc.gnu.org>

    PR fortran/64209
    * gfortran.dg/unlimited_polymorphic_19.f90: New.

[-- Attachment #2: pr64209.diff --]
[-- Type: text/plain, Size: 1807 bytes --]

Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c	(Revision 218896)
+++ gcc/fortran/trans-expr.c	(Arbeitskopie)
@@ -912,7 +912,8 @@ gfc_trans_class_array_init_assign (gfc_expr *rhs,
   gfc_actual_arglist *actual;
   gfc_expr *ppc;
   gfc_code *ppc_code;
-  tree res;
+  tree res, cond;
+  gfc_se src;
 
   actual = gfc_get_actual_arglist ();
   actual->expr = gfc_copy_expr (rhs);
@@ -932,6 +933,16 @@ gfc_trans_class_array_init_assign (gfc_expr *rhs,
      of arrays in gfc_trans_call.  */
   res = gfc_trans_call (ppc_code, false, NULL, NULL, false);
   gfc_free_statements (ppc_code);
+
+  gfc_init_se (&src, NULL);
+  gfc_conv_expr (&src, rhs);
+  src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
+  cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+			  src.expr, fold_convert (TREE_TYPE (src.expr),
+						  null_pointer_node));
+  res = build3_loc (input_location, COND_EXPR, TREE_TYPE (res), cond, res,
+		    build_empty_stmt (input_location));
+
   return res;
 }
 
@@ -943,7 +954,7 @@ tree
 gfc_trans_class_init_assign (gfc_code *code)
 {
   stmtblock_t block;
-  tree tmp;
+  tree tmp, cond;
   gfc_se dst,src,memsz;
   gfc_expr *lhs, *rhs, *sz;
 
@@ -980,6 +991,12 @@ gfc_trans_class_init_assign (gfc_code *code)
       src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
 
       tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
+
+      cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+			      src.expr, fold_convert (TREE_TYPE (src.expr),
+						      null_pointer_node));
+      tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond, tmp,
+			build_empty_stmt (input_location));
     }
 
   if (code->expr1->symtree->n.sym->attr.optional

[-- Attachment #3: unlimited_polymorphic_19.f90 --]
[-- Type: text/x-fortran, Size: 1281 bytes --]

! { dg-do run }
!
! PR 64209: [OOP] runtime segfault with CLASS(*), INTENT(OUT) dummy argument
!
! Contributed by Miha Polajnar <polajnar.miha@gmail.com>

MODULE m
  IMPLICIT NONE
  TYPE :: t
    CLASS(*), ALLOCATABLE :: x(:)
  CONTAINS
    PROCEDURE :: copy
  END TYPE t
  INTERFACE 
    PURE SUBROUTINE copy_proc_intr(a,b)
      CLASS(*), INTENT(IN) :: a
      CLASS(*), INTENT(OUT) :: b
    END SUBROUTINE copy_proc_intr
  END INTERFACE 
CONTAINS
  SUBROUTINE copy(self,cp,a)
    CLASS(t), INTENT(IN) :: self
    PROCEDURE(copy_proc_intr) :: cp
    CLASS(*), INTENT(OUT) :: a(:)
    INTEGER :: i
    IF( .not.same_type_as(self%x(1),a(1)) ) STOP -1
    DO i = 1, size(self%x)
      CALL cp(self%x(i),a(i))
    END DO
  END SUBROUTINE copy
END MODULE m

PROGRAM main
  USE m
  IMPLICIT NONE
  INTEGER, PARAMETER :: n = 3, x(n) = [ 1, 2, 3 ] 
  INTEGER :: copy_x(n)
  TYPE(t) :: test
  ALLOCATE(test%x(n),SOURCE=x)
  CALL test%copy(copy_int,copy_x)
!   PRINT '(*(I0,:2X))', copy_x
CONTAINS
  PURE SUBROUTINE copy_int(a,b)
    CLASS(*), INTENT(IN) :: a
    CLASS(*), INTENT(OUT) :: b
    SELECT TYPE(a); TYPE IS(integer) 
    SELECT TYPE(b); TYPE IS(integer)
      b = a
    END SELECT; END SELECT
  END SUBROUTINE copy_int 
END PROGRAM main

! { dg-final { cleanup-modules "m" } }

Re: [Patch, Fortran, OOP] PR 64209: runtime segfault with CLASS(*), INTENT(OUT) dummy argument

[Tobias Burnus]

Janus Weil wrote:
> the attached patch fixes a wrong-code issue with unlimited poylmorphic
> INTENT(OUT) arguments.
>
> We default-initialize all polymorphic INTENT(OUT) arguments via the
> _def_init component of the vtable. The problem is that the intrinsic
> types don't have a default initialization. Therefore their _def_init
> is NULL and we simply failed to check for that condition. That's what
> the patch does. It regtests cleanly on x86_64-unknown-linux-gnu.
> 
> Ok for trunk?

As you write yourself, the issue can only occur for CLASS(*). Hence,
please apply this only for UNLIMITED_POLY() to avoid unneccessary code side
increase and performance decrease.

OK this this change. Thanks for the patch!

Tobias

Re: [Patch, Fortran, OOP] PR 64209: runtime segfault with CLASS(*), INTENT(OUT) dummy argument

[Janus Weil]

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

2014-12-19 14:48 GMT+01:00 Tobias Burnus <tobias.burnus@physik.fu-berlin.de>:
> As you write yourself, the issue can only occur for CLASS(*). Hence,
> please apply this only for UNLIMITED_POLY() to avoid unneccessary code side
> increase and performance decrease.

Good point, thanks for reviewing. An updated patch is attached. Will
commit after regtesting.

Cheers,
Janus

[-- Attachment #2: pr64209_v2.diff --]
[-- Type: text/plain, Size: 1586 bytes --]

Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c	(Revision 218957)
+++ gcc/fortran/trans-expr.c	(Arbeitskopie)
@@ -932,6 +932,21 @@ gfc_trans_class_array_init_assign (gfc_expr *rhs,
      of arrays in gfc_trans_call.  */
   res = gfc_trans_call (ppc_code, false, NULL, NULL, false);
   gfc_free_statements (ppc_code);
+
+  if (UNLIMITED_POLY(obj))
+    {
+      /* Check if rhs is non-NULL. */
+      gfc_se src;
+      gfc_init_se (&src, NULL);
+      gfc_conv_expr (&src, rhs);
+      src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
+      tree cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+				   src.expr, fold_convert (TREE_TYPE (src.expr),
+							   null_pointer_node));
+      res = build3_loc (input_location, COND_EXPR, TREE_TYPE (res), cond, res,
+			build_empty_stmt (input_location));
+    }
+
   return res;
 }
 
@@ -980,6 +995,17 @@ gfc_trans_class_init_assign (gfc_code *code)
       src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
 
       tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
+
+      if (UNLIMITED_POLY(code->expr1))
+	{
+	  /* Check if _def_init is non-NULL. */
+	  tree cond = fold_build2_loc (input_location, NE_EXPR,
+				       boolean_type_node, src.expr,
+				       fold_convert (TREE_TYPE (src.expr),
+						     null_pointer_node));
+	  tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond,
+			    tmp, build_empty_stmt (input_location));
+	}
     }
 
   if (code->expr1->symtree->n.sym->attr.optional

Re: [Patch, Fortran, OOP] PR 64209: runtime segfault with CLASS(*), INTENT(OUT) dummy argument

[Janus Weil]

Committed as r218968.

Cheers,
Janus



2014-12-19 18:24 GMT+01:00 Janus Weil <janus@gcc.gnu.org>:
> 2014-12-19 14:48 GMT+01:00 Tobias Burnus <tobias.burnus@physik.fu-berlin.de>:
>> As you write yourself, the issue can only occur for CLASS(*). Hence,
>> please apply this only for UNLIMITED_POLY() to avoid unneccessary code side
>> increase and performance decrease.
>
> Good point, thanks for reviewing. An updated patch is attached. Will
> commit after regtesting.
>
> Cheers,
> Janus