Dear all, please find in attachment a new patch following the discussion at https://gcc.gnu.org/ml/fortran/2017-01/msg00054.html.
Suggestions on how to fix potential issues are more than welcome. Regards, Alessandro
commit e2dad3cc56447daea85c147f08b3f58a8e70617f Author: Alessandro Fanfarillo <elfa...@ucar.edu> Date: Fri Feb 10 13:45:37 2017 -0700 Resurrected patch and tests diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index c22bfa9..ed88a19 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -1136,6 +1136,116 @@ gfc_check_atomic_ref (gfc_expr *value, gfc_expr *atom, gfc_expr *stat) return gfc_check_atomic (atom, 1, value, 0, stat, 2); } +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_stopped_images (gfc_expr *team, gfc_expr *kind) +{ + if (team) + { + gfc_error ("TEAM argument of the STOPPED_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 STOPPED_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 STOPPED_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_cas (gfc_expr *atom, gfc_expr *old, gfc_expr *compare, diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c index 36fc4cc..4525573 100644 --- a/gcc/fortran/dump-parse-tree.c +++ b/gcc/fortran/dump-parse-tree.c @@ -1818,6 +1818,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 814ce78..2936550 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -263,7 +263,7 @@ enum gfc_statement ST_OMP_TASKLOOP_SIMD, ST_OMP_END_TASKLOOP_SIMD, ST_OMP_ORDERED_DEPEND, 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 @@ -429,6 +429,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, @@ -472,6 +473,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, @@ -585,6 +587,7 @@ enum gfc_isym_id GFC_ISYM_SRAND, GFC_ISYM_SR_KIND, GFC_ISYM_STAT, + GFC_ISYM_STOPPED_IMAGES, GFC_ISYM_STORAGE_SIZE, GFC_ISYM_STRIDE, GFC_ISYM_SUM, @@ -2457,7 +2460,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 e059a31..14a9f6d 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, @@ -2989,6 +3000,12 @@ add_functions (void) make_generic ("stat", GFC_ISYM_STAT, GFC_STD_GNU); + add_sym_2 ("stopped_images", GFC_ISYM_STOPPED_IMAGES, CLASS_TRANSFORMATIONAL, + ACTUAL_NO, BT_INTEGER, dd, GFC_STD_F2008_TS, + gfc_check_stopped_images, gfc_simplify_stopped_images, + gfc_resolve_stopped_images, "team", BT_INTEGER, di, OPTIONAL, + "kind", BT_INTEGER, di, OPTIONAL); + add_sym_2 ("storage_size", GFC_ISYM_STORAGE_SIZE, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008, gfc_check_storage_size, gfc_simplify_storage_size, diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index 756c5c6..6129cd6 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 *); @@ -164,6 +166,7 @@ bool gfc_check_sngl (gfc_expr *); bool gfc_check_spread (gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_srand (gfc_expr *); bool gfc_check_stat (gfc_expr *, gfc_expr *); +bool gfc_check_stopped_images (gfc_expr *, gfc_expr *); bool gfc_check_storage_size (gfc_expr *, gfc_expr *); bool gfc_check_sum (gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_symlnk (gfc_expr *, gfc_expr *); @@ -292,6 +295,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 *); @@ -308,6 +312,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 *); @@ -391,6 +396,7 @@ gfc_expr *gfc_simplify_sin (gfc_expr *); gfc_expr *gfc_simplify_sinh (gfc_expr *); gfc_expr *gfc_simplify_size (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_sizeof (gfc_expr *); +gfc_expr *gfc_simplify_stopped_images (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_storage_size (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_sngl (gfc_expr *); gfc_expr *gfc_simplify_spacing (gfc_expr *); @@ -473,6 +479,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 *); @@ -496,6 +503,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 *); @@ -571,12 +579,13 @@ void gfc_resolve_signal (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_sin (gfc_expr *, gfc_expr *); void gfc_resolve_sinh (gfc_expr *, gfc_expr *); void gfc_resolve_size (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); -void gfc_resolve_stride (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_spacing (gfc_expr *, gfc_expr *); void gfc_resolve_spread (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_sqrt (gfc_expr *, gfc_expr *); void gfc_resolve_stat (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_stopped_images (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_storage_size (gfc_expr *f, gfc_expr *a, gfc_expr *kind); +void gfc_resolve_stride (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_srand (gfc_code *); void gfc_resolve_sum (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_symlnk (gfc_expr *, gfc_expr *, gfc_expr *); diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index f5a4462..9fc2e96 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -2829,6 +2829,29 @@ gfc_resolve_atan2d (gfc_expr *f, gfc_expr *x, gfc_expr *y ATTRIBUTE_UNUSED) gfc_resolve_atrigd (f, x); } +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, @@ -2840,6 +2863,19 @@ gfc_resolve_image_index (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED, f->value.function.name = image_index; } +void +gfc_resolve_stopped_images (gfc_expr *f, gfc_expr *team ATTRIBUTE_UNUSED, + gfc_expr *kind) +{ + static char stopped_images[] = "_gfortran_caf_stopped_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 = stopped_images; +} void gfc_resolve_this_image (gfc_expr *f, gfc_expr *array, gfc_expr *dim, diff --git a/gcc/fortran/libgfortran.h b/gcc/fortran/libgfortran.h index 9f657bd..b1c97a0 100644 --- a/gcc/fortran/libgfortran.h +++ b/gcc/fortran/libgfortran.h @@ -124,7 +124,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 003a043..57faaa1 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -1601,6 +1601,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) @@ -3264,6 +3265,33 @@ 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 c8e8fc1..64f2038 100644 --- a/gcc/fortran/match.h +++ b/gcc/fortran/match.h @@ -73,6 +73,7 @@ match gfc_match_elseif (void); match gfc_match_event_post (void); match gfc_match_event_wait (void); match gfc_match_critical (void); +match gfc_match_fail_image (void); match gfc_match_block (void); match gfc_match_associate (void); match gfc_match_do (void); diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index c9f8da4..fcacf79 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -488,6 +488,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); @@ -1499,7 +1500,7 @@ next_statement (void) case ST_OMP_TARGET_EXIT_DATA: case ST_OMP_ORDERED_DEPEND: \ 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 @@ -1827,6 +1828,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 a5fe231..b2cae64 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -9084,6 +9084,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) @@ -10850,6 +10855,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 8ffe75a..5bb996b 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -2464,6 +2464,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) @@ -2486,6 +2506,26 @@ gfc_simplify_float (gfc_expr *a) return range_check (result, "FLOAT"); } +gfc_expr * +gfc_simplify_stopped_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; +} static bool is_last_ref_vtab (gfc_expr *e) @@ -6763,6 +6803,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 acef6cf..bffe50d 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 41b36a5..d83ce07 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -153,6 +153,10 @@ 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_caf_stopped_images; tree gfor_fndecl_co_broadcast; tree gfor_fndecl_co_max; tree gfor_fndecl_co_min; @@ -3732,6 +3736,27 @@ 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_caf_stopped_images = + gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("caf_stopped_images")), "WRR", + pvoid_type_node, 3, pvoid_type_node, 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 138af56..5287092 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -6231,10 +6231,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 14781ac..6e74946 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -2387,6 +2387,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) @@ -9108,6 +9121,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; @@ -9458,10 +9475,12 @@ 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_STOPPED_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 773ca70..4010359 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -674,6 +674,31 @@ gfc_trans_stop (gfc_code *code, bool error_stop) return gfc_finish_block (&se.pre); } +/* Translate the FAIL IMAGE statement. */ + +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 cc367bf..0a39e26 100644 --- a/gcc/fortran/trans-stmt.h +++ b/gcc/fortran/trans-stmt.h @@ -56,6 +56,7 @@ tree gfc_trans_select_type (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 82ed19a..e25ccaa 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -1953,6 +1953,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 c72fd35..d02f347 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -833,6 +833,10 @@ 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_caf_stopped_images; 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..3eef40a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray/image_status_single.f90 @@ -0,0 +1,9 @@ +! { dg-do run } +! { dg-options "-fcoarray=single" -lcaf_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 5c39202..3826dc3 100644 --- a/libgfortran/caf/libcaf.h +++ b/libgfortran/caf/libcaf.h @@ -243,6 +243,15 @@ 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_fail_image (void); +void _gfortran_caf_failed_images (gfc_descriptor_t *, + int __attribute__ ((unused)), + int __attribute__ ((unused))); +int _gfortran_caf_image_status (int); +void _gfortran_caf_stopped_images (gfc_descriptor_t *, + int __attribute__ ((unused)), + int __attribute__ ((unused))); + int _gfortran_caf_is_present (caf_token_t, int, caf_reference_t *); #endif /* LIBCAF_H */ diff --git a/libgfortran/caf/single.c b/libgfortran/caf/single.c index 8d3bcbf..de0ee2b 100644 --- a/libgfortran/caf/single.c +++ b/libgfortran/caf/single.c @@ -29,6 +29,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see #include <string.h> /* For memcpy and memset. */ #include <stdarg.h> /* For variadic arguments. */ #include <assert.h> +#include <signal.h> /* Define GFC_CAF_CHECK to enable run-time checking. */ /* #define GFC_CAF_CHECK 1 */ @@ -2881,3 +2882,43 @@ _gfortran_caf_lock (caf_token_t token, size_t index, _gfortran_caf_error_stop_str (msg, (int32_t) strlen (msg)); } +void _gfortran_caf_fail_image (void) +{ + raise(SIGKILL); +} + +int _gfortran_caf_image_status (int image) +{ + if(image == 1) + return 0; + else + return 6000; +} + +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 = 0; + array->dim[0]._stride = 1; + array->offset = -1; +} + +void +_gfortran_caf_stopped_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 = 0; + array->dim[0]._stride = 1; + array->offset = -1; +} void _gfortran_caf_unlock (caf_token_t token, size_t index,
ChangeLog
Description: Binary data