Re: [Fortran] Help with STAT= attribute in coarray reference

[Alessandro Fanfarillo <fanfarillo dot gcc at gmail dot com>]

Mikael,

thank a lot for the review. Now that I have (in theory) a complete
coverage of the failed images functionalities (including
https://gcc.gnu.org/ml/fortran/2016-06/msg00019.html) the plan is to
produce several tests and add them to the official patch.

Thanks again.

Regards,
Alessandro

2016-06-13 12:31 GMT-06:00 Mikael Morin <mikael.morin@sfr.fr>:
> Le 13/06/2016 19:16, Alessandro Fanfarillo a Ãcrit :
>>
>> Dear all,
>>
>> in attachment there is a working patch for adding the STAT= attribute
>> to coarray get and put needed by Failed Images (TS 18508).
>>
>> E.g.:
>>
>> integer,dimension(10) :: a[*]
>> integer :: stat
>>
>> a(:) = a(:)[num_images(),stat=stat]
>>
>>
>> In order to pass the variable assigned during the coarray reference I
>> had to modify the gfc_array_ref structure by adding a gfc_expr* field.
>> By doing so, I'm able to store the stat variable in the descriptor and
>> pass it to the OpenCoarrays routines at the right moment.
>>
>> Is there a better way of doing it?
>>
> Array ref and coarray ref should have been separated when we introduced
> coarrays, as they are really different things.
> Appart from that, I think your way is the natural way of doing it.
>
> Comments below about the patch. It's mostly good.
>
>
>> diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c
>> index 1430e80..232bae7 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)
>
> Add spaces between the tokens to match for optional whitespace.
> (tests welcome for this)
> An error is missing for multiple stat=
> (tests welcome as well)
>
>> +       ar->stat = tmp;
>> +      else
>> +       ar->stat = NULL;
>> +
>>        if (gfc_match_char (']') == MATCH_YES)
>>         {
>>           ar->codimen++;
>> @@ -237,6 +243,11 @@ coarray:
>>             }
>>           if (ar->codimen > corank)
>>             {
>> +             if(ar->stat)
>> +               {
>> +                 ar->codimen--;
>> +                 return MATCH_YES;
>> +               }
>
> I don't understand this change.
> If there are some extra codimension refs and a stat argument, you should
> still emit a "Too many codimensions" error.
> (Tests welcome for this)
>
>>               gfc_error ("Too many codimensions at %C, expected %d not
>> %d",
>>                          corank, ar->codimen);
>>               return MATCH_ERROR;
>> diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
>> index d1258cd..34a3557 100644
>> --- a/gcc/fortran/expr.c
>> +++ b/gcc/fortran/expr.c
>> @@ -4428,6 +4428,16 @@ 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;
>> +  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/resolve.c b/gcc/fortran/resolve.c
>> index f56bdf1..54be70e 100644
>> --- a/gcc/fortran/resolve.c
>> +++ b/gcc/fortran/resolve.c
>> @@ -4169,7 +4169,7 @@ compare_spec_to_ref (gfc_array_ref *ar)
>>      }
>>
>>    /* ar->codimen == 0 is a local array.  */
>> -  if (as->corank != ar->codimen && ar->codimen != 0)
>> +  if (as->corank != ar->codimen && ar->codimen != 0 && !ar->stat)
>
> I think stat is irrelevant here.
>
>>      {
>>        gfc_error ("Coindex rank mismatch in array reference at %L
>> (%d/%d)",
>>                  &ar->where, ar->codimen, as->corank);
>> diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
>> index 04339a6..1ee548a 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,
>
> The spec string ".R.RRRW" should be updated as well.
>
>>          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);
>> +       integer_type_node, boolean_type_node);
>>
>>        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);
>> +       pint_type, boolean_type_node);
>>
>>        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..7d8123b 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,16 @@ 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)
>
> Space after if
>
>> +    {
>
> Call gfc_init_se.
>
>> +      gfc_conv_expr_val (se, tmp_stat);
>
> It's better to have one dedicated se per expression, like you did for send.
>
>> +      stat = se->expr;
>> +      stat = gfc_build_addr_expr (NULL, stat);
>
> You can use gfc_conv_expr_reference directly.
>
>> +    }
>> +  else
>> +    stat = null_pointer_node;
>>
>>    gfc_init_se (&argse, NULL);
>>    if (array_expr->rank == 0)
>> @@ -1219,9 +1229,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, stat,
>> may_require_tmp);
>>    gfc_add_expr_to_block (&se->pre, tmp);
>>
>>    if (se->ss)
>> @@ -1237,11 +1247,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 +1263,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 +1387,24 @@ 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)
>
> space after if
>
>> +    {
>> +      gfc_se stat_se;
>> +      gfc_init_se (&stat_se, NULL);
>> +      gfc_conv_expr_val (&stat_se, tmp_stat);
>> +      stat = stat_se.expr;
>> +      stat = gfc_build_addr_expr (NULL, stat);
>
> gfc_conv_expr_reference
> For complex cases (say, pointer-returning functions), you'll need to add
> stat_se's pre block to se's pre block.
> (Tests welcome for this)
>
>> +    }
>> +  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, stat,
>> +                              may_require_tmp);
>>    else
>>      {
>>        tree rhs_token, rhs_offset, rhs_image_index;
>
>
> More tests welcome ;-)