Dear Mikael, thanks for your review and for the test. The attached patch, built and regtested for x86_64-pc-linux-gnu, addresses all the suggestions.
The next patch will change the documentation related to the caf_get
and caf_send functions and will add support for STAT= to the sendget
function.
In the meantime, is this patch OK for trunk?
2016-06-23 14:45 GMT-06:00 Mikael <morin-mik...@orange.fr>:
> Le 20/06/2016 22:01, Alessandro Fanfarillo a écrit :
>>
>> Hi Mikael and all,
>>
>> in attachment the new version of the patch.
>> I've addressed all the suggestions except for the stat_se's pre block
>> to se's pre block (commented in the patch for caf_get).
>> Could you please provide a simple example of a complex case? I've
>> already made several test cases and I should be able to produce a
>> complete patch in a couple of days.
>> Thanks,
>>
> Hello,
>
> Second version of comments below.
>
>> diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c
>> index 1430e80..723cc4a 100644
>> --- a/gcc/fortran/array.c
>> +++ b/gcc/fortran/array.c
>> @@ -156,6 +156,7 @@ gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec
>> *as, int init,
>> {
>> match m;
>> bool matched_bracket = false;
>> + gfc_expr *tmp;
>>
>> memset (ar, '\0', sizeof (*ar));
>>
>> @@ -226,6 +227,11 @@ coarray:
>> if (m == MATCH_ERROR)
>> return MATCH_ERROR;
>>
>> + if(gfc_match(",stat = %e",&tmp) == MATCH_YES)
>
> Still some mishandled cases, for example:
>
> tmp = me[i , stat=stat]
>
>
>> + ar->stat = tmp;
>> + else
>> + ar->stat = NULL;
>> +
>> if (gfc_match_char (']') == MATCH_YES)
>> {
>> ar->codimen++;
>> @@ -237,6 +243,14 @@ coarray:
>> }
>> if (ar->codimen > corank)
>> {
>> + /* Entering in this branch means that something bad
>> happened, except
>> + * when stat has been detected. If this is the case, we need
>> to
>> + * decrement the codimension by one. */
>
> OK, I said I didn't understand the code, but that was meaning I didn't
> understand why it is not a problem when stat is there, and why we need to
> decrement by one. I could figure out the rest myself.
> One example I have in mind is this (currently accepted):
>
> integer :: ca[*]
> tmp = ca[1,2,stat=foo]
>
> There is also this case (accepted, is it correct?):
>
> integer :: ca[5, *]
> tmp = ca[1,stat=foo,2]
>
>> + if(ar->stat)
>> + {
>> + ar->codimen--;
>> + return MATCH_YES;
>> + }
>> gfc_error ("Too many codimensions at %C, expected %d not
>> %d",
>> corank, ar->codimen);
>> return MATCH_ERROR;
>
>
>
>> diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
>> index 04339a6..bfffba6 100644
>> --- a/gcc/fortran/trans-decl.c
>> +++ b/gcc/fortran/trans-decl.c
>> @@ -3529,16 +3529,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.RRRW.", void_type_node,
>> 10,
>
> Unless you plan to do strange things in the implementation of get, you can
> probably use W as spec character for stat.
>
>> 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.RRRR.", void_type_node,
>> 10,
>
> same here.
>
>> 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 e5cc907..e11a3d6 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); */
>
>
> You can try this as complex case.
> From visually inspecting it, the code generated passes an uninitialised
> pointer as stat.
>
> program p
> integer :: tmp, a(5)
> integer, target :: t
> integer :: ca[*]
>
> a = 1
> tmp = ca[1,stat=ptr(a + 2)]
>
> contains
> function ptr(a)
> integer :: a(5)
> integer, pointer :: ptr
>
> if (all(a == 3)) then
> ptr => t
> else
> ptr => null()
> end if
> end function ptr
> end program p
>
> Mikael
>
>
commit 1213a0a0b8d7d35480ea485981cb27cab3c1b7bd
Author: Alessandro Fanfarillo <elfa...@ucar.edu>
Date: Wed Jun 29 21:59:29 2016 -0600
Second review of STAT= patch + tests
diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c
index 1430e80..03c8b17 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 d1258cd..7328898 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 6d87632..2f22c32 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -1816,6 +1816,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;
@@ -3067,7 +3068,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 04339a6..c7d8160 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -3529,16 +3529,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 c752889..957719e 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/gfortran.dg/coarray_lib_comm_1.f90
b/gcc/testsuite/gfortran.dg/coarray_lib_comm_1.f90
index d23c9d1..7b4d937 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 0000000..67751a3
--- /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(*,*) failed_images()
+
+ stat = 0
+ if(me == 1) then
+ tmp = func(me[4,stat=stat])
+ if(stat /= 0) write(*,*) me,failed_images()
+ else if(me == 2) then
+ tmp = func2(me[1,stat=stat2],me[3,stat=stat])
+ if(stat2 /= 0 .or. stat /= 0) write(*,*) me,failed_images()
+ 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 0000000..7f260b0
--- /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(*,*) failed_images()
+
+ stat = 0
+
+ if(me == 1) then
+ tmp = me[num_images(),stat = stat]
+ if(stat /= 0) write(*,*) me,failed_images()
+ else if(me == 2) then
+ tmp = me[i,stat=stat]
+ if(stat /= 0) write(*,*) me,failed_images()
+ endif
+
+end program whitespace
ChangeLog
Description: Binary data
