From 00f6de9c69119594f7dad3bd525937c94c8200d0 Mon Sep 17 00:00:00 2001 From: Tobias Burnus Date: Mon, 27 Sep 2021 14:04:54 +0200 Subject: Fortran: Fix assumed-size to assumed-rank passing [PR94070] This code inlines the size0 and size1 libgfortran calls, the former is still used by libgfortan itself (and by old code). Besides permitting more optimizations, it also permits to handle assumed-rank dummies better: If the dummy argument is a nonpointer/nonallocatable, an assumed-size actual arg is repesented by having ubound == -1 for the last dimension. However, for allocatable/pointers, this value can also exist. Hence, the dummy arg attr has to be honored. For that reason, when calling an assumed-rank procedure with nonpointer, nonallocatable dummy arguments, the bounds have to be updated to avoid the case ubound == -1 for the last dimension. PR fortran/94070 gcc/fortran/ChangeLog: * trans-array.c (gfc_tree_array_size): New function to find size inline (whole array or one dimension). (array_parameter_size): Use it, take stmt_block as arg. (gfc_conv_array_parameter): Update call. * trans-array.h (gfc_tree_array_size): Add prototype. * trans-decl.c (gfor_fndecl_size0, gfor_fndecl_size1): Remove these global vars. (gfc_build_intrinsic_function_decls): Remove their initialization. * trans-expr.c (gfc_conv_procedure_call): Update bounds of pointer/allocatable actual args to nonallocatable/nonpointer dummies to be one based. * trans-intrinsic.c (gfc_conv_intrinsic_shape): Fix case for assumed rank with allocatable/pointer dummy. (gfc_conv_intrinsic_size): Update to use inline function. * trans.h (gfor_fndecl_size0, gfor_fndecl_size1): Remove var decl. libgfortran/ChangeLog: * intrinsics/size.c (size0, size1): Comment that now not used by newer compiler code. libgomp/ChangeLog: * testsuite/libgomp.oacc-fortran/privatized-ref-2.f90: Update expected dg-note output. gcc/testsuite/ChangeLog: * gfortran.dg/c-interop/cf-out-descriptor-6.f90: Remove xfail. * gfortran.dg/c-interop/size.f90: Remove xfail. * gfortran.dg/intrinsic_size_3.f90: Update scan-tree-dump-times. * gfortran.dg/transpose_optimization_2.f90: Likewise. * gfortran.dg/size_optional_dim_1.f90: Add scan-tree-dump-not. * gfortran.dg/assumed_rank_22.f90: New test. * gfortran.dg/assumed_rank_22_aux.c: New test. --- gcc/fortran/trans-array.c | 165 ++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 139 insertions(+), 26 deletions(-) (limited to 'gcc/fortran/trans-array.c') diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 0d013de..b8061f3 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -7901,31 +7901,143 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) gfc_cleanup_loop (&loop); } + +/* Calculate the array size (number of elements); if dim != NULL_TREE, + return size for that dim (dim=0..rank-1; only for GFC_DESCRIPTOR_TYPE_P). */ +tree +gfc_tree_array_size (stmtblock_t *block, tree desc, gfc_expr *expr, tree dim) +{ + if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc))) + { + gcc_assert (dim == NULL_TREE); + return GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc)); + } + tree size, tmp, rank = NULL_TREE, cond = NULL_TREE; + symbol_attribute attr = gfc_expr_attr (expr); + gfc_array_spec *as = gfc_get_full_arrayspec_from_expr (expr); + gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))); + if ((!attr.pointer && !attr.allocatable && as && as->type == AS_ASSUMED_RANK) + || !dim) + { + if (expr->rank < 0) + rank = fold_convert (signed_char_type_node, + gfc_conv_descriptor_rank (desc)); + else + rank = build_int_cst (signed_char_type_node, expr->rank); + } + + if (dim || expr->rank == 1) + { + if (!dim) + dim = gfc_index_zero_node; + tree ubound = gfc_conv_descriptor_ubound_get (desc, dim); + tree lbound = gfc_conv_descriptor_lbound_get (desc, dim); + + size = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, ubound, lbound); + size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + size, gfc_index_one_node); + /* if (!allocatable && !pointer && assumed rank) + size = (idx == rank && ubound[rank-1] == -1 ? -1 : size; + else + size = max (0, size); */ + size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type, + size, gfc_index_zero_node); + if (!attr.pointer && !attr.allocatable + && as && as->type == AS_ASSUMED_RANK) + { + tmp = fold_build2_loc (input_location, MINUS_EXPR, signed_char_type_node, + rank, build_int_cst (signed_char_type_node, 1)); + cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + fold_convert (signed_char_type_node, dim), + tmp); + tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + gfc_conv_descriptor_ubound_get (desc, dim), + build_int_cst (gfc_array_index_type, -1)); + cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node, + cond, tmp); + tmp = build_int_cst (gfc_array_index_type, -1); + size = build3_loc (input_location, COND_EXPR, gfc_array_index_type, + cond, tmp, size); + } + return size; + } + + /* size = 1. */ + size = gfc_create_var (gfc_array_index_type, "size"); + gfc_add_modify (block, size, build_int_cst (TREE_TYPE (size), 1)); + tree extent = gfc_create_var (gfc_array_index_type, "extent"); + + stmtblock_t cond_block, loop_body; + gfc_init_block (&cond_block); + gfc_init_block (&loop_body); + + /* Loop: for (i = 0; i < rank; ++i). */ + tree idx = gfc_create_var (signed_char_type_node, "idx"); + /* Loop body. */ + /* #if (assumed-rank + !allocatable && !pointer) + if (idx == rank - 1 && dim[idx].ubound == -1) + extent = -1; + else + #endif + extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1 + if (extent < 0) + extent = 0 + size *= extent. */ + cond = NULL_TREE; + if (!attr.pointer && !attr.allocatable && as && as->type == AS_ASSUMED_RANK) + { + tmp = fold_build2_loc (input_location, MINUS_EXPR, signed_char_type_node, + rank, build_int_cst (signed_char_type_node, 1)); + cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + idx, tmp); + tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + gfc_conv_descriptor_ubound_get (desc, idx), + build_int_cst (gfc_array_index_type, -1)); + cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node, + cond, tmp); + } + tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + gfc_conv_descriptor_ubound_get (desc, idx), + gfc_conv_descriptor_lbound_get (desc, idx)); + tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + tmp, gfc_index_one_node); + gfc_add_modify (&cond_block, extent, tmp); + tmp = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, + extent, gfc_index_zero_node); + tmp = build3_v (COND_EXPR, tmp, + fold_build2_loc (input_location, MODIFY_EXPR, + gfc_array_index_type, + extent, gfc_index_zero_node), + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&cond_block, tmp); + tmp = gfc_finish_block (&cond_block); + if (cond) + tmp = build3_v (COND_EXPR, cond, + fold_build2_loc (input_location, MODIFY_EXPR, + gfc_array_index_type, extent, + build_int_cst (gfc_array_index_type, -1)), + tmp); + gfc_add_expr_to_block (&loop_body, tmp); + /* size *= extent. */ + gfc_add_modify (&loop_body, size, + fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + size, extent)); + /* Generate loop. */ + gfc_simple_for_loop (block, idx, build_int_cst (TREE_TYPE (idx), 0), rank, LT_EXPR, + build_int_cst (TREE_TYPE (idx), 1), + gfc_finish_block (&loop_body)); + return size; +} + /* Helper function for gfc_conv_array_parameter if array size needs to be computed. */ static void -array_parameter_size (tree desc, gfc_expr *expr, tree *size) +array_parameter_size (stmtblock_t *block, tree desc, gfc_expr *expr, tree *size) { tree elem; - if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc))) - *size = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc)); - else if (expr->rank > 1) - *size = build_call_expr_loc (input_location, - gfor_fndecl_size0, 1, - gfc_build_addr_expr (NULL, desc)); - else - { - tree ubound = gfc_conv_descriptor_ubound_get (desc, gfc_index_zero_node); - tree lbound = gfc_conv_descriptor_lbound_get (desc, gfc_index_zero_node); - - *size = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, ubound, lbound); - *size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - *size, gfc_index_one_node); - *size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type, - *size, gfc_index_zero_node); - } + *size = gfc_tree_array_size (block, desc, expr, NULL); elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc))); *size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, *size, fold_convert (gfc_array_index_type, elem)); @@ -8035,7 +8147,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77, else se->expr = gfc_build_addr_expr (NULL_TREE, tmp); if (size) - array_parameter_size (tmp, expr, size); + array_parameter_size (&se->pre, tmp, expr, size); return; } @@ -8047,7 +8159,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77, tmp = se->expr; } if (size) - array_parameter_size (tmp, expr, size); + array_parameter_size (&se->pre, tmp, expr, size); se->expr = gfc_conv_array_data (tmp); return; } @@ -8122,7 +8234,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77, if (expr->ts.type == BT_CHARACTER && expr->expr_type != EXPR_FUNCTION) se->string_length = expr->ts.u.cl->backend_decl; if (size) - array_parameter_size (se->expr, expr, size); + array_parameter_size (&se->pre, se->expr, expr, size); se->expr = gfc_conv_array_data (se->expr); return; } @@ -8132,7 +8244,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77, /* Result of the enclosing function. */ gfc_conv_expr_descriptor (se, expr); if (size) - array_parameter_size (se->expr, expr, size); + array_parameter_size (&se->pre, se->expr, expr, size); se->expr = gfc_build_addr_expr (NULL_TREE, se->expr); if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE @@ -8149,9 +8261,10 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77, gfc_conv_expr_descriptor (se, expr); if (size) - array_parameter_size (build_fold_indirect_ref_loc (input_location, - se->expr), - expr, size); + array_parameter_size (&se->pre, + build_fold_indirect_ref_loc (input_location, + se->expr), + expr, size); } /* Deallocate the allocatable components of structures that are -- cgit v1.1 From 4dc7ce6fb3917958d1a6036d8acf2953b9c1b868 Mon Sep 17 00:00:00 2001 From: Martin Sebor Date: Fri, 1 Oct 2021 11:50:25 -0600 Subject: Enhance -Waddress to detect more suspicious expressions [PR102103]. Resolves: PR c/102103 - missing warning comparing array address to null gcc/ChangeLog: PR c/102103 * doc/invoke.texi (-Waddress): Update. * gengtype.c (write_types): Avoid -Waddress. * poly-int.h (POLY_SET_COEFF): Avoid using null. gcc/c-family/ChangeLog: PR c/102103 * c-common.c (decl_with_nonnull_addr_p): Handle members. Check and perform warning suppression. (c_common_truthvalue_conversion): Enhance warning suppression. gcc/c/ChangeLog: PR c/102103 * c-typeck.c (maybe_warn_for_null_address): New function. (build_binary_op): Call it. gcc/cp/ChangeLog: PR c/102103 * typeck.c (warn_for_null_address): Enhance. (cp_build_binary_op): Call it also for member pointers. gcc/fortran/ChangeLog: PR c/102103 * array.c: Remove an unnecessary test. * trans-array.c: Same. gcc/testsuite/ChangeLog: PR c/102103 * g++.dg/cpp0x/constexpr-array-ptr10.C: Suppress a valid warning. * g++.dg/warn/Wreturn-local-addr-6.C: Correct a cast. * gcc.dg/Waddress.c: Expect a warning. * c-c++-common/Waddress-3.c: New test. * c-c++-common/Waddress-4.c: New test. * g++.dg/warn/Waddress-5.C: New test. * g++.dg/warn/Waddress-6.C: New test. * g++.dg/warn/pr101219.C: Expect a warning. * gcc.dg/Waddress-3.c: New test. --- gcc/fortran/trans-array.c | 1 - 1 file changed, 1 deletion(-) (limited to 'gcc/fortran/trans-array.c') diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index b8061f3..e2f59e0 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -5104,7 +5104,6 @@ set_loop_bounds (gfc_loopinfo *loop) if (info->shape) { - gcc_assert (info->shape[dim]); /* The frontend has worked out the size for us. */ if (!loopspec[n] || !specinfo->shape -- cgit v1.1