Skip to content

R
riscv-gcc-1
Commit 20d0bfce by Alessandro Fanfarillo Committed by Alessandro Fanfarillo
Options

Second review of STAT= patch + tests 

From-SVN: r238007
parent 1174b21b
Showing with 177 additions and 19 deletions
gcc/fortran/ChangeLog
2016-07-05 Alessandro Fanfarillo <fanfarillo.gcc@gmail.com>
* 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 <vehre@gcc.gnu.org>
PR fortran/71623
......
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++;
......
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)
......
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*);
......
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,
......
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;
......
gcc/testsuite/ChangeLog
2016-07-05 Alessandro Fanfarillo <fanfarillo.gcc@gmail.com>
* 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 <vehre@gcc.gnu.org>
PR fortran/71623
......
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" } }
gcc/testsuite/gfortran.dg/coarray_stat_function.f90 0 → 100644
! { 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" } }
gcc/testsuite/gfortran.dg/coarray_stat_whitespace.f90 0 → 100644
! { 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
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment