Prevent malicious descriptor stacking for scalar components.
gcc/fortran/ChangeLog: PR fortran/103790 * trans-array.cc (structure_alloc_comps): Prevent descriptor stacking for non-array data; do not broadcast caf-tokens. * trans-intrinsic.cc (conv_co_collective): Prevent generation of unused descriptor. gcc/testsuite/ChangeLog: PR fortran/103790 * gfortran.dg/coarray_collectives_18.f90: New test.
This commit is contained in:
Andre Vehreschild
parent
4d2efec9f2
commit
c9c48ab7ba
|
|
@ -9102,6 +9102,10 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
|
|||
continue;
|
||||
}
|
||||
|
||||
/* Do not broadcast a caf_token. These are local to the image. */
|
||||
if (attr->caf_token)
|
||||
continue;
|
||||
|
||||
add_when_allocated = NULL_TREE;
|
||||
if (cmp_has_alloc_comps
|
||||
&& !c->attr.pointer && !c->attr.proc_pointer)
|
||||
|
|
@ -9134,10 +9138,13 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
|
|||
if (attr->dimension)
|
||||
{
|
||||
tmp = gfc_get_element_type (TREE_TYPE (comp));
|
||||
ubound = gfc_full_array_size (&tmpblock, comp,
|
||||
c->ts.type == BT_CLASS
|
||||
? CLASS_DATA (c)->as->rank
|
||||
: c->as->rank);
|
||||
if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
|
||||
ubound = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (comp));
|
||||
else
|
||||
ubound = gfc_full_array_size (&tmpblock, comp,
|
||||
c->ts.type == BT_CLASS
|
||||
? CLASS_DATA (c)->as->rank
|
||||
: c->as->rank);
|
||||
}
|
||||
else
|
||||
{
|
||||
|
|
@ -9145,26 +9152,36 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
|
|||
ubound = build_int_cst (gfc_array_index_type, 1);
|
||||
}
|
||||
|
||||
cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node,
|
||||
&ubound, 1,
|
||||
GFC_ARRAY_ALLOCATABLE, false);
|
||||
/* Treat strings like arrays. Or the other way around, do not
|
||||
* generate an additional array layer for scalar components. */
|
||||
if (attr->dimension || c->ts.type == BT_CHARACTER)
|
||||
{
|
||||
cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node,
|
||||
&ubound, 1,
|
||||
GFC_ARRAY_ALLOCATABLE, false);
|
||||
|
||||
cdesc = gfc_create_var (cdesc, "cdesc");
|
||||
DECL_ARTIFICIAL (cdesc) = 1;
|
||||
cdesc = gfc_create_var (cdesc, "cdesc");
|
||||
DECL_ARTIFICIAL (cdesc) = 1;
|
||||
|
||||
gfc_add_modify (&tmpblock, gfc_conv_descriptor_dtype (cdesc),
|
||||
gfc_get_dtype_rank_type (1, tmp));
|
||||
gfc_conv_descriptor_lbound_set (&tmpblock, cdesc,
|
||||
gfc_index_zero_node,
|
||||
gfc_index_one_node);
|
||||
gfc_conv_descriptor_stride_set (&tmpblock, cdesc,
|
||||
gfc_index_zero_node,
|
||||
gfc_index_one_node);
|
||||
gfc_conv_descriptor_ubound_set (&tmpblock, cdesc,
|
||||
gfc_index_zero_node, ubound);
|
||||
gfc_add_modify (&tmpblock, gfc_conv_descriptor_dtype (cdesc),
|
||||
gfc_get_dtype_rank_type (1, tmp));
|
||||
gfc_conv_descriptor_lbound_set (&tmpblock, cdesc,
|
||||
gfc_index_zero_node,
|
||||
gfc_index_one_node);
|
||||
gfc_conv_descriptor_stride_set (&tmpblock, cdesc,
|
||||
gfc_index_zero_node,
|
||||
gfc_index_one_node);
|
||||
gfc_conv_descriptor_ubound_set (&tmpblock, cdesc,
|
||||
gfc_index_zero_node, ubound);
|
||||
}
|
||||
|
||||
if (attr->dimension)
|
||||
comp = gfc_conv_descriptor_data_get (comp);
|
||||
{
|
||||
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
|
||||
comp = gfc_conv_descriptor_data_get (comp);
|
||||
else
|
||||
comp = gfc_build_addr_expr (NULL_TREE, comp);
|
||||
}
|
||||
else
|
||||
{
|
||||
gfc_se se;
|
||||
|
|
@ -9172,14 +9189,18 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
|
|||
gfc_init_se (&se, NULL);
|
||||
|
||||
comp = gfc_conv_scalar_to_descriptor (&se, comp,
|
||||
c->ts.type == BT_CLASS
|
||||
? CLASS_DATA (c)->attr
|
||||
: c->attr);
|
||||
comp = gfc_build_addr_expr (NULL_TREE, comp);
|
||||
c->ts.type == BT_CLASS
|
||||
? CLASS_DATA (c)->attr
|
||||
: c->attr);
|
||||
if (c->ts.type == BT_CHARACTER)
|
||||
comp = gfc_build_addr_expr (NULL_TREE, comp);
|
||||
gfc_add_block_to_block (&tmpblock, &se.pre);
|
||||
}
|
||||
|
||||
gfc_conv_descriptor_data_set (&tmpblock, cdesc, comp);
|
||||
if (attr->dimension || c->ts.type == BT_CHARACTER)
|
||||
gfc_conv_descriptor_data_set (&tmpblock, cdesc, comp);
|
||||
else
|
||||
cdesc = comp;
|
||||
|
||||
tree fndecl;
|
||||
|
||||
|
|
|
|||
|
|
@ -11212,24 +11212,31 @@ conv_co_collective (gfc_code *code)
|
|||
return gfc_finish_block (&block);
|
||||
}
|
||||
|
||||
gfc_symbol *derived = code->ext.actual->expr->ts.type == BT_DERIVED
|
||||
? code->ext.actual->expr->ts.u.derived : NULL;
|
||||
|
||||
/* Handle the array. */
|
||||
gfc_init_se (&argse, NULL);
|
||||
if (code->ext.actual->expr->rank == 0)
|
||||
if (!derived || !derived->attr.alloc_comp
|
||||
|| code->resolved_isym->id != GFC_ISYM_CO_BROADCAST)
|
||||
{
|
||||
symbol_attribute attr;
|
||||
gfc_clear_attr (&attr);
|
||||
gfc_init_se (&argse, NULL);
|
||||
gfc_conv_expr (&argse, code->ext.actual->expr);
|
||||
gfc_add_block_to_block (&block, &argse.pre);
|
||||
gfc_add_block_to_block (&post_block, &argse.post);
|
||||
array = gfc_conv_scalar_to_descriptor (&argse, argse.expr, attr);
|
||||
array = gfc_build_addr_expr (NULL_TREE, array);
|
||||
}
|
||||
else
|
||||
{
|
||||
argse.want_pointer = 1;
|
||||
gfc_conv_expr_descriptor (&argse, code->ext.actual->expr);
|
||||
array = argse.expr;
|
||||
if (code->ext.actual->expr->rank == 0)
|
||||
{
|
||||
symbol_attribute attr;
|
||||
gfc_clear_attr (&attr);
|
||||
gfc_init_se (&argse, NULL);
|
||||
gfc_conv_expr (&argse, code->ext.actual->expr);
|
||||
gfc_add_block_to_block (&block, &argse.pre);
|
||||
gfc_add_block_to_block (&post_block, &argse.post);
|
||||
array = gfc_conv_scalar_to_descriptor (&argse, argse.expr, attr);
|
||||
array = gfc_build_addr_expr (NULL_TREE, array);
|
||||
}
|
||||
else
|
||||
{
|
||||
argse.want_pointer = 1;
|
||||
gfc_conv_expr_descriptor (&argse, code->ext.actual->expr);
|
||||
array = argse.expr;
|
||||
}
|
||||
}
|
||||
|
||||
gfc_add_block_to_block (&block, &argse.pre);
|
||||
|
|
@ -11290,9 +11297,6 @@ conv_co_collective (gfc_code *code)
|
|||
gcc_unreachable ();
|
||||
}
|
||||
|
||||
gfc_symbol *derived = code->ext.actual->expr->ts.type == BT_DERIVED
|
||||
? code->ext.actual->expr->ts.u.derived : NULL;
|
||||
|
||||
if (derived && derived->attr.alloc_comp
|
||||
&& code->resolved_isym->id == GFC_ISYM_CO_BROADCAST)
|
||||
/* The derived type has the attribute 'alloc_comp'. */
|
||||
|
|
|
|||
|
|
@ -0,0 +1,37 @@
|
|||
! { dg-do compile }
|
||||
! { dg-additional-options "-fdump-tree-original -fcoarray=lib" }
|
||||
!
|
||||
! PR 103970
|
||||
! Test case inspired by code submitted by Damian Rousson
|
||||
|
||||
program main
|
||||
|
||||
implicit none
|
||||
|
||||
type foo_t
|
||||
integer i
|
||||
integer, allocatable :: j
|
||||
end type
|
||||
|
||||
type(foo_t) foo
|
||||
integer, parameter :: source_image = 1
|
||||
|
||||
if (this_image() == source_image) then
|
||||
foo = foo_t(2,3)
|
||||
else
|
||||
allocate(foo%j)
|
||||
end if
|
||||
call co_broadcast(foo, source_image)
|
||||
|
||||
if ((foo%i /= 2) .or. (foo%j /= 3)) error stop 1
|
||||
sync all
|
||||
|
||||
end program
|
||||
|
||||
! Wrong code generation produced too many temp descriptors
|
||||
! leading to stacked descriptors handed to the co_broadcast.
|
||||
! This lead to access to non exsitant memory in opencoarrays.
|
||||
! In single image mode just checking for reduced number of
|
||||
! descriptors is possible, i.e., execute always works.
|
||||
! { dg-final { scan-tree-dump-times "desc\\.\[0-9\]+" 12 "original" } }
|
||||
|
||||
Loading…
Reference in New Issue