commit a5750c4835566687505c34f73562c7cc3b220841 Author: Alessandro Fanfarillo 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; +}