From: Paul Thomas Date: Thu, 24 Jan 2019 07:19:49 +0000 (+0000) Subject: re PR fortran/88929 (ICE on building MPICH 3.2 with GCC 9 with ISO_Fortran_binding) X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=db06a76e9a00cf4ec715a685dd5ca722826f783f;p=gcc.git re PR fortran/88929 (ICE on building MPICH 3.2 with GCC 9 with ISO_Fortran_binding) 2019-01-24 Paul Thomas PR fortran/88929 * trans-array.c (gfc_conv_descriptor_elem_len): New function. * trans-array.h : Add prototype for above. * trans-expr.c (gfc_conv_gfc_desc_to_cfi_desc): Take account of assumed rank arrays being flagged by rank = -1 in expressions. Intent in arrays need a pointer to a copy of the data to be assigned to the descriptor passed for conversion. This should then be freed, together with the CFI descriptor on return from the C call. 2019-01-24 Paul Thomas PR fortran/88929 * gfortran.dg/ISO_Fortran_binding_3.f90 : New test * gfortran.dg/ISO_Fortran_binding_3.c : Subsidiary source. From-SVN: r268231 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 31a8b2c9aa2..d728c27ffa7 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,15 @@ +2019-01-24 Paul Thomas + + PR fortran/88929 + * trans-array.c (gfc_conv_descriptor_elem_len): New function. + * trans-array.h : Add prototype for above. + * trans-expr.c (gfc_conv_gfc_desc_to_cfi_desc): Take account of + assumed rank arrays being flagged by rank = -1 in expressions. + Intent in arrays need a pointer to a copy of the data to be + assigned to the descriptor passed for conversion. This should + then be freed, together with the CFI descriptor on return from + the C call. + 2019-01-22 Harald Anlauf PR fortran/88579 diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 1814916c73d..6d7c3d22154 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -285,13 +285,31 @@ gfc_conv_descriptor_rank (tree desc) dtype = gfc_conv_descriptor_dtype (desc); tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)), GFC_DTYPE_RANK); - gcc_assert (tmp!= NULL_TREE + gcc_assert (tmp != NULL_TREE && TREE_TYPE (tmp) == signed_char_type_node); return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp), dtype, tmp, NULL_TREE); } +/* Return the element length from the descriptor dtype field. */ + +tree +gfc_conv_descriptor_elem_len (tree desc) +{ + tree tmp; + tree dtype; + + dtype = gfc_conv_descriptor_dtype (desc); + tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)), + GFC_DTYPE_ELEM_LEN); + gcc_assert (tmp != NULL_TREE + && TREE_TYPE (tmp) == size_type_node); + return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp), + dtype, tmp, NULL_TREE); +} + + tree gfc_conv_descriptor_attribute (tree desc) { diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index a6d71672876..8c2d51838d4 100644 --- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -169,6 +169,7 @@ tree gfc_conv_descriptor_offset_get (tree); tree gfc_conv_descriptor_span_get (tree); tree gfc_conv_descriptor_dtype (tree); tree gfc_conv_descriptor_rank (tree); +tree gfc_conv_descriptor_elem_len (tree); tree gfc_conv_descriptor_attribute (tree); tree gfc_get_descriptor_dimension (tree); tree gfc_conv_descriptor_stride_get (tree, tree); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 328ffc97110..1cbef7f4c29 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -4924,6 +4924,8 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym) tree tmp; tree cfi_desc_ptr; tree gfc_desc_ptr; + tree ptr = NULL_TREE; + tree size; tree type; int attribute; symbol_attribute attr = gfc_expr_attr (e); @@ -4939,7 +4941,7 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym) attribute = 1; } - if (e->rank) + if (e->rank != 0) { gfc_conv_expr_descriptor (parmse, e); @@ -4950,9 +4952,14 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym) /* All the temporary descriptors are marked as DECL_ARTIFICIAL. If the expression type is different from the descriptor type, then the offset must be found (eg. to a component ref or substring) - and the dtype updated. */ - type = gfc_typenode_for_spec (&e->ts); - if (DECL_ARTIFICIAL (parmse->expr) + and the dtype updated. Assumed type entities are only allowed + to be dummies in Fortran. They therefore lack the decl specific + appendiges and so must be treated differently from other fortran + entities passed to CFI descriptors in the interface decl. */ + type = e->ts.type != BT_ASSUMED ? gfc_typenode_for_spec (&e->ts) : + NULL_TREE; + + if (type && DECL_ARTIFICIAL (parmse->expr) && type != gfc_get_element_type (TREE_TYPE (parmse->expr))) { /* Obtain the offset to the data. */ @@ -4964,15 +4971,44 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym) gfc_conv_descriptor_dtype (parmse->expr), gfc_get_dtype_rank_type (e->rank, type)); } - else if (!is_subref_array (e) && !DECL_ARTIFICIAL (parmse->expr)) + else if (type == NULL_TREE + || (!is_subref_array (e) && !DECL_ARTIFICIAL (parmse->expr))) { /* Make sure that the span is set for expressions where it might not have been done already. */ - tmp = TREE_TYPE (parmse->expr); - tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp)); + tmp = gfc_conv_descriptor_elem_len (parmse->expr); tmp = fold_convert (gfc_array_index_type, tmp); gfc_conv_descriptor_span_set (&parmse->pre, parmse->expr, tmp); } + + /* INTENT(IN) requires a temporary for the data. Assumed types do not + work with the standard temporary generation schemes. */ + if (e->expr_type == EXPR_VARIABLE && fsym->attr.intent == INTENT_IN) + { + /* Fix the descriptor and determine the size of the data. */ + parmse->expr = gfc_evaluate_now (parmse->expr, &parmse->pre); + size = build_call_expr_loc (input_location, + gfor_fndecl_size0, 1, + gfc_build_addr_expr (NULL, parmse->expr)); + size = fold_convert (size_type_node, size); + tmp = gfc_conv_descriptor_span_get (parmse->expr); + tmp = fold_convert (size_type_node, tmp); + size = fold_build2_loc (input_location, MULT_EXPR, + size_type_node, size, tmp); + /* Fix the size and allocate. */ + size = gfc_evaluate_now (size, &parmse->pre); + tmp = builtin_decl_explicit (BUILT_IN_MALLOC); + ptr = build_call_expr_loc (input_location, tmp, 1, size); + ptr = gfc_evaluate_now (ptr, &parmse->pre); + /* Copy the data to the temporary descriptor. */ + tmp = builtin_decl_explicit (BUILT_IN_MEMCPY); + tmp = build_call_expr_loc (input_location, tmp, 3, ptr, + gfc_conv_descriptor_data_get (parmse->expr), + size); + gfc_add_expr_to_block (&parmse->pre, tmp); + gfc_conv_descriptor_data_set (&parmse->pre, parmse->expr, ptr); + } + } else { @@ -4982,7 +5018,7 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym) parmse->expr = build_fold_indirect_ref_loc (input_location, parmse->expr); - /* Copy the scalar for INTENT_IN. */ + /* Copy the scalar for INTENT(IN). */ if (e->expr_type == EXPR_VARIABLE && fsym->attr.intent == INTENT_IN) parmse->expr = gfc_evaluate_now (parmse->expr, &parmse->pre); parmse->expr = gfc_conv_scalar_to_descriptor (parmse, @@ -5012,6 +5048,17 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym) /* The CFI descriptor is passed to the bind_C procedure. */ parmse->expr = cfi_desc_ptr; + if (ptr) + { + /* Free both the temporary data and the CFI descriptor for + INTENT(IN) arrays. */ + tmp = gfc_call_free (ptr); + gfc_prepend_expr_to_block (&parmse->post, tmp); + tmp = gfc_call_free (cfi_desc_ptr); + gfc_prepend_expr_to_block (&parmse->post, tmp); + return; + } + /* Transfer values back to gfc descriptor and free the CFI descriptor. */ tmp = gfc_build_addr_expr (NULL_TREE, parmse->expr); tmp = build_call_expr_loc (input_location, diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 64cd7e2f332..158c47137e7 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2019-01-24 Paul Thomas + + PR fortran/88929 + * gfortran.dg/ISO_Fortran_binding_3.f90 : New test + * gfortran.dg/ISO_Fortran_binding_3.c : Subsidiary source. + 2019-01-23 H.J. Lu PR libgcc/88931 @@ -218,7 +224,7 @@ 2019-01-20 Kewen Lin - * gcc.target/powerpc/altivec_vld_vst_addr.c: Remove, split into + * gcc.target/powerpc/altivec_vld_vst_addr.c: Remove, split into altivec_vld_vst_addr-1.c and altivec_vld_vst_addr-2.c. * gcc.target/powerpc/altivec_vld_vst_addr-1.c: New test. * gcc.target/powerpc/altivec_vld_vst_addr-2.c: Ditto. diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_3.c b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_3.c new file mode 100644 index 00000000000..a9f64cd5cf1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_3.c @@ -0,0 +1,32 @@ +#include "../../../libgfortran/ISO_Fortran_binding.h" +#include +#include + +/* Part of the test for the fix of PR88929 - see ISO_Fortran_binding_3.f90. */ + +int c_test (CFI_cdesc_t * a_desc) +{ + CFI_index_t idx[2]; + int *res_addr; + int err = 1; /* this error code represents all errors */ + + if (a_desc->rank != 2) + return err; + + if (a_desc->type != CFI_type_int) + return err; + + err = 0; + for (idx[0] = 0; idx[0] < a_desc->dim[0].extent; idx[0]++) + for (idx[1] = 0; idx[1] < a_desc->dim[1].extent; idx[1]++) + { + res_addr = CFI_address (a_desc, idx); + err += *res_addr; + *res_addr = *res_addr + 1; + } + + if (err != 10) return 1; + + return 0; +} + diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_3.f90 b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_3.f90 new file mode 100644 index 00000000000..4870ca0edcb --- /dev/null +++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_3.f90 @@ -0,0 +1,53 @@ +! { dg-do run } +! { dg-additional-sources ISO_Fortran_binding_3.c } +! +! Test the fix for PR88929. +! + integer, dimension (:,:), allocatable :: actual + integer, dimension(2,2) :: src = reshape ([1,2,3,4], [2,2]) + + allocate (actual, source = src) + ier = test1 (actual) + if (ier .ne. 0) stop 1 +! C call is INTENT(IN). 'c_test' increments elements of 'src'. + if (any (actual .ne. src)) stop 2 + + ier = test2 (actual) + if (ier .ne. 0) stop 1 +! C call is INTENT(INOUT) 'c_test' increments elements of 'src'. + if (any (actual .ne. src + 1)) stop 2 + +contains + + function test1 (arg) RESULT(err) + USE, INTRINSIC :: ISO_C_BINDING + INTEGER(C_INT) :: err + type(*), dimension(..), intent(inOUT) :: arg + interface + function test_c (a) BIND(C, NAME="c_test") RESULT(err) + USE, INTRINSIC :: ISO_C_BINDING + type(*), dimension(..), intent(in) :: a + INTEGER(C_INT) :: err + end function + end interface + + err = test_c (arg) ! This used to ICE + + end function test1 + + function test2 (arg) RESULT(err) + USE, INTRINSIC :: ISO_C_BINDING + INTEGER(C_INT) :: err + type(*), dimension(..), intent(inout) :: arg + interface + function test_c (a) BIND(C, NAME="c_test") RESULT(err) + USE, INTRINSIC :: ISO_C_BINDING + type(*), dimension(..), intent(inout) :: a + INTEGER(C_INT) :: err + end function + end interface + + err = test_c (arg) ! This used to ICE + + end function test2 +end \ No newline at end of file