From patchwork Sat Mar 4 17:58:48 2017 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Andre Vehreschild X-Patchwork-Id: 735314 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 3vbDMX2Fbvz9s7L for ; Sun, 5 Mar 2017 04:59:19 +1100 (AEDT) Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="VtL6AaTm"; dkim-atps=neutral DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:mime-version:content-type; q=dns; s=default; b=pnqjmm+2U4rX3DVHje0t0y/7BvZ9MOwKgCaOuPtSUfE/GUD8Vr bT43RD0b6muZeGfiRokorpwCT3JfcZ/lmquNAxUkFnUJfx8mlJ1zAqNREgxkbsQc bdF22MI988iphIDD+DImN7XH2hI5QDzx1GXkEhwkmj0Lu/8asTZuUdx3M= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:mime-version:content-type; s= default; bh=QvgyNq5i8n2OnWXqR78/lNfcyiE=; b=VtL6AaTmC4xXmCZ6n9It C4wMtgB2zQHZ3asL3K19exxnXL3Lo5Qjsk4u6F8iN1QaCCo7hMTOaV9EWf3eOkV6 HDV8uSzYxzMA9zQC9oIuzJZ1Rcmmraau7RRxoWmVFk8ye8gqNV2bxBFF/UkfBZj4 U809T3h8GX7mu+58J7mE4rk= Received: (qmail 44029 invoked by alias); 4 Mar 2017 17:59:04 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Received: (qmail 43992 invoked by uid 89); 4 Mar 2017 17:59:03 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-22.0 required=5.0 tests=AWL, BAYES_00, FREEMAIL_FROM, GIT_PATCH_0, GIT_PATCH_1, GIT_PATCH_2, GIT_PATCH_3, KAM_STOCKGEN, RCVD_IN_DNSWL_LOW, RCVD_IN_SORBS_SPAM, RCVD_IN_SORBS_WEB, SPF_PASS autolearn=ham version=3.3.2 spammy=gru, unlock, prototypes, Furthermore X-Spam-User: qpsmtpd, 2 recipients X-HELO: mout.gmx.net Received: from mout.gmx.net (HELO mout.gmx.net) (212.227.15.18) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Sat, 04 Mar 2017 17:58:56 +0000 Received: from vepi2 ([84.63.213.96]) by mail.gmx.com (mrgmx002 [212.227.17.190]) with ESMTPSA (Nemesis) id 0Lt1S6-1cHKNM2W1y-012Yp1; Sat, 04 Mar 2017 18:58:51 +0100 Date: Sat, 4 Mar 2017 18:58:48 +0100 From: Andre Vehreschild To: GCC-Patches-ML , GCC-Fortran-ML Cc: Alessandro Fanfarillo , Damian Rouson Subject: [PATCH, Fortran, Coarray, v1] Add support for failed images Message-ID: <20170304185848.08865575@vepi2> MIME-Version: 1.0 X-UI-Out-Filterresults: notjunk:1; V01:K0:RKJTcWH+Mio=:l3qeH0FpJh21Xc5Wf11Ov8 erR5RoT2yIR6mmVTtpFUXcfgnpknNyRkwuJdzYsadF+NkdVzngKIbO1eZa6bA1NiwCGkDidnH 574TS9bS+ztleEz3RwumpppHdYwPFhZW2VntWR6rnoG/gpazwu6YBqFCspuXV9SwAo1A9vUfw UQwsVDJnqxfRfPwQV8YYUpLqDmzePk4psXTGmSO4hXqSLsz7VQEmU4Tdn4WY1la2Jxd3QeXoA ACJHIxSyBpG8D8NjN567feukdiN77Ji8anVTHAuWdzz1PIs9RR217MihUZ0ueUlu+HxCQGft0 G83UjxfZMJSuyzLtOJcrcXv89pMbg7Bxt/jsUID70ImBdpmydpNfSSb4Q+kzmDWa05v6GOhMx EkcnZDQaXxqS9MtEysvv30GSWw3vGMJaG9vuYIfVmz/s3VkE5g+MOQw21qnRu7Fy7N3ko8OeP Kqm0Tjpa59Z5szbqeeN7jQzG2Gk7AWrZ30Ku9v49QiL1uZMfcXcRGbD9eCnd0T0N4jB2Gn9J6 yh/V7uli96oEJkQoV2P4cKrCVZHxP8gwSLJpQT0cuLJuiQx5WDlLpbAvf03QQ5LuqAgvQCP7L 4sFtQeFcpwFLPtpdEydUmrH3gUq0vYfi5H8PS6rksysZyuKNm/WQr5UyJNKCXnFi4lbvpNoET iWBumtXg8H5I5gebVDLtQkNmLQjkDll1No3AwDuaC75c4MIt7vDjyDk59Nij+hY3RVlMEWZuC zy0yfhO54HSK3vYadBBA1uEPrS/D4TNijUX+LjaIrZ7g6x6Sa9KxgekdPKM= Hi all, attached patch polishes the one begun by Alessandro. It adds documentation and fixes the style issues. Furthermore did I try to interpret the standard according to the FAIL IMAGE statement. IMHO should it just quit the executable without any error code. The caf_single library emits "FAIL IMAGE" to stderr, while in coarray=single mode it just quits. What do you think? Bootstraps and regtests ok on x86_64-linux/f25. Ok for trunk? (May be later). Gruß, Andre diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index c22bfa9..45bc68e 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -295,6 +295,29 @@ nonnegative_check (const char *arg, gfc_expr *expr) } +/* If expr is a constant, then check to ensure that it is greater than zero. */ + +static bool +positive_check (int n, gfc_expr *expr) +{ + int i; + + if (expr->expr_type == EXPR_CONSTANT) + { + gfc_extract_int (expr, &i); + if (i <= 0) + { + gfc_error ("%qs argument of %qs intrinsic at %L must be positive", + gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, + &expr->where); + return false; + } + } + + return true; +} + + /* If expr2 is constant, then check that the value is less than (less than or equal to, if 'or_equal' is true) bit_size(expr1). */ @@ -1138,6 +1161,60 @@ gfc_check_atomic_ref (gfc_expr *value, gfc_expr *atom, gfc_expr *stat) bool +gfc_check_image_status (gfc_expr *image, gfc_expr *team) +{ + /* IMAGE has to be a positive, scalar integer. */ + if (!type_check (image, 0, BT_INTEGER) || !scalar_check (image, 0) + || !positive_check (0, image)) + return false; + + if (team) + { + gfc_error ("%qs argument of %qs intrinsic at %L not yet supported", + gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, + &team->where); + return false; + } + return true; +} + + +bool +gfc_check_failed_or_stopped_images (gfc_expr *team, gfc_expr *kind) +{ + if (team) + { + gfc_error ("%qs argument of %qs intrinsic at %L not yet supported", + gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, + &team->where); + return false; + } + + if (kind) + { + int k; + + if (!type_check (kind, 1, BT_INTEGER) || !scalar_check (kind, 1) + || !positive_check (1, kind)) + return false; + + /* Get the kind, reporting error on non-constant or overflow. */ + gfc_current_locus = kind->where; + if (gfc_extract_int (kind, &k, 1)) + return false; + if (gfc_validate_kind (BT_INTEGER, k, true) == -1) + { + gfc_error ("%qs argument of %qs intrinsic at %L shall specify a " + "valid integer kind", gfc_current_intrinsic_arg[1]->name, + gfc_current_intrinsic, &kind->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) { diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c index 36fc4cc..87a5304 100644 --- a/gcc/fortran/dump-parse-tree.c +++ b/gcc/fortran/dump-parse-tree.c @@ -1818,6 +1818,10 @@ show_code_node (int level, gfc_code *c) break; + case EXEC_FAIL_IMAGE: + fputs ("FAIL IMAGE ", dumpfile); + break; + 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/gfortran.texi b/gcc/fortran/gfortran.texi index ed9aa93..85afdda 100644 --- a/gcc/fortran/gfortran.texi +++ b/gcc/fortran/gfortran.texi @@ -1125,7 +1125,7 @@ of @code{BIND(C) procedures.} @item GNU Fortran's implementation for variables with @code{ASYNCHRONOUS} attribute is compatible with TS 29113. -@item Assumed types (@code{TYPE(*)}. +@item Assumed types (@code{TYPE(*)}). @item Assumed-rank (@code{DIMENSION(..)}). However, the array descriptor of the TS is not yet supported. @@ -1147,6 +1147,10 @@ do not support polymorphic types or types with allocatable, pointer or polymorphic components. @item Events (@code{EVENT POST}, @code{EVENT WAIT}, @code{EVENT_QUERY}) + +@item Failed images (@code{FAIL IMAGE}, @code{IMAGE_STATUS}, +@code{FAILED_IMAGES}, @code{STOPPED_IMAGES}) + @end itemize @@ -3873,6 +3877,7 @@ of such a type * caf_register_t:: * caf_deregister_t:: * caf_reference_t:: +* caf_team_t:: @end menu @node caf_token_t @@ -4035,6 +4040,11 @@ type conversion still needs to take place the type is transported here. At the moment @code{CAF_ARR_REF_VECTOR} is not implemented in the front end for descriptor-less arrays. The library caf_single has untested support for it. +@node caf_team_t +@subsection @code{caf_team_t} + +Opaque pointer to represent a team-handle. This type is a stand-in for the +future implementation of teams. It is about to change without further notice. @node Function ABI Documentation @section Function ABI Documentation @@ -4044,6 +4054,9 @@ descriptor-less arrays. The library caf_single has untested support for it. * _gfortran_caf_finish:: Finalization function * _gfortran_caf_this_image:: Querying the image number * _gfortran_caf_num_images:: Querying the maximal number of images +* _gfortran_caf_image_status :: Query the status of an image +* _gfortran_caf_failed_images :: Get an array of the indexes of the failed images +* _gfortran_caf_stopped_images :: Get an array of the indexes of the stopped images * _gfortran_caf_register:: Registering coarrays * _gfortran_caf_deregister:: Deregistering coarrays * _gfortran_caf_is_present:: Query whether an allocatable or pointer component in a derived type coarray is allocated @@ -4063,6 +4076,7 @@ descriptor-less arrays. The library caf_single has untested support for it. * _gfortran_caf_sync_memory:: Wait for completion of segment-memory operations * _gfortran_caf_error_stop:: Error termination with exit code * _gfortran_caf_error_stop_str:: Error termination with string +* _gfortran_caf_fail_image :: Mark the image failed and end its execution * _gfortran_caf_atomic_define:: Atomic variable assignment * _gfortran_caf_atomic_ref:: Atomic variable reference * _gfortran_caf_atomic_cas:: Atomic compare and swap @@ -4182,6 +4196,90 @@ then the compiler passes @code{distance=0} and @code{failed=-1} to the function. @end table +@node _gfortran_caf_image_status +@subsection @code{_gfortran_caf_image_status} --- Query the status of an image +@cindex Coarray, _gfortran_caf_image_status + +@table @asis +@item @emph{Description}: +Get the status of the image given by the id @var{image} of the team given by +@var{team}. Valid results are zero, for image is ok, @code{STAT_STOPPED_IMAGE} +from the ISO_FORTRAN_ENV module to indicate that the image has been stopped and +@code{STAT_FAILED_IMAGE} also from ISO_FORTRAN_ENV to indicate that the image +has executed a @code{FAIL IMAGE} statement. + +@item @emph{Syntax}: +@code{int _gfortran_caf_image_status (int image, caf_team_t * team)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{image} @tab the positive scalar id of the image in the current TEAM. +@item @var{team} @tab optional; team on the which the inquiry is to be +performed. +@end multitable + +@item @emph{NOTES} +This function follows TS18508. Because team-functionality is not yet +implemented a null-pointer is passed for the @var{team} argument at the moment. +@end table + + +@node _gfortran_caf_failed_images +@subsection @code{_gfortran_caf_failed_images} --- Get an array of the indexes of the failed images +@cindex Coarray, _gfortran_caf_failed_images + +@table @asis +@item @emph{Description}: +Get an array of image indexes in the current @var{team} that have failed. The +array is sorted ascendingly. When @var{team} is not provided the current team +is to be used. When @var{kind} is provided then the resulting array is of that +integer kind else it is of default integer kind. The returns an unallocated +size zero array when no images have failed. + +@item @emph{Syntax}: +@code{int _gfortran_caf_failed_images (caf_team_t * team, int * kind)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{team} @tab optional; team on the which the inquiry is to be +performed. +@item @var{image} @tab optional; the kind of the resulting integer array. +@end multitable + +@item @emph{NOTES} +This function follows TS18508. Because team-functionality is not yet +implemented a null-pointer is passed for the @var{team} argument at the moment. +@end table + + +@node _gfortran_caf_stopped_images +@subsection @code{_gfortran_caf_stopped_images} --- Get an array of the indexes of the stopped images +@cindex Coarray, _gfortran_caf_stopped_images + +@table @asis +@item @emph{Description}: +Get an array of image indexes in the current @var{team} that have stopped. The +array is sorted ascendingly. When @var{team} is not provided the current team +is to be used. When @var{kind} is provided then the resulting array is of that +integer kind else it is of default integer kind. The returns an unallocated +size zero array when no images have failed. + +@item @emph{Syntax}: +@code{int _gfortran_caf_stopped_images (caf_team_t * team, int * kind)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{team} @tab optional; team on the which the inquiry is to be +performed. +@item @var{image} @tab optional; the kind of the resulting integer array. +@end multitable + +@item @emph{NOTES} +This function follows TS18508. Because team-functionality is not yet +implemented a null-pointer is passed for the @var{team} argument at the moment. +@end table + + @node _gfortran_caf_register @subsection @code{_gfortran_caf_register} --- Registering coarrays @cindex Coarray, _gfortran_caf_register @@ -4993,6 +5091,24 @@ function should terminate the program with a nonzero-exit code. +@node _gfortran_caf_fail_image +@subsection @code{_gfortran_caf_fail_image} --- Mark the image failed and end its execution +@cindex Coarray, _gfortran_caf_fail_image + +@table @asis +@item @emph{Description}: +Invoked for an @code{FAIL IMAGE} statement. The function should terminate the +current image. + +@item @emph{Syntax}: +@code{void _gfortran_caf_fail_image ()} + +@item @emph{NOTES} +This function follows TS18508. +@end table + + + @node _gfortran_caf_atomic_define @subsection @code{_gfortran_caf_atomic_define} --- Atomic variable assignment @cindex Coarray, _gfortran_caf_atomic_define diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index 923572d..2f60fe8 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -1840,6 +1840,13 @@ 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_or_stopped_images, + gfc_simplify_failed_or_stopped_images, + 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); @@ -2081,6 +2088,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_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. */ add_sym_4 ("index", GFC_ISYM_INDEX, CLASS_ELEMENTAL, ACTUAL_YES, @@ -2989,6 +3001,13 @@ 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_failed_or_stopped_images, + gfc_simplify_failed_or_stopped_images, + 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, gfc_check_storage_size, gfc_simplify_storage_size, diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index 756c5c6..e8280f6 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_or_stopped_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 *); @@ -292,6 +294,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_or_stopped_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 +311,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 *); @@ -473,6 +477,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 +501,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 +577,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..b784ac3 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -2830,6 +2830,38 @@ gfc_resolve_atan2d (gfc_expr *f, gfc_expr *x, gfc_expr *y ATTRIBUTE_UNUSED) } +/* Resolve failed_images (team, 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 + gfc_extract_int (kind, &f->ts.kind); + f->value.function.name = failed_images; +} + + +/* Resolve image_status (image, team). */ + +void +gfc_resolve_image_status (gfc_expr *f, gfc_expr *image ATTRIBUTE_UNUSED, + 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->value.function.name = image_status; +} + + +/* Resolve image_index (...). */ + void gfc_resolve_image_index (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED, gfc_expr *sub ATTRIBUTE_UNUSED) @@ -2841,6 +2873,23 @@ gfc_resolve_image_index (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED, } +/* Resolve stopped_images (team, kind). */ + +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 + gfc_extract_int (kind, &f->ts.kind); + f->value.function.name = stopped_images; +} + + void gfc_resolve_this_image (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *distance ATTRIBUTE_UNUSED) diff --git a/gcc/fortran/libgfortran.h b/gcc/fortran/libgfortran.h index 9f657bd..c5ff992 100644 --- a/gcc/fortran/libgfortran.h +++ b/gcc/fortran/libgfortran.h @@ -117,14 +117,14 @@ typedef enum } libgfortran_error_codes; -/* Must kept in sync with libgfortrancaf.h. */ +/* Must kept in sync with libgfortran/caf/libcaf.h. */ typedef enum { GFC_STAT_UNLOCKED = 0, 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 fc37f22..a47585c 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) @@ -3265,6 +3266,28 @@ gfc_match_event_wait (void) } +/* Match a FAIL IMAGE statement. */ + +match +gfc_match_fail_image (void) +{ + if (!gfc_notify_std (GFC_STD_F2008_TS, "FAIL IMAGE statement at %C")) + return MATCH_ERROR; + + if (gfc_match_char ('(') == MATCH_YES) + goto syntax; + + new_st.op = EXEC_FAIL_IMAGE; + + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_FAIL_IMAGE); + + return MATCH_ERROR; +} + + /* Match LOCK/UNLOCK statement. Syntax: LOCK ( lock-variable [ , lock-stat-list ] ) UNLOCK ( lock-variable [ , sync-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 3c568ee..28fa218 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 37ffde8..1fbc9f6 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -10883,6 +10883,9 @@ start: resolve_lock_unlock_event (code); break; + case EXEC_FAIL_IMAGE: + 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..169aef1 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -2466,6 +2466,37 @@ gfc_simplify_exponent (gfc_expr *x) gfc_expr * +gfc_simplify_failed_or_stopped_images (gfc_expr *team ATTRIBUTE_UNUSED, + gfc_expr *kind) +{ + 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; + int actual_kind; + if (kind) + gfc_extract_int (kind, &actual_kind); + else + actual_kind = gfc_default_integer_kind; + + result = gfc_get_array_expr (BT_INTEGER, actual_kind, &gfc_current_locus); + result->rank = 1; + 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; @@ -6763,6 +6794,36 @@ gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub) return result; } +gfc_expr * +gfc_simplify_image_status (gfc_expr *image, gfc_expr *team 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; + } + + /* Simplification is possible for fcoarray = single only. For all other modes + the result depends on runtime conditions. */ + if (flag_coarray != GFC_FCOARRAY_SINGLE) + return NULL; + + if (gfc_is_constant_expr (image)) + { + gfc_expr *result; + result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, + &image->where); + if (mpz_get_si (image->value.integer) == 1) + mpz_set_si (result->value.integer, 0); + else + mpz_set_si (result->value.integer, GFC_STAT_STOPPED_IMAGE); + return result; + } + else + return NULL; +} + 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..449ca9a 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,28 @@ 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 ( + get_identifier (PREFIX("caf_fail_image")), void_type_node, 0); + /* CAF's FAIL doesn't return. */ + TREE_THIS_VOLATILE (gfor_fndecl_caf_fail_image) = 1; + + gfor_fndecl_caf_failed_images + = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("caf_failed_images")), "WRR", + void_type_node, 3, pvoid_type_node, ppvoid_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, ppvoid_type_node); + + gfor_fndecl_caf_stopped_images + = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("caf_stopped_images")), "WRR", + void_type_node, 3, pvoid_type_node, ppvoid_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 9c4715b..7bced25 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -6228,13 +6228,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, gfc_add_block_to_block (&se->pre, &post); /* Transformational functions of derived types with allocatable - components must have the result allocatable components copied. */ + components must have the result allocatable components copied when the + argument is actually given. */ 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..b7524bc 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -2388,6 +2388,42 @@ trans_this_image (gfc_se * se, gfc_expr *expr) } +/* Convert a call to image_status. */ + +static void +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); + /* In args[0] the number of the image the status is desired for has to be + given. */ + + if (flag_coarray == GFC_FCOARRAY_SINGLE) + { + tree arg; + arg = gfc_evaluate_now (args[0], &se->pre); + tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_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_LIB) + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_image_status, 2, + args[0], build_int_cst (integer_type_node, -1)); + else + gcc_unreachable (); + + se->expr = tmp; +} + + static void trans_image_index (gfc_se * se, gfc_expr *expr) { @@ -9108,6 +9144,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) trans_image_index (se, expr); break; + case GFC_ISYM_IMAGE_STATUS: + conv_intrinsic_image_status (se, expr); + break; + case GFC_ISYM_NUM_IMAGES: trans_num_images (se, expr); break; @@ -9458,10 +9498,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..98687c8 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -674,6 +674,24 @@ 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) +{ + if (flag_coarray == GFC_FCOARRAY_LIB) + return build_call_expr_loc (input_location, + gfor_fndecl_caf_fail_image, 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); + } +} + 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_image_1.f08 b/gcc/testsuite/gfortran.dg/coarray/fail_image_1.f08 new file mode 100644 index 0000000..b1e1bbb --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray/fail_image_1.f08 @@ -0,0 +1,10 @@ +! { dg-do compile } + +program fail_image_statement_1 + implicit none + + fail image ! OK + fail image (1) ! { dg-error "Syntax error in FAIL IMAGE statement at \\(1\\)" } + +end program fail_image_statement_1 + diff --git a/gcc/testsuite/gfortran.dg/coarray/fail_image_2.f08 b/gcc/testsuite/gfortran.dg/coarray/fail_image_2.f08 new file mode 100644 index 0000000..e482a60 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray/fail_image_2.f08 @@ -0,0 +1,10 @@ +! { dg-do run } + +program fail_image_statement_2 + implicit none + + fail image ! OK + error stop "This statement should not be reached." + +end program fail_image_statement_2 + diff --git a/gcc/testsuite/gfortran.dg/coarray/failed_images_1.f08 b/gcc/testsuite/gfortran.dg/coarray/failed_images_1.f08 new file mode 100644 index 0000000..4898dd8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray/failed_images_1.f08 @@ -0,0 +1,20 @@ +! { dg-do compile } + +program test_failed_images_1 + implicit none + + integer, allocatable :: fi(:) + real :: r + integer :: i + + fi = failed_images() ! OK + fi = failed_images(TEAM=1) ! { dg-error "'team' argument of 'failed_images' intrinsic at \\(1\\) not yet supported" } + fi = failed_images(KIND=1) ! OK + fi = failed_images(KIND=4) ! OK + fi = failed_images(KIND=0) ! { dg-error "'kind' argument of 'failed_images' intrinsic at \\\(1\\\) must be positive" } + fi = failed_images(KIND=r) ! { dg-error "'kind' argument of 'failed_images' intrinsic at \\\(1\\\) must be INTEGER" } + fi = failed_images(KIND=i) ! { dg-error "Constant expression required at \\\(1\\\)" } + fi = failed_images(KIND=42) ! { dg-error "'kind' argument of 'failed_images' intrinsic at \\\(1\\\) shall specify a valid integer kind" } + +end program test_failed_images_1 + diff --git a/gcc/testsuite/gfortran.dg/coarray/failed_images_2.f08 b/gcc/testsuite/gfortran.dg/coarray/failed_images_2.f08 new file mode 100644 index 0000000..ca5fe40 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray/failed_images_2.f08 @@ -0,0 +1,17 @@ +! { dg-do run } + +program test_failed_images_2 + implicit none + + integer, allocatable :: fi(:) + integer(kind=1), allocatable :: sfi(:) + + fi = failed_images() + if (size(fi) > 0) error stop "failed_images result shall be empty array" + sfi = failed_images(KIND=1) + if (size(sfi) > 0) error stop "failed_images result shall be empty array" + sfi = failed_images(KIND=8) + if (size(sfi) > 0) error stop "failed_images result shall be empty array" + +end program test_failed_images_2 + diff --git a/gcc/testsuite/gfortran.dg/coarray/image_status_1.f08 b/gcc/testsuite/gfortran.dg/coarray/image_status_1.f08 new file mode 100644 index 0000000..098a2bb --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray/image_status_1.f08 @@ -0,0 +1,26 @@ +! { dg-do compile } + +program test_image_status_1 + implicit none + + integer :: isv + integer(kind=1) :: k1 + integer(kind=2) :: k2 + integer(kind=4) :: k4 + integer(kind=8) :: k8 + + isv = image_status(1) ! Ok + isv = image_status(-1) ! { dg-error "'image' argument of 'image_status' intrinsic at \\(1\\) must be positive" } + isv = image_status(0) ! { dg-error "'image' argument of 'image_status' intrinsic at \\(1\\) must be positive" } + isv = image_status(.true.) ! { dg-error "'image' argument of 'image_status' intrinsic at \\(1\\) must be INTEGER" } + isv = image_status([1,2,3]) ! { dg-error "'image' argument of 'image_status' intrinsic at \\(1\\) must be a scalar" } + isv = image_status(k1) ! Ok + isv = image_status(k2) ! Ok + isv = image_status(k4) ! Ok + isv = image_status(k8) ! Ok + isv = image_status(1, team=1) ! { dg-error "'team' argument of 'image_status' intrinsic at \\(1\\) not yet supported" } + isv = image_status() ! { dg-error "Missing actual argument 'image' in call to 'image_status' at \\(1\\)" } + isv = image_status(team=1) ! { dg-error "Missing actual argument 'image' in call to 'image_status' at \\(1\\)" } + +end program test_image_status_1 + diff --git a/gcc/testsuite/gfortran.dg/coarray/image_status_2.f08 b/gcc/testsuite/gfortran.dg/coarray/image_status_2.f08 new file mode 100644 index 0000000..fb49289 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray/image_status_2.f08 @@ -0,0 +1,12 @@ +! { dg-do run } + +program test_image_status_2 + use iso_fortran_env , only : STAT_STOPPED_IMAGE + implicit none + + if (image_status(1) /= 0) error stop "Image 1 should report OK." + if (image_status(2) /= STAT_STOPPED_IMAGE) error stop "Image 2 should be stopped." + if (image_status(3) /= STAT_STOPPED_IMAGE) error stop "Image 3 should be stopped." + +end program test_image_status_2 + diff --git a/gcc/testsuite/gfortran.dg/coarray/stopped_images_1.f08 b/gcc/testsuite/gfortran.dg/coarray/stopped_images_1.f08 new file mode 100644 index 0000000..403de58 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray/stopped_images_1.f08 @@ -0,0 +1,20 @@ +! { dg-do compile } + +program test_stopped_images_1 + implicit none + + integer, allocatable :: gi(:) + real :: r + integer :: i + + gi = stopped_images() ! OK + gi = stopped_images(TEAM=1) ! { dg-error "'team' argument of 'stopped_images' intrinsic at \\(1\\) not yet supported" } + gi = stopped_images(KIND=1) ! OK + gi = stopped_images(KIND=4) ! OK + gi = stopped_images(KIND=0) ! { dg-error "'kind' argument of 'stopped_images' intrinsic at \\\(1\\\) must be positive" } + gi = stopped_images(KIND=r) ! { dg-error "'kind' argument of 'stopped_images' intrinsic at \\\(1\\\) must be INTEGER" } + gi = stopped_images(KIND=i) ! { dg-error "Constant expression required at \\\(1\\\)" } + gi = stopped_images(KIND=42) ! { dg-error "'kind' argument of 'stopped_images' intrinsic at \\\(1\\\) shall specify a valid integer kind" } + +end program test_stopped_images_1 + diff --git a/gcc/testsuite/gfortran.dg/coarray/stopped_images_2.f08 b/gcc/testsuite/gfortran.dg/coarray/stopped_images_2.f08 new file mode 100644 index 0000000..0bf4a81 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray/stopped_images_2.f08 @@ -0,0 +1,17 @@ +! { dg-do run } + +program test_stopped_images_2 + implicit none + + integer, allocatable :: si(:) + integer(kind=1), allocatable :: ssi(:) + + si = stopped_images() + if (size(si) > 0) error stop "stopped_images result shall be empty array" + ssi = stopped_images(KIND=1) + if (size(ssi) > 0) error stop "stopped_images result shall be empty array" + ssi = stopped_images(KIND=8) + if (size(ssi) > 0) error stop "stopped_images result shall be empty array" + +end program test_stopped_images_2 + 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_1.f08 b/gcc/testsuite/gfortran.dg/coarray_failed_images_1.f08 new file mode 100644 index 0000000..82387ec --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_failed_images_1.f08 @@ -0,0 +1,29 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original -fcoarray=lib -lcaf_single" } + +program test_failed_images_1 + implicit none + + integer :: me,np,stat + character(len=1) :: c + integer, allocatable :: fi(:) + integer(kind=1), allocatable :: sfi(:) + + fi = failed_images() + if (size(fi) > 0) error stop "failed_images result shall be empty array" + if (allocated(fi)) error stop "failed_images result shall not be allocated" + + sfi = failed_images(KIND=1) + if (size(sfi) > 0) error stop "failed_images result shall be empty array" + if (allocated(sfi)) error stop "failed_images result shall not be allocated" + + sfi = failed_images(KIND=8) + if (size(sfi) > 0) error stop "failed_images result shall be empty array" +! The implicit type conversion in the assignment above allocates an array. +! if (allocated(sfi)) error stop "failed_images result shall not be allocated" + +end program test_failed_images_1 + +! { dg-final { scan-tree-dump-times "_gfortran_caf_failed_images \\\(&D\\\.\[0-9\]+, 0B, 0B\\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_failed_images \\\(&D\\\.\[0-9\]+, 0B, D\\\.\[0-9\]+\\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_failed_images \\\(&D\\\.\[0-9\]+, 0B, D\\\.\[0-9\]+\\\);" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/coarray_image_status_1.f08 b/gcc/testsuite/gfortran.dg/coarray_image_status_1.f08 new file mode 100644 index 0000000..1062c60 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_image_status_1.f08 @@ -0,0 +1,16 @@ +! { dg-do run } +! { dg-options "-fcoarray=lib -lcaf_single -fdump-tree-original" } + +program test_image_status_1 + use iso_fortran_env , only : STAT_STOPPED_IMAGE + implicit none + + if (image_status(1) /= 0) error stop "image_status(1) should not fail" + if (image_status(42) /= STAT_STOPPED_IMAGE) error stop "image_status(42) should report stopped image" + +end program test_image_status_1 + +! { dg-final { scan-tree-dump-times "_gfortran_caf_image_status \\\(1, .+\\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_image_status \\\(42, .+\\\)" 1 "original" } } + + diff --git a/gcc/testsuite/gfortran.dg/coarray_stopped_images_1.f08 b/gcc/testsuite/gfortran.dg/coarray_stopped_images_1.f08 new file mode 100644 index 0000000..36f86ed --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_stopped_images_1.f08 @@ -0,0 +1,29 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original -fcoarray=lib -lcaf_single" } + +program test_stopped_images_1 + implicit none + + integer :: me,np,stat + character(len=1) :: c + integer, allocatable :: si(:) + integer(kind=1), allocatable :: ssi(:) + + si = stopped_images() + if (size(si) > 0) error stop "stopped_images result shall be empty array at 1" + if (allocated(si)) error stop "stopped_images result shall not be allocated at 1" + + ssi = stopped_images(KIND=1) + if (size(ssi) > 0) error stop "stopped_images result shall be empty array at 2" + if (allocated(ssi)) error stop "stopped_images result shall not be allocated at 2" + + ssi = stopped_images(KIND=8) + if (size(ssi) > 0) error stop "stopped_images result shall be empty array at 3" +! The implicit type conversion in the assignment above allocates an array. +! if (allocated(ssi)) error stop "stopped_images result shall not be allocated at 3" + +end program test_stopped_images_1 + +! { dg-final { scan-tree-dump-times "_gfortran_caf_stopped_images \\\(&D\\\.\[0-9\]+, 0B, 0B\\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_stopped_images \\\(&D\\\.\[0-9\]+, 0B, D\\\.\[0-9\]+\\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_stopped_images \\\(&D\\\.\[0-9\]+, 0B, D\\\.\[0-9\]+\\\);" 1 "original" } } diff --git a/libgfortran/caf/libcaf.h b/libgfortran/caf/libcaf.h index 5c39202..2472646 100644 --- a/libgfortran/caf/libcaf.h +++ b/libgfortran/caf/libcaf.h @@ -41,14 +41,20 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see #define likely(x) __builtin_expect(!!(x), 1) #define unlikely(x) __builtin_expect(!!(x), 0) #endif +#endif /* Definitions of the Fortran 2008 standard; need to kept in sync with - ISO_FORTRAN_ENV, cf. libgfortran.h. */ -#define STAT_UNLOCKED 0 -#define STAT_LOCKED 1 -#define STAT_LOCKED_OTHER_IMAGE 2 -#define STAT_STOPPED_IMAGE 6000 -#endif + ISO_FORTRAN_ENV, cf. gcc/fortran/libgfortran.h. */ +typedef enum +{ + CAF_STAT_UNLOCKED = 0, + CAF_STAT_LOCKED, + CAF_STAT_LOCKED_OTHER_IMAGE, + CAF_STAT_STOPPED_IMAGE = 6000, + CAF_STAT_FAILED_IMAGE = 6001 +} +caf_stat_codes_t; + /* Describes what type of array we are registerring. Keep in sync with gcc/fortran/trans.h. */ @@ -74,6 +80,7 @@ typedef enum caf_deregister_t { caf_deregister_t; typedef void* caf_token_t; +typedef void * caf_team_t; typedef gfc_array_void gfc_descriptor_t; /* Linked list of static coarrays registered. */ @@ -198,6 +205,7 @@ void _gfortran_caf_stop_str (const char *, int32_t) void _gfortran_caf_error_stop_str (const char *, int32_t) __attribute__ ((noreturn)); void _gfortran_caf_error_stop (int32_t) __attribute__ ((noreturn)); +void _gfortran_caf_fail_image (void) __attribute__ ((noreturn)); void _gfortran_caf_co_broadcast (gfc_descriptor_t *, int, int *, char *, int); void _gfortran_caf_co_sum (gfc_descriptor_t *, int, int *, char *, int); @@ -243,6 +251,13 @@ 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 *, + caf_team_t * __attribute__ ((unused)), int *); +int _gfortran_caf_image_status (int, caf_team_t * __attribute__ ((unused))); +void _gfortran_caf_stopped_images (gfc_descriptor_t *, + caf_team_t * __attribute__ ((unused)), + int *); + 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..bf1a229 100644 --- a/libgfortran/caf/single.c +++ b/libgfortran/caf/single.c @@ -264,6 +264,7 @@ _gfortran_caf_sync_images (int count __attribute__ ((unused)), *stat = 0; } + void _gfortran_caf_stop_numeric(int32_t stop_code) { @@ -271,6 +272,7 @@ _gfortran_caf_stop_numeric(int32_t stop_code) exit (0); } + void _gfortran_caf_stop_str(const char *string, int32_t len) { @@ -282,6 +284,7 @@ _gfortran_caf_stop_str(const char *string, int32_t len) exit (0); } + void _gfortran_caf_error_stop_str (const char *string, int32_t len) { @@ -294,6 +297,74 @@ _gfortran_caf_error_stop_str (const char *string, int32_t len) } +/* Reported that the program terminated because of a fail image issued. + Because this is a single image library, nothing else than aborting the whole + program can be done. */ + +void _gfortran_caf_fail_image (void) +{ + fputs ("IMAGE FAILED!\n", stderr); + exit (0); +} + + +/* Get the status of image IMAGE. Because being the single image library all + other images are reported to be stopped. */ + +int _gfortran_caf_image_status (int image, + caf_team_t * team __attribute__ ((unused))) +{ + if (image == 1) + return 0; + else + return CAF_STAT_STOPPED_IMAGE; +} + + +/* Single image library. There can not be any failed images with only one + image. */ + +void +_gfortran_caf_failed_images (gfc_descriptor_t *array, + caf_team_t * team __attribute__ ((unused)), + int * kind) +{ + int local_kind = kind != NULL ? *kind : 4; + + array->base_addr = NULL; + array->dtype = ((BT_INTEGER << GFC_DTYPE_TYPE_SHIFT) + | (local_kind << GFC_DTYPE_SIZE_SHIFT)); + /* Setting lower_bound higher then upper_bound is what the compiler does to + indicate an empty array. */ + array->dim[0].lower_bound = 0; + array->dim[0]._ubound = -1; + array->dim[0]._stride = 1; + array->offset = 0; +} + + +/* With only one image available no other images can be stopped. Therefore + return an empty array. */ + +void +_gfortran_caf_stopped_images (gfc_descriptor_t *array, + caf_team_t * team __attribute__ ((unused)), + int * kind) +{ + int local_kind = kind != NULL ? *kind : 4; + + array->base_addr = NULL; + array->dtype = ((BT_INTEGER << GFC_DTYPE_TYPE_SHIFT) + | (local_kind << GFC_DTYPE_SIZE_SHIFT)); + /* Setting lower_bound higher then upper_bound is what the compiler does to + indicate an empty array. */ + array->dim[0].lower_bound = 0; + array->dim[0]._ubound = -1; + array->dim[0]._stride = 1; + array->offset = 0; +} + + void _gfortran_caf_error_stop (int32_t error) {