diff options
Diffstat (limited to 'gcc/fortran')
-rw-r--r-- | gcc/fortran/ChangeLog | 46 | ||||
-rw-r--r-- | gcc/fortran/array.c | 16 | ||||
-rw-r--r-- | gcc/fortran/check.c | 45 | ||||
-rw-r--r-- | gcc/fortran/dump-parse-tree.c | 16 | ||||
-rw-r--r-- | gcc/fortran/expr.c | 20 | ||||
-rw-r--r-- | gcc/fortran/gfortran.h | 8 | ||||
-rw-r--r-- | gcc/fortran/intrinsic.c | 75 | ||||
-rw-r--r-- | gcc/fortran/intrinsic.h | 5 | ||||
-rw-r--r-- | gcc/fortran/iresolve.c | 70 | ||||
-rw-r--r-- | gcc/fortran/iso-fortran-env.def | 5 | ||||
-rw-r--r-- | gcc/fortran/match.c | 129 | ||||
-rw-r--r-- | gcc/fortran/match.h | 4 | ||||
-rw-r--r-- | gcc/fortran/parse.c | 18 | ||||
-rw-r--r-- | gcc/fortran/resolve.c | 4 | ||||
-rw-r--r-- | gcc/fortran/simplify.c | 28 | ||||
-rw-r--r-- | gcc/fortran/st.c | 4 | ||||
-rw-r--r-- | gcc/fortran/trans-decl.c | 48 | ||||
-rw-r--r-- | gcc/fortran/trans-intrinsic.c | 76 | ||||
-rw-r--r-- | gcc/fortran/trans-stmt.c | 104 | ||||
-rw-r--r-- | gcc/fortran/trans-stmt.h | 4 | ||||
-rw-r--r-- | gcc/fortran/trans-types.c | 6 | ||||
-rw-r--r-- | gcc/fortran/trans.c | 16 | ||||
-rw-r--r-- | gcc/fortran/trans.h | 6 |
23 files changed, 675 insertions, 78 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 659e8ac..9a2cc32 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,49 @@ +2018-01-26 Damian Rouson <damian@sourceryinstitute.org> + Alessandro Fanfarillo <fanfarillo.gcc@gmail.com> + Soren Rasmussen <s.c.rasmussen@gmail.com> + + Partial support for Fortran 2018 teams features. + + * array.c (gfc_match_array_ref): add team attribute in coarray + transfers. + * check.c (gfc_check_get_team, gfc_check_team_number): add new + functions for get_team and team_number. + * dump-parse-tree.c (show_code_node): add new statements: form team, + change team, end team, and sync team. + * expr.c (gfc_find_team_co): add new function. + * gfortran.h: add new statements. + * intrinsic.c (add_functions): add get_team and team_number functions. + * intrinsic.h: add get_team and team_number prototypes for check, + simplify, and resolve. + * iresolve.c (gfc_resolve_get_team, gfc_resolve_team_number): add new + functions. + * iso-fortran-env.def: add the team_type derived type. + * match.c (gfc_match_if, gfc_match_form_team, gfc_match_team_number) + (gfc_match_end_team, gfc_match_sync_team, gfc_match_change_team): + add change team, end team, form team, sync team match and functions. + * match.h: add new prototypes for change team, end team, form team, + and sync team. + * parse.c (decode_statement): add cases for change team, end team, + form team, and sync team. + * resolve.c: add cases for exec form team, change team, end team, and + sync team. + * simplify.c (gfc_simplify_get_team): add new function for get team. + * st.c (gfc_free_statement): add cases exec for change team, end team, + form team, sync team. + * trans-decl.c (gfor_fndecl_caf_form_team) + (gfor_fndecl_caf_change_team, gfor_fndecl_caf_end_team) + (gfor_fndecl_caf_sync_team, gfor_fndecl_caf_get_team) + (gfor_fndecl_caf_team_number): add functions and definitions. + * trans-intrinsic.c (conv_caf_send, conv_intrinsic_team_number): add + new function and team_type argument support. + * trans-stmt.c (gfc_trans_form_team, gfc_trans_change_team) + (gfc_trans_end_team, gfc_trans_sync_team): add new functions. + * trans-stmt.h: add new prototypes. + * trans-types.c (gfc_get_derived_type): check condition for team_type. + * trans.c (trans_code): new exec cases for form team, change team, end + team, and sync team. + * trans.h: add new prototypes. + 2018-01-26 Steven G. Kargl <kargl@gcc.gnu.org> PR fortran/83998 diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index caa0b7f..22a5ddc 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -158,6 +158,7 @@ gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init, bool matched_bracket = false; gfc_expr *tmp; bool stat_just_seen = false; + bool team_just_seen = false; memset (ar, '\0', sizeof (*ar)); @@ -235,8 +236,21 @@ coarray: if (m == MATCH_ERROR) return MATCH_ERROR; + team_just_seen = false; stat_just_seen = false; - if (gfc_match(" , stat = %e",&tmp) == MATCH_YES && ar->stat == NULL) + if (gfc_match (" , team = %e", &tmp) == MATCH_YES && ar->team == NULL) + { + ar->team = tmp; + team_just_seen = true; + } + + if (ar->team && !team_just_seen) + { + gfc_error ("TEAM= attribute in %C misplaced"); + return MATCH_ERROR; + } + + if (gfc_match (" , stat = %e",&tmp) == MATCH_YES && ar->stat == NULL) { ar->stat = tmp; stat_just_seen = true; diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index f1c6695..dbb1aa0 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -1253,6 +1253,20 @@ gfc_check_failed_or_stopped_images (gfc_expr *team, gfc_expr *kind) bool +gfc_check_get_team (gfc_expr *level) +{ + if (level) + { + gfc_error ("%qs argument of %qs intrinsic at %L not yet supported", + gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, + &level->where); + return false; + } + return true; +} + + +bool gfc_check_atomic_cas (gfc_expr *atom, gfc_expr *old, gfc_expr *compare, gfc_expr *new_val, gfc_expr *stat) { @@ -2264,7 +2278,7 @@ gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary, return false; } } - + if (array->rank == 1 || boundary->rank == 0) { if (!scalar_check (boundary, 2)) @@ -2313,7 +2327,7 @@ gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary, case BT_COMPLEX: case BT_CHARACTER: break; - + default: gfc_error ("Missing %qs argument to %qs intrinsic at %L for %qs " "of type %qs", gfc_current_intrinsic_arg[2]->name, @@ -5275,6 +5289,33 @@ gfc_check_num_images (gfc_expr *distance, gfc_expr *failed) bool +gfc_check_team_number (gfc_expr *team) +{ + if (flag_coarray == GFC_FCOARRAY_NONE) + { + gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); + return false; + } + + if (team) + { + if (team->ts.type != BT_DERIVED + || team->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV + || team->ts.u.derived->intmod_sym_id != ISOFORTRAN_TEAM_TYPE) + { + gfc_error ("TEAM argument at %L to the intrinsic TEAM_NUMBER " + "shall be of type TEAM_TYPE", &team->where); + return false; + } + } + else + return true; + + return true; +} + + +bool gfc_check_this_image (gfc_expr *coarray, gfc_expr *dim, gfc_expr *distance) { if (flag_coarray == GFC_FCOARRAY_NONE) diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c index 5ff5316..0de2a0f 100644 --- a/gcc/fortran/dump-parse-tree.c +++ b/gcc/fortran/dump-parse-tree.c @@ -1868,6 +1868,22 @@ show_code_node (int level, gfc_code *c) fputs ("FAIL IMAGE ", dumpfile); break; + case EXEC_CHANGE_TEAM: + fputs ("CHANGE TEAM", dumpfile); + break; + + case EXEC_END_TEAM: + fputs ("END TEAM", dumpfile); + break; + + case EXEC_FORM_TEAM: + fputs ("FORM TEAM", dumpfile); + break; + + case EXEC_SYNC_TEAM: + fputs ("SYNC TEAM", dumpfile); + break; + case EXEC_SYNC_ALL: fputs ("SYNC ALL ", dumpfile); if (c->expr2 != NULL) diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 2a5f8ec..40f20c9 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -5060,7 +5060,25 @@ gfc_ref_this_image (gfc_ref *ref) } gfc_expr * -gfc_find_stat_co(gfc_expr *e) +gfc_find_team_co (gfc_expr *e) +{ + gfc_ref *ref; + + for (ref = e->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) + return ref->u.ar.team; + + if (e->value.function.actual->expr) + for (ref = e->value.function.actual->expr->ref; ref; + ref = ref->next) + if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) + return ref->u.ar.team; + + return NULL; +} + +gfc_expr * +gfc_find_stat_co (gfc_expr *e) { gfc_ref *ref; diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 6ddf450..f35430d 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -263,7 +263,8 @@ 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_FAIL_IMAGE,ST_NONE + ST_EVENT_WAIT, ST_FAIL_IMAGE, ST_FORM_TEAM, ST_CHANGE_TEAM, + ST_END_TEAM, ST_SYNC_TEAM, ST_NONE }; /* Types of interfaces that we can have. Assignment interfaces are @@ -455,6 +456,7 @@ enum gfc_isym_id GFC_ISYM_GETGID, GFC_ISYM_GETLOG, GFC_ISYM_GETPID, + GFC_ISYM_GET_TEAM, GFC_ISYM_GETUID, GFC_ISYM_GMTIME, GFC_ISYM_HOSTNM, @@ -597,6 +599,7 @@ enum gfc_isym_id GFC_ISYM_SYSTEM_CLOCK, GFC_ISYM_TAN, GFC_ISYM_TANH, + GFC_ISYM_TEAM_NUMBER, GFC_ISYM_THIS_IMAGE, GFC_ISYM_TIME, GFC_ISYM_TIME8, @@ -1913,6 +1916,7 @@ typedef struct gfc_array_ref int dimen; /* # of components in the reference */ int codimen; bool in_allocate; /* For coarray checks. */ + gfc_expr *team; gfc_expr *stat; locus where; gfc_array_spec *as; @@ -2497,6 +2501,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_FORM_TEAM, EXEC_CHANGE_TEAM, EXEC_END_TEAM, EXEC_SYNC_TEAM, 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, @@ -3223,6 +3228,7 @@ bool gfc_is_coarray (gfc_expr *); int gfc_get_corank (gfc_expr *); bool gfc_has_ultimate_allocatable (gfc_expr *); bool gfc_has_ultimate_pointer (gfc_expr *); +gfc_expr* gfc_find_team_co (gfc_expr *); gfc_expr* gfc_find_stat_co (gfc_expr *); gfc_expr* gfc_build_intrinsic_call (gfc_namespace *, gfc_isym_id, const char*, locus, unsigned, ...); diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index 4844cee..a47de41 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -860,7 +860,7 @@ add_sym_5s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind, int kind3, int optional3, sym_intent intent3, const char *a4, bt type4, int kind4, int optional4, sym_intent intent4, const char *a5, bt type5, int kind5, int optional5, - sym_intent intent5) + sym_intent intent5) { gfc_check_f cf; gfc_simplify_f sf; @@ -1246,7 +1246,8 @@ add_functions (void) *num = "number", *tm = "time", *nm = "name", *md = "mode", *vl = "values", *p1 = "path1", *p2 = "path2", *com = "command", *ca = "coarray", *sub = "sub", *dist = "distance", *failed="failed", - *c_ptr_1 = "c_ptr_1", *c_ptr_2 = "c_ptr_2", *back = "back"; + *c_ptr_1 = "c_ptr_1", *c_ptr_2 = "c_ptr_2", *back = "back", + *team = "team", *image = "image", *level = "level"; int di, dr, dd, dl, dc, dz, ii; @@ -1282,8 +1283,8 @@ add_functions (void) NULL, gfc_simplify_abs, gfc_resolve_abs, a, BT_COMPLEX, dz, REQUIRED); - add_sym_1 ("zabs", GFC_ISYM_ABS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU, - NULL, gfc_simplify_abs, gfc_resolve_abs, + add_sym_1 ("zabs", GFC_ISYM_ABS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU, + NULL, gfc_simplify_abs, gfc_resolve_abs, a, BT_COMPLEX, dd, REQUIRED); make_alias ("cdabs", GFC_STD_GNU); @@ -1344,8 +1345,8 @@ add_functions (void) make_alias ("imag", GFC_STD_GNU); make_alias ("imagpart", GFC_STD_GNU); - add_sym_1 ("dimag", GFC_ISYM_AIMAG, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU, - NULL, gfc_simplify_aimag, gfc_resolve_aimag, + add_sym_1 ("dimag", GFC_ISYM_AIMAG, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU, + NULL, gfc_simplify_aimag, gfc_resolve_aimag, z, BT_COMPLEX, dd, REQUIRED); make_generic ("aimag", GFC_ISYM_AIMAG, GFC_STD_F77); @@ -1397,7 +1398,7 @@ add_functions (void) x, BT_REAL, dd, REQUIRED); make_generic ("asin", GFC_ISYM_ASIN, GFC_STD_F77); - + add_sym_1 ("asinh", GFC_ISYM_ASINH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F2008, gfc_check_fn_rc2008, gfc_simplify_asinh, gfc_resolve_asinh, x, BT_REAL, dr, REQUIRED); @@ -1428,7 +1429,7 @@ add_functions (void) y, BT_REAL, dr, REQUIRED, x, BT_REAL, dr, REQUIRED); make_generic ("atan", GFC_ISYM_ATAN, GFC_STD_F77); - + add_sym_1 ("atanh", GFC_ISYM_ATANH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F2008, gfc_check_fn_rc2008, gfc_simplify_atanh, gfc_resolve_atanh, x, BT_REAL, dr, REQUIRED); @@ -1448,7 +1449,7 @@ add_functions (void) y, BT_REAL, dd, REQUIRED, x, BT_REAL, dd, REQUIRED); make_generic ("atan2", GFC_ISYM_ATAN2, GFC_STD_F77); - + /* Bessel and Neumann functions for G77 compatibility. */ add_sym_1 ("besj0", GFC_ISYM_J0, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU, gfc_check_fn_r, gfc_simplify_bessel_j0, gfc_resolve_g77_math1, @@ -1613,7 +1614,7 @@ add_functions (void) make_generic ("cmplx", GFC_ISYM_CMPLX, GFC_STD_F77); - add_sym_0 ("command_argument_count", GFC_ISYM_COMMAND_ARGUMENT_COUNT, CLASS_INQUIRY, + add_sym_0 ("command_argument_count", GFC_ISYM_COMMAND_ARGUMENT_COUNT, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2003, NULL, NULL, NULL); make_generic ("command_argument_count", GFC_ISYM_COMMAND_ARGUMENT_COUNT, @@ -1639,7 +1640,7 @@ add_functions (void) z, BT_COMPLEX, dz, REQUIRED); add_sym_1 ("dconjg", GFC_ISYM_CONJG, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dd, GFC_STD_GNU, - NULL, gfc_simplify_conjg, gfc_resolve_conjg, + NULL, gfc_simplify_conjg, gfc_resolve_conjg, z, BT_COMPLEX, dd, REQUIRED); make_generic ("conjg", GFC_ISYM_CONJG, GFC_STD_F77); @@ -1657,7 +1658,7 @@ add_functions (void) x, BT_COMPLEX, dz, REQUIRED); add_sym_1 ("zcos", GFC_ISYM_COS, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dd, GFC_STD_GNU, - NULL, gfc_simplify_cos, gfc_resolve_cos, + NULL, gfc_simplify_cos, gfc_resolve_cos, x, BT_COMPLEX, dd, REQUIRED); make_alias ("cdcos", GFC_STD_GNU); @@ -1826,7 +1827,7 @@ add_functions (void) x, BT_COMPLEX, dz, REQUIRED); add_sym_1 ("zexp", GFC_ISYM_EXP, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dd, GFC_STD_GNU, - NULL, gfc_simplify_exp, gfc_resolve_exp, + NULL, gfc_simplify_exp, gfc_resolve_exp, x, BT_COMPLEX, dd, REQUIRED); make_alias ("cdexp", GFC_STD_GNU); @@ -1850,8 +1851,8 @@ add_functions (void) ACTUAL_NO, BT_INTEGER, dd, GFC_STD_F2008_TS, gfc_check_failed_or_stopped_images, gfc_simplify_failed_or_stopped_images, - gfc_resolve_failed_images, "team", BT_VOID, di, OPTIONAL, - "kind", BT_INTEGER, di, OPTIONAL); + gfc_resolve_failed_images, team, BT_VOID, 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); @@ -1944,6 +1945,11 @@ add_functions (void) make_generic ("getpid", GFC_ISYM_GETPID, GFC_STD_GNU); + add_sym_1 ("get_team", GFC_ISYM_GET_TEAM, CLASS_TRANSFORMATIONAL, + ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008_TS, + gfc_check_get_team, NULL, gfc_resolve_get_team, + level, BT_INTEGER, di, OPTIONAL); + add_sym_0 ("getuid", GFC_ISYM_GETUID, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU, NULL, NULL, gfc_resolve_getuid); @@ -2096,8 +2102,8 @@ add_functions (void) 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_VOID, di, OPTIONAL); + gfc_simplify_image_status, gfc_resolve_image_status, image, + BT_INTEGER, di, REQUIRED, team, BT_VOID, 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. */ @@ -2345,7 +2351,7 @@ add_functions (void) p1, BT_CHARACTER, dc, REQUIRED, p2, BT_CHARACTER, dc, REQUIRED); make_generic ("link", GFC_ISYM_LINK, GFC_STD_GNU); - + add_sym_1 ("log", GFC_ISYM_LOG, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77, gfc_check_fn_rc, gfc_simplify_log, gfc_resolve_log, x, BT_REAL, dr, REQUIRED); @@ -2543,7 +2549,7 @@ add_functions (void) ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, msk, BT_LOGICAL, dl, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL, back, BT_LOGICAL, dl, OPTIONAL); - + make_generic ("minloc", GFC_ISYM_MINLOC, GFC_STD_F95); add_sym_3red ("minval", GFC_ISYM_MINVAL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, @@ -2747,7 +2753,7 @@ add_functions (void) p1, BT_CHARACTER, dc, REQUIRED, p2, BT_CHARACTER, dc, REQUIRED); make_generic ("rename", GFC_ISYM_RENAME, GFC_STD_GNU); - + add_sym_2 ("repeat", GFC_ISYM_REPEAT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_F95, gfc_check_repeat, gfc_simplify_repeat, gfc_resolve_repeat, stg, BT_CHARACTER, dc, REQUIRED, ncopies, BT_INTEGER, di, REQUIRED); @@ -2957,7 +2963,7 @@ add_functions (void) x, BT_UNKNOWN, 0, REQUIRED); make_from_module(); - /* COMPILER_OPTIONS and COMPILER_VERSION are part of ISO_FORTRAN_ENV. */ + /* COMPILER_OPTIONS and COMPILER_VERSION are part of ISO_FORTRAN_ENV. */ add_sym_0 ("compiler_options", GFC_ISYM_COMPILER_OPTIONS, CLASS_INQUIRY, ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_F2008, NULL, gfc_simplify_compiler_options, NULL); @@ -3013,8 +3019,8 @@ add_functions (void) ACTUAL_NO, BT_INTEGER, dd, GFC_STD_F2008_TS, gfc_check_failed_or_stopped_images, gfc_simplify_failed_or_stopped_images, - gfc_resolve_stopped_images, "team", BT_VOID, di, OPTIONAL, - "kind", BT_INTEGER, di, OPTIONAL); + gfc_resolve_stopped_images, team, BT_VOID, 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, @@ -3022,7 +3028,7 @@ add_functions (void) gfc_resolve_storage_size, a, BT_UNKNOWN, 0, REQUIRED, kind, BT_INTEGER, di, OPTIONAL); - + add_sym_3red ("sum", GFC_ISYM_SUM, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, gfc_check_product_sum, gfc_simplify_sum, gfc_resolve_sum, ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, @@ -3062,6 +3068,11 @@ add_functions (void) make_generic ("tanh", GFC_ISYM_TANH, GFC_STD_F77); + add_sym_1 ("team_number", GFC_ISYM_TEAM_NUMBER, CLASS_TRANSFORMATIONAL, + ACTUAL_YES, BT_INTEGER, di, GFC_STD_F2008_TS, + gfc_check_team_number, NULL, gfc_resolve_team_number, + team, BT_DERIVED, di, OPTIONAL); + add_sym_3 ("this_image", GFC_ISYM_THIS_IMAGE, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008, gfc_check_this_image, gfc_simplify_this_image, gfc_resolve_this_image, ca, BT_REAL, dr, OPTIONAL, dm, BT_INTEGER, ii, OPTIONAL, @@ -3158,11 +3169,11 @@ add_functions (void) bck, BT_LOGICAL, dl, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL); make_generic ("verify", GFC_ISYM_VERIFY, GFC_STD_F95); - + add_sym_1 ("loc", GFC_ISYM_LOC, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, ii, GFC_STD_GNU, gfc_check_loc, NULL, gfc_resolve_loc, x, BT_UNKNOWN, 0, REQUIRED); - + make_generic ("loc", GFC_ISYM_LOC, GFC_STD_GNU); if (flag_dec_math) @@ -4544,11 +4555,11 @@ check_specific (gfc_intrinsic_sym *specific, gfc_expr *expr, int error_flag) first_expr = arg->expr; for ( ; arg && arg->expr; arg = arg->next, n++) - if (!gfc_check_conformance (first_expr, arg->expr, + if (!gfc_check_conformance (first_expr, arg->expr, "arguments '%s' and '%s' for " - "intrinsic '%s'", - gfc_current_intrinsic_arg[0]->name, - gfc_current_intrinsic_arg[n]->name, + "intrinsic '%s'", + gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic)) return false; } @@ -5153,12 +5164,12 @@ gfc_warn_intrinsic_shadow (const gfc_symbol* sym, bool in_module, bool func) /* Try to find an intrinsic of the same name. */ if (func) isym = gfc_find_function (sym->name); - else + else isym = gfc_find_subroutine (sym->name); /* If no intrinsic was found with this name or it's not included in the selected standard, everything's fine. */ - if (!isym || !gfc_check_intrinsic_standard (isym, NULL, true, + if (!isym || !gfc_check_intrinsic_standard (isym, NULL, true, sym->declared_at)) return; diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index 7615dd1..a483bfa 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -83,6 +83,7 @@ bool gfc_check_fn_r (gfc_expr *); bool gfc_check_fn_rc (gfc_expr *); bool gfc_check_fn_rc2008 (gfc_expr *); bool gfc_check_fnum (gfc_expr *); +bool gfc_check_get_team (gfc_expr *); bool gfc_check_hostnm (gfc_expr *); bool gfc_check_huge (gfc_expr *); bool gfc_check_hypot (gfc_expr *, gfc_expr *); @@ -169,6 +170,7 @@ bool gfc_check_stat (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 *); +bool gfc_check_team_number (gfc_expr *); bool gfc_check_transf_bit_intrins (gfc_actual_arglist *); bool gfc_check_transfer (gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_transpose (gfc_expr *); @@ -300,6 +302,7 @@ gfc_expr *gfc_simplify_float (gfc_expr *); gfc_expr *gfc_simplify_floor (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_fraction (gfc_expr *); gfc_expr *gfc_simplify_gamma (gfc_expr *); +gfc_expr *gfc_simplify_get_team (gfc_expr *); gfc_expr *gfc_simplify_huge (gfc_expr *); gfc_expr *gfc_simplify_hypot (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_iachar (gfc_expr *, gfc_expr *); @@ -498,6 +501,7 @@ void gfc_resolve_gamma (gfc_expr *, gfc_expr *); void gfc_resolve_getcwd (gfc_expr *, gfc_expr *); void gfc_resolve_getgid (gfc_expr *); void gfc_resolve_getpid (gfc_expr *); +void gfc_resolve_get_team (gfc_expr *, gfc_expr *); void gfc_resolve_getuid (gfc_expr *); void gfc_resolve_hostnm (gfc_expr *, gfc_expr *); void gfc_resolve_hypot (gfc_expr *, gfc_expr *, gfc_expr *); @@ -595,6 +599,7 @@ void gfc_resolve_symlnk (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_system (gfc_expr *, gfc_expr *); void gfc_resolve_tan (gfc_expr *, gfc_expr *); void gfc_resolve_tanh (gfc_expr *, gfc_expr *); +void gfc_resolve_team_number (gfc_expr *, gfc_expr *); void gfc_resolve_this_image (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_time (gfc_expr *); void gfc_resolve_time8 (gfc_expr *); diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index 9a4e199..2134432 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -36,10 +36,10 @@ along with GCC; see the file COPYING3. If not see #include "constructor.h" #include "arith.h" -/* Given printf-like arguments, return a stable version of the result string. +/* Given printf-like arguments, return a stable version of the result string. We already have a working, optimized string hashing table in the form of - the identifier table. Reusing this table is likely not to be wasted, + the identifier table. Reusing this table is likely not to be wasted, since if the function name makes it to the gimple output of the frontend, we'll have to create the identifier anyway. */ @@ -316,7 +316,7 @@ gfc_resolve_aint (gfc_expr *f, gfc_expr *a, gfc_expr *kind) { gfc_typespec ts; gfc_clear_ts (&ts); - + f->ts.type = a->ts.type; f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer); @@ -363,7 +363,7 @@ gfc_resolve_anint (gfc_expr *f, gfc_expr *a, gfc_expr *kind) { gfc_typespec ts; gfc_clear_ts (&ts); - + f->ts.type = a->ts.type; f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer); @@ -458,7 +458,7 @@ gfc_resolve_besn (gfc_expr *f, gfc_expr *n, gfc_expr *x) { gfc_typespec ts; gfc_clear_ts (&ts); - + f->ts = x->ts; if (n->ts.kind != gfc_c_int_kind) { @@ -475,7 +475,7 @@ gfc_resolve_bessel_n2 (gfc_expr *f, gfc_expr *n1, gfc_expr *n2, gfc_expr *x) { gfc_typespec ts; gfc_clear_ts (&ts); - + f->ts = x->ts; f->rank = 1; if (n1->expr_type == EXPR_CONSTANT && n2->expr_type == EXPR_CONSTANT) @@ -811,7 +811,7 @@ gfc_resolve_cshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift, m = gfc_default_integer_kind; if (dim != NULL) m = m < dim->ts.kind ? dim->ts.kind : m; - + /* Convert shift to at least m, so we don't need kind=1 and kind=2 versions of the library functions. */ if (shift->ts.kind < m) @@ -822,7 +822,7 @@ gfc_resolve_cshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift, ts.kind = m; gfc_convert_type_warn (shift, &ts, 2, 0); } - + if (dim != NULL) { if (dim->expr_type != EXPR_CONSTANT && dim->symtree != NULL @@ -861,7 +861,7 @@ gfc_resolve_ctime (gfc_expr *f, gfc_expr *time) { gfc_typespec ts; gfc_clear_ts (&ts); - + f->ts.type = BT_CHARACTER; f->ts.kind = gfc_default_character_kind; @@ -976,7 +976,7 @@ gfc_resolve_eoshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift, m = gfc_default_integer_kind; if (dim != NULL) m = m < dim->ts.kind ? dim->ts.kind : m; - + /* Convert shift to at least m, so we don't need kind=1 and kind=2 versions of the library functions. */ if (shift->ts.kind < m) @@ -987,7 +987,7 @@ gfc_resolve_eoshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift, ts.kind = m; gfc_convert_type_warn (shift, &ts, 2, 0); } - + if (dim != NULL) { if (dim->expr_type != EXPR_CONSTANT && dim->symtree != NULL @@ -1225,7 +1225,7 @@ void gfc_resolve_iand (gfc_expr *f, gfc_expr *i, gfc_expr *j) { /* If the kind of i and j are different, then g77 cross-promoted the - kinds to the largest value. The Fortran 95 standard requires the + kinds to the largest value. The Fortran 95 standard requires the kinds to match. */ if (i->ts.kind != j->ts.kind) { @@ -1316,7 +1316,7 @@ void gfc_resolve_ieor (gfc_expr *f, gfc_expr *i, gfc_expr *j) { /* If the kind of i and j are different, then g77 cross-promoted the - kinds to the largest value. The Fortran 95 standard requires the + kinds to the largest value. The Fortran 95 standard requires the kinds to match. */ if (i->ts.kind != j->ts.kind) { @@ -1335,7 +1335,7 @@ void gfc_resolve_ior (gfc_expr *f, gfc_expr *i, gfc_expr *j) { /* If the kind of i and j are different, then g77 cross-promoted the - kinds to the largest value. The Fortran 95 standard requires the + kinds to the largest value. The Fortran 95 standard requires the kinds to match. */ if (i->ts.kind != j->ts.kind) { @@ -1435,7 +1435,7 @@ gfc_resolve_isatty (gfc_expr *f, gfc_expr *u) { gfc_typespec ts; gfc_clear_ts (&ts); - + f->ts.type = BT_LOGICAL; f->ts.kind = gfc_default_integer_kind; if (u->ts.kind != gfc_c_int_kind) @@ -1642,7 +1642,7 @@ gfc_resolve_matmul (gfc_expr *f, gfc_expr *a, gfc_expr *b) mpz_init_set (f->shape[0], b->shape[1]); } } - else + else { /* b->rank == 1 and a->rank == 2 here, all other cases have been caught in check.c. */ @@ -2961,6 +2961,19 @@ gfc_resolve_image_status (gfc_expr *f, gfc_expr *image ATTRIBUTE_UNUSED, } +/* Resolve get_team (). */ + +void +gfc_resolve_get_team (gfc_expr *f, gfc_expr *level ATTRIBUTE_UNUSED) +{ + static char get_team[] = "_gfortran_caf_get_team"; + f->rank = 0; + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_default_integer_kind; + f->value.function.name = get_team; +} + + /* Resolve image_index (...). */ void @@ -2991,6 +3004,19 @@ gfc_resolve_stopped_images (gfc_expr *f, gfc_expr *team ATTRIBUTE_UNUSED, } +/* Resolve team_number (team). */ + +void +gfc_resolve_team_number (gfc_expr *f, gfc_expr *team ATTRIBUTE_UNUSED) +{ + static char team_number[] = "_gfortran_caf_team_number"; + f->rank = 0; + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_default_integer_kind; + f->value.function.name = team_number; +} + + void gfc_resolve_this_image (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *distance ATTRIBUTE_UNUSED) @@ -3180,7 +3206,7 @@ gfc_resolve_ttynam (gfc_expr *f, gfc_expr *unit) { gfc_typespec ts; gfc_clear_ts (&ts); - + f->ts.type = BT_CHARACTER; f->ts.kind = gfc_default_character_kind; @@ -3399,7 +3425,7 @@ gfc_resolve_random_number (gfc_code *c) name = gfc_get_string (PREFIX ("random_r%d"), kind); else name = gfc_get_string (PREFIX ("arandom_r%d"), kind); - + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); } @@ -3444,7 +3470,7 @@ gfc_resolve_kill_sub (gfc_code *c) name = gfc_get_string (PREFIX ("kill_i%d_sub"), kind); c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); } - + void gfc_resolve_link_sub (gfc_code *c) @@ -3777,7 +3803,7 @@ gfc_resolve_ctime_sub (gfc_code *c) { gfc_typespec ts; gfc_clear_ts (&ts); - + /* ctime TIME argument is a INTEGER(KIND=8), says the doc */ if (c->ext.actual->expr->ts.kind != 8) { @@ -3961,7 +3987,7 @@ gfc_resolve_fput_sub (gfc_code *c) } -void +void gfc_resolve_fseek_sub (gfc_code *c) { gfc_expr *unit; @@ -4035,7 +4061,7 @@ gfc_resolve_ttynam_sub (gfc_code *c) { gfc_typespec ts; gfc_clear_ts (&ts); - + if (c->ext.actual->expr->ts.kind != gfc_c_int_kind) { ts.type = BT_INTEGER; diff --git a/gcc/fortran/iso-fortran-env.def b/gcc/fortran/iso-fortran-env.def index b150e49..25f9e09 100644 --- a/gcc/fortran/iso-fortran-env.def +++ b/gcc/fortran/iso-fortran-env.def @@ -128,6 +128,11 @@ NAMED_DERIVED_TYPE (ISOFORTRAN_EVENT_TYPE, "event_type", \ ? get_int_kind_from_node (ptr_type_node) : gfc_default_integer_kind, GFC_STD_F2008_TS) +NAMED_DERIVED_TYPE (ISOFORTRAN_TEAM_TYPE, "team_type", \ + flag_coarray == GFC_FCOARRAY_LIB + ? get_int_kind_from_node (ptr_type_node) + : gfc_default_integer_kind, GFC_STD_F2008_TS) + #undef NAMED_INTCST #undef NAMED_KINDARRAY #undef NAMED_FUNCTION diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 320a0d8..cf44fab 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -1596,11 +1596,13 @@ gfc_match_if (gfc_statement *if_type) match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT) match ("backspace", gfc_match_backspace, ST_BACKSPACE) match ("call", gfc_match_call, ST_CALL) + match ("change team", gfc_match_change_team, ST_CHANGE_TEAM) match ("close", gfc_match_close, ST_CLOSE) match ("continue", gfc_match_continue, ST_CONTINUE) match ("cycle", gfc_match_cycle, ST_CYCLE) match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE) match ("end file", gfc_match_endfile, ST_END_FILE) + match ("end team", gfc_match_end_team, ST_END_TEAM) match ("error stop", gfc_match_error_stop, ST_ERROR_STOP) match ("event post", gfc_match_event_post, ST_EVENT_POST) match ("event wait", gfc_match_event_wait, ST_EVENT_WAIT) @@ -1608,6 +1610,7 @@ gfc_match_if (gfc_statement *if_type) 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 ("form team", gfc_match_form_team, ST_FORM_TEAM) match ("go to", gfc_match_goto, ST_GOTO) match ("if", match_arithmetic_if, ST_ARITHMETIC_IF) match ("inquire", gfc_match_inquire, ST_INQUIRE) @@ -1624,6 +1627,7 @@ gfc_match_if (gfc_statement *if_type) match ("sync all", gfc_match_sync_all, ST_SYNC_CALL); match ("sync images", gfc_match_sync_images, ST_SYNC_IMAGES); match ("sync memory", gfc_match_sync_memory, ST_SYNC_MEMORY); + match ("sync team", gfc_match_sync_team, ST_SYNC_TEAM) match ("unlock", gfc_match_unlock, ST_UNLOCK) match ("where", match_simple_where, ST_WHERE) match ("write", gfc_match_write, ST_WRITE) @@ -3348,6 +3352,131 @@ syntax: return MATCH_ERROR; } +/* Match a FORM TEAM statement. */ + +match +gfc_match_form_team (void) +{ + match m; + gfc_expr *teamid,*team; + + if (!gfc_notify_std (GFC_STD_F2008_TS, "FORM TEAM statement at %C")) + return MATCH_ERROR; + + if (gfc_match_char ('(') == MATCH_NO) + goto syntax; + + new_st.op = EXEC_FORM_TEAM; + + if (gfc_match ("%e", &teamid) != MATCH_YES) + goto syntax; + m = gfc_match_char (','); + if (m == MATCH_ERROR) + goto syntax; + if (gfc_match ("%e", &team) != MATCH_YES) + goto syntax; + + m = gfc_match_char (')'); + if (m == MATCH_NO) + goto syntax; + + new_st.expr1 = teamid; + new_st.expr2 = team; + + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_FORM_TEAM); + + return MATCH_ERROR; +} + +/* Match a CHANGE TEAM statement. */ + +match +gfc_match_change_team (void) +{ + match m; + gfc_expr *team; + + if (!gfc_notify_std (GFC_STD_F2008_TS, "CHANGE TEAM statement at %C")) + return MATCH_ERROR; + + if (gfc_match_char ('(') == MATCH_NO) + goto syntax; + + new_st.op = EXEC_CHANGE_TEAM; + + if (gfc_match ("%e", &team) != MATCH_YES) + goto syntax; + + m = gfc_match_char (')'); + if (m == MATCH_NO) + goto syntax; + + new_st.expr1 = team; + + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_CHANGE_TEAM); + + return MATCH_ERROR; +} + +/* Match a END TEAM statement. */ + +match +gfc_match_end_team (void) +{ + if (!gfc_notify_std (GFC_STD_F2008_TS, "END TEAM statement at %C")) + return MATCH_ERROR; + + if (gfc_match_char ('(') == MATCH_YES) + goto syntax; + + new_st.op = EXEC_END_TEAM; + + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_END_TEAM); + + return MATCH_ERROR; +} + +/* Match a SYNC TEAM statement. */ + +match +gfc_match_sync_team (void) +{ + match m; + gfc_expr *team; + + if (!gfc_notify_std (GFC_STD_F2008_TS, "SYNC TEAM statement at %C")) + return MATCH_ERROR; + + if (gfc_match_char ('(') == MATCH_NO) + goto syntax; + + new_st.op = EXEC_SYNC_TEAM; + + if (gfc_match ("%e", &team) != MATCH_YES) + goto syntax; + + m = gfc_match_char (')'); + if (m == MATCH_NO) + goto syntax; + + new_st.expr1 = team; + + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_SYNC_TEAM); + + return MATCH_ERROR; +} /* Match LOCK/UNLOCK statement. Syntax: LOCK ( lock-variable [ , lock-stat-list ] ) diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h index 6f12b13..418542b 100644 --- a/gcc/fortran/match.h +++ b/gcc/fortran/match.h @@ -74,6 +74,10 @@ 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_change_team (void); +match gfc_match_end_team (void); +match gfc_match_form_team (void); +match gfc_match_sync_team (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 d63d7bc..a3693a1 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -451,6 +451,7 @@ decode_statement (void) case 'c': match ("call", gfc_match_call, ST_CALL); + match ("change team", gfc_match_change_team, ST_CHANGE_TEAM); match ("close", gfc_match_close, ST_CLOSE); match ("continue", gfc_match_continue, ST_CONTINUE); match ("contiguous", gfc_match_contiguous, ST_ATTR_DECL); @@ -470,6 +471,7 @@ decode_statement (void) case 'e': match ("end file", gfc_match_endfile, ST_END_FILE); + match ("end team", gfc_match_end_team, ST_END_TEAM); match ("exit", gfc_match_exit, ST_EXIT); match ("else", gfc_match_else, ST_ELSE); match ("else where", gfc_match_elsewhere, ST_ELSEWHERE); @@ -491,6 +493,7 @@ decode_statement (void) 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 ("form team", gfc_match_form_team, ST_FORM_TEAM); match ("format", gfc_match_format, ST_FORMAT); break; @@ -558,6 +561,7 @@ decode_statement (void) match ("sync all", gfc_match_sync_all, ST_SYNC_ALL); match ("sync images", gfc_match_sync_images, ST_SYNC_IMAGES); match ("sync memory", gfc_match_sync_memory, ST_SYNC_MEMORY); + match ("sync team", gfc_match_sync_team, ST_SYNC_TEAM); break; case 't': @@ -1503,6 +1507,8 @@ 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_FORM_TEAM: case ST_CHANGE_TEAM: \ + case ST_END_TEAM: case ST_SYNC_TEAM: \ 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 @@ -1834,6 +1840,18 @@ gfc_ascii_statement (gfc_statement st) case ST_FAIL_IMAGE: p = "FAIL IMAGE"; break; + case ST_CHANGE_TEAM: + p = "CHANGE TEAM"; + break; + case ST_END_TEAM: + p = "END TEAM"; + break; + case ST_FORM_TEAM: + p = "FORM TEAM"; + break; + case ST_SYNC_TEAM: + p = "SYNC TEAM"; + break; case ST_END_ASSOCIATE: p = "END ASSOCIATE"; break; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index a2b892a..8078005 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -11101,6 +11101,10 @@ start: break; case EXEC_FAIL_IMAGE: + case EXEC_FORM_TEAM: + case EXEC_CHANGE_TEAM: + case EXEC_END_TEAM: + case EXEC_SYNC_TEAM: break; case EXEC_ENTRY: diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 1e5e423..2458956 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -2893,6 +2893,30 @@ gfc_simplify_failed_or_stopped_images (gfc_expr *team ATTRIBUTE_UNUSED, gfc_expr * +gfc_simplify_get_team (gfc_expr *level ATTRIBUTE_UNUSED) +{ + if (flag_coarray == GFC_FCOARRAY_NONE) + { + gfc_current_locus = *gfc_current_intrinsic_where; + gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); + return &gfc_bad_expr; + } + + if (flag_coarray == GFC_FCOARRAY_SINGLE) + { + gfc_expr *result; + result = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind, &gfc_current_locus); + result->rank = 0; + return result; + } + + /* For fcoarray = lib no simplification is possible, because it is not known + what images failed or are stopped at compile time. */ + return NULL; +} + + +gfc_expr * gfc_simplify_float (gfc_expr *a) { gfc_expr *result; @@ -3058,7 +3082,7 @@ gfc_simplify_fraction (gfc_expr *x) #if MPFR_VERSION < MPFR_VERSION_NUM(3,1,0) - /* MPFR versions before 3.1.0 do not include mpfr_frexp. + /* MPFR versions before 3.1.0 do not include mpfr_frexp. TODO: remove the kludge when MPFR 3.1.0 or newer will be required */ if (mpfr_sgn (x->value.real) == 0) @@ -7348,7 +7372,7 @@ gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size) || !gfc_is_constant_expr (size)) return NULL; - if (!gfc_calculate_transfer_sizes (source, mold, size, &source_size, + if (!gfc_calculate_transfer_sizes (source, mold, size, &source_size, &result_size, &result_length)) return NULL; diff --git a/gcc/fortran/st.c b/gcc/fortran/st.c index 1de7de7..7603cbd 100644 --- a/gcc/fortran/st.c +++ b/gcc/fortran/st.c @@ -121,6 +121,10 @@ gfc_free_statement (gfc_code *p) case EXEC_EVENT_POST: case EXEC_EVENT_WAIT: case EXEC_FAIL_IMAGE: + case EXEC_CHANGE_TEAM: + case EXEC_END_TEAM: + case EXEC_FORM_TEAM: + case EXEC_SYNC_TEAM: break; case EXEC_BLOCK: diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 144a344..9b0b2a1 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -157,6 +157,12 @@ 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_caf_form_team; +tree gfor_fndecl_caf_change_team; +tree gfor_fndecl_caf_end_team; +tree gfor_fndecl_caf_sync_team; +tree gfor_fndecl_caf_get_team; +tree gfor_fndecl_caf_team_number; tree gfor_fndecl_co_broadcast; tree gfor_fndecl_co_max; tree gfor_fndecl_co_min; @@ -3363,7 +3369,7 @@ gfc_build_intrinsic_function_decls (void) jtype = gfc_get_int_type (ikinds[jkind]); if (itype && jtype) { - sprintf(name, PREFIX("pow_i%d_i%d"), ikinds[ikind], + sprintf (name, PREFIX("pow_i%d_i%d"), ikinds[ikind], ikinds[jkind]); gfor_fndecl_math_powi[jkind][ikind].integer = gfc_build_library_function_decl (get_identifier (name), @@ -3378,7 +3384,7 @@ gfc_build_intrinsic_function_decls (void) rtype = gfc_get_real_type (rkinds[rkind]); if (rtype && itype) { - sprintf(name, PREFIX("pow_r%d_i%d"), rkinds[rkind], + sprintf (name, PREFIX("pow_r%d_i%d"), rkinds[rkind], ikinds[ikind]); gfor_fndecl_math_powi[rkind][ikind].real = gfc_build_library_function_decl (get_identifier (name), @@ -3390,7 +3396,7 @@ gfc_build_intrinsic_function_decls (void) ctype = gfc_get_complex_type (rkinds[rkind]); if (ctype && itype) { - sprintf(name, PREFIX("pow_c%d_i%d"), rkinds[rkind], + sprintf (name, PREFIX("pow_c%d_i%d"), rkinds[rkind], ikinds[ikind]); gfor_fndecl_math_powi[rkind][ikind].cmplx = gfc_build_library_function_decl (get_identifier (name), @@ -3642,10 +3648,10 @@ gfc_build_builtin_function_decls (void) boolean_type_node, pint_type); gfor_fndecl_caf_send = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_send")), ".R.RRRRRRW", void_type_node, 10, + get_identifier (PREFIX("caf_send")), ".R.RRRRRRWR", void_type_node, 11, pvoid_type_node, size_type_node, integer_type_node, pvoid_type_node, pvoid_type_node, pvoid_type_node, integer_type_node, integer_type_node, - boolean_type_node, pint_type); + boolean_type_node, pint_type, pvoid_type_node); gfor_fndecl_caf_sendget = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("caf_sendget")), ".R.RRRR.RRRRRR", @@ -3769,6 +3775,38 @@ gfc_build_builtin_function_decls (void) void_type_node, 3, pvoid_type_node, ppvoid_type_node, integer_type_node); + gfor_fndecl_caf_form_team + = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("caf_form_team")), "RWR", + void_type_node, 3, integer_type_node, ppvoid_type_node, + integer_type_node); + + gfor_fndecl_caf_change_team + = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("caf_change_team")), "RR", + void_type_node, 2, ppvoid_type_node, + integer_type_node); + + gfor_fndecl_caf_end_team + = gfc_build_library_function_decl ( + get_identifier (PREFIX("caf_end_team")), void_type_node, 0); + + gfor_fndecl_caf_get_team + = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("caf_get_team")), "R", + void_type_node, 1, integer_type_node); + + gfor_fndecl_caf_sync_team + = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("caf_sync_team")), "RR", + void_type_node, 2, ppvoid_type_node, + integer_type_node); + + gfor_fndecl_caf_team_number + = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("caf_team_number")), "R", + integer_type_node, 1, integer_type_node); + gfor_fndecl_caf_image_status = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("caf_image_status")), "RR", diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index af647c4..9cc4f33 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -1846,11 +1846,11 @@ gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind, static tree conv_caf_send (gfc_code *code) { - gfc_expr *lhs_expr, *rhs_expr, *tmp_stat; + gfc_expr *lhs_expr, *rhs_expr, *tmp_stat, *tmp_team; gfc_se lhs_se, rhs_se; stmtblock_t block; tree caf_decl, token, offset, image_index, tmp, lhs_kind, rhs_kind; - tree may_require_tmp, src_stat, dst_stat; + tree may_require_tmp, src_stat, dst_stat, dst_team; tree lhs_type = NULL_TREE; tree vec = null_pointer_node, rhs_vec = null_pointer_node; symbol_attribute lhs_caf_attr, rhs_caf_attr; @@ -1866,6 +1866,7 @@ conv_caf_send (gfc_code *code) { lhs_caf_attr = gfc_caf_attr (lhs_expr); rhs_caf_attr = gfc_caf_attr (rhs_expr); src_stat = dst_stat = null_pointer_node; + dst_team = null_pointer_node; /* LHS. */ gfc_init_se (&lhs_se, NULL); @@ -2077,6 +2078,18 @@ conv_caf_send (gfc_code *code) { gfc_add_block_to_block (&block, &stat_se.post); } + tmp_team = gfc_find_team_co (lhs_expr); + + if (tmp_team) + { + gfc_se team_se; + gfc_init_se (&team_se, NULL); + gfc_conv_expr_reference (&team_se, tmp_team); + dst_team = team_se.expr; + gfc_add_block_to_block (&block, &team_se.pre); + gfc_add_block_to_block (&block, &team_se.post); + } + if (!gfc_is_coindexed (rhs_expr)) { if (lhs_caf_attr.alloc_comp || lhs_caf_attr.pointer_comp) @@ -2092,10 +2105,10 @@ conv_caf_send (gfc_code *code) { may_require_tmp, dst_realloc, src_stat); } else - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_send, 10, + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_send, 11, token, offset, image_index, lhs_se.expr, vec, rhs_se.expr, lhs_kind, rhs_kind, - may_require_tmp, src_stat); + may_require_tmp, src_stat, dst_team); } else { @@ -2432,6 +2445,48 @@ conv_intrinsic_image_status (gfc_se *se, gfc_expr *expr) se->expr = tmp; } +static void +conv_intrinsic_team_number (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_SINGLE && expr->value.function.actual->expr) + { + tree arg; + + arg = gfc_evaluate_now (args[0], &se->pre); + tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, + fold_convert (integer_type_node, arg), + integer_one_node); + tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, + tmp, integer_zero_node, + build_int_cst (integer_type_node, + GFC_STAT_STOPPED_IMAGE)); + } + else if (flag_coarray == GFC_FCOARRAY_SINGLE) + { + // the value -1 represents that no team has been created yet + tmp = build_int_cst (integer_type_node, -1); + } + else if (flag_coarray == GFC_FCOARRAY_LIB && expr->value.function.actual->expr) + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_team_number, 1, + args[0], build_int_cst (integer_type_node, -1)); + else if (flag_coarray == GFC_FCOARRAY_LIB) + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_team_number, 1, + integer_zero_node, build_int_cst (integer_type_node, -1)); + else + gcc_unreachable (); + + se->expr = tmp; +} + static void trans_image_index (gfc_se * se, gfc_expr *expr) @@ -2553,7 +2608,6 @@ trans_image_index (gfc_se * se, gfc_expr *expr) build_int_cst (type, 0), tmp); } - static void trans_num_images (gfc_se * se, gfc_expr *expr) { @@ -2581,7 +2635,6 @@ trans_num_images (gfc_se * se, gfc_expr *expr) } else failed = build_int_cst (integer_type_node, -1); - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2, distance, failed); se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp); @@ -3000,7 +3053,6 @@ conv_intrinsic_stride (gfc_se * se, gfc_expr * expr) se->expr = gfc_conv_descriptor_stride_get (desc, tmp); } - static void gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr) { @@ -4584,7 +4636,7 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) /* Special case for character maxloc. Remove unneeded actual arguments, then call a library function. */ - + if (arrayexpr->ts.type == BT_CHARACTER) { gfc_actual_arglist *a, *b; @@ -6099,7 +6151,6 @@ conv_generic_with_optional_char_arg (gfc_se* se, gfc_expr* expr, gfc_free_symbol (sym); } - /* The length of a character string. */ static void gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr) @@ -8662,7 +8713,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) case GFC_ISYM_MINLOC: gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR); break; - + case GFC_ISYM_MAXLOC: gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR); break; @@ -9190,6 +9241,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, false); break; + case GFC_ISYM_TEAM_NUMBER: + conv_intrinsic_team_number (se, expr); + break; + case GFC_ISYM_TRANSFER: if (se->ss && se->ss->info->useflags) /* Access the previously obtained result. */ @@ -9587,6 +9642,7 @@ gfc_is_intrinsic_libcall (gfc_expr * expr) case GFC_ISYM_CSHIFT: case GFC_ISYM_EOSHIFT: + case GFC_ISYM_GET_TEAM: case GFC_ISYM_FAILED_IMAGES: case GFC_ISYM_STOPPED_IMAGES: case GFC_ISYM_PACK: diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index df83a2b..573fd48 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -696,6 +696,110 @@ gfc_trans_fail_image (gfc_code *code ATTRIBUTE_UNUSED) } } +/* Translate the FORM TEAM statement. */ + +tree +gfc_trans_form_team (gfc_code *code) +{ + if (flag_coarray == GFC_FCOARRAY_LIB) + { + gfc_se argse; + tree team_id,team_type; + gfc_init_se (&argse, NULL); + gfc_conv_expr_val (&argse, code->expr1); + team_id = fold_convert (integer_type_node, argse.expr); + gfc_init_se (&argse, NULL); + gfc_conv_expr_val (&argse, code->expr2); + team_type = gfc_build_addr_expr (ppvoid_type_node, argse.expr); + + return build_call_expr_loc (input_location, + gfor_fndecl_caf_form_team, 3, + team_id, team_type, + build_int_cst (integer_type_node, 0)); + } + else + { + const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4); + gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name); + tree tmp = gfc_get_symbol_decl (exsym); + return build_call_expr_loc (input_location, tmp, 1, integer_zero_node); + } +} + +/* Translate the CHANGE TEAM statement. */ + +tree +gfc_trans_change_team (gfc_code *code) +{ + if (flag_coarray == GFC_FCOARRAY_LIB) + { + gfc_se argse; + tree team_type; + + gfc_init_se (&argse, NULL); + gfc_conv_expr_val (&argse, code->expr1); + team_type = gfc_build_addr_expr (ppvoid_type_node, argse.expr); + + return build_call_expr_loc (input_location, + gfor_fndecl_caf_change_team, 2, team_type, + build_int_cst (integer_type_node, 0)); + } + else + { + const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4); + gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name); + tree tmp = gfc_get_symbol_decl (exsym); + return build_call_expr_loc (input_location, tmp, 1, integer_zero_node); + } +} + +/* Translate the END TEAM statement. */ + +tree +gfc_trans_end_team (gfc_code *code ATTRIBUTE_UNUSED) +{ + if (flag_coarray == GFC_FCOARRAY_LIB) + { + return build_call_expr_loc (input_location, + gfor_fndecl_caf_end_team, 1, + build_int_cst (pchar_type_node, 0)); + } + else + { + const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4); + gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name); + tree tmp = gfc_get_symbol_decl (exsym); + return build_call_expr_loc (input_location, tmp, 1, integer_zero_node); + } +} + +/* Translate the SYNC TEAM statement. */ + +tree +gfc_trans_sync_team (gfc_code *code) +{ + if (flag_coarray == GFC_FCOARRAY_LIB) + { + gfc_se argse; + tree team_type; + + gfc_init_se (&argse, NULL); + gfc_conv_expr_val (&argse, code->expr1); + team_type = gfc_build_addr_expr (ppvoid_type_node, argse.expr); + + return build_call_expr_loc (input_location, + gfor_fndecl_caf_sync_team, 2, + team_type, + build_int_cst (integer_type_node, 0)); + } + else + { + const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4); + gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name); + tree tmp = gfc_get_symbol_decl (exsym); + return build_call_expr_loc (input_location, tmp, 1, integer_zero_node); + } +} 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 130058d..c798c80 100644 --- a/gcc/fortran/trans-stmt.h +++ b/gcc/fortran/trans-stmt.h @@ -58,6 +58,10 @@ 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_form_team (gfc_code *); +tree gfc_trans_change_team (gfc_code *); +tree gfc_trans_end_team (gfc_code *); +tree gfc_trans_sync_team (gfc_code *); tree gfc_trans_where (gfc_code *); tree gfc_trans_allocate (gfc_code *); tree gfc_trans_deallocate (gfc_code *); diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index fd25ce5..b15a4b2 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -2545,12 +2545,14 @@ gfc_get_derived_type (gfc_symbol * derived, int codimen) || (flag_coarray == GFC_FCOARRAY_LIB && derived->from_intmod == INTMOD_ISO_FORTRAN_ENV && (derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE - || derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE))) + || derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE + || derived->intmod_sym_id == ISOFORTRAN_TEAM_TYPE))) return ptr_type_node; if (flag_coarray != GFC_FCOARRAY_LIB && derived->from_intmod == INTMOD_ISO_FORTRAN_ENV - && derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE) + && (derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE + || derived->intmod_sym_id == ISOFORTRAN_TEAM_TYPE)) return gfc_get_int_type (gfc_default_integer_kind); if (derived && derived->attr.flavor == FL_PROCEDURE diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index 9ce7deb..aa10fbb 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -1972,6 +1972,22 @@ trans_code (gfc_code * code, tree cond) res = gfc_trans_forall (code); break; + case EXEC_FORM_TEAM: + res = gfc_trans_form_team (code); + break; + + case EXEC_CHANGE_TEAM: + res = gfc_trans_change_team (code); + break; + + case EXEC_END_TEAM: + res = gfc_trans_end_team (code); + break; + + case EXEC_SYNC_TEAM: + res = gfc_trans_sync_team (code); + break; + case EXEC_WHERE: res = gfc_trans_where (code); break; diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 35e1bd2..2ada805 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -837,6 +837,12 @@ 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_caf_form_team; +extern GTY(()) tree gfor_fndecl_caf_change_team; +extern GTY(()) tree gfor_fndecl_caf_end_team; +extern GTY(()) tree gfor_fndecl_caf_get_team; +extern GTY(()) tree gfor_fndecl_caf_sync_team; +extern GTY(()) tree gfor_fndecl_caf_team_number; extern GTY(()) tree gfor_fndecl_co_broadcast; extern GTY(()) tree gfor_fndecl_co_max; extern GTY(()) tree gfor_fndecl_co_min; |