From c9c48ab7bad9fe5e096076e56a60ce0a5a2b65f7 Mon Sep 17 00:00:00 2001 From: Andre Vehreschild Date: Fri, 28 Jan 2022 09:20:23 +0100 Subject: [PATCH] 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. --- gcc/fortran/trans-array.cc | 71 ++++++++++++++-------- gcc/fortran/trans-intrinsic.cc | 40 ++++++------ .../gfortran.dg/coarray_collectives_18.f90 | 37 +++++++++++ 3 files changed, 105 insertions(+), 43 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/coarray_collectives_18.f90 diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index 2f0c8a4..1234932 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -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; diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc index da854fa..e680de1 100644 --- a/gcc/fortran/trans-intrinsic.cc +++ b/gcc/fortran/trans-intrinsic.cc @@ -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) - { - 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 + if (!derived || !derived->attr.alloc_comp + || code->resolved_isym->id != GFC_ISYM_CO_BROADCAST) { - 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'. */ diff --git a/gcc/testsuite/gfortran.dg/coarray_collectives_18.f90 b/gcc/testsuite/gfortran.dg/coarray_collectives_18.f90 new file mode 100644 index 0000000..c83899d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_collectives_18.f90 @@ -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" } } + -- 2.7.4