From 6da86c254aa4d68aab2b1f501a88d53f8777178b Mon Sep 17 00:00:00 2001 From: Andre Vehreschild Date: Fri, 28 Jan 2022 10:35:07 +0100 Subject: [PATCH] Revert "Prevent malicious descriptor stacking for scalar components." Breaks bootstrap. This reverts commit c9c48ab7bad9fe5e096076e56a60ce0a5a2b65f7. --- gcc/fortran/trans-array.cc | 71 ++++++++-------------- gcc/fortran/trans-intrinsic.cc | 40 ++++++------ .../gfortran.dg/coarray_collectives_18.f90 | 37 ----------- 3 files changed, 43 insertions(+), 105 deletions(-) delete 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 1234932..2f0c8a4 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -9102,10 +9102,6 @@ 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) @@ -9138,13 +9134,10 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, if (attr->dimension) { tmp = gfc_get_element_type (TREE_TYPE (comp)); - 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); + ubound = gfc_full_array_size (&tmpblock, comp, + c->ts.type == BT_CLASS + ? CLASS_DATA (c)->as->rank + : c->as->rank); } else { @@ -9152,36 +9145,26 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, ubound = build_int_cst (gfc_array_index_type, 1); } - /* 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_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) - { - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp))) - comp = gfc_conv_descriptor_data_get (comp); - else - comp = gfc_build_addr_expr (NULL_TREE, comp); - } + comp = gfc_conv_descriptor_data_get (comp); else { gfc_se se; @@ -9189,18 +9172,14 @@ 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); - if (c->ts.type == BT_CHARACTER) - comp = gfc_build_addr_expr (NULL_TREE, comp); + c->ts.type == BT_CLASS + ? CLASS_DATA (c)->attr + : c->attr); + comp = gfc_build_addr_expr (NULL_TREE, comp); gfc_add_block_to_block (&tmpblock, &se.pre); } - if (attr->dimension || c->ts.type == BT_CHARACTER) - gfc_conv_descriptor_data_set (&tmpblock, cdesc, comp); - else - cdesc = comp; + gfc_conv_descriptor_data_set (&tmpblock, cdesc, comp); tree fndecl; diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc index e680de1..da854fa 100644 --- a/gcc/fortran/trans-intrinsic.cc +++ b/gcc/fortran/trans-intrinsic.cc @@ -11212,31 +11212,24 @@ 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 (!derived || !derived->attr.alloc_comp - || code->resolved_isym->id != GFC_ISYM_CO_BROADCAST) + if (code->ext.actual->expr->rank == 0) { - 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; - } + 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); @@ -11297,6 +11290,9 @@ 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 deleted file mode 100644 index c83899d..0000000 --- a/gcc/testsuite/gfortran.dg/coarray_collectives_18.f90 +++ /dev/null @@ -1,37 +0,0 @@ -! { 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