Thanks Andre. 2016-09-19 9:55 GMT-06:00 Andre Vehreschild <ve...@gmx.de>: > Hi Alessandro,
> The if in resolve.c at 8837: resolve_failed_image (... is intentional? It is > doing nothing. So do you plan to add more code, or will there never be > anything. If the later I recommend to just put a comment there and remove the > empty if. I added the if statement during the development and I forgot to remove it. > > There still is no test when -fcoarray=single is used. This shouldn't be so > hard, should it? Done. Built and regtested on x86_64-pc-linux-gnu. > > Regards, > Andre > > On Mon, 19 Sep 2016 08:30:12 -0700 > Alessandro Fanfarillo <fanfarillo....@gmail.com> wrote: > >> * PING * >> >> On Sep 7, 2016 3:01 PM, "Alessandro Fanfarillo" <fanfarillo....@gmail.com> >> wrote: >> >> > Dear all, >> > the attached patch supports failed images also when -fcoarray=single is >> > used. >> > >> > Built and regtested on x86_64-pc-linux-gnu. >> > >> > Cheers, >> > Alessandro >> > >> > 2016-08-09 5:22 GMT-06:00 Paul Richard Thomas < >> > paul.richard.tho...@gmail.com>: >> > > Hi Sandro, >> > > >> > > As far as I can see, this is OK barring a couple of minor wrinkles and >> > > a question: >> > > >> > > For coarray_failed_images_err.f90 and coarray_image_status_err.f90 you >> > > have used the option -fdump-tree-original without making use of the >> > > tree dump. >> > > >> > > Mikael asked you to provide an executable test with -fcoarray=single. >> > > Is this not possible for some reason? >> > > >> > > Otherwise, this is OK for trunk. >> > > >> > > Thanks for the patch. >> > > >> > > Paul >> > > >> > > On 4 August 2016 at 05:07, Alessandro Fanfarillo >> > > <fanfarillo....@gmail.com> wrote: >> > >> * PING * >> > >> >> > >> 2016-07-21 13:05 GMT-06:00 Alessandro Fanfarillo < >> > fanfarillo....@gmail.com>: >> > >>> Dear Mikael and all, >> > >>> >> > >>> in attachment the new patch, built and regtested on >> > x86_64-pc-linux-gnu. >> > >>> >> > >>> Cheers, >> > >>> Alessandro >> > >>> >> > >>> 2016-07-20 13:17 GMT-06:00 Mikael Morin <morin-mik...@orange.fr>: >> > >>>> Le 20/07/2016 à 11:39, Andre Vehreschild a écrit : >> > >>>>> >> > >>>>> Hi Mikael, >> > >>>>> >> > >>>>> >> > >>>>>>> + if(st == ST_FAIL_IMAGE) >> > >>>>>>> + new_st.op = EXEC_FAIL_IMAGE; >> > >>>>>>> + else >> > >>>>>>> + gcc_unreachable(); >> > >>>>>> >> > >>>>>> You can use >> > >>>>>> gcc_assert (st == ST_FAIL_IMAGE); >> > >>>>>> foo...; >> > >>>>>> instead of >> > >>>>>> if (st == ST_FAIL_IMAGE) >> > >>>>>> foo...; >> > >>>>>> else >> > >>>>>> gcc_unreachable (); >> > >>>>> >> > >>>>> >> > >>>>> Be careful, this is not 100% identical in the general case. For older >> > >>>>> gcc version (gcc < 4008) gcc_assert() is mapped to nothing, esp. not >> > to >> > >>>>> an abort(), so the behavior can change. But in this case everything >> > is >> > >>>>> fine, because the patch is most likely not backported. >> > >>>>> >> > >>>> Didn't know about this. The difference seems to be very subtle. >> > >>>> I don't mind much anyway. The original version can stay if preferred, >> > this >> > >>>> was just a suggestion. >> > >>>> >> > >>>> By the way, if the function is inlined in its single caller, the >> > assert or >> > >>>> unreachable statement can be removed, which avoids choosing between >> > them. >> > >>>> That's another suggestion. >> > >>>> >> > >>>> >> > >>>>>>> + >> > >>>>>>> + return MATCH_YES; >> > >>>>>>> + >> > >>>>>>> + syntax: >> > >>>>>>> + gfc_syntax_error (st); >> > >>>>>>> + >> > >>>>>>> + return MATCH_ERROR; >> > >>>>>>> +} >> > >>>>>>> + >> > >>>>>>> +match >> > >>>>>>> +gfc_match_fail_image (void) >> > >>>>>>> +{ >> > >>>>>>> + /* if (!gfc_notify_std (GFC_STD_F2008_TS, "FAIL IMAGE statement >> > >>>>>>> at %C")) */ >> > >>>>>>> + /* return MATCH_ERROR; */ >> > >>>>>>> + >> > >>>>>> >> > >>>>>> Can this be uncommented? >> > >>>>>> >> > >>>>>>> + return fail_image_statement (ST_FAIL_IMAGE); >> > >>>>>>> +} >> > >>>>>>> >> > >>>>>>> /* Match LOCK/UNLOCK statement. Syntax: >> > >>>>>>> LOCK ( lock-variable [ , lock-stat-list ] ) >> > >>>>>>> diff --git a/gcc/fortran/trans-intrinsic.c >> > >>>>>>> b/gcc/fortran/trans-intrinsic.c index 1aaf4e2..b2f5596 100644 >> > >>>>>>> --- a/gcc/fortran/trans-intrinsic.c >> > >>>>>>> +++ b/gcc/fortran/trans-intrinsic.c >> > >>>>>>> @@ -1647,6 +1647,24 @@ trans_this_image (gfc_se * se, gfc_expr >> > >>>>>>> *expr) m, lbound)); >> > >>>>>>> } >> > >>>>>>> >> > >>>>>>> +static void >> > >>>>>>> +gfc_conv_intrinsic_image_status (gfc_se *se, gfc_expr *expr) >> > >>>>>>> +{ >> > >>>>>>> + unsigned int num_args; >> > >>>>>>> + tree *args,tmp; >> > >>>>>>> + >> > >>>>>>> + num_args = gfc_intrinsic_argument_list_length (expr); >> > >>>>>>> + args = XALLOCAVEC (tree, num_args); >> > >>>>>>> + >> > >>>>>>> + gfc_conv_intrinsic_function_args (se, expr, args, num_args); >> > >>>>>>> + >> > >>>>>>> + if (flag_coarray == GFC_FCOARRAY_LIB) >> > >>>>>>> + { >> > >>>>>> >> > >>>>>> Can everything be put under the if? >> > >>>>>> Does it work with -fcoarray=single? >> > >>>>> >> > >>>>> >> > >>>>> IMO coarray=single should not generate code here, therefore putting >> > >>>>> everything under the if should to fine. >> > >>>>> >> > >>>> My point was more avoiding generating code for the arguments if they >> > are not >> > >>>> used in the end. >> > >>>> Regarding the -fcoarray=single case, the function returns a result, >> > which >> > >>>> can be used in an expression, so I don't think it will work without >> > at least >> > >>>> hardcoding a fixed value as result in that case. >> > >>>> But even that wouldn't be enough, as the function wouldn't work >> > consistently >> > >>>> with the fail image statement. >> > >>>> >> > >>>>> Sorry for the comments ... >> > >>>>> >> > >>>> Comments are welcome here, as far as I know. ;-) >> > >>>> >> > >>>> Mikael >> > > >> > > >> > > >> > > -- >> > > The difference between genius and stupidity is; genius has its limits. >> > > >> > > Albert Einstein >> > > > > -- > Andre Vehreschild * Email: vehre ad gmx dot de
commit a5750c4835566687505c34f73562c7cc3b220841 Author: Alessandro Fanfarillo <elfa...@ucar.edu> Date: Wed Sep 21 12:00:50 2016 -0600 Third review of failed images patch diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index ff5e80b..110bec0 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -1217,6 +1217,82 @@ gfc_check_event_query (gfc_expr *event, gfc_expr *count, gfc_expr *stat) return true; } +bool +gfc_check_image_status (gfc_expr *image, gfc_expr *team) +{ + if (!type_check (image, 1, BT_INTEGER)) + return false; + + int i = gfc_validate_kind (BT_INTEGER, image->ts.kind, false); + int j = gfc_validate_kind (BT_INTEGER, gfc_default_integer_kind, false); + + if (gfc_integer_kinds[i].range < gfc_integer_kinds[j].range) + { + gfc_error ("IMAGE argument of the IMAGE_STATUS intrinsic function at %L " + "shall have at least the range of the default integer", + &image->where); + return false; + } + + j = gfc_validate_kind (BT_INTEGER, gfc_default_integer_kind*2, false); + + if (gfc_integer_kinds[i].range > gfc_integer_kinds[j].range) + { + gfc_error ("IMAGE argument of the IMAGE_STATUS intrinsic function at %L " + "shall have at most the range of the double precision integer", + &image->where); + return false; + } + + if (team) + { + gfc_error ("TEAM argument of the IMAGE_STATUS intrinsic function at %L " + "not yet supported", + &team->where); + return false; + } + + return true; +} + +bool +gfc_check_failed_images (gfc_expr *team, gfc_expr *kind) +{ + if (team) + { + gfc_error ("TEAM argument of the FAILED_IMAGES intrinsic function " + "at %L not yet supported", &team->where); + return false; + } + + if (kind) + { + int i = gfc_validate_kind (BT_INTEGER, kind->ts.kind, false); + int j = gfc_validate_kind (BT_INTEGER, gfc_default_integer_kind, false); + + if (gfc_integer_kinds[i].range < gfc_integer_kinds[j].range) + { + gfc_error ("KIND argument of the FAILED_IMAGES intrinsic function " + "at %L shall have at least the range " + "of the default integer", &kind->where); + return false; + } + + j = gfc_validate_kind (BT_INTEGER, gfc_default_integer_kind*2, false); + + if (gfc_integer_kinds[i].range > gfc_integer_kinds[j].range) + { + gfc_error ("KIND argument of the FAILED_IMAGES " + "intrinsic function at %L shall have at most the " + "range of the double precision integer", + &kind->where); + return false; + } + } + + return true; +} + bool gfc_check_atomic_fetch_op (gfc_expr *atom, gfc_expr *value, gfc_expr *old, diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c index 8c24074..e731916 100644 --- a/gcc/fortran/dump-parse-tree.c +++ b/gcc/fortran/dump-parse-tree.c @@ -1636,6 +1636,9 @@ show_code_node (int level, gfc_code *c) break; + case EXEC_FAIL_IMAGE: + fputs ("FAIL IMAGE ", dumpfile); + case EXEC_SYNC_ALL: fputs ("SYNC ALL ", dumpfile); if (c->expr2 != NULL) diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index c3fb6ed..c617340 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -255,7 +255,7 @@ enum gfc_statement ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD, ST_PROCEDURE, ST_GENERIC, ST_CRITICAL, ST_END_CRITICAL, ST_GET_FCN_CHARACTERISTICS, ST_LOCK, ST_UNLOCK, ST_EVENT_POST, - ST_EVENT_WAIT,ST_NONE + ST_EVENT_WAIT,ST_FAIL_IMAGE,ST_NONE }; /* Types of interfaces that we can have. Assignment interfaces are @@ -420,6 +420,7 @@ enum gfc_isym_id GFC_ISYM_EXP, GFC_ISYM_EXPONENT, GFC_ISYM_EXTENDS_TYPE_OF, + GFC_ISYM_FAILED_IMAGES, GFC_ISYM_FDATE, GFC_ISYM_FE_RUNTIME_ERROR, GFC_ISYM_FGET, @@ -463,6 +464,7 @@ enum gfc_isym_id GFC_ISYM_IEOR, GFC_ISYM_IERRNO, GFC_ISYM_IMAGE_INDEX, + GFC_ISYM_IMAGE_STATUS, GFC_ISYM_INDEX, GFC_ISYM_INT, GFC_ISYM_INT2, @@ -2395,7 +2397,7 @@ enum gfc_exec_op EXEC_OPEN, EXEC_CLOSE, EXEC_WAIT, EXEC_READ, EXEC_WRITE, EXEC_IOLENGTH, EXEC_TRANSFER, EXEC_DT_END, EXEC_BACKSPACE, EXEC_ENDFILE, EXEC_INQUIRE, EXEC_REWIND, EXEC_FLUSH, - EXEC_LOCK, EXEC_UNLOCK, EXEC_EVENT_POST, EXEC_EVENT_WAIT, + EXEC_LOCK, EXEC_UNLOCK, EXEC_EVENT_POST, EXEC_EVENT_WAIT, EXEC_FAIL_IMAGE, EXEC_OACC_KERNELS_LOOP, EXEC_OACC_PARALLEL_LOOP, EXEC_OACC_ROUTINE, EXEC_OACC_PARALLEL, EXEC_OACC_KERNELS, EXEC_OACC_DATA, EXEC_OACC_HOST_DATA, EXEC_OACC_LOOP, EXEC_OACC_UPDATE, EXEC_OACC_WAIT, EXEC_OACC_CACHE, diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index cad54b8..ac0dd5e 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -1840,6 +1840,12 @@ add_functions (void) a, BT_UNKNOWN, 0, REQUIRED, mo, BT_UNKNOWN, 0, REQUIRED); + add_sym_2 ("failed_images", GFC_ISYM_FAILED_IMAGES, CLASS_TRANSFORMATIONAL, + ACTUAL_NO, BT_INTEGER, dd, GFC_STD_F2008_TS, + gfc_check_failed_images, gfc_simplify_failed_images, + gfc_resolve_failed_images, "team", BT_INTEGER, di, OPTIONAL, + "kind", BT_INTEGER, di, OPTIONAL); + add_sym_0 ("fdate", GFC_ISYM_FDATE, CLASS_IMPURE, ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_GNU, NULL, NULL, gfc_resolve_fdate); @@ -2081,6 +2087,11 @@ add_functions (void) gfc_check_image_index, gfc_simplify_image_index, gfc_resolve_image_index, ca, BT_REAL, dr, REQUIRED, sub, BT_INTEGER, ii, REQUIRED); + add_sym_2 ("image_status", GFC_ISYM_IMAGE_STATUS, CLASS_ELEMENTAL, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_F2008_TS, gfc_check_image_status, + gfc_simplify_image_status, gfc_resolve_image_status, "image", + BT_INTEGER, di, REQUIRED, "team", BT_INTEGER, di, OPTIONAL); + /* The resolution function for INDEX is called gfc_resolve_index_func because the name gfc_resolve_index is already used in resolve.c. */ add_sym_4 ("index", GFC_ISYM_INDEX, CLASS_ELEMENTAL, ACTUAL_YES, diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index f228976..ae488e8 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -71,6 +71,7 @@ bool gfc_check_dshift (gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_eoshift (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_dtime_etime (gfc_expr *); bool gfc_check_event_query (gfc_expr *, gfc_expr *, gfc_expr *); +bool gfc_check_failed_images (gfc_expr *, gfc_expr *); bool gfc_check_fgetputc (gfc_expr *, gfc_expr *); bool gfc_check_fgetput (gfc_expr *); bool gfc_check_float (gfc_expr *); @@ -92,6 +93,7 @@ bool gfc_check_ibits (gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_ichar_iachar (gfc_expr *, gfc_expr *); bool gfc_check_idnint (gfc_expr *); bool gfc_check_ieor (gfc_expr *, gfc_expr *); +bool gfc_check_image_status (gfc_expr *, gfc_expr *); bool gfc_check_index (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_int (gfc_expr *, gfc_expr *); bool gfc_check_intconv (gfc_expr *); @@ -289,6 +291,7 @@ gfc_expr *gfc_simplify_erfc_scaled (gfc_expr *); gfc_expr *gfc_simplify_exp (gfc_expr *); gfc_expr *gfc_simplify_exponent (gfc_expr *); gfc_expr *gfc_simplify_extends_type_of (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_failed_images (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_float (gfc_expr *); gfc_expr *gfc_simplify_floor (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_fraction (gfc_expr *); @@ -305,6 +308,7 @@ gfc_expr *gfc_simplify_ibset (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_ichar (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_ieor (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_image_index (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_image_status (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_index (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_int (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_int2 (gfc_expr *); @@ -467,6 +471,7 @@ void gfc_resolve_event_query (gfc_code *); void gfc_resolve_exp (gfc_expr *, gfc_expr *); void gfc_resolve_exponent (gfc_expr *, gfc_expr *); void gfc_resolve_extends_type_of (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_failed_images (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_fdate (gfc_expr *); void gfc_resolve_floor (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_fnum (gfc_expr *, gfc_expr *); @@ -490,6 +495,7 @@ void gfc_resolve_ibclr (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_ibits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_ibset (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_image_index (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_image_status (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_index_func (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_ierrno (gfc_expr *); diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index ecea1c3..dc05cd3 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -2577,6 +2577,30 @@ gfc_resolve_tanh (gfc_expr *f, gfc_expr *x) = gfc_get_string ("__tanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind); } +void +gfc_resolve_failed_images (gfc_expr *f, gfc_expr *team ATTRIBUTE_UNUSED, + gfc_expr *kind) +{ + static char failed_images[] = "_gfortran_caf_failed_images"; + f->rank = 1; + f->ts.type = BT_INTEGER; + if (kind == NULL) + f->ts.kind = gfc_default_integer_kind; + else + f->ts.kind = kind->ts.kind; + f->value.function.name = failed_images; +} + +void +gfc_resolve_image_status (gfc_expr *f, gfc_expr *image, + gfc_expr *team ATTRIBUTE_UNUSED) +{ + static char image_status[] = "_gfortran_caf_image_status"; + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_default_integer_kind; + f->ts = image->ts; + f->value.function.name = image_status; +} void gfc_resolve_image_index (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED, diff --git a/gcc/fortran/libgfortran.h b/gcc/fortran/libgfortran.h index e913250..f00ed83 100644 --- a/gcc/fortran/libgfortran.h +++ b/gcc/fortran/libgfortran.h @@ -123,7 +123,7 @@ typedef enum GFC_STAT_LOCKED, GFC_STAT_LOCKED_OTHER_IMAGE, GFC_STAT_STOPPED_IMAGE = 6000, /* See LIBERROR_INQUIRE_INTERNAL_UNIT above. */ - GFC_STAT_FAILED_IMAGE + GFC_STAT_FAILED_IMAGE = 6001 } libgfortran_stat_codes; diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 9056cb7..8916767 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -1600,6 +1600,7 @@ gfc_match_if (gfc_statement *if_type) match ("event post", gfc_match_event_post, ST_EVENT_POST) match ("event wait", gfc_match_event_wait, ST_EVENT_WAIT) match ("exit", gfc_match_exit, ST_EXIT) + match ("fail image", gfc_match_fail_image, ST_FAIL_IMAGE) match ("flush", gfc_match_flush, ST_FLUSH) match ("forall", match_simple_forall, ST_FORALL) match ("go to", gfc_match_goto, ST_GOTO) @@ -3079,6 +3080,34 @@ gfc_match_event_wait (void) return event_statement (ST_EVENT_WAIT); } +/* Match a FAIL IMAGE statement. */ + +static match +fail_image_statement (gfc_statement st) +{ + if (gfc_match_char ('(') == MATCH_YES) + goto syntax; + + gcc_assert (st == ST_FAIL_IMAGE); + + new_st.op = EXEC_FAIL_IMAGE; + + return MATCH_YES; + + syntax: + gfc_syntax_error (st); + + return MATCH_ERROR; +} + +match +gfc_match_fail_image (void) +{ + if (!gfc_notify_std (GFC_STD_F2008_TS, "FAIL IMAGE statement at %C")) + return MATCH_ERROR; + + return fail_image_statement (ST_FAIL_IMAGE); +} /* Match LOCK/UNLOCK statement. Syntax: LOCK ( lock-variable [ , lock-stat-list ] ) diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h index 348ca70..4e4b833 100644 --- a/gcc/fortran/match.h +++ b/gcc/fortran/match.h @@ -72,6 +72,7 @@ match gfc_match_else (void); match gfc_match_elseif (void); match gfc_match_event_post (void); match gfc_match_event_wait (void); +match gfc_match_fail_image (void); match gfc_match_critical (void); match gfc_match_block (void); match gfc_match_associate (void); diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index d78a2c0..3722075 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -483,6 +483,7 @@ decode_statement (void) break; case 'f': + match ("fail image", gfc_match_fail_image, ST_FAIL_IMAGE); match ("final", gfc_match_final_decl, ST_FINAL); match ("flush", gfc_match_flush, ST_FLUSH); match ("format", gfc_match_format, ST_FORMAT); @@ -1419,7 +1420,7 @@ next_statement (void) case ST_OMP_CANCEL: case ST_OMP_CANCELLATION_POINT: \ case ST_OMP_TARGET_UPDATE: case ST_ERROR_STOP: case ST_SYNC_ALL: \ case ST_SYNC_IMAGES: case ST_SYNC_MEMORY: case ST_LOCK: case ST_UNLOCK: \ - case ST_EVENT_POST: case ST_EVENT_WAIT: \ + case ST_EVENT_POST: case ST_EVENT_WAIT: case ST_FAIL_IMAGE: \ case ST_OACC_UPDATE: case ST_OACC_WAIT: case ST_OACC_CACHE: \ case ST_OACC_ENTER_DATA: case ST_OACC_EXIT_DATA @@ -1745,6 +1746,9 @@ gfc_ascii_statement (gfc_statement st) case ST_EVENT_WAIT: p = "EVENT WAIT"; break; + case ST_FAIL_IMAGE: + p = "FAIL IMAGE"; + break; case ST_END_ASSOCIATE: p = "END ASSOCIATE"; break; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 11b6a14..57c759a 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -8859,6 +8859,11 @@ find_reachable_labels (gfc_code *block) } } +static void +resolve_fail_image (gfc_code *code ATTRIBUTE_UNUSED) +{ + return; +} static void resolve_lock_unlock_event (gfc_code *code) @@ -10607,6 +10612,10 @@ start: resolve_lock_unlock_event (code); break; + case EXEC_FAIL_IMAGE: + resolve_fail_image (code); + break; + case EXEC_ENTRY: /* Keep track of which entry we are up to. */ current_entry_id = code->ext.entry->id; diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index ad547a1..5e55f02 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -2312,6 +2312,26 @@ gfc_simplify_exponent (gfc_expr *x) return range_check (result, "EXPONENT"); } +gfc_expr * +gfc_simplify_failed_images (gfc_expr *team ATTRIBUTE_UNUSED, gfc_expr *kind) +{ + gfc_expr *result; + int actual_kind; + + if (flag_coarray != GFC_FCOARRAY_SINGLE) + return NULL; + + if (!kind) + actual_kind = gfc_default_integer_kind; + else + actual_kind = kind->ts.kind; + + result = transformational_result (result, NULL, BT_INTEGER, actual_kind, + &gfc_current_locus); + init_result_expr (result, 0, NULL); + result = simplify_transformation (result, NULL, NULL, 0, NULL); + return result; +} gfc_expr * gfc_simplify_float (gfc_expr *a) @@ -6578,6 +6598,20 @@ gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub) return result; } +gfc_expr * +gfc_simplify_image_status (gfc_expr *image ATTRIBUTE_UNUSED, + gfc_expr *team ATTRIBUTE_UNUSED) +{ + if (flag_coarray != GFC_FCOARRAY_SINGLE) + return NULL; + + gfc_expr *result; + /* FIXME: gfc_current_locus is wrong. */ + result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, + &gfc_current_locus); + mpz_set_si (result->value.integer, 0); + return result; +} gfc_expr * gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim, diff --git a/gcc/fortran/st.c b/gcc/fortran/st.c index 7395497..b3a6721 100644 --- a/gcc/fortran/st.c +++ b/gcc/fortran/st.c @@ -120,6 +120,7 @@ gfc_free_statement (gfc_code *p) case EXEC_UNLOCK: case EXEC_EVENT_POST: case EXEC_EVENT_WAIT: + case EXEC_FAIL_IMAGE: break; case EXEC_BLOCK: diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 1bab5d5..ed9f89f 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -154,6 +154,9 @@ tree gfor_fndecl_caf_unlock; tree gfor_fndecl_caf_event_post; tree gfor_fndecl_caf_event_wait; tree gfor_fndecl_caf_event_query; +tree gfor_fndecl_caf_fail_image; +tree gfor_fndecl_caf_failed_images; +tree gfor_fndecl_caf_image_status; tree gfor_fndecl_co_broadcast; tree gfor_fndecl_co_max; tree gfor_fndecl_co_min; @@ -3694,6 +3697,18 @@ gfc_build_builtin_function_decls (void) void_type_node, 5, pvoid_type_node, size_type_node, integer_type_node, pint_type, pint_type); + gfor_fndecl_caf_fail_image = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("caf_fail_image")), "R", + void_type_node, 1, pvoid_type_node); + + gfor_fndecl_caf_failed_images = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("caf_failed_images")), "WRR", pvoid_type_node, + 3, pvoid_type_node, integer_type_node, integer_type_node); + + gfor_fndecl_caf_image_status = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("caf_image_status")), "RR", + integer_type_node, 2, integer_type_node, integer_type_node); + gfor_fndecl_co_broadcast = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("caf_co_broadcast")), "W.WW", void_type_node, 5, pvoid_type_node, integer_type_node, diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 9fcd6a1..5aadc6c 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -6239,10 +6239,11 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, components must have the result allocatable components copied. */ arg = expr->value.function.actual; if (result && arg && expr->rank - && expr->value.function.isym - && expr->value.function.isym->transformational - && arg->expr->ts.type == BT_DERIVED - && arg->expr->ts.u.derived->attr.alloc_comp) + && expr->value.function.isym + && expr->value.function.isym->transformational + && arg->expr + && arg->expr->ts.type == BT_DERIVED + && arg->expr->ts.u.derived->attr.alloc_comp) { tree tmp2; /* Copy the allocatable components. We have to use a diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index c6883dc..b0b721f 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -2360,6 +2360,19 @@ trans_this_image (gfc_se * se, gfc_expr *expr) m, lbound)); } +static void +gfc_conv_intrinsic_image_status (gfc_se *se, gfc_expr *expr) +{ + unsigned int num_args; + tree *args,tmp; + + num_args = gfc_intrinsic_argument_list_length (expr); + args = XALLOCAVEC (tree, num_args); + gfc_conv_intrinsic_function_args (se, expr, args, num_args); + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_image_status, 2, + args[0], build_int_cst (integer_type_node, -1)); + se->expr = tmp; +} static void trans_image_index (gfc_se * se, gfc_expr *expr) @@ -9017,6 +9030,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) trans_image_index (se, expr); break; + case GFC_ISYM_IMAGE_STATUS: + gfc_conv_intrinsic_image_status (se, expr); + break; + case GFC_ISYM_NUM_IMAGES: trans_num_images (se, expr); break; @@ -9367,10 +9384,11 @@ gfc_is_intrinsic_libcall (gfc_expr * expr) /* Ignore absent optional parameters. */ return 1; - case GFC_ISYM_RESHAPE: case GFC_ISYM_CSHIFT: case GFC_ISYM_EOSHIFT: + case GFC_ISYM_FAILED_IMAGES: case GFC_ISYM_PACK: + case GFC_ISYM_RESHAPE: case GFC_ISYM_UNPACK: /* Pass absent optional parameters. */ return 2; diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 9fdacc1..22c37ee 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -674,6 +674,32 @@ gfc_trans_stop (gfc_code *code, bool error_stop) return gfc_finish_block (&se.pre); } +/* Translate the FAIL IMAGE statement. We have to translate this statement + to a runtime library call. */ + +tree +gfc_trans_fail_image (gfc_code *code ATTRIBUTE_UNUSED) +{ + gfc_se se; + tree tmp; + + /* Start a new block for this statement. */ + gfc_init_se (&se, NULL); + gfc_start_block (&se.pre); + + if (flag_coarray == GFC_FCOARRAY_LIB) + tmp = build_call_expr_loc (input_location, + gfor_fndecl_caf_fail_image, 1, + build_int_cst (pchar_type_node, 0)); + else + tmp = build_call_expr_loc (input_location, + gfor_fndecl_stop_string, 1, + build_int_cst (pchar_type_node, 1)); + + gfc_add_expr_to_block (&se.pre, tmp); + gfc_add_block_to_block (&se.pre, &se.post); + return gfc_finish_block (&se.pre); +} tree gfc_trans_lock_unlock (gfc_code *code, gfc_exec_op op) diff --git a/gcc/fortran/trans-stmt.h b/gcc/fortran/trans-stmt.h index f9c8e74..4b5b4fc 100644 --- a/gcc/fortran/trans-stmt.h +++ b/gcc/fortran/trans-stmt.h @@ -56,6 +56,7 @@ tree gfc_trans_select (gfc_code *); tree gfc_trans_sync (gfc_code *, gfc_exec_op); tree gfc_trans_lock_unlock (gfc_code *, gfc_exec_op); tree gfc_trans_event_post_wait (gfc_code *, gfc_exec_op); +tree gfc_trans_fail_image (gfc_code *); tree gfc_trans_forall (gfc_code *); tree gfc_trans_where (gfc_code *); tree gfc_trans_allocate (gfc_code *); diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index 9210e0f..827e0bf 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -1858,6 +1858,10 @@ trans_code (gfc_code * code, tree cond) res = gfc_trans_event_post_wait (code, code->op); break; + case EXEC_FAIL_IMAGE: + res = gfc_trans_fail_image (code); + break; + case EXEC_FORALL: res = gfc_trans_forall (code); break; diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 4d3d207..4641ace 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -800,6 +800,9 @@ extern GTY(()) tree gfor_fndecl_caf_unlock; extern GTY(()) tree gfor_fndecl_caf_event_post; extern GTY(()) tree gfor_fndecl_caf_event_wait; extern GTY(()) tree gfor_fndecl_caf_event_query; +extern GTY(()) tree gfor_fndecl_caf_fail_image; +extern GTY(()) tree gfor_fndecl_caf_failed_images; +extern GTY(()) tree gfor_fndecl_caf_image_status; extern GTY(()) tree gfor_fndecl_co_broadcast; extern GTY(()) tree gfor_fndecl_co_max; extern GTY(()) tree gfor_fndecl_co_min; diff --git a/gcc/testsuite/gfortran.dg/coarray/fail_st.f90 b/gcc/testsuite/gfortran.dg/coarray/fail_st.f90 new file mode 100644 index 0000000..b6e50e0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray/fail_st.f90 @@ -0,0 +1,9 @@ +! { dg-do run } +! { dg-options "-fcoarray=single" } +! +program fail_statement + implicit none + + fail image + +end program fail_statement diff --git a/gcc/testsuite/gfortran.dg/coarray/failed_images_single.f90 b/gcc/testsuite/gfortran.dg/coarray/failed_images_single.f90 new file mode 100644 index 0000000..5583fef --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray/failed_images_single.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! { dg-options "-fcoarray=single -lcaf_single" } +! +program test_failed_images + use iso_fortran_env + implicit none + + integer, allocatable :: failed(:) + + failed = failed_images() + + write(*,*) failed,lbound(failed),ubound(failed) + write(*,*) failed_images() + +end program test_failed_images diff --git a/gcc/testsuite/gfortran.dg/coarray/image_status_single.f90 b/gcc/testsuite/gfortran.dg/coarray/image_status_single.f90 new file mode 100644 index 0000000..71d58b4 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray/image_status_single.f90 @@ -0,0 +1,9 @@ +! { dg-do run } +! { dg-options "-fcoarray=single" } +! +program test_image_status + implicit none + + write(*,*) image_status(1) + +end program test_image_status diff --git a/gcc/testsuite/gfortran.dg/coarray_fail_st.f90 b/gcc/testsuite/gfortran.dg/coarray_fail_st.f90 new file mode 100644 index 0000000..d4eb8e2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_fail_st.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original -fcoarray=lib" } +! +program fail_statement + implicit none + + integer :: me,np,stat + + me = this_image() + np = num_images() + stat = 0 + + if(me == 1) fail image + + sync all(stat=stat) + + if(stat /= 0) write(*,*) 'Image failed during sync' + +end program fail_statement + +! { dg-final { scan-tree-dump-times "_gfortran_caf_fail_image \\\(0B\\\);" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/coarray_failed_images.f90 b/gcc/testsuite/gfortran.dg/coarray_failed_images.f90 new file mode 100644 index 0000000..b64ed25 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_failed_images.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original -fcoarray=lib" } +! +program test_failed_images + implicit none + + integer :: me,np,stat + character(len=1) :: c + + me = this_image() + np = num_images() + stat = 0 + + sync all(stat=stat) + + if(stat /= 0) then + write(*,*) failed_images() + endif +end program test_failed_images + +! { dg-final { scan-tree-dump-times "_gfortran_caf_failed_images \\\(&atmp.1, 0B, 0B\\\);" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/coarray_failed_images_err.f90 b/gcc/testsuite/gfortran.dg/coarray_failed_images_err.f90 new file mode 100644 index 0000000..c3b1a79 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_failed_images_err.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib" } +! +program test_failed_images_err + implicit none + + integer :: me,np,stat + character(len=1) :: c + + me = this_image() + np = num_images() + stat = 0 + + sync all(stat=stat) + + if(stat /= 0) then + write(*,*) failed_images(me) ! { dg-error "TEAM argument of the FAILED_IMAGES intrinsic function at .1. not yet supported" } + endif +end program test_failed_images_err diff --git a/gcc/testsuite/gfortran.dg/coarray_image_status.f90 b/gcc/testsuite/gfortran.dg/coarray_image_status.f90 new file mode 100644 index 0000000..9145da7 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_image_status.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original -fcoarray=lib" } +! +program test_image_status + implicit none + + integer :: me,np,stat + character(len=1) :: c + + me = this_image() + np = num_images() + stat = 0 + + sync all(stat=stat) + + if(stat /= 0) then + write(*,*) image_status(1) + endif +end program test_image_status + +! { dg-final { scan-tree-dump-times "_gfortran_caf_image_status \\\(1, -1\\\);" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/coarray_image_status_err.f90 b/gcc/testsuite/gfortran.dg/coarray_image_status_err.f90 new file mode 100644 index 0000000..bf36f59 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_image_status_err.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib" } +! +program test_image_status_err + implicit none + + integer :: me,np,stat + character(len=1) :: c + + me = this_image() + np = num_images() + stat = 0 + + sync all(stat=stat) + + if(stat /= 0) then + write(*,*) image_status(1,team=1) ! { dg-error "TEAM argument of the IMAGE_STATUS intrinsic function at .1. not yet supported" } + endif +end program test_image_status_err diff --git a/libgfortran/caf/libcaf.h b/libgfortran/caf/libcaf.h index aad0f62..8e10ba6 100644 --- a/libgfortran/caf/libcaf.h +++ b/libgfortran/caf/libcaf.h @@ -231,5 +231,7 @@ void _gfortran_caf_unlock (caf_token_t, size_t, int, int *, char *, int); void _gfortran_caf_event_post (caf_token_t, size_t, int, int *, char *, int); void _gfortran_caf_event_wait (caf_token_t, size_t, int, int *, char *, int); void _gfortran_caf_event_query (caf_token_t, size_t, int, int *, int *); - +void _gfortran_caf_failed_images(gfc_descriptor_t *, + int __attribute__ ((unused)), + int __attribute__ ((unused))); #endif /* LIBCAF_H */ diff --git a/libgfortran/caf/single.c b/libgfortran/caf/single.c index c472446..72e4672 100644 --- a/libgfortran/caf/single.c +++ b/libgfortran/caf/single.c @@ -2877,3 +2877,17 @@ _gfortran_caf_unlock (caf_token_t token, size_t index, } _gfortran_caf_error_stop_str (msg, (int32_t) strlen (msg)); } + +void +_gfortran_caf_failed_images(gfc_descriptor_t *array, + int team __attribute__ ((unused)), + int kind __attribute__ ((unused))) +{ + int *mem = (int *)calloc(1,sizeof(int)); + array->base_addr = mem; + array->dtype = 265; + array->dim[0].lower_bound = 0; + array->dim[0]._ubound = -1; + array->dim[0]._stride = 1; + array->offset = -1; +}