From: Andre Vehreschild Date: Sat, 14 Apr 2018 14:45:59 +0000 (+0200) Subject: re PR fortran/81773 ([Coarray] Get with vector index on lhs leads to incorrect caf_ge... X-Git-Tag: releases/gcc-8.1.0~160 X-Git-Url: http://git.ipfire.org/?a=commitdiff_plain;h=2368eaf95dff456f6527f6d82579af0246141553;p=thirdparty%2Fgcc.git re PR fortran/81773 ([Coarray] Get with vector index on lhs leads to incorrect caf_get_by_ref() call.) gcc/fortran/ChangeLog: 2018-04-14 Andre Vehreschild PR fortran/81773 PR fortran/83606 * dependency.c (gfc_dep_resolver): Coarray indexes are to be ignored during dependency computation. They define no data dependency. * trans-array.c (conv_array_index_offset): The stride can not be set here, prevent fail. * trans-intrinsic.c (conv_caf_send): Add creation of temporary array for caf_get's result and copying to the array with vectorial indexing. gcc/testsuite/ChangeLog: 2018-04-14 Andre Vehreschild PR fortran/81773 PR fortran/83606 * gfortran.dg/coarray/get_to_indexed_array_1.f90: New test. * gfortran.dg/coarray/get_to_indirect_array.f90: New test. From-SVN: r259385 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index c6ec69e86c0c..9d126868cc9e 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,15 @@ +2018-04-14 Andre Vehreschild + + PR fortran/81773 + PR fortran/83606 + * dependency.c (gfc_dep_resolver): Coarray indexes are to be ignored + during dependency computation. They define no data dependency. + * trans-array.c (conv_array_index_offset): The stride can not be set + here, prevent fail. + * trans-intrinsic.c (conv_caf_send): Add creation of temporary array + for caf_get's result and copying to the array with vectorial + indexing. + 2018-04-14 Thomas Koenig PR fortran/85387 diff --git a/gcc/fortran/dependency.c b/gcc/fortran/dependency.c index a0bbd584947f..3e14ddc25d86 100644 --- a/gcc/fortran/dependency.c +++ b/gcc/fortran/dependency.c @@ -2238,8 +2238,9 @@ gfc_dep_resolver (gfc_ref *lref, gfc_ref *rref, gfc_reverse *reverse) break; /* Exactly matching and forward overlapping ranges don't cause a - dependency. */ - if (fin_dep < GFC_DEP_BACKWARD) + dependency, when they are not part of a coarray ref. */ + if (fin_dep < GFC_DEP_BACKWARD + && lref->u.ar.codimen == 0 && rref->u.ar.codimen == 0) return 0; /* Keep checking. We only have a dependency if diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index bd7316890318..b68e77d52818 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -3215,7 +3215,7 @@ conv_array_index_offset (gfc_se * se, gfc_ss * ss, int dim, int i, } /* Multiply by the stride. */ - if (!integer_onep (stride)) + if (stride != NULL && !integer_onep (stride)) index = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, index, stride); diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index a45aec708fb9..00edd447bb2a 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -1907,34 +1907,124 @@ conv_caf_send (gfc_code *code) { } else { - /* If has_vector, pass descriptor for whole array and the - vector bounds separately. */ - gfc_array_ref *ar, ar2; - bool has_vector = false; + bool has_vector = gfc_has_vector_subscript (lhs_expr); - if (gfc_is_coindexed (lhs_expr) && gfc_has_vector_subscript (lhs_expr)) + if (gfc_is_coindexed (lhs_expr) || !has_vector) { - has_vector = true; - ar = gfc_find_array_ref (lhs_expr); - ar2 = *ar; - memset (ar, '\0', sizeof (*ar)); - ar->as = ar2.as; - ar->type = AR_FULL; + /* If has_vector, pass descriptor for whole array and the + vector bounds separately. */ + gfc_array_ref *ar, ar2; + bool has_tmp_lhs_array = false; + if (has_vector) + { + has_tmp_lhs_array = true; + ar = gfc_find_array_ref (lhs_expr); + ar2 = *ar; + memset (ar, '\0', sizeof (*ar)); + ar->as = ar2.as; + ar->type = AR_FULL; + } + lhs_se.want_pointer = 1; + gfc_conv_expr_descriptor (&lhs_se, lhs_expr); + /* Using gfc_conv_expr_descriptor, we only get the descriptor, but + that has the wrong type if component references are done. */ + lhs_type = gfc_typenode_for_spec (&lhs_expr->ts); + tmp = build_fold_indirect_ref_loc (input_location, lhs_se.expr); + gfc_add_modify (&lhs_se.pre, gfc_conv_descriptor_dtype (tmp), + gfc_get_dtype_rank_type (has_vector ? ar2.dimen + : lhs_expr->rank, + lhs_type)); + if (has_tmp_lhs_array) + { + vec = conv_caf_vector_subscript (&block, lhs_se.expr, &ar2); + *ar = ar2; + } } - lhs_se.want_pointer = 1; - gfc_conv_expr_descriptor (&lhs_se, lhs_expr); - /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that - has the wrong type if component references are done. */ - lhs_type = gfc_typenode_for_spec (&lhs_expr->ts); - tmp = build_fold_indirect_ref_loc (input_location, lhs_se.expr); - gfc_add_modify (&lhs_se.pre, gfc_conv_descriptor_dtype (tmp), - gfc_get_dtype_rank_type (has_vector ? ar2.dimen - : lhs_expr->rank, - lhs_type)); - if (has_vector) + else { - vec = conv_caf_vector_subscript (&block, lhs_se.expr, &ar2); - *ar = ar2; + /* Special casing for arr1 ([...]) = arr2[...], i.e. caf_get to + indexed array expression. This is rewritten to: + + tmp_array = arr2[...] + arr1 ([...]) = tmp_array + + because using the standard gfc_conv_expr (lhs_expr) did the + assignment with lhs and rhs exchanged. */ + + gfc_ss *lss_for_tmparray, *lss_real; + gfc_loopinfo loop; + gfc_se se; + stmtblock_t body; + tree tmparr_desc, src; + tree index = gfc_index_zero_node; + tree stride = gfc_index_zero_node; + int n; + + /* Walk both sides of the assignment, once to get the shape of the + temporary array to create right. */ + lss_for_tmparray = gfc_walk_expr (lhs_expr); + /* And a second time to be able to create an assignment of the + temporary to the lhs_expr. gfc_trans_create_temp_array replaces + the tree in the descriptor with the one for the temporary + array. */ + lss_real = gfc_walk_expr (lhs_expr); + gfc_init_loopinfo (&loop); + gfc_add_ss_to_loop (&loop, lss_for_tmparray); + gfc_add_ss_to_loop (&loop, lss_real); + gfc_conv_ss_startstride (&loop); + gfc_conv_loop_setup (&loop, &lhs_expr->where); + lhs_type = gfc_typenode_for_spec (&lhs_expr->ts); + gfc_trans_create_temp_array (&lhs_se.pre, &lhs_se.post, + lss_for_tmparray, lhs_type, NULL_TREE, + false, true, false, + &lhs_expr->where); + tmparr_desc = lss_for_tmparray->info->data.array.descriptor; + gfc_start_scalarized_body (&loop, &body); + gfc_init_se (&se, NULL); + gfc_copy_loopinfo_to_se (&se, &loop); + se.ss = lss_real; + gfc_conv_expr (&se, lhs_expr); + gfc_add_block_to_block (&body, &se.pre); + + /* Walk over all indexes of the loop. */ + for (n = loop.dimen - 1; n > 0; --n) + { + tmp = loop.loopvar[n]; + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, tmp, loop.from[n]); + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, tmp, index); + + stride = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + loop.to[n - 1], loop.from[n - 1]); + stride = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, + stride, gfc_index_one_node); + + index = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, tmp, stride); + } + + index = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + index, loop.from[0]); + + index = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, + loop.loopvar[0], index); + + src = build_fold_indirect_ref (gfc_conv_array_data (tmparr_desc)); + src = gfc_build_array_ref (src, index, NULL); + /* Now create the assignment of lhs_expr = tmp_array. */ + gfc_add_modify (&body, se.expr, src); + gfc_add_block_to_block (&body, &se.post); + lhs_se.expr = gfc_build_addr_expr (NULL_TREE, tmparr_desc); + gfc_trans_scalarizing_loops (&loop, &body); + gfc_add_block_to_block (&loop.pre, &loop.post); + gfc_add_expr_to_block (&lhs_se.post, gfc_finish_block (&loop.pre)); + gfc_free_ss (lss_for_tmparray); + gfc_free_ss (lss_real); } } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 4c9fdf7bac7f..1369288a803f 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2018-04-14 Andre Vehreschild + + PR fortran/81773 + PR fortran/83606 + * gfortran.dg/coarray/get_to_indexed_array_1.f90: New test. + * gfortran.dg/coarray/get_to_indirect_array.f90: New test. + 2018-04-14 Thomas Koenig PR fortran/85387 diff --git a/gcc/testsuite/gfortran.dg/coarray/get_to_indexed_array_1.f90 b/gcc/testsuite/gfortran.dg/coarray/get_to_indexed_array_1.f90 new file mode 100644 index 000000000000..04714711707c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray/get_to_indexed_array_1.f90 @@ -0,0 +1,32 @@ +! { dg-do run } + +! Test that index vector on lhs of caf-expression works correctly. + +program pr81773 + + integer, parameter :: ndim = 5 + integer :: i + integer :: vec(ndim) = -1 + integer :: res(ndim)[*] = [ (i, i=1, ndim) ] + type T + integer :: padding + integer :: dest(ndim) + integer :: src(ndim) + end type + + type(T) :: dest + type(T), allocatable :: caf[:] + + vec([ndim, 3, 1]) = res(1:3)[1] + if (any (vec /= [ 3, -1, 2, -1, 1])) stop 1 + + dest = T(42, [ ( -1, i = 1, ndim ) ], [ ( i - 2, i = ndim, 1, -1) ] ) + dest%dest([ 4,3,2 ]) = res(3:5)[1] + if (any (dest%dest /= [-1, 5, 4, 3, -1])) stop 2 + + vec(:) = -1 + allocate(caf[*], source = T(42, [ ( -1, i = 1, ndim ) ], [ ( i - 2, i = ndim, 1, -1) ] )) + vec([ 5,3,2 ]) = caf[1]%src(2:4) + if (any (vec /= [ -1, 0, 1, -1, 2])) stop 3 +end + diff --git a/gcc/testsuite/gfortran.dg/coarray/get_to_indirect_array.f90 b/gcc/testsuite/gfortran.dg/coarray/get_to_indirect_array.f90 new file mode 100644 index 000000000000..efb783536375 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray/get_to_indirect_array.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +! +! Test that pr81773/fortran is fixed. + +program get_to_indexed_array + + integer, parameter :: ndim = 5 + integer :: i + integer :: vec(1:ndim) = 0 + integer :: indx(1:2) = [3, 2] + integer :: mat(1:ndim, 1:ndim) = 0 + integer :: res(1:ndim)[*]=[ (i, i=1, ndim) ] + + ! No sync needed, because this test always is running on single image + vec([ndim , 1]) = res(1:2)[1] + if (vec(1) /= res(2) .or. vec(ndim) /= res(1)) then + print *,"vec: ", vec, " on image: ", this_image() + stop 1 + end if + + mat(2:3,[indx(:)]) = reshape(res(1:4)[1], [2, 2]) + if (any(mat(2:3, 3:2:-1) /= reshape(res(1:4), [2,2]))) then + print *, "mat: ", mat, " on image: ", this_image() + stop 2 + end if +end + +! vim:ts=2:sts=2:sw=2: