Hi all!
Proposed patch to solve problems with memory handling with allocatable
intent(out) arrays with bind(c).
The patch also seems to affect PR92189.
Patch tested only on x86_64-pc-linux-gnu.
The code currently generated tries to deallocate the artificial cfi.n
pointer before it is associated with the allocatable array.
Since the cfi.n pointer is uninitialized in some infrequent situations
(using -static-libgfortran seems to do the trick) the pointer seems to
contain garbage and a segmentation fault is generated.
Since the deallocation is done prior to the cfi.n pointer being
associated with the allocatable array the memory is never freed and the
array will be passed still allocated and consequently attempts to
allocate it will fail.
A diff of only the main code changes without spacing changes is attached
to facilitate human reviewing.
Thank you very much.
Best regards,
José Rui
2020-2-21 José Rui Faustino de Sousa <jrfso...@gmail.com>
PR fortran/92621
* trans-expr.c (gfc_conv_gfc_desc_to_cfi_desc): Add code to deallocate
allocatable intent(out) dummy array arguments, slightly rearrange code.
(gfc_conv_procedure_call): Split if conditional in two branches removes
unnecessary checks for is_bind_c and obsolete comments from second
branch.
2020-02-21 José Rui Faustino de Sousa <jrfso...@gmail.com>
PR fortran/92621
* bind-c-intent-out.f90: Changes dg-do compile to run, changes regex to
match the changes in code generation.
2020-02-21 José Rui Faustino de Sousa <jrfso...@gmail.com>
PR fortran/92621
* PR92621.f90: New test.
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 5825a4b..70dd9be 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -5248,6 +5248,39 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse,
gfc_expr *e, gfc_symbol *fsym)
if (POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
parmse->expr = build_fold_indirect_ref_loc (input_location,
parmse->expr);
+ }
+ else
+ gfc_conv_expr (parmse, e);
+
+ if (POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
+ parmse->expr = build_fold_indirect_ref_loc (input_location,
+ parmse->expr);
+
+ /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
+ allocated on entry, it must be deallocated. */
+ if (fsym && fsym->attr.allocatable
+ && fsym->attr.intent == INTENT_OUT)
+ {
+ tmp = parmse->expr;
+
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
+ tmp = gfc_conv_descriptor_data_get (tmp);
+ tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
+ NULL_TREE, NULL_TREE, true,
+ e,
+ GFC_CAF_COARRAY_NOCOARRAY);
+ if (fsym->attr.optional
+ && e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->attr.optional)
+ tmp = fold_build3_loc (input_location, COND_EXPR,
+ void_type_node,
+ gfc_conv_expr_present (e->symtree->n.sym),
+ tmp, build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&parmse->pre, tmp);
+ }
+
+ if (e->rank != 0)
+ {
bool is_artificial = (INDIRECT_REF_P (parmse->expr)
? DECL_ARTIFICIAL (TREE_OPERAND (parmse->expr, 0))
: DECL_ARTIFICIAL (parmse->expr));
@@ -5293,16 +5326,8 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse,
gfc_expr *e, gfc_symbol *fsym)
}
}
else
- {
- gfc_conv_expr (parmse, e);
-
- if (POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
- parmse->expr = build_fold_indirect_ref_loc (input_location,
- parmse->expr);
-
- parmse->expr = gfc_conv_scalar_to_descriptor (parmse,
- parmse->expr, attr);
- }
+ parmse->expr = gfc_conv_scalar_to_descriptor (parmse,
+ parmse->expr, attr);
/* Set the CFI attribute field through a temporary value for the
gfc attribute. */
@@ -6170,113 +6195,113 @@ gfc_conv_procedure_call (gfc_se * se,
gfc_symbol * sym,
/* Implement F2018, C.12.6.1: paragraph (2). */
gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
- else if (e->expr_type == EXPR_VARIABLE
- && is_subref_array (e)
- && !(fsym && fsym->attr.pointer))
- /* The actual argument is a component reference to an
- array of derived types. In this case, the argument
- is converted to a temporary, which is passed and then
- written back after the procedure call. */
- gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
- fsym ? fsym->attr.intent : INTENT_INOUT,
- fsym && fsym->attr.pointer);
-
- else if (gfc_is_class_array_ref (e, NULL)
- && fsym && fsym->ts.type == BT_DERIVED)
- /* The actual argument is a component reference to an
- array of derived types. In this case, the argument
- is converted to a temporary, which is passed and then
- written back after the procedure call.
- OOP-TODO: Insert code so that if the dynamic type is
- the same as the declared type, copy-in/copy-out does
- not occur. */
- gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
- fsym->attr.intent,
- fsym->attr.pointer);
-
- else if (gfc_is_class_array_function (e)
- && fsym && fsym->ts.type == BT_DERIVED)
- /* See previous comment. For function actual argument,
- the write out is not needed so the intent is set as
- intent in. */
- {
- e->must_finalize = 1;
- gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
- INTENT_IN, fsym->attr.pointer);
- }
- else if (fsym && fsym->attr.contiguous
- && !gfc_is_simply_contiguous (e, false, true)
- && gfc_expr_is_variable (e))
- {
- gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
- fsym->attr.intent,
- fsym->attr.pointer);
- }
else
- gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym,
- sym->name, NULL);
-
- /* Unallocated allocatable arrays and unassociated pointer arrays
- need their dtype setting if they are argument associated with
- assumed rank dummies. */
- if (!sym->attr.is_bind_c && e && fsym && fsym->as
- && fsym->as->type == AS_ASSUMED_RANK)
{
- if (gfc_expr_attr (e).pointer
- || gfc_expr_attr (e).allocatable)
- set_dtype_for_unallocated (&parmse, e);
- else if (e->expr_type == EXPR_VARIABLE
- && e->symtree->n.sym->attr.dummy
- && e->symtree->n.sym->as
- && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE)
+ if (e->expr_type == EXPR_VARIABLE
+ && is_subref_array (e)
+ && !(fsym && fsym->attr.pointer))
+ /* The actual argument is a component reference to an
+ array of derived types. In this case, the argument
+ is converted to a temporary, which is passed and then
+ written back after the procedure call. */
+ gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
+ fsym ? fsym->attr.intent :
INTENT_INOUT,
+ fsym && fsym->attr.pointer);
+
+ else if (gfc_is_class_array_ref (e, NULL)
+ && fsym && fsym->ts.type == BT_DERIVED)
+ /* The actual argument is a component reference to an
+ array of derived types. In this case, the argument
+ is converted to a temporary, which is passed and then
+ written back after the procedure call.
+ OOP-TODO: Insert code so that if the dynamic type is
+ the same as the declared type, copy-in/copy-out does
+ not occur. */
+ gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
+ fsym->attr.intent,
+ fsym->attr.pointer);
+
+ else if (gfc_is_class_array_function (e)
+ && fsym && fsym->ts.type == BT_DERIVED)
+ /* See previous comment. For function actual argument,
+ the write out is not needed so the intent is set as
+ intent in. */
{
- tree minus_one;
- tmp = build_fold_indirect_ref_loc (input_location,
- parmse.expr);
- minus_one = build_int_cst (gfc_array_index_type, -1);
- gfc_conv_descriptor_ubound_set (&parmse.pre, tmp,
- gfc_rank_cst[e->rank - 1],
- minus_one);
- }
- }
+ e->must_finalize = 1;
+ gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
+ INTENT_IN, fsym->attr.pointer);
+ }
+ else if (fsym && fsym->attr.contiguous
+ && !gfc_is_simply_contiguous (e, false, true)
+ && gfc_expr_is_variable (e))
+ {
+ gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
+ fsym->attr.intent,
+ fsym->attr.pointer);
+ }
+ else
+ gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym,
+ sym->name, NULL);
+
+ /* Unallocated allocatable arrays and unassociated pointer
arrays
+ need their dtype setting if they are argument associated
with
+ assumed rank dummies. */
+ if (e && fsym && fsym->as
+ && fsym->as->type == AS_ASSUMED_RANK)
+ {
+ if (gfc_expr_attr (e).pointer
+ || gfc_expr_attr (e).allocatable)
+ set_dtype_for_unallocated (&parmse, e);
+ else if (e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->attr.dummy
+ && e->symtree->n.sym->as
+ && e->symtree->n.sym->as->type ==
AS_ASSUMED_SIZE)
+ {
+ tree minus_one;
+ tmp = build_fold_indirect_ref_loc (input_location,
+ parmse.expr);
+ minus_one = build_int_cst (gfc_array_index_type, -1);
+ gfc_conv_descriptor_ubound_set (&parmse.pre, tmp,
+ gfc_rank_cst[e->rank
- 1],
+ minus_one);
+ }
+ }
- /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
- allocated on entry, it must be deallocated. */
- if (fsym && fsym->attr.allocatable
- && fsym->attr.intent == INTENT_OUT)
- {
- if (fsym->ts.type == BT_DERIVED
- && fsym->ts.u.derived->attr.alloc_comp)
- {
- // deallocate the components first
- tmp = gfc_deallocate_alloc_comp (fsym->ts.u.derived,
- parmse.expr, e->rank);
- if (tmp != NULL_TREE)
+ /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
+ allocated on entry, it must be deallocated. */
+ if (fsym && fsym->attr.allocatable
+ && fsym->attr.intent == INTENT_OUT)
+ {
+ if (fsym->ts.type == BT_DERIVED
+ && fsym->ts.u.derived->attr.alloc_comp)
+ {
+ // deallocate the components first
+ tmp = gfc_deallocate_alloc_comp (fsym->ts.u.derived,
+ parmse.expr,
e->rank);
+ if (tmp != NULL_TREE)
+ gfc_add_expr_to_block (&se->pre, tmp);
+ }
+
+ tmp = parmse.expr;
+
+ if (TREE_TYPE(tmp) != pvoid_type_node)
+ tmp = build_fold_indirect_ref_loc (input_location,
+ parmse.expr);
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
+ tmp = gfc_conv_descriptor_data_get (tmp);
+ tmp = gfc_deallocate_with_status (tmp, NULL_TREE,
NULL_TREE,
+ NULL_TREE, NULL_TREE,
true,
+ e,
+
GFC_CAF_COARRAY_NOCOARRAY);
+ if (fsym->attr.optional
+ && e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->attr.optional)
+ tmp = fold_build3_loc (input_location, COND_EXPR,
+ void_type_node,
+ gfc_conv_expr_present
(e->symtree->n.sym),
+ tmp, build_empty_stmt
(input_location));
gfc_add_expr_to_block (&se->pre, tmp);
- }
-
- tmp = parmse.expr;
- /* With bind(C), the actual argument is replaced by a bind-C
- descriptor; in this case, the data component arrives here,
- which shall not be dereferenced, but still freed and
- nullified. */
- if (TREE_TYPE(tmp) != pvoid_type_node)
- tmp = build_fold_indirect_ref_loc (input_location,
- parmse.expr);
- if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
- tmp = gfc_conv_descriptor_data_get (tmp);
- tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
- NULL_TREE, NULL_TREE, true,
- e,
- GFC_CAF_COARRAY_NOCOARRAY);
- if (fsym->attr.optional
- && e->expr_type == EXPR_VARIABLE
- && e->symtree->n.sym->attr.optional)
- tmp = fold_build3_loc (input_location, COND_EXPR,
- void_type_node,
- gfc_conv_expr_present (e->symtree->n.sym),
- tmp, build_empty_stmt (input_location));
- gfc_add_expr_to_block (&se->pre, tmp);
+ }
}
}
}
diff --git a/gcc/testsuite/gfortran.dg/PR92621.f90
b/gcc/testsuite/gfortran.dg/PR92621.f90
new file mode 100644
index 0000000..9ca2e70
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/PR92621.f90
@@ -0,0 +1,41 @@
+! { dg-do run }
+! { dg-options "-static-libgfortran" }
+!
+! PR fortran/92621
+!
+
+subroutine hello(val) bind(c)
+ use, intrinsic :: iso_c_binding, only: c_int
+
+ implicit none
+
+ integer(kind=c_int), allocatable, intent(out) :: val(:)
+
+ allocate(val(1))
+ val = 2
+ return
+end subroutine hello
+
+program alloc_p
+
+ use, intrinsic :: iso_c_binding, only: c_int
+
+ implicit none
+
+ interface
+ subroutine hello(val) bind(c)
+ import :: c_int
+ implicit none
+ integer(kind=c_int), allocatable, intent(out) :: val(:)
+ end subroutine hello
+ end interface
+
+ integer(kind=c_int), allocatable :: a(:)
+
+ allocate(a(1))
+ a = 1
+ call hello(a)
+ stop
+
+end program alloc_p
+
diff --git a/gcc/testsuite/gfortran.dg/bind-c-intent-out.f90
b/gcc/testsuite/gfortran.dg/bind-c-intent-out.f90
index 39822c0..470afb8 100644
--- a/gcc/testsuite/gfortran.dg/bind-c-intent-out.f90
+++ b/gcc/testsuite/gfortran.dg/bind-c-intent-out.f90
@@ -1,4 +1,4 @@
-! { dg-do compile }
+! { dg-do run }
! { dg-options "-fdump-tree-original" }
!
! PR fortran/91863
@@ -38,5 +38,7 @@ end program p
! As cfi (i.e. the descriptor itself) is allocated in libgomp, it has
to be freed after the call.
! { dg-final { scan-tree-dump-times "__builtin_free" 2 "original" } }
-! { dg-final { scan-tree-dump-times "__builtin_free
\\(cfi\\.\[0-9\]+\\);" 2 "original" } }
-! { dg-final { scan-tree-dump-times "cfi\\.\[0-9\]+ = 0B;" 2 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_free \\(\\(void \\*\\)
a\\.data\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_free
\\(cfi\\.\[0-9\]+\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "\\(integer\\(kind\\=4\\)\\\[0:\\\]
\\* restrict\\) a\\.data = 0B;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "cfi\\.\[0-9\]+ = 0B;" 1 "original" } }
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 5825a4b..70dd9be 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -5248,6 +5248,39 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
if (POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
parmse->expr = build_fold_indirect_ref_loc (input_location,
parmse->expr);
+ }
+ else
+ gfc_conv_expr (parmse, e);
+
+ if (POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
+ parmse->expr = build_fold_indirect_ref_loc (input_location,
+ parmse->expr);
+
+ /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
+ allocated on entry, it must be deallocated. */
+ if (fsym && fsym->attr.allocatable
+ && fsym->attr.intent == INTENT_OUT)
+ {
+ tmp = parmse->expr;
+
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
+ tmp = gfc_conv_descriptor_data_get (tmp);
+ tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
+ NULL_TREE, NULL_TREE, true,
+ e,
+ GFC_CAF_COARRAY_NOCOARRAY);
+ if (fsym->attr.optional
+ && e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->attr.optional)
+ tmp = fold_build3_loc (input_location, COND_EXPR,
+ void_type_node,
+ gfc_conv_expr_present (e->symtree->n.sym),
+ tmp, build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&parmse->pre, tmp);
+ }
+
+ if (e->rank != 0)
+ {
bool is_artificial = (INDIRECT_REF_P (parmse->expr)
? DECL_ARTIFICIAL (TREE_OPERAND (parmse->expr, 0))
: DECL_ARTIFICIAL (parmse->expr));
@@ -5293,16 +5326,8 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
}
}
else
- {
- gfc_conv_expr (parmse, e);
-
- if (POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
- parmse->expr = build_fold_indirect_ref_loc (input_location,
- parmse->expr);
-
parmse->expr = gfc_conv_scalar_to_descriptor (parmse,
parmse->expr, attr);
- }
/* Set the CFI attribute field through a temporary value for the
gfc attribute. */
@@ -6170,7 +6195,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
/* Implement F2018, C.12.6.1: paragraph (2). */
gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
- else if (e->expr_type == EXPR_VARIABLE
+ else
+ {
+ if (e->expr_type == EXPR_VARIABLE
&& is_subref_array (e)
&& !(fsym && fsym->attr.pointer))
/* The actual argument is a component reference to an
@@ -6219,7 +6246,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
/* Unallocated allocatable arrays and unassociated pointer arrays
need their dtype setting if they are argument associated with
assumed rank dummies. */
- if (!sym->attr.is_bind_c && e && fsym && fsym->as
+ if (e && fsym && fsym->as
&& fsym->as->type == AS_ASSUMED_RANK)
{
if (gfc_expr_attr (e).pointer
@@ -6256,10 +6283,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
}
tmp = parmse.expr;
- /* With bind(C), the actual argument is replaced by a bind-C
- descriptor; in this case, the data component arrives here,
- which shall not be dereferenced, but still freed and
- nullified. */
+
if (TREE_TYPE(tmp) != pvoid_type_node)
tmp = build_fold_indirect_ref_loc (input_location,
parmse.expr);
@@ -6280,6 +6304,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
}
}
}
+ }
/* The case with fsym->attr.optional is that of a user subroutine
with an interface indicating an optional argument. When we call
