From 20d0bfcefd6caf09c23113732edd98241a46af56 Mon Sep 17 00:00:00 2001 From: Alessandro Fanfarillo Date: Tue, 5 Jul 2016 09:33:06 -0600 Subject: [PATCH] Second review of STAT= patch + tests From-SVN: r238007 --- gcc/fortran/ChangeLog | 13 +++++ gcc/fortran/array.c | 17 +++++++ gcc/fortran/expr.c | 17 +++++++ gcc/fortran/gfortran.h | 3 +- gcc/fortran/trans-decl.c | 8 ++-- gcc/fortran/trans-intrinsic.c | 48 +++++++++++++++---- gcc/testsuite/ChangeLog | 7 +++ .../gfortran.dg/coarray_lib_comm_1.f90 | 9 ++-- .../gfortran.dg/coarray_stat_function.f90 | 45 +++++++++++++++++ .../gfortran.dg/coarray_stat_whitespace.f90 | 29 +++++++++++ 10 files changed, 177 insertions(+), 19 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/coarray_stat_function.f90 create mode 100644 gcc/testsuite/gfortran.dg/coarray_stat_whitespace.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 0947d6dce73..ed6b40b1408 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,16 @@ +2016-07-05 Alessandro Fanfarillo + + * array.c (gfc_match_array_ref): Add parsing support for + STAT= attribute in CAF reference. + * expr.c (gfc_find_stat_co): New function that returns + the STAT= assignment. + * gfortran.h (gfc_array_ref): New member. + * trans-decl.c (gfc_build_builtin_function_decls): + new attribute for caf_get and caf_send functions. + * trans-intrinsic.c (gfc_conv_intrinsic_caf_get): Passing + the stat attribute to external function. + (gfc_conv_intrinsic_caf_send): Ditto. + 2016-07-05 Andre Vehreschild PR fortran/71623 diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index 1430e80251d..03c8b17178c 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -156,6 +156,8 @@ gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init, { match m; bool matched_bracket = false; + gfc_expr *tmp; + bool stat_just_seen = false; memset (ar, '\0', sizeof (*ar)); @@ -220,12 +222,27 @@ coarray: return MATCH_ERROR; } + ar->stat = NULL; + for (ar->codimen = 0; ar->codimen + ar->dimen < GFC_MAX_DIMENSIONS; ar->codimen++) { m = match_subscript (ar, init, true); if (m == MATCH_ERROR) return MATCH_ERROR; + stat_just_seen = false; + if (gfc_match(" , stat = %e",&tmp) == MATCH_YES && ar->stat == NULL) + { + ar->stat = tmp; + stat_just_seen = true; + } + + if (ar->stat && !stat_just_seen) + { + gfc_error ("STAT= attribute in %C misplaced"); + return MATCH_ERROR; + } + if (gfc_match_char (']') == MATCH_YES) { ar->codimen++; diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index d1258cdf380..7328898f2b6 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -4428,6 +4428,23 @@ gfc_ref_this_image (gfc_ref *ref) return true; } +gfc_expr * +gfc_find_stat_co(gfc_expr *e) +{ + gfc_ref *ref; + + for (ref = e->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) + return ref->u.ar.stat; + + if(e->value.function.actual->expr) + for(ref = e->value.function.actual->expr->ref; ref; + ref = ref->next) + if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) + return ref->u.ar.stat; + + return NULL; +} bool gfc_is_coindexed (gfc_expr *e) diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 0bb71cb184d..77831ab31e9 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -1814,6 +1814,7 @@ typedef struct gfc_array_ref int dimen; /* # of components in the reference */ int codimen; bool in_allocate; /* For coarray checks. */ + gfc_expr *stat; locus where; gfc_array_spec *as; @@ -3065,7 +3066,7 @@ bool gfc_is_coarray (gfc_expr *); int gfc_get_corank (gfc_expr *); bool gfc_has_ultimate_allocatable (gfc_expr *); bool gfc_has_ultimate_pointer (gfc_expr *); - +gfc_expr* gfc_find_stat_co (gfc_expr *); gfc_expr* gfc_build_intrinsic_call (gfc_namespace *, gfc_isym_id, const char*, locus, unsigned, ...); bool gfc_check_vardef_context (gfc_expr*, bool, bool, bool, const char*); diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 5626753c5d5..f026bea5d86 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -3526,16 +3526,16 @@ gfc_build_builtin_function_decls (void) ppvoid_type_node, pint_type, pchar_type_node, integer_type_node); gfor_fndecl_caf_get = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_get")), ".R.RRRW", void_type_node, 9, + get_identifier (PREFIX("caf_get")), ".R.RRRWW", void_type_node, 10, pvoid_type_node, size_type_node, integer_type_node, pvoid_type_node, pvoid_type_node, pvoid_type_node, integer_type_node, integer_type_node, - boolean_type_node); + boolean_type_node, pint_type); gfor_fndecl_caf_send = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_send")), ".R.RRRR", void_type_node, 9, + get_identifier (PREFIX("caf_send")), ".R.RRRRW", void_type_node, 10, pvoid_type_node, size_type_node, integer_type_node, pvoid_type_node, pvoid_type_node, pvoid_type_node, integer_type_node, integer_type_node, - boolean_type_node); + boolean_type_node, pint_type); gfor_fndecl_caf_sendget = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("caf_sendget")), ".R.RRRR.RRR", void_type_node, diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 574300eabb5..c6555400a49 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -1100,10 +1100,10 @@ static void gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind, tree may_require_tmp) { - gfc_expr *array_expr; + gfc_expr *array_expr, *tmp_stat; gfc_se argse; tree caf_decl, token, offset, image_index, tmp; - tree res_var, dst_var, type, kind, vec; + tree res_var, dst_var, type, kind, vec, stat; gcc_assert (flag_coarray == GFC_FCOARRAY_LIB); @@ -1122,6 +1122,19 @@ gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind, dst_var = lhs; vec = null_pointer_node; + tmp_stat = gfc_find_stat_co(expr); + + if (tmp_stat) + { + gfc_se stat_se; + gfc_init_se(&stat_se, NULL); + gfc_conv_expr_reference (&stat_se, tmp_stat); + stat = stat_se.expr; + gfc_add_block_to_block (&se->pre, &stat_se.pre); + gfc_add_block_to_block (&se->post, &stat_se.post); + } + else + stat = null_pointer_node; gfc_init_se (&argse, NULL); if (array_expr->rank == 0) @@ -1219,9 +1232,9 @@ gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind, ASM_VOLATILE_P (tmp) = 1; gfc_add_expr_to_block (&se->pre, tmp); - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_get, 9, + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_get, 10, token, offset, image_index, argse.expr, vec, - dst_var, kind, lhs_kind, may_require_tmp); + dst_var, kind, lhs_kind, may_require_tmp, stat); gfc_add_expr_to_block (&se->pre, tmp); if (se->ss) @@ -1237,11 +1250,11 @@ gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind, static tree conv_caf_send (gfc_code *code) { - gfc_expr *lhs_expr, *rhs_expr; + gfc_expr *lhs_expr, *rhs_expr, *tmp_stat; gfc_se lhs_se, rhs_se; stmtblock_t block; tree caf_decl, token, offset, image_index, tmp, lhs_kind, rhs_kind; - tree may_require_tmp; + tree may_require_tmp, stat; tree lhs_type = NULL_TREE; tree vec = null_pointer_node, rhs_vec = null_pointer_node; @@ -1253,6 +1266,8 @@ conv_caf_send (gfc_code *code) { ? boolean_false_node : boolean_true_node; gfc_init_block (&block); + stat = null_pointer_node; + /* LHS. */ gfc_init_se (&lhs_se, NULL); if (lhs_expr->rank == 0) @@ -1375,10 +1390,25 @@ conv_caf_send (gfc_code *code) { rhs_kind = build_int_cst (integer_type_node, rhs_expr->ts.kind); + tmp_stat = gfc_find_stat_co(lhs_expr); + + if (tmp_stat) + { + gfc_se stat_se; + gfc_init_se (&stat_se, NULL); + gfc_conv_expr_reference (&stat_se, tmp_stat); + stat = stat_se.expr; + gfc_add_block_to_block (&block, &stat_se.pre); + gfc_add_block_to_block (&block, &stat_se.post); + } + else + stat = null_pointer_node; + if (!gfc_is_coindexed (rhs_expr)) - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_send, 9, token, - offset, image_index, lhs_se.expr, vec, - rhs_se.expr, lhs_kind, rhs_kind, may_require_tmp); + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_send, 10, token, + offset, image_index, lhs_se.expr, vec, + rhs_se.expr, lhs_kind, rhs_kind, may_require_tmp, + stat); else { tree rhs_token, rhs_offset, rhs_image_index; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 2db9b450df9..944dbb66160 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2016-07-05 Alessandro Fanfarillo + + * gfortran.dg/coarray_stat_function.f90: New test. + * gfortran.dg/coarray_stat_whitespace.f90: New test. + * gfortran.dg/coarray_lib_comm_1: Adapting old test + to new interfaces. + 2016-07-05 Andre Vehreschild PR fortran/71623 diff --git a/gcc/testsuite/gfortran.dg/coarray_lib_comm_1.f90 b/gcc/testsuite/gfortran.dg/coarray_lib_comm_1.f90 index d23c9d18a7a..7b4d9375de5 100644 --- a/gcc/testsuite/gfortran.dg/coarray_lib_comm_1.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_lib_comm_1.f90 @@ -38,9 +38,8 @@ B(1:5) = B(3:7) if (any (A-B /= 0)) call abort end -! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, &parm.\[0-9\]+, 4, 4, 0\\\);" 1 "original" } } -! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, &parm.\[0-9\]+, 4, 4, 1\\\);" 1 "original" } } -! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, &p, 4, 4, 1\\\);" 1 "original" } } -! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.1, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) b, 1, &parm.\[0-9\]+, 0B, &p, 4, 4, 0\\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, &parm.\[0-9\]+, 4, 4, 0, 0B\\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, &parm.\[0-9\]+, 4, 4, 1, 0B\\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, &p, 4, 4, 1, 0B\\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.1, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) b, 1, &parm.\[0-9\]+, 0B, &p, 4, 4, 0, 0B\\\);" 1 "original" } } ! { dg-final { scan-tree-dump-times "_gfortran_caf_sendget \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, 4, 4, 0\\\);" 1 "original" } } - diff --git a/gcc/testsuite/gfortran.dg/coarray_stat_function.f90 b/gcc/testsuite/gfortran.dg/coarray_stat_function.f90 new file mode 100644 index 00000000000..c29687efbe2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_stat_function.f90 @@ -0,0 +1,45 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original -fcoarray=lib" } +! +program function_stat + implicit none + + integer :: me[*],tmp,stat,stat2,next + + me = this_image() + next = me + 1 + if(me == num_images()) next = 1 + stat = 0 + + sync all(stat=stat) + + if(stat /= 0) write(*,*) 'Image failed during sync' + + stat = 0 + if(me == 1) then + tmp = func(me[4,stat=stat]) + if(stat /= 0) write(*,*) me,'failure in func arg' + else if(me == 2) then + tmp = func2(me[1,stat=stat2],me[3,stat=stat]) + if(stat2 /= 0 .or. stat /= 0) write(*,*) me,'failure in func2 args' + endif + +contains + + function func(remote_me) + integer func + integer remote_me + func = remote_me + end function func + + function func2(remote_me,remote_neighbor) + integer func2 + integer remote_me,remote_neighbor + func2 = remote_me + remote_neighbor + end function func2 + +end program function_stat + +! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) desc.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) me, 4, &desc.\[0-9\]+, 0B, &desc.\[0-9\]+, 4, 4, 0, &stat\\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) desc.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) me, 1, &desc.\[0-9\]+, 0B, &desc.\[0-9\]+, 4, 4, 0, &stat2\\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) desc.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) me, 3, &desc.\[0-9\]+, 0B, &desc.\[0-9\]+, 4, 4, 0, &stat\\\);" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/coarray_stat_whitespace.f90 b/gcc/testsuite/gfortran.dg/coarray_stat_whitespace.f90 new file mode 100644 index 00000000000..aa790b996ef --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_stat_whitespace.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib" } +! +! Support for stat= in caf reference +! +program whitespace + implicit none + + integer :: me[*],tmp,stat,i + + me = this_image() + stat = 0 + i = 1 + + sync all(stat = stat) + + if(stat /= 0) write(*,*) 'failure during sync' + + stat = 0 + + if(me == 1) then + tmp = me[num_images(),stat = stat] + if(stat /= 0) write(*,*) 'failure in img:',me + else if(me == 2) then + tmp = me[i,stat=stat] + if(stat /= 0) write(*,*) 'failure in img:',me + endif + +end program whitespace -- 2.30.2