* [Fortran, Patch] (RFC, Coarray) Implement TS18508's EVENTS
@ 2015-04-29 7:58 Tobias Burnus
2015-11-25 17:30 ` Alessandro Fanfarillo
0 siblings, 1 reply; 15+ messages in thread
From: Tobias Burnus @ 2015-04-29 7:58 UTC (permalink / raw)
To: gcc-patches, fortran
[-- Attachment #1: Type: text/plain, Size: 2473 bytes --]
Dear all,
attached patch fixes a bug and implements EVENTS. I think the patch is
finished, but I still have to extend the test cases, to re-read the
patch and to write a changelog. As I am not sure how soon I will able
to do so, I follow the paradigm: release soon, release often and post
it here. Comments and reviews are welcome.
The patch fixes two bug in the "errmsg" handling, found by Alessandro:
I don't pass on the address of the actual argument and in libcaf_single,
I copy only 8 characters (sizeof pointer) instead of all of the the
characters of the error message.
Regarding events: Events is a way to permit barrier/locking-free
programming: One sends the finished data to an other image and then
tells that image that the data is there ("event post(msg_var[idx])").
That image can then either wait for the event by querying the status
on the local variable ("event wait(msg_var)") or only check the status
and if it is not ready do something else (e.g. another iteration);
that's done via "call event_query(msg_var, count)".
Technically, event_post works like atomic_add(msg_var[idx], 1) and
event_query like "atomic_ref(msg_var, count)". event_wait is the same
as event_query plus a spin/sleep loop waiting for the status change,
followed by an atomic_add(msg_var, -until_count). Except that
event_post/event_wait are image control statements. (Otherwise it
could happen that the event is there before the data for which the
event has been posted.)
Regarding the implementation in this patch, the limitations are the
same as for locking: Currently, neither lock_type nor event_type
variables are permitted as (nonallocatable) components
of a derived type - and type extension of them also not yet supported.*
The spec can be found at http://bitly.com/sc22wg5 -> 2015 -> TS draft
or directly at
http://isotc.iso.org/livelink/livelink?func=ll&objId=17064344&objAction=Open
Tobias
* Doing so is not really difficult but I need to handle cases like
the following. For "allocatable" with SOURCE= I also need to handle
it with polymorphic types.
type t1
type(event_type) :: EV
type(lock_type) :: LK
end type1
type t2
type(t1) :: a(5)
end type t2
type t3
type(t2) :: b(8)
end type t3
type(t3), save :: caf(3)[*]
For those, I need to call _gfortran_caf_register for
caf(:)%b(:)%a(:)%ev and caf(:)%b(:)%a(:)%lk
Looping though all array references.
Similar for
type(t3), allocatable :: caf2(:)[:]
allocate(caf2(n)[*])
for the allocate call.
[-- Attachment #2: event.diff --]
[-- Type: text/x-diff, Size: 64853 bytes --]
gcc/fortran/check.c | 54 +++++++
gcc/fortran/dump-parse-tree.c | 27 ++++
gcc/fortran/expr.c | 13 ++
gcc/fortran/gfortran.h | 8 +-
gcc/fortran/gfortran.texi | 141 ++++++++++++++++--
gcc/fortran/interface.c | 31 +++-
gcc/fortran/intrinsic.c | 7 +
gcc/fortran/intrinsic.h | 2 +
gcc/fortran/iresolve.c | 8 ++
gcc/fortran/iso-fortran-env.def | 5 +
gcc/fortran/match.c | 199 ++++++++++++++++++++++++++
gcc/fortran/match.h | 2 +
gcc/fortran/module.c | 8 +-
gcc/fortran/parse.c | 69 ++++++++-
gcc/fortran/resolve.c | 94 ++++++++++--
gcc/fortran/st.c | 2 +
gcc/fortran/trans-decl.c | 28 +++-
gcc/fortran/trans-expr.c | 8 +-
gcc/fortran/trans-intrinsic.c | 150 +++++++++++++++++++
gcc/fortran/trans-stmt.c | 163 +++++++++++++++++++++
gcc/fortran/trans-stmt.h | 1 +
gcc/fortran/trans-types.c | 5 +
gcc/fortran/trans.c | 17 ++-
gcc/fortran/trans.h | 7 +-
gcc/testsuite/gfortran.dg/coarray/event_1.f90 | 51 +++++++
gcc/testsuite/gfortran.dg/coarray/event_2.f90 | 89 ++++++++++++
26 files changed, 1151 insertions(+), 38 deletions(-)
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index cdb5ff1..d3570b3 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -1151,6 +1151,60 @@ gfc_check_atomic_cas (gfc_expr *atom, gfc_expr *old, gfc_expr *compare,
bool
+gfc_check_event_query (gfc_expr *event, gfc_expr *count, gfc_expr *stat)
+{
+ if (event->ts.type != BT_DERIVED
+ || event->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
+ || event->ts.u.derived->intmod_sym_id != ISOFORTRAN_EVENT_TYPE)
+ {
+ gfc_error ("EVENT argument at %L to the intrinsic EVENT_QUERY "
+ "shall be of type EVENT_TYPE", &event->where);
+ return false;
+ }
+
+ if (!scalar_check (event, 0))
+ return false;
+
+ if (!gfc_check_vardef_context (count, false, false, false, NULL))
+ {
+ gfc_error ("COUNT argument of the EVENT_QUERY intrinsic function at %L "
+ "shall be definable", &count->where);
+ return false;
+ }
+
+ if (!type_check (count, 1, BT_INTEGER))
+ return false;
+
+ int i = gfc_validate_kind (BT_INTEGER, count->ts.kind, false);
+ int j = gfc_validate_kind (BT_INTEGER, gfc_default_integer_kind, false);
+
+ if (gfc_integer_kinds[i].range < gfc_integer_kinds[j].range)
+ {
+ gfc_error ("COUNT argument of the EVENT_QUERY intrinsic function at %L "
+ "shall have at least the range of the default integer",
+ &count->where);
+ return false;
+ }
+
+ if (stat != NULL)
+ {
+ if (!type_check (stat, 2, BT_INTEGER))
+ return false;
+ if (!scalar_check (stat, 2))
+ return false;
+ if (!variable_check (stat, 2, false))
+ return false;
+
+ if (!gfc_notify_std (GFC_STD_F2008_TS, "STAT= argument to %s at %L",
+ gfc_current_intrinsic, &stat->where))
+ return false;
+ }
+
+ return true;
+}
+
+
+bool
gfc_check_atomic_fetch_op (gfc_expr *atom, gfc_expr *value, gfc_expr *old,
gfc_expr *stat)
{
diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c
index 83ecbaa..c886010 100644
--- a/gcc/fortran/dump-parse-tree.c
+++ b/gcc/fortran/dump-parse-tree.c
@@ -1659,6 +1659,33 @@ show_code_node (int level, gfc_code *c)
}
break;
+ case EXEC_EVENT_POST:
+ case EXEC_EVENT_WAIT:
+ if (c->op == EXEC_EVENT_POST)
+ fputs ("EVENT POST ", dumpfile);
+ else
+ fputs ("EVENT WAIT ", dumpfile);
+
+ fputs ("event-variable=", dumpfile);
+ if (c->expr1 != NULL)
+ show_expr (c->expr1);
+ if (c->expr4 != NULL)
+ {
+ fputs (" until_count=", dumpfile);
+ show_expr (c->expr4);
+ }
+ if (c->expr2 != NULL)
+ {
+ fputs (" stat=", dumpfile);
+ show_expr (c->expr2);
+ }
+ if (c->expr3 != NULL)
+ {
+ fputs (" errmsg=", dumpfile);
+ show_expr (c->expr3);
+ }
+ break;
+
case EXEC_LOCK:
case EXEC_UNLOCK:
if (c->op == EXEC_LOCK)
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 7f3a59d..4692013 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -4842,6 +4842,19 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
return false;
}
+ /* TS18508, C702/C203. */
+ if (!alloc_obj
+ && (attr.lock_comp
+ || (e->ts.type == BT_DERIVED
+ && e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+ && e->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)))
+ {
+ if (context)
+ gfc_error ("LOCK_EVENT in variable definition context (%s) at %L",
+ context, &e->where);
+ return false;
+ }
+
/* INTENT(IN) dummy argument. Check this, unless the object itself is the
component of sub-component of a pointer; we need to distinguish
assignment to a pointer component from pointer-assignment to a pointer
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 832a6ce..c035b39 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -253,7 +253,8 @@ typedef enum
ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD,
ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD,
ST_PROCEDURE, ST_GENERIC, ST_CRITICAL, ST_END_CRITICAL,
- ST_GET_FCN_CHARACTERISTICS, ST_LOCK, ST_UNLOCK, ST_NONE
+ ST_GET_FCN_CHARACTERISTICS, ST_LOCK, ST_UNLOCK, ST_EVENT_POST,
+ ST_EVENT_WAIT, ST_NONE
}
gfc_statement;
@@ -413,6 +414,7 @@ enum gfc_isym_id
GFC_ISYM_ERFC,
GFC_ISYM_ERFC_SCALED,
GFC_ISYM_ETIME,
+ GFC_ISYM_EVENT_QUERY,
GFC_ISYM_EXECUTE_COMMAND_LINE,
GFC_ISYM_EXIT,
GFC_ISYM_EXP,
@@ -847,7 +849,7 @@ typedef struct
entities. */
unsigned alloc_comp:1, pointer_comp:1, proc_pointer_comp:1,
private_comp:1, zero_comp:1, coarray_comp:1, lock_comp:1,
- defined_assign_comp:1, unlimited_polymorphic:1;
+ event_comp:1, defined_assign_comp:1, unlimited_polymorphic:1;
/* This is a temporary selector for SELECT TYPE or an associate
variable for SELECT_TYPE or ASSOCIATE. */
@@ -2330,7 +2332,7 @@ typedef enum
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_LOCK, EXEC_UNLOCK, EXEC_EVENT_POST, EXEC_EVENT_WAIT,
EXEC_OACC_KERNELS_LOOP, EXEC_OACC_PARALLEL_LOOP,
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 a06c5fc..616cd2c 100644
--- a/gcc/fortran/gfortran.texi
+++ b/gcc/fortran/gfortran.texi
@@ -3306,7 +3306,9 @@ typedef enum caf_register_t {
CAF_REGTYPE_COARRAY_ALLOC,
CAF_REGTYPE_LOCK_STATIC,
CAF_REGTYPE_LOCK_ALLOC,
- CAF_REGTYPE_CRITICAL
+ CAF_REGTYPE_CRITICAL,
+ CAF_REGTYPE_EVENT_STATIC,
+ CAF_REGTYPE_EVENT_ALLOC
}
caf_register_t;
@end verbatim
@@ -3327,6 +3329,9 @@ caf_register_t;
* _gfortran_caf_sendget:: Sending data between remote images
* _gfortran_caf_lock:: Locking a lock variable
* _gfortran_caf_unlock:: Unlocking a lock variable
+* _gfortran_caf_event_post:: Post an event
+* _gfortran_caf_event_wait:: Wait that an event occurred
+* _gfortran_caf_event_query:: Query event count
* _gfortran_caf_sync_all:: All-image barrier
* _gfortran_caf_sync_images:: Barrier for selected images
* _gfortran_caf_sync_memory:: Wait for completion of segment-memory operations
@@ -3480,7 +3485,7 @@ int *stat, char *errmsg, int errmsg_len)}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{size} @tab For normal coarrays, the byte size of the coarray to be
-allocated; for lock types, the number of elements.
+allocated; for lock types and event types, the number of elements.
@item @var{type} @tab one of the caf_register_t types.
@item @var{token} @tab intent(out) An opaque pointer identifying the coarray.
@item @var{stat} @tab intent(out) For allocatable coarrays, stores the STAT=;
@@ -3505,7 +3510,10 @@ image. For lock types, the value shall only used for checking the allocation
status. Note that for critical blocks, the locking is only required on one
image; in the locking statement, the processor shall always pass always an
image index of one for critical-block lock variables
-(@code{CAF_REGTYPE_CRITICAL}).
+(@code{CAF_REGTYPE_CRITICAL}). For lock types and critical-block variables,
+the initial value shall be unlocked (or, respecitively, not in critical
+section) such as the value false; for event types, the initial state should
+be no event, e.g. zero.
@end table
@@ -3733,8 +3741,7 @@ always 0.
number.
@item @var{aquired_lock} @tab intent(out) If not NULL, it returns whether lock
could be obtained
-@item @var{stat} @tab intent(out) For allocatable coarrays, stores the STAT=;
-may be NULL
+@item @var{stat} @tab intent(out) Stores the STAT=; may be NULL
@item @var{errmsg} @tab intent(out) When an error occurs, this will be set to
an error message; may be NULL
@item @var{errmsg_len} @tab the buffer size of errmsg.
@@ -3768,8 +3775,7 @@ int *stat, char *errmsg, int errmsg_len)}
always 0.
@item @var{image_index} @tab The ID of the remote image; must be a positive
number.
-@item @var{stat} @tab intent(out) For allocatable coarrays, stores the STAT=;
-may be NULL
+@item @var{stat} @tab intent(out) Stores the STAT=; may be NULL
@item @var{errmsg} @tab intent(out) When an error occurs, this will be set to
an error message; may be NULL
@item @var{errmsg_len} @tab the buffer size of errmsg.
@@ -3782,6 +3788,119 @@ images for critical-block locking variables.
@end table
+
+@node _gfortran_caf_event_post
+@subsection @code{_gfortran_caf_event_post} --- Post an event
+@cindex Coarray, _gfortran_caf_event_post
+
+@table @asis
+@item @emph{Description}:
+Increment the event count of the specified event variable.
+
+@item @emph{Syntax}:
+@code{void _gfortran_caf_event_post (caf_token_t token, size_t index,
+int image_index, int *stat, char *errmsg, int errmsg_len)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{token} @tab intent(in) An opaque pointer identifying the coarray.
+@item @var{index} @tab Array index; first array index is 0. For scalars, it is
+always 0.
+@item @var{image_index} @tab The ID of the remote image; must be a positive
+number; zero indicates the current image when accessed noncoindexed.
+@item @var{stat} @tab intent(out) Stores the STAT=; may be NULL
+@item @var{errmsg} @tab intent(out) When an error occurs, this will be set to
+an error message; may be NULL
+@item @var{errmsg_len} @tab the buffer size of errmsg.
+@end multitable
+
+@item @emph{NOTES}
+This acts like an atomic add of one to the remote image's event variable.
+The statement is an image-control statement but does not imply sync memory.
+Still, all preceeding push communications of this image to the specified
+remote image has to be completed before @code{event_wait} on the remote
+image returns.
+@end table
+
+
+
+@node _gfortran_caf_event_wait
+@subsection @code{_gfortran_caf_event_wait} --- Wait that an event occurred
+@cindex Coarray, _gfortran_caf_event_wait
+
+@table @asis
+@item @emph{Description}:
+Wait until the event count has reached at least the specified
+@var{until_count}; if so, atomically decrement the event variable by this
+amount and return.
+
+@item @emph{Syntax}:
+@code{void _gfortran_caf_event_wait (caf_token_t token, size_t index,
+int until_count, int *stat, char *errmsg, int errmsg_len)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{token} @tab intent(in) An opaque pointer identifying the coarray.
+@item @var{index} @tab Array index; first array index is 0. For scalars, it is
+always 0.
+@item @var{until_count} @tab The number of events which have to be available
+before the function returns.
+@item @var{stat} @tab intent(out) Stores the STAT=; may be NULL
+@item @var{errmsg} @tab intent(out) When an error occurs, this will be set to
+an error message; may be NULL
+@item @var{errmsg_len} @tab the buffer size of errmsg.
+@end multitable
+
+@item @emph{NOTES}
+This function only operates on a local coarray. It acts like a loop checking
+atomically the value of the event variable, breaking if the value is greater
+or equal the requested number of counts. Before the function returns, the
+event variable has to be decremented by the requested @var{until_count} value.
+A possible implementation would be a busy loop for a certain number of spins
+(possibly depending on the number of threads relative to the number of available
+cores) followed by other waiting strategy such as a sleeping wait (possibly with
+an increasing number of sleep time) or, if possible, a futex wait.
+
+The statement is an image-control statement but does not imply sync memory.
+Still, all preceeding push communications to this image of images having
+issued a @code{event_push} have to be completed before this function returns.
+@end table
+
+
+
+@node _gfortran_caf_event_query
+@subsection @code{_gfortran_caf_event_query} --- Query event count
+@cindex Coarray, _gfortran_caf_event_query
+
+@table @asis
+@item @emph{Description}:
+Return the event count of the specified event count.
+
+@item @emph{Syntax}:
+@code{void _gfortran_caf_event_query (caf_token_t token, size_t index,
+int image_index, int *count, int *stat)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{token} @tab intent(in) An opaque pointer identifying the coarray.
+@item @var{index} @tab Array index; first array index is 0. For scalars, it is
+always 0.
+@item @var{image_index} @tab The ID of the remote image; must be a positive
+number; zero indicates the current image when accessed noncoindexed.
+@item @var{count} @tab intent(out) The number of events currently posted to
+the event variable
+@item @var{stat} @tab intent(out) Stores the STAT=; may be NULL
+@end multitable
+
+@item @emph{NOTES}
+The typical use is to check the local even variable to only call
+@code{event_wait} when the data is available. However, a coindexed variable
+is permitted; there is no ordering or synchronization implied. It acts like
+an atomic fetch of the value of the event variable.
+@end table
+
+
+
@node _gfortran_caf_sync_all
@subsection @code{_gfortran_caf_sync_all} --- All-image barrier
@cindex Coarray, _gfortran_caf_sync_all
@@ -3926,7 +4045,7 @@ int image_index, void *value, int *stat, int type, int kind)}
@item @var{offset} @tab By which amount of bytes the actual data is shifted
compared to the base address of the coarray.
@item @var{image_index} @tab The ID of the remote image; must be a positive
-number.
+number; zero indicates the current image when used noncoindexed.
@item @var{value} @tab intent(in) the value to be assigned, passed by reference.
@item @var{stat} @tab intent(out) Stores the status STAT= and may be NULL.
@item @var{type} @tab the data type, i.e. @code{BT_INTEGER} (1) or
@@ -3956,7 +4075,7 @@ int image_index, void *value, int *stat, int type, int kind)}
@item @var{offset} @tab By which amount of bytes the actual data is shifted
compared to the base address of the coarray.
@item @var{image_index} @tab The ID of the remote image; must be a positive
-number.
+number; zero indicates the current image when used noncoindexed.
@item @var{value} @tab intent(out) The variable assigned the atomically
referenced variable.
@item @var{stat} @tab intent(out) Stores the status STAT= and may be NULL.
@@ -3989,7 +4108,7 @@ int type, int kind)}
@item @var{offset} @tab By which amount of bytes the actual data is shifted
compared to the base address of the coarray.
@item @var{image_index} @tab The ID of the remote image; must be a positive
-number.
+number; zero indicates the current image when used noncoindexed.
@item @var{old} @tab intent(out) the value which the atomic variable had
just before the cas operation.
@item @var{compare} @tab intent(in) The value used for comparision.
@@ -4031,7 +4150,7 @@ int image_index, void *value, void *old, int *stat, int type, int kind)}
@item @var{offset} @tab By which amount of bytes the actual data is shifted
compared to the base address of the coarray.
@item @var{image_index} @tab The ID of the remote image; must be a positive
-number.
+number; zero indicates the current image when used noncoindexed.
@item @var{old} @tab intent(out) the value which the atomic variable had
just before the atomic operation.
@item @var{val} @tab intent(in) The new value for the atomic variable,
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 320eb01..dab6dc0 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -2140,6 +2140,21 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
formal->name, &actual->where);
return 0;
}
+
+ /* TS18508, C702/C703. */
+ if (formal->attr.intent != INTENT_INOUT
+ && (((formal->ts.type == BT_DERIVED || formal->ts.type == BT_CLASS)
+ && formal->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+ && formal->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
+ || formal->attr.event_comp))
+
+ {
+ if (where)
+ gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, "
+ "which is EVENT_TYPE or has a EVENT_TYPE component",
+ formal->name, &actual->where);
+ return 0;
+ }
}
/* F2008, C1239/C1240. */
@@ -3362,7 +3377,8 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
if (a->expr
&& (a->expr->ts.type == BT_DERIVED || a->expr->ts.type == BT_CLASS)
&& ((a->expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
- && a->expr->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
+ && a->expr->ts.u.derived->intmod_sym_id
+ == ISOFORTRAN_LOCK_TYPE)
|| gfc_expr_attr (a->expr).lock_comp))
{
gfc_error ("Actual argument of LOCK_TYPE or with LOCK_TYPE "
@@ -3371,6 +3387,19 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
break;
}
+ if (a->expr
+ && (a->expr->ts.type == BT_DERIVED || a->expr->ts.type == BT_CLASS)
+ && ((a->expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+ && a->expr->ts.u.derived->intmod_sym_id
+ == ISOFORTRAN_EVENT_TYPE)
+ || gfc_expr_attr (a->expr).event_comp))
+ {
+ gfc_error ("Actual argument of EVENT_TYPE or with EVENT_TYPE "
+ "component at %L requires an explicit interface for "
+ "procedure %qs", &a->expr->where, sym->name);
+ break;
+ }
+
if (a->expr && a->expr->expr_type == EXPR_NULL
&& a->expr->ts.type == BT_UNKNOWN)
{
diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index a958f8e..3a971cb 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -3128,6 +3128,13 @@ add_subroutines (void)
GFC_STD_F95, gfc_check_cpu_time, NULL, gfc_resolve_cpu_time,
tm, BT_REAL, dr, REQUIRED, INTENT_OUT);
+ add_sym_3s ("event_query", GFC_ISYM_EVENT_QUERY, CLASS_ATOMIC,
+ BT_UNKNOWN, 0, GFC_STD_F2008_TS,
+ gfc_check_event_query, NULL, gfc_resolve_event_query,
+ "event", BT_INTEGER, di, REQUIRED, INTENT_IN,
+ c, BT_INTEGER, di, OPTIONAL, INTENT_IN,
+ stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
+
/* More G77 compatibility garbage. */
add_sym_2s ("ctime", GFC_ISYM_CTIME, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_ctime_sub, NULL, gfc_resolve_ctime_sub,
diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h
index be7f214..2ca41aa 100644
--- a/gcc/fortran/intrinsic.h
+++ b/gcc/fortran/intrinsic.h
@@ -70,6 +70,7 @@ bool gfc_check_dprod (gfc_expr *, gfc_expr *);
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_fgetputc (gfc_expr *, gfc_expr *);
bool gfc_check_fgetput (gfc_expr *);
bool gfc_check_float (gfc_expr *);
@@ -462,6 +463,7 @@ void gfc_resolve_dtime_sub (gfc_code *);
void gfc_resolve_eoshift (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
gfc_expr *);
void gfc_resolve_etime_sub (gfc_code *);
+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 *);
diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c
index 6fa0994..51bf8ea 100644
--- a/gcc/fortran/iresolve.c
+++ b/gcc/fortran/iresolve.c
@@ -2957,6 +2957,14 @@ gfc_resolve_atomic_ref (gfc_code *c)
void
+gfc_resolve_event_query (gfc_code *c)
+{
+ const char *name = "event_query";
+ c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+
+void
gfc_resolve_mvbits (gfc_code *c)
{
static const sym_intent INTENTS[] = {INTENT_IN, INTENT_IN, INTENT_IN,
diff --git a/gcc/fortran/iso-fortran-env.def b/gcc/fortran/iso-fortran-env.def
index eba0b4c..c5fb3ff 100644
--- a/gcc/fortran/iso-fortran-env.def
+++ b/gcc/fortran/iso-fortran-env.def
@@ -123,6 +123,11 @@ NAMED_FUNCTION (ISOFORTRAN_COMPILER_VERSION, "compiler_version", \
NAMED_DERIVED_TYPE (ISOFORTRAN_LOCK_TYPE, "lock_type", \
get_int_kind_from_node (ptr_type_node), GFC_STD_F2008)
+NAMED_DERIVED_TYPE (ISOFORTRAN_EVENT_TYPE, "event_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 8234c27..4b7172b 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -1468,6 +1468,8 @@ gfc_match_if (gfc_statement *if_type)
match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE)
match ("end file", gfc_match_endfile, ST_END_FILE)
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)
match ("exit", gfc_match_exit, ST_EXIT)
match ("flush", gfc_match_flush, ST_FLUSH)
match ("forall", match_simple_forall, ST_FORALL)
@@ -2748,6 +2750,203 @@ gfc_match_error_stop (void)
}
+/* Match EVENT POST/WAIT statement. Syntax:
+ EVENT POST ( event-variable [, sync-stat-list] )
+ EVENT WAIT ( event-variable [, wait-spec-list] )
+ with
+ wait-spec-list is sync-stat-list or until-spec
+ until-spec is UNTIL_COUNT = scalar-int-expr
+ sync-stat is STAT= or ERRMSG=. */
+
+static match
+event_statement (gfc_statement st)
+{
+ match m;
+ gfc_expr *tmp, *eventvar, *until_count, *stat, *errmsg;
+ bool saw_until_count, saw_stat, saw_errmsg;
+
+ tmp = eventvar = until_count = stat = errmsg = NULL;
+ saw_until_count = saw_stat = saw_errmsg = false;
+
+ if (gfc_pure (NULL))
+ {
+ gfc_error ("Image control statement EVENT %s at %C in PURE procedure",
+ st == ST_EVENT_POST ? "POST" : "WAIT");
+ return MATCH_ERROR;
+ }
+
+ gfc_unset_implicit_pure (NULL);
+
+ if (flag_coarray == GFC_FCOARRAY_NONE)
+ {
+ gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
+ return MATCH_ERROR;
+ }
+
+ if (gfc_find_state (COMP_CRITICAL))
+ {
+ gfc_error ("Image control statement EVENT %s at %C in CRITICAL block",
+ st == ST_EVENT_POST ? "POST" : "WAIT");
+ return MATCH_ERROR;
+ }
+
+ if (gfc_find_state (COMP_DO_CONCURRENT))
+ {
+ gfc_error ("Image control statement EVENT %s at %C in DO CONCURRENT "
+ "block", st == ST_EVENT_POST ? "POST" : "WAIT");
+ return MATCH_ERROR;
+ }
+
+ if (gfc_match_char ('(') != MATCH_YES)
+ goto syntax;
+
+ if (gfc_match ("%e", &eventvar) != MATCH_YES)
+ goto syntax;
+ m = gfc_match_char (',');
+ if (m == MATCH_ERROR)
+ goto syntax;
+ if (m == MATCH_NO)
+ {
+ m = gfc_match_char (')');
+ if (m == MATCH_YES)
+ goto done;
+ goto syntax;
+ }
+
+ for (;;)
+ {
+ m = gfc_match (" stat = %v", &tmp);
+ if (m == MATCH_ERROR)
+ goto syntax;
+ if (m == MATCH_YES)
+ {
+ if (saw_stat)
+ {
+ gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
+ goto cleanup;
+ }
+ stat = tmp;
+ saw_stat = true;
+
+ m = gfc_match_char (',');
+ if (m == MATCH_YES)
+ continue;
+
+ tmp = NULL;
+ break;
+ }
+
+ m = gfc_match (" errmsg = %v", &tmp);
+ if (m == MATCH_ERROR)
+ goto syntax;
+ if (m == MATCH_YES)
+ {
+ if (saw_errmsg)
+ {
+ gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
+ goto cleanup;
+ }
+ errmsg = tmp;
+ saw_errmsg = true;
+
+ m = gfc_match_char (',');
+ if (m == MATCH_YES)
+ continue;
+
+ tmp = NULL;
+ break;
+ }
+
+ m = gfc_match (" until_count = %e", &tmp);
+ if (m == MATCH_ERROR || st == ST_EVENT_POST)
+ goto syntax;
+ if (m == MATCH_YES)
+ {
+ if (saw_until_count)
+ {
+ gfc_error ("Redundant UNTIL_COUNT tag found at %L ",
+ &tmp->where);
+ goto cleanup;
+ }
+ until_count = tmp;
+ saw_until_count = true;
+
+ m = gfc_match_char (',');
+ if (m == MATCH_YES)
+ continue;
+
+ tmp = NULL;
+ break;
+ }
+
+ break;
+ }
+
+ if (m == MATCH_ERROR)
+ goto syntax;
+
+ if (gfc_match (" )%t") != MATCH_YES)
+ goto syntax;
+
+done:
+ switch (st)
+ {
+ case ST_EVENT_POST:
+ new_st.op = EXEC_EVENT_POST;
+ break;
+ case ST_EVENT_WAIT:
+ new_st.op = EXEC_EVENT_WAIT;
+ break;
+ default:
+ gcc_unreachable ();
+ }
+
+ new_st.expr1 = eventvar;
+ new_st.expr2 = stat;
+ new_st.expr3 = errmsg;
+ new_st.expr4 = until_count;
+
+ return MATCH_YES;
+
+syntax:
+ gfc_syntax_error (st);
+
+cleanup:
+ if (until_count != tmp)
+ gfc_free_expr (until_count);
+ if (errmsg != tmp)
+ gfc_free_expr (errmsg);
+ if (stat != tmp)
+ gfc_free_expr (stat);
+
+ gfc_free_expr (tmp);
+ gfc_free_expr (eventvar);
+
+ return MATCH_ERROR;
+
+}
+
+
+match
+gfc_match_event_post (void)
+{
+ if (!gfc_notify_std (GFC_STD_F2008_TS, "EVENT POST statement at %C"))
+ return MATCH_ERROR;
+
+ return event_statement (ST_EVENT_POST);
+}
+
+
+match
+gfc_match_event_wait (void)
+{
+ if (!gfc_notify_std (GFC_STD_F2008_TS, "EVENT WAIT statement at %C"))
+ return MATCH_ERROR;
+
+ return event_statement (ST_EVENT_WAIT);
+}
+
+
/* 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 96d3ec1..7427b50 100644
--- a/gcc/fortran/match.h
+++ b/gcc/fortran/match.h
@@ -69,6 +69,8 @@ match gfc_match_assignment (void);
match gfc_match_if (gfc_statement *);
match gfc_match_else (void);
match gfc_match_elseif (void);
+match gfc_match_event_post (void);
+match gfc_match_event_wait (void);
match gfc_match_critical (void);
match gfc_match_block (void);
match gfc_match_associate (void);
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index 1abfc46..c1145f5 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -1889,7 +1889,7 @@ typedef enum
AB_ELEMENTAL, AB_PURE, AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT,
AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE,
AB_ALLOC_COMP, AB_POINTER_COMP, AB_PROC_POINTER_COMP, AB_PRIVATE_COMP,
- AB_VALUE, AB_VOLATILE, AB_PROTECTED, AB_LOCK_COMP,
+ AB_VALUE, AB_VOLATILE, AB_PROTECTED, AB_LOCK_COMP, AB_EVENT_COMP,
AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP,
AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS, AB_CODIMENSION,
AB_COARRAY_COMP, AB_VTYPE, AB_VTAB, AB_CONTIGUOUS, AB_CLASS_POINTER,
@@ -1935,6 +1935,7 @@ static const mstring attr_bits[] =
minit ("ALLOC_COMP", AB_ALLOC_COMP),
minit ("COARRAY_COMP", AB_COARRAY_COMP),
minit ("LOCK_COMP", AB_LOCK_COMP),
+ minit ("EVENT_COMP", AB_EVENT_COMP),
minit ("POINTER_COMP", AB_POINTER_COMP),
minit ("PROC_POINTER_COMP", AB_PROC_POINTER_COMP),
minit ("PRIVATE_COMP", AB_PRIVATE_COMP),
@@ -2117,6 +2118,8 @@ mio_symbol_attribute (symbol_attribute *attr)
MIO_NAME (ab_attribute) (AB_COARRAY_COMP, attr_bits);
if (attr->lock_comp)
MIO_NAME (ab_attribute) (AB_LOCK_COMP, attr_bits);
+ if (attr->event_comp)
+ MIO_NAME (ab_attribute) (AB_EVENT_COMP, attr_bits);
if (attr->zero_comp)
MIO_NAME (ab_attribute) (AB_ZERO_COMP, attr_bits);
if (attr->is_class)
@@ -2269,6 +2272,9 @@ mio_symbol_attribute (symbol_attribute *attr)
case AB_LOCK_COMP:
attr->lock_comp = 1;
break;
+ case AB_EVENT_COMP:
+ attr->event_comp = 1;
+ break;
case AB_POINTER_COMP:
attr->pointer_comp = 1;
break;
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index 2c7c554..7b3e04e 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -457,6 +457,8 @@ decode_statement (void)
match ("entry% ", gfc_match_entry, ST_ENTRY);
match ("equivalence", gfc_match_equivalence, ST_EQUIVALENCE);
match ("external", gfc_match_external, ST_ATTR_DECL);
+ match ("event post", gfc_match_event_post, ST_EVENT_POST);
+ match ("event wait", gfc_match_event_wait, ST_EVENT_WAIT);
break;
case 'f':
@@ -1323,6 +1325,7 @@ next_statement (void)
case ST_OMP_CANCEL: case ST_OMP_CANCELLATION_POINT: \
case ST_OMP_TARGET_UPDATE: case ST_ERROR_STOP: case ST_SYNC_ALL: \
case ST_SYNC_IMAGES: case ST_SYNC_MEMORY: case ST_LOCK: case ST_UNLOCK: \
+ case ST_EVENT_POST: case ST_EVENT_WAIT: \
case ST_OACC_UPDATE: case ST_OACC_WAIT: case ST_OACC_CACHE: \
case ST_OACC_ENTER_DATA: case ST_OACC_EXIT_DATA
@@ -1628,6 +1631,12 @@ gfc_ascii_statement (gfc_statement st)
case ST_ELSEWHERE:
p = "ELSEWHERE";
break;
+ case ST_EVENT_POST:
+ p = "EVENT POST";
+ break;
+ case ST_EVENT_WAIT:
+ p = "EVENT WAIT";
+ break;
case ST_END_ASSOCIATE:
p = "END ASSOCIATE";
break;
@@ -2609,7 +2618,7 @@ parse_derived (void)
gfc_statement st;
gfc_state_data s;
gfc_symbol *sym;
- gfc_component *c, *lock_comp = NULL;
+ gfc_component *c, *lock_comp = NULL, *event_comp = NULL;
accept_statement (ST_DERIVED_DECL);
push_state (&s, COMP_DERIVED, gfc_new_block);
@@ -2717,8 +2726,8 @@ endType:
sym = gfc_current_block ();
for (c = sym->components; c; c = c->next)
{
- bool coarray, lock_type, allocatable, pointer;
- coarray = lock_type = allocatable = pointer = false;
+ bool coarray, lock_type, event_type, allocatable, pointer;
+ coarray = lock_type = event_type = allocatable = pointer = false;
/* Look for allocatable components. */
if (c->attr.allocatable
@@ -2780,6 +2789,23 @@ endType:
sym->attr.lock_comp = 1;
}
+ /* Looking for event_type components. */
+ if ((c->ts.type == BT_DERIVED
+ && c->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+ && c->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
+ || (c->ts.type == BT_CLASS && c->attr.class_ok
+ && CLASS_DATA (c)->ts.u.derived->from_intmod
+ == INTMOD_ISO_FORTRAN_ENV
+ && CLASS_DATA (c)->ts.u.derived->intmod_sym_id
+ == ISOFORTRAN_EVENT_TYPE)
+ || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.event_comp
+ && !allocatable && !pointer))
+ {
+ event_type = 1;
+ event_comp = c;
+ sym->attr.event_comp = 1;
+ }
+
/* Check for F2008, C1302 - and recall that pointers may not be coarrays
(5.3.14) and that subobjects of coarray are coarray themselves (2.4.7),
unless there are nondirect [allocatable or pointer] components
@@ -2820,6 +2846,43 @@ endType:
"coarray subcomponent)", lock_comp->name, &lock_comp->loc,
sym->name, c->name, &c->loc);
+ /* Similarly for EVENT TYPE. */
+
+ if (pointer && !coarray && event_type)
+ gfc_error ("Component %s at %L of type EVENT_TYPE must have a "
+ "codimension or be a subcomponent of a coarray, "
+ "which is not possible as the component has the "
+ "pointer attribute", c->name, &c->loc);
+ else if (pointer && !coarray && c->ts.type == BT_DERIVED
+ && c->ts.u.derived->attr.event_comp)
+ gfc_error ("Pointer component %s at %L has a noncoarray subcomponent "
+ "of type EVENT_TYPE, which must have a codimension or be a "
+ "subcomponent of a coarray", c->name, &c->loc);
+
+ if (event_type && allocatable && !coarray)
+ gfc_error ("Allocatable component %s at %L of type EVENT_TYPE must have "
+ "a codimension", c->name, &c->loc);
+ else if (event_type && allocatable && c->ts.type == BT_DERIVED
+ && c->ts.u.derived->attr.event_comp)
+ gfc_error ("Allocatable component %s at %L must have a codimension as "
+ "it has a noncoarray subcomponent of type EVENT_TYPE",
+ c->name, &c->loc);
+
+ if (sym->attr.coarray_comp && !coarray && event_type)
+ gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with "
+ "subcomponent of type EVENT_TYPE must have a codimension or "
+ "be a subcomponent of a coarray. (Variables of type %s may "
+ "not have a codimension as already a coarray "
+ "subcomponent exists)", c->name, &c->loc, sym->name);
+
+ if (sym->attr.event_comp && coarray && !event_type)
+ gfc_error_1 ("Noncoarray component %s at %L of type EVENT_TYPE or with "
+ "subcomponent of type EVENT_TYPE must have a codimension or "
+ "be a subcomponent of a coarray. (Variables of type %s may "
+ "not have a codimension as %s at %L has a codimension or a "
+ "coarray subcomponent)", event_comp->name, &event_comp->loc,
+ sym->name, c->name, &c->loc);
+
/* Look for private components. */
if (sym->component_access == ACCESS_PRIVATE
|| c->attr.access == ACCESS_PRIVATE
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 316b413..a61d9bf 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -6975,6 +6975,21 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
&code->expr3->where, &e->where);
goto failure;
}
+
+ /* Check TS18508, C702/C703. */
+ if (code->expr3->ts.type == BT_DERIVED
+ && ((codimension && gfc_expr_attr (code->expr3).event_comp)
+ || (code->expr3->ts.u.derived->from_intmod
+ == INTMOD_ISO_FORTRAN_ENV
+ && code->expr3->ts.u.derived->intmod_sym_id
+ == ISOFORTRAN_EVENT_TYPE)))
+ {
+ gfc_error_1 ("The source-expr at %L shall neither be of type "
+ "EVENT_TYPE nor have a EVENT_TYPE component if "
+ "allocate-object at %L is a coarray",
+ &code->expr3->where, &e->where);
+ goto failure;
+ }
}
/* Check F08:C629. */
@@ -7026,6 +7041,13 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
no SOURCE exists by setting expr3. */
code->expr3 = gfc_default_initializer (&code->ext.alloc.ts);
}
+ else if (flag_coarray != GFC_FCOARRAY_LIB && e->ts.type == BT_DERIVED
+ && e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+ && e->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
+ {
+ /* We have to zero initialize the integer variable. */
+ code->expr3 = gfc_get_int_expr (gfc_default_integer_kind, &e->where, 0);
+ }
else if (!code->expr3)
{
/* Set up default initializer if needed. */
@@ -8543,21 +8565,40 @@ find_reachable_labels (gfc_code *block)
static void
-resolve_lock_unlock (gfc_code *code)
+resolve_lock_unlock_event (gfc_code *code)
{
if (code->expr1->expr_type == EXPR_FUNCTION
&& code->expr1->value.function.isym
&& code->expr1->value.function.isym->id == GFC_ISYM_CAF_GET)
remove_caf_get_intrinsic (code->expr1);
- if (code->expr1->ts.type != BT_DERIVED
- || code->expr1->expr_type != EXPR_VARIABLE
- || code->expr1->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
- || code->expr1->ts.u.derived->intmod_sym_id != ISOFORTRAN_LOCK_TYPE
- || code->expr1->rank != 0
- || (!gfc_is_coarray (code->expr1) && !gfc_is_coindexed (code->expr1)))
+ if ((code->op == EXEC_LOCK && code->op == EXEC_UNLOCK)
+ && (code->expr1->ts.type != BT_DERIVED
+ || code->expr1->expr_type != EXPR_VARIABLE
+ || code->expr1->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
+ || code->expr1->ts.u.derived->intmod_sym_id != ISOFORTRAN_LOCK_TYPE
+ || code->expr1->rank != 0
+ || (!gfc_is_coarray (code->expr1) &&
+ !gfc_is_coindexed (code->expr1))))
gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
&code->expr1->where);
+ else if ((code->op == EXEC_EVENT_POST && code->op == EXEC_EVENT_WAIT)
+ && (code->expr1->ts.type != BT_DERIVED
+ || code->expr1->expr_type != EXPR_VARIABLE
+ || code->expr1->ts.u.derived->from_intmod
+ != INTMOD_ISO_FORTRAN_ENV
+ || code->expr1->ts.u.derived->intmod_sym_id
+ != ISOFORTRAN_EVENT_TYPE
+ || code->expr1->rank != 0))
+ gfc_error ("Event variable at %L must be a scalar of type EVENT_TYPE",
+ &code->expr1->where);
+ else if (code->op == EXEC_EVENT_POST && !gfc_is_coarray (code->expr1)
+ && !gfc_is_coindexed (code->expr1))
+ gfc_error ("Event variable argument at %L must be a coarray or coindexed",
+ &code->expr1->where);
+ else if (code->op == EXEC_EVENT_WAIT && !gfc_is_coarray (code->expr1))
+ gfc_error ("Event variable argument at %L must be a coarray but not "
+ "coindexed", &code->expr1->where);
/* Check STAT. */
if (code->expr2
@@ -8583,17 +8624,22 @@ resolve_lock_unlock (gfc_code *code)
_("ERRMSG variable")))
return;
- /* Check ACQUIRED_LOCK. */
- if (code->expr4
+ /* Check for LOCK the ACQUIRED_LOCK. */
+ if (code->op != EXEC_EVENT_WAIT && code->expr4
&& (code->expr4->ts.type != BT_LOGICAL || code->expr4->rank != 0
|| code->expr4->expr_type != EXPR_VARIABLE))
gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
"variable", &code->expr4->where);
-
- if (code->expr4
+ if (code->op != EXEC_EVENT_WAIT && code->expr4
&& !gfc_check_vardef_context (code->expr4, false, false, false,
_("ACQUIRED_LOCK variable")))
return;
+
+ /* Check for EVENT WAIT the UNTIL_COUNT. */
+ if (code->op == EXEC_EVENT_WAIT && code->expr4
+ && (code->expr4->ts.type != BT_INTEGER || code->expr4->rank != 0))
+ gfc_error ("UNTIL_COUNT= argument at %L must be a scalar INTEGER "
+ "expression", &code->expr4->where);
}
@@ -10126,7 +10172,9 @@ gfc_resolve_code (gfc_code *code, gfc_namespace *ns)
case EXEC_LOCK:
case EXEC_UNLOCK:
- resolve_lock_unlock (code);
+ case EXEC_EVENT_POST:
+ case EXEC_EVENT_WAIT:
+ resolve_lock_unlock_event (code);
break;
case EXEC_ENTRY:
@@ -13611,6 +13659,19 @@ resolve_symbol (gfc_symbol *sym)
return;
}
+ /* TS18508, C702/C703. */
+ if (sym->ts.type == BT_DERIVED
+ && ((sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+ && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
+ || sym->ts.u.derived->attr.event_comp)
+ && !sym->attr.codimension && !sym->ts.u.derived->attr.coarray_comp)
+ {
+ gfc_error ("Variable %s at %L of type EVENT_TYPE or with subcomponent of "
+ "type LOCK_TYPE must be a coarray", sym->name,
+ &sym->declared_at);
+ return;
+ }
+
/* An assumed-size array with INTENT(OUT) shall not be of a type for which
default initialization is defined (5.1.2.4.4). */
if (sym->ts.type == BT_DERIVED
@@ -13640,6 +13701,15 @@ resolve_symbol (gfc_symbol *sym)
return;
}
+ /* TS18508. */
+ if (sym->ts.type == BT_DERIVED && sym->attr.dummy
+ && sym->attr.intent == INTENT_OUT && sym->attr.event_comp)
+ {
+ gfc_error ("Dummy argument %qs at %L of EVENT_TYPE shall not be "
+ "INTENT(OUT)", sym->name, &sym->declared_at);
+ return;
+ }
+
/* F2008, C525. */
if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
|| (sym->ts.type == BT_CLASS && sym->attr.class_ok
diff --git a/gcc/fortran/st.c b/gcc/fortran/st.c
index 116af15..03792f8 100644
--- a/gcc/fortran/st.c
+++ b/gcc/fortran/st.c
@@ -118,6 +118,8 @@ gfc_free_statement (gfc_code *p)
case EXEC_SYNC_MEMORY:
case EXEC_LOCK:
case EXEC_UNLOCK:
+ case EXEC_EVENT_POST:
+ case EXEC_EVENT_WAIT:
break;
case EXEC_BLOCK:
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 4c18920..c6bd851 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -163,6 +163,9 @@ tree gfor_fndecl_caf_atomic_cas;
tree gfor_fndecl_caf_atomic_op;
tree gfor_fndecl_caf_lock;
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_co_broadcast;
tree gfor_fndecl_co_max;
tree gfor_fndecl_co_min;
@@ -3545,6 +3548,21 @@ gfc_build_builtin_function_decls (void)
void_type_node, 6, pvoid_type_node, size_type_node, integer_type_node,
pint_type, pchar_type_node, integer_type_node);
+ gfor_fndecl_caf_event_post = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("caf_event_post")), "R..WW",
+ void_type_node, 6, pvoid_type_node, size_type_node, integer_type_node,
+ pint_type, pchar_type_node, integer_type_node);
+
+ gfor_fndecl_caf_event_wait = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("caf_event_wait")), "R..WW",
+ void_type_node, 6, pvoid_type_node, size_type_node, integer_type_node,
+ pint_type, pchar_type_node, integer_type_node);
+
+ gfor_fndecl_caf_event_query = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("caf_event_query")), "R..WW",
+ void_type_node, 5, pvoid_type_node, size_type_node, integer_type_node,
+ pint_type, pint_type);
+
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,
@@ -4839,7 +4857,7 @@ static void
generate_coarray_sym_init (gfc_symbol *sym)
{
tree tmp, size, decl, token;
- bool is_lock_type;
+ bool is_lock_type, is_event_type;
int reg_type;
if (sym->attr.dummy || sym->attr.allocatable || !sym->attr.codimension
@@ -4855,13 +4873,17 @@ generate_coarray_sym_init (gfc_symbol *sym)
&& sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
&& sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE;
+ is_event_type = sym->ts.type == BT_DERIVED
+ && sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+ && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE;
+
/* FIXME: Workaround for PR middle-end/49106, cf. also PR middle-end/49108
to make sure the variable is not optimized away. */
DECL_PRESERVE_P (DECL_CONTEXT (decl)) = 1;
/* For lock types, we pass the array size as only the library knows the
size of the variable. */
- if (is_lock_type)
+ if (is_lock_type || is_event_type)
size = gfc_index_one_node;
else
size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (decl)));
@@ -4883,6 +4905,8 @@ generate_coarray_sym_init (gfc_symbol *sym)
GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE(decl)));
if (is_lock_type)
reg_type = sym->attr.artificial ? GFC_CAF_CRITICAL : GFC_CAF_LOCK_STATIC;
+ else if (is_event_type)
+ reg_type = GFC_CAF_EVENT_STATIC;
else
reg_type = GFC_CAF_COARRAY_STATIC;
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register, 6, size,
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 9c5ce7d..e51f238 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -5677,7 +5677,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
len = cl.backend_decl;
}
- byref = (comp && (comp->attr.dimension || comp->ts.type == BT_CHARACTER))
+ byref = (comp && (comp->attr.dimension
+ || (comp->ts.type == BT_CHARACTER && !sym->attr.is_bind_c)))
|| (!comp && gfc_return_by_reference (sym));
if (byref)
{
@@ -6490,6 +6491,11 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
{
gfc_se se;
+ if (flag_coarray != GFC_FCOARRAY_LIB && ts->type == BT_DERIVED
+ && ts->u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+ && ts->u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
+ return build_constructor (type, NULL);
+
if (!(expr || pointer || procptr))
return NULL_TREE;
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 20e5b37..2337554 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -9260,6 +9260,152 @@ conv_intrinsic_atomic_cas (gfc_code *code)
return gfc_finish_block (&block);
}
+static tree
+conv_intrinsic_event_query (gfc_code *code)
+{
+ gfc_se se, argse;
+ tree stat = NULL_TREE, stat2 = NULL_TREE;
+ tree count = NULL_TREE, count2 = NULL_TREE;
+
+ gfc_expr *event_expr = code->ext.actual->expr;
+
+ if (code->ext.actual->next->next->expr)
+ {
+ gcc_assert (code->ext.actual->next->next->expr->expr_type
+ == EXPR_VARIABLE);
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr_val (&argse, code->ext.actual->next->next->expr);
+ stat = argse.expr;
+ }
+ else if (flag_coarray == GFC_FCOARRAY_LIB)
+ stat = null_pointer_node;
+
+ if (code->ext.actual->next->expr)
+ {
+ gcc_assert (code->ext.actual->next->expr->expr_type == EXPR_VARIABLE);
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr_val (&argse, code->ext.actual->next->expr);
+ count = argse.expr;
+ }
+
+ gfc_start_block (&se.pre);
+ if (flag_coarray == GFC_FCOARRAY_LIB)
+ {
+ tree tmp, token, image_index;
+ tree index = size_zero_node;
+
+ if (event_expr->expr_type == EXPR_FUNCTION
+ && event_expr->value.function.isym
+ && event_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
+ event_expr = event_expr->value.function.actual->expr;
+
+ tree caf_decl = gfc_get_tree_for_caf_expr (event_expr);
+
+ if (event_expr->symtree->n.sym->ts.type != BT_DERIVED
+ || event_expr->symtree->n.sym->ts.u.derived->from_intmod
+ != INTMOD_ISO_FORTRAN_ENV
+ || event_expr->symtree->n.sym->ts.u.derived->intmod_sym_id
+ != ISOFORTRAN_EVENT_TYPE)
+ {
+ gfc_error ("Sorry, the event component of derived type at %L is not "
+ "yet supported", &event_expr->where);
+ return NULL_TREE;
+ }
+
+ if (gfc_is_coindexed (event_expr))
+ image_index = gfc_caf_get_image_index (&se.pre, event_expr, caf_decl);
+ else
+ image_index = integer_zero_node;
+
+ gfc_get_caf_token_offset (&token, NULL, caf_decl, NULL_TREE, event_expr);
+
+ /* For arrays, obtain the array index. */
+ if (gfc_expr_attr (event_expr).dimension)
+ {
+ tree desc, tmp, extent, lbound, ubound;
+ gfc_array_ref *ar, ar2;
+ int i;
+
+ /* TODO: Extend this, once DT components are supported. */
+ ar = &event_expr->ref->u.ar;
+ ar2 = *ar;
+ memset (ar, '\0', sizeof (*ar));
+ ar->as = ar2.as;
+ ar->type = AR_FULL;
+
+ gfc_init_se (&argse, NULL);
+ argse.descriptor_only = 1;
+ gfc_conv_expr_descriptor (&argse, event_expr);
+ gfc_add_block_to_block (&se.pre, &argse.pre);
+ desc = argse.expr;
+ *ar = ar2;
+
+ extent = integer_one_node;
+ for (i = 0; i < ar->dimen; i++)
+ {
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr_type (&argse, ar->start[i], integer_type_node);
+ gfc_add_block_to_block (&argse.pre, &argse.pre);
+ lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ integer_type_node, argse.expr,
+ fold_convert(integer_type_node, lbound));
+ tmp = fold_build2_loc (input_location, MULT_EXPR,
+ integer_type_node, extent, tmp);
+ index = fold_build2_loc (input_location, PLUS_EXPR,
+ integer_type_node, index, tmp);
+ if (i < ar->dimen - 1)
+ {
+ ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
+ tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
+ tmp = fold_convert (integer_type_node, tmp);
+ extent = fold_build2_loc (input_location, MULT_EXPR,
+ integer_type_node, extent, tmp);
+ }
+ }
+ }
+
+ if (count != null_pointer_node && TREE_TYPE (count) != integer_type_node)
+ {
+ count2 = count;
+ count = gfc_create_var (integer_type_node, "count");
+ }
+
+ if (stat != null_pointer_node && TREE_TYPE (stat) != integer_type_node)
+ {
+ stat2 = stat;
+ stat = gfc_create_var (integer_type_node, "stat");
+ }
+
+ tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_event_query, 5,
+ token, index, image_index, count
+ ? gfc_build_addr_expr (NULL, count) : count,
+ stat != null_pointer_node
+ ? gfc_build_addr_expr (NULL, stat) : stat);
+ gfc_add_expr_to_block (&se.pre, tmp);
+
+ if (count2 != NULL_TREE)
+ gfc_add_modify (&se.pre, count2,
+ fold_convert (TREE_TYPE (count2), count));
+
+ if (stat2 != NULL_TREE)
+ gfc_add_modify (&se.pre, stat2,
+ fold_convert (TREE_TYPE (stat2), stat));
+
+ return gfc_finish_block (&se.pre);
+ }
+
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr_val (&argse, code->ext.actual->expr);
+ gfc_add_modify (&se.pre, count, fold_convert (TREE_TYPE (count), argse.expr));
+
+ if (stat != NULL_TREE)
+ gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0));
+
+ return gfc_finish_block (&se.pre);
+}
+
+
static tree
conv_intrinsic_move_alloc (gfc_code *code)
@@ -9527,6 +9673,10 @@ gfc_conv_intrinsic_subroutine (gfc_code *code)
res = conv_intrinsic_atomic_ref (code);
break;
+ case GFC_ISYM_EVENT_QUERY:
+ res = conv_intrinsic_event_query (code);
+ break;
+
case GFC_ISYM_C_F_POINTER:
case GFC_ISYM_C_F_PROCPOINTER:
res = conv_isocbinding_subroutine (code);
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 53e9bcc..6073f9a 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -788,6 +788,7 @@ gfc_trans_lock_unlock (gfc_code *code, gfc_exec_op op)
if (code->expr3)
{
gfc_init_se (&argse, NULL);
+ argse.want_pointer = 1;
gfc_conv_expr (&argse, code->expr3);
gfc_add_block_to_block (&se.pre, &argse.pre);
errmsg = argse.expr;
@@ -854,6 +855,167 @@ gfc_trans_lock_unlock (gfc_code *code, gfc_exec_op op)
tree
+gfc_trans_event_post_wait (gfc_code *code, gfc_exec_op op)
+{
+ gfc_se se, argse;
+ tree stat = NULL_TREE, stat2 = NULL_TREE;
+ tree until_count = NULL_TREE;
+
+ if (code->expr2)
+ {
+ gcc_assert (code->expr2->expr_type == EXPR_VARIABLE);
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr_val (&argse, code->expr2);
+ stat = argse.expr;
+ }
+ else if (flag_coarray == GFC_FCOARRAY_LIB)
+ stat = null_pointer_node;
+
+ if (code->expr4)
+ {
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr_val (&argse, code->expr4);
+ until_count = fold_convert (integer_type_node, argse.expr);
+ }
+ else
+ until_count = integer_one_node;
+
+ if (flag_coarray != GFC_FCOARRAY_LIB)
+ {
+ gfc_start_block (&se.pre);
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr_val (&argse, code->expr1);
+
+ if (op == EXEC_EVENT_POST)
+ gfc_add_modify (&se.pre, argse.expr,
+ fold_build2_loc (input_location, PLUS_EXPR,
+ TREE_TYPE (argse.expr), argse.expr,
+ build_int_cst (TREE_TYPE (argse.expr), 1)));
+ else
+ gfc_add_modify (&se.pre, argse.expr,
+ fold_build2_loc (input_location, MINUS_EXPR,
+ TREE_TYPE (argse.expr), argse.expr,
+ fold_convert (TREE_TYPE (argse.expr),
+ until_count)));
+ if (stat != NULL_TREE)
+ gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0));
+
+ return gfc_finish_block (&se.pre);
+ }
+
+ gfc_start_block (&se.pre);
+ tree tmp, token, image_index, errmsg, errmsg_len;
+ tree index = size_zero_node;
+ tree caf_decl = gfc_get_tree_for_caf_expr (code->expr1);
+
+ if (code->expr1->symtree->n.sym->ts.type != BT_DERIVED
+ || code->expr1->symtree->n.sym->ts.u.derived->from_intmod
+ != INTMOD_ISO_FORTRAN_ENV
+ || code->expr1->symtree->n.sym->ts.u.derived->intmod_sym_id
+ != ISOFORTRAN_EVENT_TYPE)
+ {
+ gfc_error ("Sorry, the event component of derived type at %L is not "
+ "yet supported", &code->expr1->where);
+ return NULL_TREE;
+ }
+
+ gfc_get_caf_token_offset (&token, NULL, caf_decl, NULL_TREE, code->expr1);
+
+ if (gfc_is_coindexed (code->expr1))
+ image_index = gfc_caf_get_image_index (&se.pre, code->expr1, caf_decl);
+ else
+ image_index = integer_zero_node;
+
+ /* For arrays, obtain the array index. */
+ if (gfc_expr_attr (code->expr1).dimension)
+ {
+ tree desc, tmp, extent, lbound, ubound;
+ gfc_array_ref *ar, ar2;
+ int i;
+
+ /* TODO: Extend this, once DT components are supported. */
+ ar = &code->expr1->ref->u.ar;
+ ar2 = *ar;
+ memset (ar, '\0', sizeof (*ar));
+ ar->as = ar2.as;
+ ar->type = AR_FULL;
+
+ gfc_init_se (&argse, NULL);
+ argse.descriptor_only = 1;
+ gfc_conv_expr_descriptor (&argse, code->expr1);
+ gfc_add_block_to_block (&se.pre, &argse.pre);
+ desc = argse.expr;
+ *ar = ar2;
+
+ extent = integer_one_node;
+ for (i = 0; i < ar->dimen; i++)
+ {
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr_type (&argse, ar->start[i], integer_type_node);
+ gfc_add_block_to_block (&argse.pre, &argse.pre);
+ lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ integer_type_node, argse.expr,
+ fold_convert(integer_type_node, lbound));
+ tmp = fold_build2_loc (input_location, MULT_EXPR,
+ integer_type_node, extent, tmp);
+ index = fold_build2_loc (input_location, PLUS_EXPR,
+ integer_type_node, index, tmp);
+ if (i < ar->dimen - 1)
+ {
+ ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
+ tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
+ tmp = fold_convert (integer_type_node, tmp);
+ extent = fold_build2_loc (input_location, MULT_EXPR,
+ integer_type_node, extent, tmp);
+ }
+ }
+ }
+
+ /* errmsg. */
+ if (code->expr3)
+ {
+ gfc_init_se (&argse, NULL);
+ argse.want_pointer = 1;
+ gfc_conv_expr (&argse, code->expr3);
+ gfc_add_block_to_block (&se.pre, &argse.pre);
+ errmsg = argse.expr;
+ errmsg_len = fold_convert (integer_type_node, argse.string_length);
+ }
+ else
+ {
+ errmsg = null_pointer_node;
+ errmsg_len = integer_zero_node;
+ }
+
+ if (stat != null_pointer_node && TREE_TYPE (stat) != integer_type_node)
+ {
+ stat2 = stat;
+ stat = gfc_create_var (integer_type_node, "stat");
+ }
+
+ if (op == EXEC_EVENT_POST)
+ tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_event_post, 6,
+ token, index, image_index,
+ stat != null_pointer_node
+ ? gfc_build_addr_expr (NULL, stat) : stat,
+ errmsg, errmsg_len);
+ else
+ tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_event_wait, 6,
+ token, index, until_count,
+ stat != null_pointer_node
+ ? gfc_build_addr_expr (NULL, stat) : stat,
+ errmsg, errmsg_len);
+ gfc_add_expr_to_block (&se.pre, tmp);
+
+ if (stat2 != NULL_TREE)
+ gfc_add_modify (&se.pre, stat2, fold_convert (TREE_TYPE (stat2), stat));
+
+ return gfc_finish_block (&se.pre);
+}
+
+
+tree
gfc_trans_sync (gfc_code *code, gfc_exec_op type)
{
gfc_se se, argse;
@@ -891,6 +1053,7 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type)
{
gcc_assert (code->expr3->expr_type == EXPR_VARIABLE);
gfc_init_se (&argse, NULL);
+ argse.want_pointer = 1;
gfc_conv_expr (&argse, code->expr3);
gfc_conv_string_parameter (&argse);
errmsg = gfc_build_addr_expr (NULL, argse.expr);
diff --git a/gcc/fortran/trans-stmt.h b/gcc/fortran/trans-stmt.h
index 2f2a0b3..9841fb8 100644
--- a/gcc/fortran/trans-stmt.h
+++ b/gcc/fortran/trans-stmt.h
@@ -55,6 +55,7 @@ tree gfc_trans_do_while (gfc_code *);
tree gfc_trans_select (gfc_code *);
tree gfc_trans_sync (gfc_code *, gfc_exec_op);
tree gfc_trans_lock_unlock (gfc_code *, gfc_exec_op);
+tree gfc_trans_event_post_wait (gfc_code *, gfc_exec_op);
tree gfc_trans_forall (gfc_code *);
tree gfc_trans_where (gfc_code *);
tree gfc_trans_allocate (gfc_code *);
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index 2533478..eaaa895 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -2392,6 +2392,11 @@ gfc_get_derived_type (gfc_symbol * derived)
&& derived->intmod_sym_id == ISOFORTRAN_LOCK_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)
+ return gfc_get_int_type (gfc_default_integer_kind);
+
if (derived && derived->attr.flavor == FL_PROCEDURE
&& derived->attr.generic)
derived = gfc_find_dt_in_generic (derived);
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index 2dabf08..0a0aa63 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -718,7 +718,7 @@ gfc_allocate_using_malloc (stmtblock_t * block, tree pointer,
static void
gfc_allocate_using_lib (stmtblock_t * block, tree pointer, tree size,
tree token, tree status, tree errmsg, tree errlen,
- bool lock_var)
+ bool lock_var, bool event_var)
{
tree tmp, pstat;
@@ -749,7 +749,8 @@ gfc_allocate_using_lib (stmtblock_t * block, tree pointer, tree size,
build_int_cst (size_type_node, 1)),
build_int_cst (integer_type_node,
lock_var ? GFC_CAF_LOCK_ALLOC
- : GFC_CAF_COARRAY_ALLOC),
+ : event_var ? GFC_CAF_EVENT_ALLOC
+ : GFC_CAF_COARRAY_ALLOC),
token, pstat, errmsg, errlen);
tmp = fold_build2_loc (input_location, MODIFY_EXPR,
@@ -811,6 +812,11 @@ gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size, tree token,
== INTMOD_ISO_FORTRAN_ENV
&& expr->ts.u.derived->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE;
+ bool event_var = expr->ts.type == BT_DERIVED
+ && expr->ts.u.derived->from_intmod
+ == INTMOD_ISO_FORTRAN_ENV
+ && expr->ts.u.derived->intmod_sym_id
+ == ISOFORTRAN_EVENT_TYPE;
/* In the front end, we represent the lock variable as pointer. However,
the FE only passes the pointer around and leaves the actual
representation to the library. Hence, we have to convert back to the
@@ -820,7 +826,7 @@ gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size, tree token,
size, TYPE_SIZE_UNIT (ptr_type_node));
gfc_allocate_using_lib (&alloc_block, mem, size, token, status,
- errmsg, errlen, lock_var);
+ errmsg, errlen, lock_var, event_var);
if (status != NULL_TREE)
{
@@ -1825,6 +1831,11 @@ trans_code (gfc_code * code, tree cond)
res = gfc_trans_lock_unlock (code, code->op);
break;
+ case EXEC_EVENT_POST:
+ case EXEC_EVENT_WAIT:
+ res = gfc_trans_event_post_wait (code, code->op);
+ break;
+
case EXEC_FORALL:
res = gfc_trans_forall (code);
break;
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index e2a1fea..80f5fe0 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -113,7 +113,9 @@ typedef enum
GFC_CAF_COARRAY_ALLOC,
GFC_CAF_LOCK_STATIC,
GFC_CAF_LOCK_ALLOC,
- GFC_CAF_CRITICAL
+ GFC_CAF_CRITICAL,
+ GFC_CAF_EVENT_STATIC,
+ GFC_CAF_EVENT_ALLOC
}
gfc_coarray_type;
@@ -760,6 +762,9 @@ extern GTY(()) tree gfor_fndecl_caf_atomic_cas;
extern GTY(()) tree gfor_fndecl_caf_atomic_op;
extern GTY(()) tree gfor_fndecl_caf_lock;
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_co_broadcast;
extern GTY(()) tree gfor_fndecl_co_max;
extern GTY(()) tree gfor_fndecl_co_min;
diff --git a/gcc/testsuite/gfortran.dg/coarray/event_1.f90 b/gcc/testsuite/gfortran.dg/coarray/event_1.f90
new file mode 100644
index 0000000..08922d1
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray/event_1.f90
@@ -0,0 +1,51 @@
+! { dg-do run }
+!
+! Run-time test for EVENT_TYPE
+!
+use iso_fortran_env, only: event_type
+implicit none
+
+type(event_type), save :: var[*]
+integer :: count, stat
+
+count = -42
+call event_query (var, count)
+if (count /= 0) call abort()
+
+stat = 99
+event post (var, stat=stat)
+if (stat /= 0) call abort()
+call event_query(var, count, stat=stat)
+if (count /= 1 .or. stat /= 0) call abort()
+
+stat = 99
+event post (var[this_image()])
+call event_query(var, count)
+if (count /= 2) call abort()
+
+stat = 99
+event wait (var)
+call event_query(var[this_image()], count)
+if (count /= 1) call abort()
+
+stat = 99
+event post (var)
+call event_query(var, count)
+if (count /= 2) call abort()
+
+stat = 99
+event post (var)
+call event_query(var, count)
+if (count /= 3) call abort()
+
+stat = 99
+event wait (var, until_count=2)
+call event_query(var, count)
+if (count /= 1) call abort()
+
+stat = 99
+event wait (var, stat=stat, until_count=1)
+if (stat /= 0) call abort()
+call event_query(event=var, stat=stat, count=count)
+if (count /= 0 .or. stat /= 0) call abort()
+end
diff --git a/gcc/testsuite/gfortran.dg/coarray/event_2.f90 b/gcc/testsuite/gfortran.dg/coarray/event_2.f90
new file mode 100644
index 0000000..62dbd57
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray/event_2.f90
@@ -0,0 +1,89 @@
+! { dg-do run }
+!
+! Run-time test for EVENT_TYPE
+!
+use iso_fortran_env, only: event_type
+implicit none
+
+type(event_type), save, allocatable :: var(:)[:]
+integer :: count, stat
+
+allocate(var(3)[*])
+
+count = -42
+call event_query (var(1), count)
+if (count /= 0) call abort()
+call event_query (var(1), count)
+if (count /= 0) call abort()
+call event_query (var(2), count)
+if (count /= 0) call abort()
+call event_query (var(3), count)
+if (count /= 0) call abort()
+
+stat = 99
+event post (var(2), stat=stat)
+if (stat /= 0) call abort()
+call event_query (var(1), count)
+if (count /= 0) call abort()
+call event_query(var(2), count, stat=stat)
+if (count /= 1 .or. stat /= 0) call abort()
+call event_query (var(3), count)
+if (count /= 0) call abort()
+
+stat = 99
+event post (var(2)[this_image()])
+call event_query(var(1), count)
+if (count /= 0) call abort()
+call event_query(var(2), count)
+if (count /= 2) call abort()
+call event_query(var(2)[this_image()], count)
+if (count /= 2) call abort()
+call event_query(var(3), count)
+if (count /= 0) call abort()
+
+stat = 99
+event wait (var(2))
+call event_query(var(1), count)
+if (count /= 0) call abort()
+call event_query(var(2), count)
+if (count /= 1) call abort()
+call event_query(var(3), count)
+if (count /= 0) call abort()
+
+stat = 99
+event post (var(2))
+call event_query(var(1), count)
+if (count /= 0) call abort()
+call event_query(var(2), count)
+if (count /= 2) call abort()
+call event_query(var(3), count)
+if (count /= 0) call abort()
+
+stat = 99
+event post (var(2))
+call event_query(var(1), count)
+if (count /= 0) call abort()
+call event_query(var(2), count)
+if (count /= 3) call abort()
+call event_query(var(3), count)
+if (count /= 0) call abort()
+
+stat = 99
+event wait (var(2), until_count=2)
+call event_query(var(1), count)
+if (count /= 0) call abort()
+call event_query(var(2), count)
+if (count /= 1) call abort()
+call event_query(var(3), count)
+if (count /= 0) call abort()
+
+stat = 99
+event wait (var(2), stat=stat, until_count=1)
+if (stat /= 0) call abort()
+call event_query(event=var(1), stat=stat, count=count)
+if (count /= 0 .or. stat /= 0) call abort()
+call event_query(event=var(2), stat=stat, count=count)
+if (count /= 0 .or. stat /= 0) call abort()
+call event_query(event=var(3), stat=stat, count=count)
+if (count /= 0 .or. stat /= 0) call abort()
+end
^ permalink raw reply [flat|nested] 15+ messages in thread
* Re: [Fortran, Patch] (RFC, Coarray) Implement TS18508's EVENTS
2015-04-29 7:58 [Fortran, Patch] (RFC, Coarray) Implement TS18508's EVENTS Tobias Burnus
@ 2015-11-25 17:30 ` Alessandro Fanfarillo
2015-11-25 19:17 ` Damian Rouson
` (2 more replies)
0 siblings, 3 replies; 15+ messages in thread
From: Alessandro Fanfarillo @ 2015-11-25 17:30 UTC (permalink / raw)
To: Tobias Burnus; +Cc: gcc-patches, gfortran
[-- Attachment #1: Type: text/plain, Size: 2918 bytes --]
Dear all,
in attachment the previous patch compatible with the current trunk.
The patch also includes the changes introduced in the latest TS 18508.
Built and regtested on x86_64-pc-linux-gnu.
PS: I will add the test cases in a different patch.
2015-04-29 9:55 GMT+02:00 Tobias Burnus <tobias.burnus@physik.fu-berlin.de>:
> Dear all,
>
> attached patch fixes a bug and implements EVENTS. I think the patch is
> finished, but I still have to extend the test cases, to re-read the
> patch and to write a changelog. As I am not sure how soon I will able
> to do so, I follow the paradigm: release soon, release often and post
> it here. Comments and reviews are welcome.
>
> The patch fixes two bug in the "errmsg" handling, found by Alessandro:
> I don't pass on the address of the actual argument and in libcaf_single,
> I copy only 8 characters (sizeof pointer) instead of all of the the
> characters of the error message.
>
> Regarding events: Events is a way to permit barrier/locking-free
> programming: One sends the finished data to an other image and then
> tells that image that the data is there ("event post(msg_var[idx])").
> That image can then either wait for the event by querying the status
> on the local variable ("event wait(msg_var)") or only check the status
> and if it is not ready do something else (e.g. another iteration);
> that's done via "call event_query(msg_var, count)".
>
> Technically, event_post works like atomic_add(msg_var[idx], 1) and
> event_query like "atomic_ref(msg_var, count)". event_wait is the same
> as event_query plus a spin/sleep loop waiting for the status change,
> followed by an atomic_add(msg_var, -until_count). Except that
> event_post/event_wait are image control statements. (Otherwise it
> could happen that the event is there before the data for which the
> event has been posted.)
>
> Regarding the implementation in this patch, the limitations are the
> same as for locking: Currently, neither lock_type nor event_type
> variables are permitted as (nonallocatable) components
> of a derived type - and type extension of them also not yet supported.*
>
> The spec can be found at http://bitly.com/sc22wg5 -> 2015 -> TS draft
> or directly at
> http://isotc.iso.org/livelink/livelink?func=ll&objId=17064344&objAction=Open
>
> Tobias
>
>
> * Doing so is not really difficult but I need to handle cases like
> the following. For "allocatable" with SOURCE= I also need to handle
> it with polymorphic types.
>
> type t1
> type(event_type) :: EV
> type(lock_type) :: LK
> end type1
> type t2
> type(t1) :: a(5)
> end type t2
> type t3
> type(t2) :: b(8)
> end type t3
>
> type(t3), save :: caf(3)[*]
>
> For those, I need to call _gfortran_caf_register for
> caf(:)%b(:)%a(:)%ev and caf(:)%b(:)%a(:)%lk
> Looping though all array references.
>
> Similar for
> type(t3), allocatable :: caf2(:)[:]
> allocate(caf2(n)[*])
> for the allocate call.
[-- Attachment #2: ChangeLog_events.diff --]
[-- Type: text/plain, Size: 3237 bytes --]
commit 4ebad7d27c29884eb7eed8ddc0628c9b6dc64622
Author: Alessandro Fanfarillo <fanfarillo@ing.uniroma2.it>
Date: Wed Nov 25 14:46:07 2015 +0100
ChangeLog update
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 0c81201..3d2c4cf 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,62 @@
+2015-11-25 Tobias Burnus <burnus@net-b.de>
+ Alessandro Fanfarillo <fanfarillo.gcc@gmail.com>
+
+ * check.c (gfc_check_event_query): New function.
+ * dump-parse-tree.c (show_code_node): Handle EXEC_EVENT_POST,
+ EXEC_EVENT_WAIT.
+ * expr.c (gfc_check_vardef_context): New check for event variables
+ definition.
+ * gfortran.h (gfc_statement): Add ST_EVENT_POST, ST_EVENT_WAIT.
+ (gfc_isym_id): GFC_ISYM_EVENT_QUERY.
+ (struct symbol_attribute): New field.
+ (gfc_exec_op): Add EXEC_EVENT_POST and EXEC_EVENT_WAIT.
+ * gfortran.texi: Document about new events functions and minor
+ changes.
+ * interface.c (compare_parameter): New check.
+ (gfc_procedure_use): New check for explicit procedure interface.
+ (add_subroutines): Add event_query.
+ * intrinsic.h (gfc_check_event_query,gfc_resolve_event_query):
+ New prototypes.
+ * iresolve.c (gfc_resolve_event_query): New function.
+ * iso-fortran-env.def (event_type): New type.
+ * match.c (event_statement,gfc_match_event_post,gfc_match_event_wait):
+ New functions.
+ (gfc_match_name): New event post and event wait.
+ * match.h (gfc_match_event_post,gfc_match_event_wait):
+ New prototypes.
+ * module.c (ab_attribute): Add AB_EVENT_COMP.
+ (attr_bits): Likewise.
+ (mio_symbol_attribute): Handle event_comp attribute.
+ * parse.c (decode_statement): Add ST_EVENT_POST, ST_EVENT_WAIT.
+ (next_statement): Add ST_EVENT_POST, ST_EVENT_WAIT.
+ (gfc_ascii_statement): Add ST_EVENT_POST, ST_EVENT_WAIT.
+ (parse_derived): Check for event_type components.
+ * resolve.c (resolve_allocate_expr): Check for event variable def.
+ (resolve_lock_unlock): Renamed to resolve_lock_unlock_event. It
+ includes logic for locks and events.
+ (gfc_resolve_code): Call it.
+ (gfc_resolve_symbol): New check for event variable to be a corray.
+ * st.c (gfc_free_statement): Handle new EXEC_EVENT_POST and
+ EXEC_EVENT_WAIT.
+ * trans-decl.c (gfor_fndecl_caf_event_post,gfor_fndecl_caf_event_wait,
+ gfor_fndecl_caf_event_query): New global variables.
+ (generate_coarray_sym_init): Checking for event_type.
+ (gfc_conv_procedure_call): Check for C bind attribute.
+ * trans-intrinsic.c (conv_intrinsic_event_query): New function.
+ (conv_intrinsic_move_alloc): Call it.
+ * trans-stmt.c (gfc_trans_lock_unlock): Passing address
+ of actual argument.
+ (gfc_trans_sync): Likewise.
+ (gfc_trans_event_post_wait): New function.
+ * trans-stmt.h (gfc_trans_event_post_wait): New prototype.
+ * trans-types.c (gfc_get_derived_type): Integer_kind as event_type.
+ * trans.c (gfc_allocate_using_lib): New argument and logic for events.
+ (gfc_allocate_allocatable): Passing new argument.
+ (trans_code): Handle EXEC_EVENT_POST, EXEC_EVENT_WAIT.
+ * trans.h (gfc_coarray_type): New elements.
+ (gfor_fndecl_caf_event_post,gfor_fndecl_caf_event_wait,
+ gfor_fndecl_caf_event_query): Declare them.
+
2015-11-22 Steven G. Kargl <kargl@gcc.gnu.org>
PR fortran/68486
[-- Attachment #3: new_events.diff --]
[-- Type: text/plain, Size: 59455 bytes --]
commit e02ca8b66a41be95f69d86063dfa1a96330559e8
Author: Alessandro Fanfarillo <fanfarillo@ing.uniroma2.it>
Date: Wed Nov 25 18:10:28 2015 +0100
Update of Tobias's patch for EVENTS implementation (https://gcc.gnu.org/ml/fortran/2015-04/msg00119.html)
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 038ee21..6dc7f3e 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -1157,6 +1157,59 @@ gfc_check_atomic_cas (gfc_expr *atom, gfc_expr *old, gfc_expr *compare,
return true;
}
+bool
+gfc_check_event_query (gfc_expr *event, gfc_expr *count, gfc_expr *stat)
+{
+ if (event->ts.type != BT_DERIVED
+ || event->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
+ || event->ts.u.derived->intmod_sym_id != ISOFORTRAN_EVENT_TYPE)
+ {
+ gfc_error ("EVENT argument at %L to the intrinsic EVENT_QUERY "
+ "shall be of type EVENT_TYPE", &event->where);
+ return false;
+ }
+
+ if (!scalar_check (event, 0))
+ return false;
+
+ if (!gfc_check_vardef_context (count, false, false, false, NULL))
+ {
+ gfc_error ("COUNT argument of the EVENT_QUERY intrinsic function at %L "
+ "shall be definable", &count->where);
+ return false;
+ }
+
+ if (!type_check (count, 1, BT_INTEGER))
+ return false;
+
+ int i = gfc_validate_kind (BT_INTEGER, count->ts.kind, false);
+ int j = gfc_validate_kind (BT_INTEGER, gfc_default_integer_kind, false);
+
+ if (gfc_integer_kinds[i].range < gfc_integer_kinds[j].range)
+ {
+ gfc_error ("COUNT argument of the EVENT_QUERY intrinsic function at %L "
+ "shall have at least the range of the default integer",
+ &count->where);
+ return false;
+ }
+
+ if (stat != NULL)
+ {
+ if (!type_check (stat, 2, BT_INTEGER))
+ return false;
+ if (!scalar_check (stat, 2))
+ return false;
+ if (!variable_check (stat, 2, false))
+ return false;
+
+ if (!gfc_notify_std (GFC_STD_F2008_TS, "STAT= argument to %s at %L",
+ gfc_current_intrinsic, &stat->where))
+ return false;
+ }
+
+ return true;
+}
+
bool
gfc_check_atomic_fetch_op (gfc_expr *atom, gfc_expr *value, gfc_expr *old,
diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c
index 48476af..df54df9 100644
--- a/gcc/fortran/dump-parse-tree.c
+++ b/gcc/fortran/dump-parse-tree.c
@@ -1659,6 +1659,33 @@ show_code_node (int level, gfc_code *c)
}
break;
+ case EXEC_EVENT_POST:
+ case EXEC_EVENT_WAIT:
+ if (c->op == EXEC_EVENT_POST)
+ fputs ("EVENT POST ", dumpfile);
+ else
+ fputs ("EVENT WAIT ", dumpfile);
+
+ fputs ("event-variable=", dumpfile);
+ if (c->expr1 != NULL)
+ show_expr (c->expr1);
+ if (c->expr4 != NULL)
+ {
+ fputs (" until_count=", dumpfile);
+ show_expr (c->expr4);
+ }
+ if (c->expr2 != NULL)
+ {
+ fputs (" stat=", dumpfile);
+ show_expr (c->expr2);
+ }
+ if (c->expr3 != NULL)
+ {
+ fputs (" errmsg=", dumpfile);
+ show_expr (c->expr3);
+ }
+ break;
+
case EXEC_LOCK:
case EXEC_UNLOCK:
if (c->op == EXEC_LOCK)
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 7aaf0e2..2aeb0b5 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -4860,6 +4860,19 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
return false;
}
+ /* TS18508, C702/C203. */
+ if (!alloc_obj
+ && (attr.lock_comp
+ || (e->ts.type == BT_DERIVED
+ && e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+ && e->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)))
+ {
+ if (context)
+ gfc_error ("LOCK_EVENT in variable definition context (%s) at %L",
+ context, &e->where);
+ return false;
+ }
+
/* INTENT(IN) dummy argument. Check this, unless the object itself is the
component of sub-component of a pointer; we need to distinguish
assignment to a pointer component from pointer-assignment to a pointer
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 5487c93..22d055c 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -241,7 +241,8 @@ enum gfc_statement
ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD,
ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD,
ST_PROCEDURE, ST_GENERIC, ST_CRITICAL, ST_END_CRITICAL,
- ST_GET_FCN_CHARACTERISTICS, ST_LOCK, ST_UNLOCK, ST_NONE
+ ST_GET_FCN_CHARACTERISTICS, ST_LOCK, ST_UNLOCK, ST_EVENT_POST,
+ ST_EVENT_WAIT,ST_NONE
};
/* Types of interfaces that we can have. Assignment interfaces are
@@ -393,6 +394,7 @@ enum gfc_isym_id
GFC_ISYM_ERFC,
GFC_ISYM_ERFC_SCALED,
GFC_ISYM_ETIME,
+ GFC_ISYM_EVENT_QUERY,
GFC_ISYM_EXECUTE_COMMAND_LINE,
GFC_ISYM_EXIT,
GFC_ISYM_EXP,
@@ -828,7 +830,7 @@ typedef struct
entities. */
unsigned alloc_comp:1, pointer_comp:1, proc_pointer_comp:1,
private_comp:1, zero_comp:1, coarray_comp:1, lock_comp:1,
- defined_assign_comp:1, unlimited_polymorphic:1;
+ event_comp:1, defined_assign_comp:1, unlimited_polymorphic:1;
/* This is a temporary selector for SELECT TYPE or an associate
variable for SELECT_TYPE or ASSOCIATE. */
@@ -2343,7 +2345,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_LOCK, EXEC_UNLOCK, EXEC_EVENT_POST, EXEC_EVENT_WAIT,
EXEC_OACC_KERNELS_LOOP, EXEC_OACC_PARALLEL_LOOP,
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 876f226..d82ded6 100644
--- a/gcc/fortran/gfortran.texi
+++ b/gcc/fortran/gfortran.texi
@@ -3342,7 +3342,9 @@ typedef enum caf_register_t {
CAF_REGTYPE_COARRAY_ALLOC,
CAF_REGTYPE_LOCK_STATIC,
CAF_REGTYPE_LOCK_ALLOC,
- CAF_REGTYPE_CRITICAL
+ CAF_REGTYPE_CRITICAL,
+ CAF_REGTYPE_EVENT_STATIC,
+ CAF_REGTYPE_EVENT_ALLOC
}
caf_register_t;
@end verbatim
@@ -3363,6 +3365,9 @@ caf_register_t;
* _gfortran_caf_sendget:: Sending data between remote images
* _gfortran_caf_lock:: Locking a lock variable
* _gfortran_caf_unlock:: Unlocking a lock variable
+* _gfortran_caf_event_post:: Post an event
+* _gfortran_caf_event_wait:: Wait that an event occurred
+* _gfortran_caf_event_query:: Query event count
* _gfortran_caf_sync_all:: All-image barrier
* _gfortran_caf_sync_images:: Barrier for selected images
* _gfortran_caf_sync_memory:: Wait for completion of segment-memory operations
@@ -3516,7 +3521,7 @@ int *stat, char *errmsg, int errmsg_len)}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{size} @tab For normal coarrays, the byte size of the coarray to be
-allocated; for lock types, the number of elements.
+allocated; for lock types and event types, the number of elements.
@item @var{type} @tab one of the caf_register_t types.
@item @var{token} @tab intent(out) An opaque pointer identifying the coarray.
@item @var{stat} @tab intent(out) For allocatable coarrays, stores the STAT=;
@@ -3541,7 +3546,10 @@ image. For lock types, the value shall only used for checking the allocation
status. Note that for critical blocks, the locking is only required on one
image; in the locking statement, the processor shall always pass always an
image index of one for critical-block lock variables
-(@code{CAF_REGTYPE_CRITICAL}).
+(@code{CAF_REGTYPE_CRITICAL}). For lock types and critical-block variables,
+the initial value shall be unlocked (or, respecitively, not in critical
+section) such as the value false; for event types, the initial state should
+be no event, e.g. zero.
@end table
@@ -3561,8 +3569,7 @@ int errmsg_len)}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
-@item @var{stat} @tab intent(out) For allocatable coarrays, stores the STAT=;
-may be NULL
+@item @var{stat} @tab intent(out) Stores the STAT=; may be NULL
@item @var{errmsg} @tab intent(out) When an error occurs, this will be set
to an error message; may be NULL
@item @var{errmsg_len} @tab the buffer size of errmsg.
@@ -3769,8 +3776,7 @@ always 0.
number.
@item @var{aquired_lock} @tab intent(out) If not NULL, it returns whether lock
could be obtained
-@item @var{stat} @tab intent(out) For allocatable coarrays, stores the STAT=;
-may be NULL
+@item @var{stat} @tab intent(out) Stores the STAT=; may be NULL
@item @var{errmsg} @tab intent(out) When an error occurs, this will be set to
an error message; may be NULL
@item @var{errmsg_len} @tab the buffer size of errmsg.
@@ -3782,7 +3788,6 @@ is always zero and the image index is one. Libraries are permitted to use other
images for critical-block locking variables.
@end table
-
@node _gfortran_caf_unlock
@subsection @code{_gfortran_caf_lock} --- Unlocking a lock variable
@cindex Coarray, _gfortran_caf_unlock
@@ -3817,6 +3822,115 @@ is always zero and the image index is one. Libraries are permitted to use other
images for critical-block locking variables.
@end table
+@node _gfortran_caf_event_post
+@subsection @code{_gfortran_caf_event_post} --- Post an event
+@cindex Coarray, _gfortran_caf_event_post
+
+@table @asis
+@item @emph{Description}:
+Increment the event count of the specified event variable.
+
+@item @emph{Syntax}:
+@code{void _gfortran_caf_event_post (caf_token_t token, size_t index,
+int image_index, int *stat, char *errmsg, int errmsg_len)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{token} @tab intent(in) An opaque pointer identifying the coarray.
+@item @var{index} @tab Array index; first array index is 0. For scalars, it is
+always 0.
+@item @var{image_index} @tab The ID of the remote image; must be a positive
+number; zero indicates the current image when accessed noncoindexed.
+@item @var{stat} @tab intent(out) Stores the STAT=; may be NULL
+@item @var{errmsg} @tab intent(out) When an error occurs, this will be set to
+an error message; may be NULL
+@item @var{errmsg_len} @tab the buffer size of errmsg.
+@end multitable
+
+@item @emph{NOTES}
+This acts like an atomic add of one to the remote image's event variable.
+The statement is an image-control statement but does not imply sync memory.
+Still, all preceeding push communications of this image to the specified
+remote image has to be completed before @code{event_wait} on the remote
+image returns.
+@end table
+
+
+
+@node _gfortran_caf_event_wait
+@subsection @code{_gfortran_caf_event_wait} --- Wait that an event occurred
+@cindex Coarray, _gfortran_caf_event_wait
+
+@table @asis
+@item @emph{Description}:
+Wait until the event count has reached at least the specified
+@var{until_count}; if so, atomically decrement the event variable by this
+amount and return.
+
+@item @emph{Syntax}:
+@code{void _gfortran_caf_event_wait (caf_token_t token, size_t index,
+int until_count, int *stat, char *errmsg, int errmsg_len)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{token} @tab intent(in) An opaque pointer identifying the coarray.
+@item @var{index} @tab Array index; first array index is 0. For scalars, it is
+always 0.
+@item @var{until_count} @tab The number of events which have to be available
+before the function returns.
+@item @var{stat} @tab intent(out) Stores the STAT=; may be NULL
+@item @var{errmsg} @tab intent(out) When an error occurs, this will be set to
+an error message; may be NULL
+@item @var{errmsg_len} @tab the buffer size of errmsg.
+@end multitable
+
+@item @emph{NOTES}
+This function only operates on a local coarray. It acts like a loop checking
+atomically the value of the event variable, breaking if the value is greater
+or equal the requested number of counts. Before the function returns, the
+event variable has to be decremented by the requested @var{until_count} value.
+A possible implementation would be a busy loop for a certain number of spins
+(possibly depending on the number of threads relative to the number of available
+cores) followed by other waiting strategy such as a sleeping wait (possibly with
+an increasing number of sleep time) or, if possible, a futex wait.
+
+The statement is an image-control statement but does not imply sync memory.
+Still, all preceeding push communications to this image of images having
+issued a @code{event_push} have to be completed before this function returns.
+@end table
+
+
+
+@node _gfortran_caf_event_query
+@subsection @code{_gfortran_caf_event_query} --- Query event count
+@cindex Coarray, _gfortran_caf_event_query
+
+@table @asis
+@item @emph{Description}:
+Return the event count of the specified event count.
+
+@item @emph{Syntax}:
+@code{void _gfortran_caf_event_query (caf_token_t token, size_t index,
+int image_index, int *count, int *stat)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{token} @tab intent(in) An opaque pointer identifying the coarray.
+@item @var{index} @tab Array index; first array index is 0. For scalars, it is
+always 0.
+@item @var{image_index} @tab The ID of the remote image; must be a positive
+number; zero indicates the current image when accessed noncoindexed.
+@item @var{count} @tab intent(out) The number of events currently posted to
+the event variable
+@item @var{stat} @tab intent(out) Stores the STAT=; may be NULL
+@end multitable
+
+@item @emph{NOTES}
+The typical use is to check the local even variable to only call
+@code{event_wait} when the data is available. However, a coindexed variable
+is permitted; there is no ordering or synchronization implied. It acts like
+an atomic fetch of the value of the event variable.
+@end table
@node _gfortran_caf_sync_all
@subsection @code{_gfortran_caf_sync_all} --- All-image barrier
@@ -3962,7 +4076,7 @@ int image_index, void *value, int *stat, int type, int kind)}
@item @var{offset} @tab By which amount of bytes the actual data is shifted
compared to the base address of the coarray.
@item @var{image_index} @tab The ID of the remote image; must be a positive
-number.
+number; zero indicates the current image when used noncoindexed.
@item @var{value} @tab intent(in) the value to be assigned, passed by reference.
@item @var{stat} @tab intent(out) Stores the status STAT= and may be NULL.
@item @var{type} @tab the data type, i.e. @code{BT_INTEGER} (1) or
@@ -3992,7 +4106,7 @@ int image_index, void *value, int *stat, int type, int kind)}
@item @var{offset} @tab By which amount of bytes the actual data is shifted
compared to the base address of the coarray.
@item @var{image_index} @tab The ID of the remote image; must be a positive
-number.
+number; zero indicates the current image when used noncoindexed.
@item @var{value} @tab intent(out) The variable assigned the atomically
referenced variable.
@item @var{stat} @tab intent(out) Stores the status STAT= and may be NULL.
@@ -4025,7 +4139,7 @@ int type, int kind)}
@item @var{offset} @tab By which amount of bytes the actual data is shifted
compared to the base address of the coarray.
@item @var{image_index} @tab The ID of the remote image; must be a positive
-number.
+number; zero indicates the current image when used noncoindexed.
@item @var{old} @tab intent(out) the value which the atomic variable had
just before the cas operation.
@item @var{compare} @tab intent(in) The value used for comparision.
@@ -4067,7 +4181,7 @@ int image_index, void *value, void *old, int *stat, int type, int kind)}
@item @var{offset} @tab By which amount of bytes the actual data is shifted
compared to the base address of the coarray.
@item @var{image_index} @tab The ID of the remote image; must be a positive
-number.
+number; zero indicates the current image when used noncoindexed.
@item @var{old} @tab intent(out) the value which the atomic variable had
just before the atomic operation.
@item @var{val} @tab intent(in) The new value for the atomic variable,
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index dcf3eae..f74239d 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -2157,6 +2157,21 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
formal->name, &actual->where);
return 0;
}
+
+ /* TS18508, C702/C703. */
+ if (formal->attr.intent != INTENT_INOUT
+ && (((formal->ts.type == BT_DERIVED || formal->ts.type == BT_CLASS)
+ && formal->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+ && formal->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
+ || formal->attr.event_comp))
+
+ {
+ if (where)
+ gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, "
+ "which is EVENT_TYPE or has a EVENT_TYPE component",
+ formal->name, &actual->where);
+ return 0;
+ }
}
/* F2008, C1239/C1240. */
@@ -3385,6 +3400,19 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
break;
}
+ if (a->expr
+ && (a->expr->ts.type == BT_DERIVED || a->expr->ts.type == BT_CLASS)
+ && ((a->expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+ && a->expr->ts.u.derived->intmod_sym_id
+ == ISOFORTRAN_EVENT_TYPE)
+ || gfc_expr_attr (a->expr).event_comp))
+ {
+ gfc_error ("Actual argument of EVENT_TYPE or with EVENT_TYPE "
+ "component at %L requires an explicit interface for "
+ "procedure %qs", &a->expr->where, sym->name);
+ break;
+ }
+
if (a->expr && a->expr->expr_type == EXPR_NULL
&& a->expr->ts.type == BT_UNKNOWN)
{
diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index 4e6a0d0..170006a 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -3164,6 +3164,13 @@ add_subroutines (void)
GFC_STD_F95, gfc_check_cpu_time, NULL, gfc_resolve_cpu_time,
tm, BT_REAL, dr, REQUIRED, INTENT_OUT);
+ add_sym_3s ("event_query", GFC_ISYM_EVENT_QUERY, CLASS_ATOMIC,
+ BT_UNKNOWN, 0, GFC_STD_F2008_TS,
+ gfc_check_event_query, NULL, gfc_resolve_event_query,
+ "event", BT_INTEGER, di, REQUIRED, INTENT_IN,
+ c, BT_INTEGER, di, OPTIONAL, INTENT_IN,
+ stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
+
/* More G77 compatibility garbage. */
add_sym_2s ("ctime", GFC_ISYM_CTIME, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_ctime_sub, NULL, gfc_resolve_ctime_sub,
diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h
index ca2ad30..9b76542 100644
--- a/gcc/fortran/intrinsic.h
+++ b/gcc/fortran/intrinsic.h
@@ -70,6 +70,7 @@ bool gfc_check_dprod (gfc_expr *, gfc_expr *);
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_fgetputc (gfc_expr *, gfc_expr *);
bool gfc_check_fgetput (gfc_expr *);
bool gfc_check_float (gfc_expr *);
@@ -462,6 +463,7 @@ void gfc_resolve_dtime_sub (gfc_code *);
void gfc_resolve_eoshift (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
gfc_expr *);
void gfc_resolve_etime_sub (gfc_code *);
+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 *);
diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c
index 80b429f..8aa3a16 100644
--- a/gcc/fortran/iresolve.c
+++ b/gcc/fortran/iresolve.c
@@ -2945,6 +2945,12 @@ gfc_resolve_atomic_ref (gfc_code *c)
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
+void
+gfc_resolve_event_query (gfc_code *c)
+{
+ const char *name = "event_query";
+ c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
void
gfc_resolve_mvbits (gfc_code *c)
diff --git a/gcc/fortran/iso-fortran-env.def b/gcc/fortran/iso-fortran-env.def
index eba0b4c..c5fb3ff 100644
--- a/gcc/fortran/iso-fortran-env.def
+++ b/gcc/fortran/iso-fortran-env.def
@@ -123,6 +123,11 @@ NAMED_FUNCTION (ISOFORTRAN_COMPILER_VERSION, "compiler_version", \
NAMED_DERIVED_TYPE (ISOFORTRAN_LOCK_TYPE, "lock_type", \
get_int_kind_from_node (ptr_type_node), GFC_STD_F2008)
+NAMED_DERIVED_TYPE (ISOFORTRAN_EVENT_TYPE, "event_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 22b0d7d..b553464 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -1463,6 +1463,8 @@ gfc_match_if (gfc_statement *if_type)
match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE)
match ("end file", gfc_match_endfile, ST_END_FILE)
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)
match ("exit", gfc_match_exit, ST_EXIT)
match ("flush", gfc_match_flush, ST_FLUSH)
match ("forall", match_simple_forall, ST_FORALL)
@@ -2747,6 +2749,202 @@ gfc_match_error_stop (void)
return gfc_match_stopcode (ST_ERROR_STOP);
}
+/* Match EVENT POST/WAIT statement. Syntax:
+ EVENT POST ( event-variable [, sync-stat-list] )
+ EVENT WAIT ( event-variable [, wait-spec-list] )
+ with
+ wait-spec-list is sync-stat-list or until-spec
+ until-spec is UNTIL_COUNT = scalar-int-expr
+ sync-stat is STAT= or ERRMSG=. */
+
+static match
+event_statement (gfc_statement st)
+{
+ match m;
+ gfc_expr *tmp, *eventvar, *until_count, *stat, *errmsg;
+ bool saw_until_count, saw_stat, saw_errmsg;
+
+ tmp = eventvar = until_count = stat = errmsg = NULL;
+ saw_until_count = saw_stat = saw_errmsg = false;
+
+ if (gfc_pure (NULL))
+ {
+ gfc_error ("Image control statement EVENT %s at %C in PURE procedure",
+ st == ST_EVENT_POST ? "POST" : "WAIT");
+ return MATCH_ERROR;
+ }
+
+ gfc_unset_implicit_pure (NULL);
+
+ if (flag_coarray == GFC_FCOARRAY_NONE)
+ {
+ gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
+ return MATCH_ERROR;
+ }
+
+ if (gfc_find_state (COMP_CRITICAL))
+ {
+ gfc_error ("Image control statement EVENT %s at %C in CRITICAL block",
+ st == ST_EVENT_POST ? "POST" : "WAIT");
+ return MATCH_ERROR;
+ }
+
+ if (gfc_find_state (COMP_DO_CONCURRENT))
+ {
+ gfc_error ("Image control statement EVENT %s at %C in DO CONCURRENT "
+ "block", st == ST_EVENT_POST ? "POST" : "WAIT");
+ return MATCH_ERROR;
+ }
+
+ if (gfc_match_char ('(') != MATCH_YES)
+ goto syntax;
+
+ if (gfc_match ("%e", &eventvar) != MATCH_YES)
+ goto syntax;
+ m = gfc_match_char (',');
+ if (m == MATCH_ERROR)
+ goto syntax;
+ if (m == MATCH_NO)
+ {
+ m = gfc_match_char (')');
+ if (m == MATCH_YES)
+ goto done;
+ goto syntax;
+ }
+
+ for (;;)
+ {
+ m = gfc_match (" stat = %v", &tmp);
+ if (m == MATCH_ERROR)
+ goto syntax;
+ if (m == MATCH_YES)
+ {
+ if (saw_stat)
+ {
+ gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
+ goto cleanup;
+ }
+ stat = tmp;
+ saw_stat = true;
+
+ m = gfc_match_char (',');
+ if (m == MATCH_YES)
+ continue;
+
+ tmp = NULL;
+ break;
+ }
+
+ m = gfc_match (" errmsg = %v", &tmp);
+ if (m == MATCH_ERROR)
+ goto syntax;
+ if (m == MATCH_YES)
+ {
+ if (saw_errmsg)
+ {
+ gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
+ goto cleanup;
+ }
+ errmsg = tmp;
+ saw_errmsg = true;
+
+ m = gfc_match_char (',');
+ if (m == MATCH_YES)
+ continue;
+
+ tmp = NULL;
+ break;
+ }
+
+ m = gfc_match (" until_count = %e", &tmp);
+ if (m == MATCH_ERROR || st == ST_EVENT_POST)
+ goto syntax;
+ if (m == MATCH_YES)
+ {
+ if (saw_until_count)
+ {
+ gfc_error ("Redundant UNTIL_COUNT tag found at %L ",
+ &tmp->where);
+ goto cleanup;
+ }
+ until_count = tmp;
+ saw_until_count = true;
+
+ m = gfc_match_char (',');
+ if (m == MATCH_YES)
+ continue;
+
+ tmp = NULL;
+ break;
+ }
+
+ break;
+ }
+
+ if (m == MATCH_ERROR)
+ goto syntax;
+
+ if (gfc_match (" )%t") != MATCH_YES)
+ goto syntax;
+
+done:
+ switch (st)
+ {
+ case ST_EVENT_POST:
+ new_st.op = EXEC_EVENT_POST;
+ break;
+ case ST_EVENT_WAIT:
+ new_st.op = EXEC_EVENT_WAIT;
+ break;
+ default:
+ gcc_unreachable ();
+ }
+
+ new_st.expr1 = eventvar;
+ new_st.expr2 = stat;
+ new_st.expr3 = errmsg;
+ new_st.expr4 = until_count;
+
+ return MATCH_YES;
+
+syntax:
+ gfc_syntax_error (st);
+
+cleanup:
+ if (until_count != tmp)
+ gfc_free_expr (until_count);
+ if (errmsg != tmp)
+ gfc_free_expr (errmsg);
+ if (stat != tmp)
+ gfc_free_expr (stat);
+
+ gfc_free_expr (tmp);
+ gfc_free_expr (eventvar);
+
+ return MATCH_ERROR;
+
+}
+
+
+match
+gfc_match_event_post (void)
+{
+ if (!gfc_notify_std (GFC_STD_F2008_TS, "EVENT POST statement at %C"))
+ return MATCH_ERROR;
+
+ return event_statement (ST_EVENT_POST);
+}
+
+
+match
+gfc_match_event_wait (void)
+{
+ if (!gfc_notify_std (GFC_STD_F2008_TS, "EVENT WAIT statement at %C"))
+ return MATCH_ERROR;
+
+ return event_statement (ST_EVENT_WAIT);
+}
+
/* Match LOCK/UNLOCK statement. Syntax:
LOCK ( lock-variable [ , lock-stat-list ] )
diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h
index a52c189..7d383ed 100644
--- a/gcc/fortran/match.h
+++ b/gcc/fortran/match.h
@@ -69,6 +69,8 @@ match gfc_match_assignment (void);
match gfc_match_if (gfc_statement *);
match gfc_match_else (void);
match gfc_match_elseif (void);
+match gfc_match_event_post (void);
+match gfc_match_event_wait (void);
match gfc_match_critical (void);
match gfc_match_block (void);
match gfc_match_associate (void);
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index 6b544ee..704ff15 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -1981,7 +1981,7 @@ enum ab_attribute
AB_ELEMENTAL, AB_PURE, AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT,
AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE,
AB_ALLOC_COMP, AB_POINTER_COMP, AB_PROC_POINTER_COMP, AB_PRIVATE_COMP,
- AB_VALUE, AB_VOLATILE, AB_PROTECTED, AB_LOCK_COMP,
+ AB_VALUE, AB_VOLATILE, AB_PROTECTED, AB_LOCK_COMP, AB_EVENT_COMP,
AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP,
AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS, AB_CODIMENSION,
AB_COARRAY_COMP, AB_VTYPE, AB_VTAB, AB_CONTIGUOUS, AB_CLASS_POINTER,
@@ -2028,6 +2028,7 @@ static const mstring attr_bits[] =
minit ("ALLOC_COMP", AB_ALLOC_COMP),
minit ("COARRAY_COMP", AB_COARRAY_COMP),
minit ("LOCK_COMP", AB_LOCK_COMP),
+ minit ("EVENT_COMP", AB_EVENT_COMP),
minit ("POINTER_COMP", AB_POINTER_COMP),
minit ("PROC_POINTER_COMP", AB_PROC_POINTER_COMP),
minit ("PRIVATE_COMP", AB_PRIVATE_COMP),
@@ -2216,6 +2217,8 @@ mio_symbol_attribute (symbol_attribute *attr)
MIO_NAME (ab_attribute) (AB_COARRAY_COMP, attr_bits);
if (attr->lock_comp)
MIO_NAME (ab_attribute) (AB_LOCK_COMP, attr_bits);
+ if (attr->event_comp)
+ MIO_NAME (ab_attribute) (AB_EVENT_COMP, attr_bits);
if (attr->zero_comp)
MIO_NAME (ab_attribute) (AB_ZERO_COMP, attr_bits);
if (attr->is_class)
@@ -2383,6 +2386,9 @@ mio_symbol_attribute (symbol_attribute *attr)
case AB_LOCK_COMP:
attr->lock_comp = 1;
break;
+ case AB_EVENT_COMP:
+ attr->event_comp = 1;
+ break;
case AB_POINTER_COMP:
attr->pointer_comp = 1;
break;
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index b280621..2ec6412 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -477,6 +477,8 @@ decode_statement (void)
match ("entry% ", gfc_match_entry, ST_ENTRY);
match ("equivalence", gfc_match_equivalence, ST_EQUIVALENCE);
match ("external", gfc_match_external, ST_ATTR_DECL);
+ match ("event post", gfc_match_event_post, ST_EVENT_POST);
+ match ("event wait", gfc_match_event_wait, ST_EVENT_WAIT);
break;
case 'f':
@@ -1348,6 +1350,7 @@ next_statement (void)
case ST_OMP_CANCEL: case ST_OMP_CANCELLATION_POINT: \
case ST_OMP_TARGET_UPDATE: case ST_ERROR_STOP: case ST_SYNC_ALL: \
case ST_SYNC_IMAGES: case ST_SYNC_MEMORY: case ST_LOCK: case ST_UNLOCK: \
+ case ST_EVENT_POST: case ST_EVENT_WAIT: \
case ST_OACC_UPDATE: case ST_OACC_WAIT: case ST_OACC_CACHE: \
case ST_OACC_ENTER_DATA: case ST_OACC_EXIT_DATA
@@ -1654,6 +1657,12 @@ gfc_ascii_statement (gfc_statement st)
case ST_ELSEWHERE:
p = "ELSEWHERE";
break;
+ case ST_EVENT_POST:
+ p = "EVENT POST";
+ break;
+ case ST_EVENT_WAIT:
+ p = "EVENT WAIT";
+ break;
case ST_END_ASSOCIATE:
p = "END ASSOCIATE";
break;
@@ -2646,7 +2655,7 @@ parse_derived (void)
gfc_statement st;
gfc_state_data s;
gfc_symbol *sym;
- gfc_component *c, *lock_comp = NULL;
+ gfc_component *c, *lock_comp = NULL, *event_comp = NULL;
accept_statement (ST_DERIVED_DECL);
push_state (&s, COMP_DERIVED, gfc_new_block);
@@ -2754,8 +2763,8 @@ endType:
sym = gfc_current_block ();
for (c = sym->components; c; c = c->next)
{
- bool coarray, lock_type, allocatable, pointer;
- coarray = lock_type = allocatable = pointer = false;
+ bool coarray, lock_type, event_type, allocatable, pointer;
+ coarray = lock_type = event_type = allocatable = pointer = false;
/* Look for allocatable components. */
if (c->attr.allocatable
@@ -2817,6 +2826,23 @@ endType:
sym->attr.lock_comp = 1;
}
+ /* Looking for event_type components. */
+ if ((c->ts.type == BT_DERIVED
+ && c->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+ && c->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
+ || (c->ts.type == BT_CLASS && c->attr.class_ok
+ && CLASS_DATA (c)->ts.u.derived->from_intmod
+ == INTMOD_ISO_FORTRAN_ENV
+ && CLASS_DATA (c)->ts.u.derived->intmod_sym_id
+ == ISOFORTRAN_EVENT_TYPE)
+ || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.event_comp
+ && !allocatable && !pointer))
+ {
+ event_type = 1;
+ event_comp = c;
+ sym->attr.event_comp = 1;
+ }
+
/* Check for F2008, C1302 - and recall that pointers may not be coarrays
(5.3.14) and that subobjects of coarray are coarray themselves (2.4.7),
unless there are nondirect [allocatable or pointer] components
@@ -2857,6 +2883,43 @@ endType:
"coarray subcomponent)", lock_comp->name, &lock_comp->loc,
sym->name, c->name, &c->loc);
+ /* Similarly for EVENT TYPE. */
+
+ if (pointer && !coarray && event_type)
+ gfc_error ("Component %s at %L of type EVENT_TYPE must have a "
+ "codimension or be a subcomponent of a coarray, "
+ "which is not possible as the component has the "
+ "pointer attribute", c->name, &c->loc);
+ else if (pointer && !coarray && c->ts.type == BT_DERIVED
+ && c->ts.u.derived->attr.event_comp)
+ gfc_error ("Pointer component %s at %L has a noncoarray subcomponent "
+ "of type EVENT_TYPE, which must have a codimension or be a "
+ "subcomponent of a coarray", c->name, &c->loc);
+
+ if (event_type && allocatable && !coarray)
+ gfc_error ("Allocatable component %s at %L of type EVENT_TYPE must have "
+ "a codimension", c->name, &c->loc);
+ else if (event_type && allocatable && c->ts.type == BT_DERIVED
+ && c->ts.u.derived->attr.event_comp)
+ gfc_error ("Allocatable component %s at %L must have a codimension as "
+ "it has a noncoarray subcomponent of type EVENT_TYPE",
+ c->name, &c->loc);
+
+ if (sym->attr.coarray_comp && !coarray && event_type)
+ gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with "
+ "subcomponent of type EVENT_TYPE must have a codimension or "
+ "be a subcomponent of a coarray. (Variables of type %s may "
+ "not have a codimension as already a coarray "
+ "subcomponent exists)", c->name, &c->loc, sym->name);
+
+ if (sym->attr.event_comp && coarray && !event_type)
+ gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with "
+ "subcomponent of type EVENT_TYPE must have a codimension or "
+ "be a subcomponent of a coarray. (Variables of type %s may "
+ "not have a codimension as %s at %L has a codimension or a "
+ "coarray subcomponent)", event_comp->name, &event_comp->loc,
+ sym->name, c->name, &c->loc);
+
/* Look for private components. */
if (sym->component_access == ACCESS_PRIVATE
|| c->attr.access == ACCESS_PRIVATE
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 685e3f5..9d14c73 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -7055,6 +7055,21 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec)
&code->expr3->where, &e->where);
goto failure;
}
+
+ /* Check TS18508, C702/C703. */
+ if (code->expr3->ts.type == BT_DERIVED
+ && ((codimension && gfc_expr_attr (code->expr3).event_comp)
+ || (code->expr3->ts.u.derived->from_intmod
+ == INTMOD_ISO_FORTRAN_ENV
+ && code->expr3->ts.u.derived->intmod_sym_id
+ == ISOFORTRAN_EVENT_TYPE)))
+ {
+ gfc_error ("The source-expr at %L shall neither be of type "
+ "EVENT_TYPE nor have a EVENT_TYPE component if "
+ "allocate-object at %L is a coarray",
+ &code->expr3->where, &e->where);
+ goto failure;
+ }
}
/* Check F08:C629. */
@@ -7106,6 +7121,13 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec)
no SOURCE exists by setting expr3. */
code->expr3 = gfc_default_initializer (&code->ext.alloc.ts);
}
+ else if (flag_coarray != GFC_FCOARRAY_LIB && e->ts.type == BT_DERIVED
+ && e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+ && e->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
+ {
+ /* We have to zero initialize the integer variable. */
+ code->expr3 = gfc_get_int_expr (gfc_default_integer_kind, &e->where, 0);
+ }
else if (!code->expr3)
{
/* Set up default initializer if needed. */
@@ -8706,21 +8728,40 @@ find_reachable_labels (gfc_code *block)
static void
-resolve_lock_unlock (gfc_code *code)
+resolve_lock_unlock_event (gfc_code *code)
{
if (code->expr1->expr_type == EXPR_FUNCTION
&& code->expr1->value.function.isym
&& code->expr1->value.function.isym->id == GFC_ISYM_CAF_GET)
remove_caf_get_intrinsic (code->expr1);
- if (code->expr1->ts.type != BT_DERIVED
- || code->expr1->expr_type != EXPR_VARIABLE
- || code->expr1->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
- || code->expr1->ts.u.derived->intmod_sym_id != ISOFORTRAN_LOCK_TYPE
- || code->expr1->rank != 0
- || (!gfc_is_coarray (code->expr1) && !gfc_is_coindexed (code->expr1)))
+ if ((code->op == EXEC_LOCK || code->op == EXEC_UNLOCK)
+ && (code->expr1->ts.type != BT_DERIVED
+ || code->expr1->expr_type != EXPR_VARIABLE
+ || code->expr1->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
+ || code->expr1->ts.u.derived->intmod_sym_id != ISOFORTRAN_LOCK_TYPE
+ || code->expr1->rank != 0
+ || (!gfc_is_coarray (code->expr1) &&
+ !gfc_is_coindexed (code->expr1))))
gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
&code->expr1->where);
+ else if ((code->op == EXEC_EVENT_POST && code->op == EXEC_EVENT_WAIT)
+ && (code->expr1->ts.type != BT_DERIVED
+ || code->expr1->expr_type != EXPR_VARIABLE
+ || code->expr1->ts.u.derived->from_intmod
+ != INTMOD_ISO_FORTRAN_ENV
+ || code->expr1->ts.u.derived->intmod_sym_id
+ != ISOFORTRAN_EVENT_TYPE
+ || code->expr1->rank != 0))
+ gfc_error ("Event variable at %L must be a scalar of type EVENT_TYPE",
+ &code->expr1->where);
+ else if (code->op == EXEC_EVENT_POST && !gfc_is_coarray (code->expr1)
+ && !gfc_is_coindexed (code->expr1))
+ gfc_error ("Event variable argument at %L must be a coarray or coindexed",
+ &code->expr1->where);
+ else if (code->op == EXEC_EVENT_WAIT && !gfc_is_coarray (code->expr1))
+ gfc_error ("Event variable argument at %L must be a coarray but not "
+ "coindexed", &code->expr1->where);
/* Check STAT. */
if (code->expr2
@@ -8746,17 +8787,23 @@ resolve_lock_unlock (gfc_code *code)
_("ERRMSG variable")))
return;
- /* Check ACQUIRED_LOCK. */
- if (code->expr4
+ /* Check for LOCK the ACQUIRED_LOCK. */
+ if (code->op != EXEC_EVENT_WAIT && code->expr4
&& (code->expr4->ts.type != BT_LOGICAL || code->expr4->rank != 0
|| code->expr4->expr_type != EXPR_VARIABLE))
gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
"variable", &code->expr4->where);
- if (code->expr4
+ if (code->op != EXEC_EVENT_WAIT && code->expr4
&& !gfc_check_vardef_context (code->expr4, false, false, false,
_("ACQUIRED_LOCK variable")))
return;
+
+ /* Check for EVENT WAIT the UNTIL_COUNT. */
+ if (code->op == EXEC_EVENT_WAIT && code->expr4
+ && (code->expr4->ts.type != BT_INTEGER || code->expr4->rank != 0))
+ gfc_error ("UNTIL_COUNT= argument at %L must be a scalar INTEGER "
+ "expression", &code->expr4->where);
}
@@ -10402,7 +10449,9 @@ start:
case EXEC_LOCK:
case EXEC_UNLOCK:
- resolve_lock_unlock (code);
+ case EXEC_EVENT_POST:
+ case EXEC_EVENT_WAIT:
+ resolve_lock_unlock_event (code);
break;
case EXEC_ENTRY:
@@ -14000,6 +14049,19 @@ resolve_symbol (gfc_symbol *sym)
return;
}
+ /* TS18508, C702/C703. */
+ if (sym->ts.type == BT_DERIVED
+ && ((sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+ && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
+ || sym->ts.u.derived->attr.event_comp)
+ && !sym->attr.codimension && !sym->ts.u.derived->attr.coarray_comp)
+ {
+ gfc_error ("Variable %s at %L of type EVENT_TYPE or with subcomponent of "
+ "type LOCK_TYPE must be a coarray", sym->name,
+ &sym->declared_at);
+ return;
+ }
+
/* An assumed-size array with INTENT(OUT) shall not be of a type for which
default initialization is defined (5.1.2.4.4). */
if (sym->ts.type == BT_DERIVED
@@ -14029,6 +14091,15 @@ resolve_symbol (gfc_symbol *sym)
return;
}
+ /* TS18508. */
+ if (sym->ts.type == BT_DERIVED && sym->attr.dummy
+ && sym->attr.intent == INTENT_OUT && sym->attr.event_comp)
+ {
+ gfc_error ("Dummy argument %qs at %L of EVENT_TYPE shall not be "
+ "INTENT(OUT)", sym->name, &sym->declared_at);
+ return;
+ }
+
/* F2008, C525. */
if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
|| (sym->ts.type == BT_CLASS && sym->attr.class_ok
diff --git a/gcc/fortran/st.c b/gcc/fortran/st.c
index d0a11aa..b0385c6 100644
--- a/gcc/fortran/st.c
+++ b/gcc/fortran/st.c
@@ -118,6 +118,8 @@ gfc_free_statement (gfc_code *p)
case EXEC_SYNC_MEMORY:
case EXEC_LOCK:
case EXEC_UNLOCK:
+ case EXEC_EVENT_POST:
+ case EXEC_EVENT_WAIT:
break;
case EXEC_BLOCK:
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 39ff8e2..165f6e3 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -144,6 +144,9 @@ tree gfor_fndecl_caf_atomic_cas;
tree gfor_fndecl_caf_atomic_op;
tree gfor_fndecl_caf_lock;
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_co_broadcast;
tree gfor_fndecl_co_max;
tree gfor_fndecl_co_min;
@@ -3544,6 +3547,21 @@ gfc_build_builtin_function_decls (void)
void_type_node, 6, pvoid_type_node, size_type_node, integer_type_node,
pint_type, pchar_type_node, integer_type_node);
+ gfor_fndecl_caf_event_post = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("caf_event_post")), "R..WW",
+ void_type_node, 6, pvoid_type_node, size_type_node, integer_type_node,
+ pint_type, pchar_type_node, integer_type_node);
+
+ gfor_fndecl_caf_event_wait = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("caf_event_wait")), "R..WW",
+ void_type_node, 6, pvoid_type_node, size_type_node, integer_type_node,
+ pint_type, pchar_type_node, integer_type_node);
+
+ gfor_fndecl_caf_event_query = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("caf_event_query")), "R..WW",
+ void_type_node, 5, pvoid_type_node, size_type_node, integer_type_node,
+ pint_type, pint_type);
+
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,
@@ -4839,7 +4857,7 @@ static void
generate_coarray_sym_init (gfc_symbol *sym)
{
tree tmp, size, decl, token;
- bool is_lock_type;
+ bool is_lock_type, is_event_type;
int reg_type;
if (sym->attr.dummy || sym->attr.allocatable || !sym->attr.codimension
@@ -4855,13 +4873,17 @@ generate_coarray_sym_init (gfc_symbol *sym)
&& sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
&& sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE;
+ is_event_type = sym->ts.type == BT_DERIVED
+ && sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+ && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE;
+
/* FIXME: Workaround for PR middle-end/49106, cf. also PR middle-end/49108
to make sure the variable is not optimized away. */
DECL_PRESERVE_P (DECL_CONTEXT (decl)) = 1;
/* For lock types, we pass the array size as only the library knows the
size of the variable. */
- if (is_lock_type)
+ if (is_lock_type || is_event_type)
size = gfc_index_one_node;
else
size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (decl)));
@@ -4883,6 +4905,8 @@ generate_coarray_sym_init (gfc_symbol *sym)
GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE(decl)));
if (is_lock_type)
reg_type = sym->attr.artificial ? GFC_CAF_CRITICAL : GFC_CAF_LOCK_STATIC;
+ else if (is_event_type)
+ reg_type = GFC_CAF_EVENT_STATIC;
else
reg_type = GFC_CAF_COARRAY_STATIC;
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register, 6, size,
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 6647a4e..22195e0 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -5784,8 +5784,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
len = cl.backend_decl;
}
- byref = (comp && (comp->attr.dimension || comp->ts.type == BT_CHARACTER))
- || (!comp && gfc_return_by_reference (sym));
+ byref = (comp && (comp->attr.dimension
+ || (comp->ts.type == BT_CHARACTER && !sym->attr.is_bind_c)))
+ || (!comp && gfc_return_by_reference (sym));
if (byref)
{
if (se->direct_byref)
@@ -6611,6 +6612,11 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
{
gfc_se se;
+ if (flag_coarray != GFC_FCOARRAY_LIB && ts->type == BT_DERIVED
+ && ts->u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+ && ts->u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
+ return build_constructor (type, NULL);
+
if (!(expr || pointer || procptr))
return NULL_TREE;
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 1dabc26..21efe44 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -9291,6 +9291,154 @@ conv_intrinsic_atomic_cas (gfc_code *code)
return gfc_finish_block (&block);
}
+static tree
+conv_intrinsic_event_query (gfc_code *code)
+{
+ gfc_se se, argse;
+ tree stat = NULL_TREE, stat2 = NULL_TREE;
+ tree count = NULL_TREE, count2 = NULL_TREE;
+
+ gfc_expr *event_expr = code->ext.actual->expr;
+
+ if (code->ext.actual->next->next->expr)
+ {
+ gcc_assert (code->ext.actual->next->next->expr->expr_type
+ == EXPR_VARIABLE);
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr_val (&argse, code->ext.actual->next->next->expr);
+ stat = argse.expr;
+ }
+ else if (flag_coarray == GFC_FCOARRAY_LIB)
+ stat = null_pointer_node;
+
+ if (code->ext.actual->next->expr)
+ {
+ gcc_assert (code->ext.actual->next->expr->expr_type == EXPR_VARIABLE);
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr_val (&argse, code->ext.actual->next->expr);
+ count = argse.expr;
+ }
+
+ gfc_start_block (&se.pre);
+ if (flag_coarray == GFC_FCOARRAY_LIB)
+ {
+ tree tmp, token, image_index;
+ tree index = size_zero_node;
+
+ if (event_expr->expr_type == EXPR_FUNCTION
+ && event_expr->value.function.isym
+ && event_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
+ event_expr = event_expr->value.function.actual->expr;
+
+ tree caf_decl = gfc_get_tree_for_caf_expr (event_expr);
+
+ if (event_expr->symtree->n.sym->ts.type != BT_DERIVED
+ || event_expr->symtree->n.sym->ts.u.derived->from_intmod
+ != INTMOD_ISO_FORTRAN_ENV
+ || event_expr->symtree->n.sym->ts.u.derived->intmod_sym_id
+ != ISOFORTRAN_EVENT_TYPE)
+ {
+ gfc_error ("Sorry, the event component of derived type at %L is not "
+ "yet supported", &event_expr->where);
+ return NULL_TREE;
+ }
+
+ if (gfc_is_coindexed (event_expr))
+ {
+ gfc_error ("The event variable at %L shall not be coindexed ",
+ &event_expr->where);
+ return NULL_TREE;
+ }
+
+ image_index = integer_zero_node;
+
+ gfc_get_caf_token_offset (&token, NULL, caf_decl, NULL_TREE, event_expr);
+
+ /* For arrays, obtain the array index. */
+ if (gfc_expr_attr (event_expr).dimension)
+ {
+ tree desc, tmp, extent, lbound, ubound;
+ gfc_array_ref *ar, ar2;
+ int i;
+
+ /* TODO: Extend this, once DT components are supported. */
+ ar = &event_expr->ref->u.ar;
+ ar2 = *ar;
+ memset (ar, '\0', sizeof (*ar));
+ ar->as = ar2.as;
+ ar->type = AR_FULL;
+
+ gfc_init_se (&argse, NULL);
+ argse.descriptor_only = 1;
+ gfc_conv_expr_descriptor (&argse, event_expr);
+ gfc_add_block_to_block (&se.pre, &argse.pre);
+ desc = argse.expr;
+ *ar = ar2;
+
+ extent = integer_one_node;
+ for (i = 0; i < ar->dimen; i++)
+ {
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr_type (&argse, ar->start[i], integer_type_node);
+ gfc_add_block_to_block (&argse.pre, &argse.pre);
+ lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ integer_type_node, argse.expr,
+ fold_convert(integer_type_node, lbound));
+ tmp = fold_build2_loc (input_location, MULT_EXPR,
+ integer_type_node, extent, tmp);
+ index = fold_build2_loc (input_location, PLUS_EXPR,
+ integer_type_node, index, tmp);
+ if (i < ar->dimen - 1)
+ {
+ ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
+ tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
+ tmp = fold_convert (integer_type_node, tmp);
+ extent = fold_build2_loc (input_location, MULT_EXPR,
+ integer_type_node, extent, tmp);
+ }
+ }
+ }
+
+ if (count != null_pointer_node && TREE_TYPE (count) != integer_type_node)
+ {
+ count2 = count;
+ count = gfc_create_var (integer_type_node, "count");
+ }
+
+ if (stat != null_pointer_node && TREE_TYPE (stat) != integer_type_node)
+ {
+ stat2 = stat;
+ stat = gfc_create_var (integer_type_node, "stat");
+ }
+
+ tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_event_query, 5,
+ token, index, image_index, count
+ ? gfc_build_addr_expr (NULL, count) : count,
+ stat != null_pointer_node
+ ? gfc_build_addr_expr (NULL, stat) : stat);
+ gfc_add_expr_to_block (&se.pre, tmp);
+
+ if (count2 != NULL_TREE)
+ gfc_add_modify (&se.pre, count2,
+ fold_convert (TREE_TYPE (count2), count));
+
+ if (stat2 != NULL_TREE)
+ gfc_add_modify (&se.pre, stat2,
+ fold_convert (TREE_TYPE (stat2), stat));
+
+ return gfc_finish_block (&se.pre);
+ }
+
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr_val (&argse, code->ext.actual->expr);
+ gfc_add_modify (&se.pre, count, fold_convert (TREE_TYPE (count), argse.expr));
+
+ if (stat != NULL_TREE)
+ gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0));
+
+ return gfc_finish_block (&se.pre);
+}
static tree
conv_intrinsic_move_alloc (gfc_code *code)
@@ -9587,6 +9735,10 @@ gfc_conv_intrinsic_subroutine (gfc_code *code)
res = conv_intrinsic_atomic_ref (code);
break;
+ case GFC_ISYM_EVENT_QUERY:
+ res = conv_intrinsic_event_query (code);
+ break;
+
case GFC_ISYM_C_F_POINTER:
case GFC_ISYM_C_F_PROCPOINTER:
res = conv_isocbinding_subroutine (code);
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 06591a3..d3e83e9 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -776,6 +776,7 @@ gfc_trans_lock_unlock (gfc_code *code, gfc_exec_op op)
if (code->expr3)
{
gfc_init_se (&argse, NULL);
+ argse.want_pointer = 1;
gfc_conv_expr (&argse, code->expr3);
gfc_add_block_to_block (&se.pre, &argse.pre);
errmsg = argse.expr;
@@ -840,6 +841,165 @@ gfc_trans_lock_unlock (gfc_code *code, gfc_exec_op op)
return gfc_finish_block (&se.pre);
}
+tree
+gfc_trans_event_post_wait (gfc_code *code, gfc_exec_op op)
+{
+ gfc_se se, argse;
+ tree stat = NULL_TREE, stat2 = NULL_TREE;
+ tree until_count = NULL_TREE;
+
+ if (code->expr2)
+ {
+ gcc_assert (code->expr2->expr_type == EXPR_VARIABLE);
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr_val (&argse, code->expr2);
+ stat = argse.expr;
+ }
+ else if (flag_coarray == GFC_FCOARRAY_LIB)
+ stat = null_pointer_node;
+
+ if (code->expr4)
+ {
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr_val (&argse, code->expr4);
+ until_count = fold_convert (integer_type_node, argse.expr);
+ }
+ else
+ until_count = integer_one_node;
+
+ if (flag_coarray != GFC_FCOARRAY_LIB)
+ {
+ gfc_start_block (&se.pre);
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr_val (&argse, code->expr1);
+
+ if (op == EXEC_EVENT_POST)
+ gfc_add_modify (&se.pre, argse.expr,
+ fold_build2_loc (input_location, PLUS_EXPR,
+ TREE_TYPE (argse.expr), argse.expr,
+ build_int_cst (TREE_TYPE (argse.expr), 1)));
+ else
+ gfc_add_modify (&se.pre, argse.expr,
+ fold_build2_loc (input_location, MINUS_EXPR,
+ TREE_TYPE (argse.expr), argse.expr,
+ fold_convert (TREE_TYPE (argse.expr),
+ until_count)));
+ if (stat != NULL_TREE)
+ gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0));
+
+ return gfc_finish_block (&se.pre);
+ }
+
+ gfc_start_block (&se.pre);
+ tree tmp, token, image_index, errmsg, errmsg_len;
+ tree index = size_zero_node;
+ tree caf_decl = gfc_get_tree_for_caf_expr (code->expr1);
+
+ if (code->expr1->symtree->n.sym->ts.type != BT_DERIVED
+ || code->expr1->symtree->n.sym->ts.u.derived->from_intmod
+ != INTMOD_ISO_FORTRAN_ENV
+ || code->expr1->symtree->n.sym->ts.u.derived->intmod_sym_id
+ != ISOFORTRAN_EVENT_TYPE)
+ {
+ gfc_error ("Sorry, the event component of derived type at %L is not "
+ "yet supported", &code->expr1->where);
+ return NULL_TREE;
+ }
+
+ gfc_get_caf_token_offset (&token, NULL, caf_decl, NULL_TREE, code->expr1);
+
+ if (gfc_is_coindexed (code->expr1))
+ image_index = gfc_caf_get_image_index (&se.pre, code->expr1, caf_decl);
+ else
+ image_index = integer_zero_node;
+
+ /* For arrays, obtain the array index. */
+ if (gfc_expr_attr (code->expr1).dimension)
+ {
+ tree desc, tmp, extent, lbound, ubound;
+ gfc_array_ref *ar, ar2;
+ int i;
+
+ /* TODO: Extend this, once DT components are supported. */
+ ar = &code->expr1->ref->u.ar;
+ ar2 = *ar;
+ memset (ar, '\0', sizeof (*ar));
+ ar->as = ar2.as;
+ ar->type = AR_FULL;
+
+ gfc_init_se (&argse, NULL);
+ argse.descriptor_only = 1;
+ gfc_conv_expr_descriptor (&argse, code->expr1);
+ gfc_add_block_to_block (&se.pre, &argse.pre);
+ desc = argse.expr;
+ *ar = ar2;
+
+ extent = integer_one_node;
+ for (i = 0; i < ar->dimen; i++)
+ {
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr_type (&argse, ar->start[i], integer_type_node);
+ gfc_add_block_to_block (&argse.pre, &argse.pre);
+ lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ integer_type_node, argse.expr,
+ fold_convert(integer_type_node, lbound));
+ tmp = fold_build2_loc (input_location, MULT_EXPR,
+ integer_type_node, extent, tmp);
+ index = fold_build2_loc (input_location, PLUS_EXPR,
+ integer_type_node, index, tmp);
+ if (i < ar->dimen - 1)
+ {
+ ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
+ tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
+ tmp = fold_convert (integer_type_node, tmp);
+ extent = fold_build2_loc (input_location, MULT_EXPR,
+ integer_type_node, extent, tmp);
+ }
+ }
+ }
+
+ /* errmsg. */
+ if (code->expr3)
+ {
+ gfc_init_se (&argse, NULL);
+ argse.want_pointer = 1;
+ gfc_conv_expr (&argse, code->expr3);
+ gfc_add_block_to_block (&se.pre, &argse.pre);
+ errmsg = argse.expr;
+ errmsg_len = fold_convert (integer_type_node, argse.string_length);
+ }
+ else
+ {
+ errmsg = null_pointer_node;
+ errmsg_len = integer_zero_node;
+ }
+
+ if (stat != null_pointer_node && TREE_TYPE (stat) != integer_type_node)
+ {
+ stat2 = stat;
+ stat = gfc_create_var (integer_type_node, "stat");
+ }
+
+ if (op == EXEC_EVENT_POST)
+ tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_event_post, 6,
+ token, index, image_index,
+ stat != null_pointer_node
+ ? gfc_build_addr_expr (NULL, stat) : stat,
+ errmsg, errmsg_len);
+ else
+ tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_event_wait, 6,
+ token, index, until_count,
+ stat != null_pointer_node
+ ? gfc_build_addr_expr (NULL, stat) : stat,
+ errmsg, errmsg_len);
+ gfc_add_expr_to_block (&se.pre, tmp);
+
+ if (stat2 != NULL_TREE)
+ gfc_add_modify (&se.pre, stat2, fold_convert (TREE_TYPE (stat2), stat));
+
+ return gfc_finish_block (&se.pre);
+}
tree
gfc_trans_sync (gfc_code *code, gfc_exec_op type)
@@ -879,6 +1039,7 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type)
{
gcc_assert (code->expr3->expr_type == EXPR_VARIABLE);
gfc_init_se (&argse, NULL);
+ argse.want_pointer = 1;
gfc_conv_expr (&argse, code->expr3);
gfc_conv_string_parameter (&argse);
errmsg = gfc_build_addr_expr (NULL, argse.expr);
diff --git a/gcc/fortran/trans-stmt.h b/gcc/fortran/trans-stmt.h
index 0ff93c4..76f1f28 100644
--- a/gcc/fortran/trans-stmt.h
+++ b/gcc/fortran/trans-stmt.h
@@ -55,6 +55,7 @@ tree gfc_trans_do_while (gfc_code *);
tree gfc_trans_select (gfc_code *);
tree gfc_trans_sync (gfc_code *, gfc_exec_op);
tree gfc_trans_lock_unlock (gfc_code *, gfc_exec_op);
+tree gfc_trans_event_post_wait (gfc_code *, gfc_exec_op);
tree gfc_trans_forall (gfc_code *);
tree gfc_trans_where (gfc_code *);
tree gfc_trans_allocate (gfc_code *);
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index 6e2b3f1..60bd8e1 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -2371,6 +2371,11 @@ gfc_get_derived_type (gfc_symbol * derived)
&& derived->intmod_sym_id == ISOFORTRAN_LOCK_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)
+ return gfc_get_int_type (gfc_default_integer_kind);
+
if (derived && derived->attr.flavor == FL_PROCEDURE
&& derived->attr.generic)
derived = gfc_find_dt_in_generic (derived);
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index 2a91c35..001db41 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -711,7 +711,7 @@ gfc_allocate_using_malloc (stmtblock_t * block, tree pointer,
static void
gfc_allocate_using_lib (stmtblock_t * block, tree pointer, tree size,
tree token, tree status, tree errmsg, tree errlen,
- bool lock_var)
+ bool lock_var, bool event_var)
{
tree tmp, pstat;
@@ -738,7 +738,8 @@ gfc_allocate_using_lib (stmtblock_t * block, tree pointer, tree size,
build_int_cst (size_type_node, 1)),
build_int_cst (integer_type_node,
lock_var ? GFC_CAF_LOCK_ALLOC
- : GFC_CAF_COARRAY_ALLOC),
+ : event_var ? GFC_CAF_EVENT_ALLOC
+ : GFC_CAF_COARRAY_ALLOC),
token, pstat, errmsg, errlen);
tmp = fold_build2_loc (input_location, MODIFY_EXPR,
@@ -798,6 +799,11 @@ gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size, tree token,
== INTMOD_ISO_FORTRAN_ENV
&& expr->ts.u.derived->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE;
+ bool event_var = expr->ts.type == BT_DERIVED
+ && expr->ts.u.derived->from_intmod
+ == INTMOD_ISO_FORTRAN_ENV
+ && expr->ts.u.derived->intmod_sym_id
+ == ISOFORTRAN_EVENT_TYPE;
/* In the front end, we represent the lock variable as pointer. However,
the FE only passes the pointer around and leaves the actual
representation to the library. Hence, we have to convert back to the
@@ -807,7 +813,7 @@ gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size, tree token,
size, TYPE_SIZE_UNIT (ptr_type_node));
gfc_allocate_using_lib (&alloc_block, mem, size, token, status,
- errmsg, errlen, lock_var);
+ errmsg, errlen, lock_var, event_var);
if (status != NULL_TREE)
{
@@ -1797,6 +1803,11 @@ trans_code (gfc_code * code, tree cond)
res = gfc_trans_lock_unlock (code, code->op);
break;
+ case EXEC_EVENT_POST:
+ case EXEC_EVENT_WAIT:
+ res = gfc_trans_event_post_wait (code, code->op);
+ break;
+
case EXEC_FORALL:
res = gfc_trans_forall (code);
break;
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 3a23a3c..088eca3 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -113,7 +113,9 @@ enum gfc_coarray_type
GFC_CAF_COARRAY_ALLOC,
GFC_CAF_LOCK_STATIC,
GFC_CAF_LOCK_ALLOC,
- GFC_CAF_CRITICAL
+ GFC_CAF_CRITICAL,
+ GFC_CAF_EVENT_STATIC,
+ GFC_CAF_EVENT_ALLOC
};
@@ -763,6 +765,9 @@ extern GTY(()) tree gfor_fndecl_caf_atomic_cas;
extern GTY(()) tree gfor_fndecl_caf_atomic_op;
extern GTY(()) tree gfor_fndecl_caf_lock;
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_co_broadcast;
extern GTY(()) tree gfor_fndecl_co_max;
extern GTY(()) tree gfor_fndecl_co_min;
^ permalink raw reply [flat|nested] 15+ messages in thread
* Re: [Fortran, Patch] (RFC, Coarray) Implement TS18508's EVENTS
2015-11-25 17:30 ` Alessandro Fanfarillo
@ 2015-11-25 19:17 ` Damian Rouson
2015-11-25 22:47 ` Paul Richard Thomas
2015-11-26 16:53 ` Steve Kargl
2 siblings, 0 replies; 15+ messages in thread
From: Damian Rouson @ 2015-11-25 19:17 UTC (permalink / raw)
To: Alessandro Fanfarillo; +Cc: Tobias Burnus, gcc-patches, gfortran
> On Nov 25, 2015, at 9:24 AM, Alessandro Fanfarillo <fanfarillo.gcc@gmail.com> wrote:
>
> Dear all,
>
> in attachment the previous patch compatible with the current trunk.
> The patch also includes the changes introduced in the latest TS 18508.
>
> Built and regtested on x86_64-pc-linux-gnu.
>
> PS: I will add the test cases in a different patch.
All,
As I mentioned previously, WG5 approved the latest TS 18508 document in September and forwarded it to SC22 for approval for publishing so it is essentially final. This is an opportune time to commit the feature. I believe it also puts gfortran in the lead on Fortran 2015 parallel programming support. I don’t think even the Cray compiler supports EVENTs yet. Hopefully this is ok for committing during Stage 3 given that the original version of the patch was submitted by Tobias in April.
This feature could have significant, positive impact on parallel performance so it will be exciting to see it hit the trunk. If it gets committed before my next short course, December 7-8, then I’ll incorporate some discussion of EVENTs into the course.
Damian
^ permalink raw reply [flat|nested] 15+ messages in thread
* Re: [Fortran, Patch] (RFC, Coarray) Implement TS18508's EVENTS
2015-11-25 17:30 ` Alessandro Fanfarillo
2015-11-25 19:17 ` Damian Rouson
@ 2015-11-25 22:47 ` Paul Richard Thomas
2015-11-25 23:08 ` Steve Kargl
2015-11-26 16:53 ` Steve Kargl
2 siblings, 1 reply; 15+ messages in thread
From: Paul Richard Thomas @ 2015-11-25 22:47 UTC (permalink / raw)
To: Alessandro Fanfarillo; +Cc: Tobias Burnus, gcc-patches, gfortran
Dear Alessandro and Tobias,
I have been through the patch to check for obvious bloopers but can
find none, as expected given the author :-)
I would dearly like to see the testcases at the same time as the patch
but.... I think that the commit should be made sooner, rather than
later. Given its nature, I think that it is pretty safe at this stage
of the 6.0.0 lifecycle and so I say OK for trunk.
Cheers
Paul
On 25 November 2015 at 18:24, Alessandro Fanfarillo
<fanfarillo.gcc@gmail.com> wrote:
> Dear all,
>
> in attachment the previous patch compatible with the current trunk.
> The patch also includes the changes introduced in the latest TS 18508.
>
> Built and regtested on x86_64-pc-linux-gnu.
>
> PS: I will add the test cases in a different patch.
>
> 2015-04-29 9:55 GMT+02:00 Tobias Burnus <tobias.burnus@physik.fu-berlin.de>:
>> Dear all,
>>
>> attached patch fixes a bug and implements EVENTS. I think the patch is
>> finished, but I still have to extend the test cases, to re-read the
>> patch and to write a changelog. As I am not sure how soon I will able
>> to do so, I follow the paradigm: release soon, release often and post
>> it here. Comments and reviews are welcome.
>>
>> The patch fixes two bug in the "errmsg" handling, found by Alessandro:
>> I don't pass on the address of the actual argument and in libcaf_single,
>> I copy only 8 characters (sizeof pointer) instead of all of the the
>> characters of the error message.
>>
>> Regarding events: Events is a way to permit barrier/locking-free
>> programming: One sends the finished data to an other image and then
>> tells that image that the data is there ("event post(msg_var[idx])").
>> That image can then either wait for the event by querying the status
>> on the local variable ("event wait(msg_var)") or only check the status
>> and if it is not ready do something else (e.g. another iteration);
>> that's done via "call event_query(msg_var, count)".
>>
>> Technically, event_post works like atomic_add(msg_var[idx], 1) and
>> event_query like "atomic_ref(msg_var, count)". event_wait is the same
>> as event_query plus a spin/sleep loop waiting for the status change,
>> followed by an atomic_add(msg_var, -until_count). Except that
>> event_post/event_wait are image control statements. (Otherwise it
>> could happen that the event is there before the data for which the
>> event has been posted.)
>>
>> Regarding the implementation in this patch, the limitations are the
>> same as for locking: Currently, neither lock_type nor event_type
>> variables are permitted as (nonallocatable) components
>> of a derived type - and type extension of them also not yet supported.*
>>
>> The spec can be found at http://bitly.com/sc22wg5 -> 2015 -> TS draft
>> or directly at
>> http://isotc.iso.org/livelink/livelink?func=ll&objId=17064344&objAction=Open
>>
>> Tobias
>>
>>
>> * Doing so is not really difficult but I need to handle cases like
>> the following. For "allocatable" with SOURCE= I also need to handle
>> it with polymorphic types.
>>
>> type t1
>> type(event_type) :: EV
>> type(lock_type) :: LK
>> end type1
>> type t2
>> type(t1) :: a(5)
>> end type t2
>> type t3
>> type(t2) :: b(8)
>> end type t3
>>
>> type(t3), save :: caf(3)[*]
>>
>> For those, I need to call _gfortran_caf_register for
>> caf(:)%b(:)%a(:)%ev and caf(:)%b(:)%a(:)%lk
>> Looping though all array references.
>>
>> Similar for
>> type(t3), allocatable :: caf2(:)[:]
>> allocate(caf2(n)[*])
>> for the allocate call.
--
Outside of a dog, a book is a man's best friend. Inside of a dog it's
too dark to read.
Groucho Marx
^ permalink raw reply [flat|nested] 15+ messages in thread
* Re: [Fortran, Patch] (RFC, Coarray) Implement TS18508's EVENTS
2015-11-25 22:47 ` Paul Richard Thomas
@ 2015-11-25 23:08 ` Steve Kargl
0 siblings, 0 replies; 15+ messages in thread
From: Steve Kargl @ 2015-11-25 23:08 UTC (permalink / raw)
To: Paul Richard Thomas
Cc: Alessandro Fanfarillo, Tobias Burnus, gcc-patches, gfortran
Paul
I've bootstrap and regression tested the patch on x86_64-*-freebsd.
I intend to do the same tonight on i386-*-freebsd. After that, I'll
go over the patch as you have done and then intend to commit it.
AFAICT, Tobias is busy with Real-Life (tm) (or taking a much
needed rest from gfortran hacking). tobias, if you would rather
commit the patch, I'm fine with that; otherwise, I'll take care
of it in the next few days.
--
steve
On Wed, Nov 25, 2015 at 11:28:28PM +0100, Paul Richard Thomas wrote:
> Dear Alessandro and Tobias,
>
> I have been through the patch to check for obvious bloopers but can
> find none, as expected given the author :-)
>
> I would dearly like to see the testcases at the same time as the patch
> but.... I think that the commit should be made sooner, rather than
> later. Given its nature, I think that it is pretty safe at this stage
> of the 6.0.0 lifecycle and so I say OK for trunk.
>
> Cheers
>
> Paul
>
> On 25 November 2015 at 18:24, Alessandro Fanfarillo
> <fanfarillo.gcc@gmail.com> wrote:
> > Dear all,
> >
> > in attachment the previous patch compatible with the current trunk.
> > The patch also includes the changes introduced in the latest TS 18508.
> >
> > Built and regtested on x86_64-pc-linux-gnu.
> >
> > PS: I will add the test cases in a different patch.
> >
> > 2015-04-29 9:55 GMT+02:00 Tobias Burnus <tobias.burnus@physik.fu-berlin.de>:
> >> Dear all,
> >>
> >> attached patch fixes a bug and implements EVENTS. I think the patch is
> >> finished, but I still have to extend the test cases, to re-read the
> >> patch and to write a changelog. As I am not sure how soon I will able
> >> to do so, I follow the paradigm: release soon, release often and post
> >> it here. Comments and reviews are welcome.
> >>
> >> The patch fixes two bug in the "errmsg" handling, found by Alessandro:
> >> I don't pass on the address of the actual argument and in libcaf_single,
> >> I copy only 8 characters (sizeof pointer) instead of all of the the
> >> characters of the error message.
> >>
> >> Regarding events: Events is a way to permit barrier/locking-free
> >> programming: One sends the finished data to an other image and then
> >> tells that image that the data is there ("event post(msg_var[idx])").
> >> That image can then either wait for the event by querying the status
> >> on the local variable ("event wait(msg_var)") or only check the status
> >> and if it is not ready do something else (e.g. another iteration);
> >> that's done via "call event_query(msg_var, count)".
> >>
> >> Technically, event_post works like atomic_add(msg_var[idx], 1) and
> >> event_query like "atomic_ref(msg_var, count)". event_wait is the same
> >> as event_query plus a spin/sleep loop waiting for the status change,
> >> followed by an atomic_add(msg_var, -until_count). Except that
> >> event_post/event_wait are image control statements. (Otherwise it
> >> could happen that the event is there before the data for which the
> >> event has been posted.)
> >>
> >> Regarding the implementation in this patch, the limitations are the
> >> same as for locking: Currently, neither lock_type nor event_type
> >> variables are permitted as (nonallocatable) components
> >> of a derived type - and type extension of them also not yet supported.*
> >>
> >> The spec can be found at http://bitly.com/sc22wg5 -> 2015 -> TS draft
> >> or directly at
> >> http://isotc.iso.org/livelink/livelink?func=ll&objId=17064344&objAction=Open
> >>
> >> Tobias
> >>
> >>
> >> * Doing so is not really difficult but I need to handle cases like
> >> the following. For "allocatable" with SOURCE= I also need to handle
> >> it with polymorphic types.
> >>
> >> type t1
> >> type(event_type) :: EV
> >> type(lock_type) :: LK
> >> end type1
> >> type t2
> >> type(t1) :: a(5)
> >> end type t2
> >> type t3
> >> type(t2) :: b(8)
> >> end type t3
> >>
> >> type(t3), save :: caf(3)[*]
> >>
> >> For those, I need to call _gfortran_caf_register for
> >> caf(:)%b(:)%a(:)%ev and caf(:)%b(:)%a(:)%lk
> >> Looping though all array references.
> >>
> >> Similar for
> >> type(t3), allocatable :: caf2(:)[:]
> >> allocate(caf2(n)[*])
> >> for the allocate call.
>
>
>
> --
> Outside of a dog, a book is a man's best friend. Inside of a dog it's
> too dark to read.
>
> Groucho Marx
--
Steve
^ permalink raw reply [flat|nested] 15+ messages in thread
* Re: [Fortran, Patch] (RFC, Coarray) Implement TS18508's EVENTS
2015-11-25 17:30 ` Alessandro Fanfarillo
2015-11-25 19:17 ` Damian Rouson
2015-11-25 22:47 ` Paul Richard Thomas
@ 2015-11-26 16:53 ` Steve Kargl
2015-11-26 18:02 ` Alessandro Fanfarillo
2015-12-02 14:16 ` Alessandro Fanfarillo
2 siblings, 2 replies; 15+ messages in thread
From: Steve Kargl @ 2015-11-26 16:53 UTC (permalink / raw)
To: Alessandro Fanfarillo; +Cc: Tobias Burnus, gcc-patches, gfortran
On Wed, Nov 25, 2015 at 06:24:49PM +0100, Alessandro Fanfarillo wrote:
> Dear all,
>
> in attachment the previous patch compatible with the current trunk.
> The patch also includes the changes introduced in the latest TS 18508.
>
> Built and regtested on x86_64-pc-linux-gnu.
>
> PS: I will add the test cases in a different patch.
>
I have now built and regression tested the patch on
x86_64-*-freebsd and i386-*-freebsd. There were no
regressions. In reading through the patch, nothing
jumped out at me as suspicious/wrong. Tobias, this
is OK to commit. If you don't committed by Sunday,
I'll do it for you.
--
steve
^ permalink raw reply [flat|nested] 15+ messages in thread
* Re: [Fortran, Patch] (RFC, Coarray) Implement TS18508's EVENTS
2015-11-26 16:53 ` Steve Kargl
@ 2015-11-26 18:02 ` Alessandro Fanfarillo
2015-12-02 14:16 ` Alessandro Fanfarillo
1 sibling, 0 replies; 15+ messages in thread
From: Alessandro Fanfarillo @ 2015-11-26 18:02 UTC (permalink / raw)
To: Steve Kargl; +Cc: Tobias Burnus, gcc-patches, gfortran
[-- Attachment #1: Type: text/plain, Size: 885 bytes --]
Hi all,
in attachment the patch for tests and missing functions in
libcaf_single (needed by the test suite).
Built and regtested on x86_64-pc-linux-gnu.
2015-11-26 17:51 GMT+01:00 Steve Kargl <sgk@troutmask.apl.washington.edu>:
> On Wed, Nov 25, 2015 at 06:24:49PM +0100, Alessandro Fanfarillo wrote:
>> Dear all,
>>
>> in attachment the previous patch compatible with the current trunk.
>> The patch also includes the changes introduced in the latest TS 18508.
>>
>> Built and regtested on x86_64-pc-linux-gnu.
>>
>> PS: I will add the test cases in a different patch.
>>
>
> I have now built and regression tested the patch on
> x86_64-*-freebsd and i386-*-freebsd. There were no
> regressions. In reading through the patch, nothing
> jumped out at me as suspicious/wrong. Tobias, this
> is OK to commit. If you don't committed by Sunday,
> I'll do it for you.
>
> --
> steve
[-- Attachment #2: event_tests.diff --]
[-- Type: text/plain, Size: 8530 bytes --]
commit d68b49bae714a7b5881587a61d30d643fa0cdb90
Author: Alessandro Fanfarillo <fanfarillo@ing.uniroma2.it>
Date: Thu Nov 26 18:51:47 2015 +0100
New tests for coarray events and new functions in libcaf_single
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index e0b16f5..bcc99ea 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2015-11-26 Tobias Burnus <burnus@net-b.de>
+ Alessandro Fanfarillo <fanfarillo.gcc@gmail.com>
+
+ * gfortran.dg/coarray/event_1.f90: New.
+ * gfortran.dg/coarray/event_2.f90: New.
+
2015-11-25 Markus Trippelsdorf <markus@trippelsdorf.de>
Paolo Carlini <paolo.carlini@oracle.com>
diff --git a/gcc/testsuite/gfortran.dg/coarray/event_1.f90 b/gcc/testsuite/gfortran.dg/coarray/event_1.f90
new file mode 100644
index 0000000..b4385f3
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray/event_1.f90
@@ -0,0 +1,51 @@
+! { dg-do run }
+!
+! Run-time test for EVENT_TYPE
+!
+use iso_fortran_env, only: event_type
+implicit none
+
+type(event_type), save :: var[*]
+integer :: count, stat
+
+count = -42
+call event_query (var, count)
+if (count /= 0) call abort()
+
+stat = 99
+event post (var, stat=stat)
+if (stat /= 0) call abort()
+call event_query(var, count, stat=stat)
+if (count /= 1 .or. stat /= 0) call abort()
+
+stat = 99
+event post (var[this_image()])
+call event_query(var, count)
+if (count /= 2) call abort()
+
+stat = 99
+event wait (var)
+call event_query(var, count)
+if (count /= 1) call abort()
+
+stat = 99
+event post (var)
+call event_query(var, count)
+if (count /= 2) call abort()
+
+stat = 99
+event post (var)
+call event_query(var, count)
+if (count /= 3) call abort()
+
+stat = 99
+event wait (var, until_count=2)
+call event_query(var, count)
+if (count /= 1) call abort()
+
+stat = 99
+event wait (var, stat=stat, until_count=1)
+if (stat /= 0) call abort()
+call event_query(event=var, stat=stat, count=count)
+if (count /= 0 .or. stat /= 0) call abort()
+end
diff --git a/gcc/testsuite/gfortran.dg/coarray/event_2.f90 b/gcc/testsuite/gfortran.dg/coarray/event_2.f90
new file mode 100644
index 0000000..2d451a5
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray/event_2.f90
@@ -0,0 +1,89 @@
+! { dg-do run }
+!
+! Run-time test for EVENT_TYPE
+!
+use iso_fortran_env, only: event_type
+implicit none
+
+type(event_type), save, allocatable :: var(:)[:]
+integer :: count, stat
+
+allocate(var(3)[*])
+
+count = -42
+call event_query (var(1), count)
+if (count /= 0) call abort()
+call event_query (var(1), count)
+if (count /= 0) call abort()
+call event_query (var(2), count)
+if (count /= 0) call abort()
+call event_query (var(3), count)
+if (count /= 0) call abort()
+
+stat = 99
+event post (var(2), stat=stat)
+if (stat /= 0) call abort()
+call event_query (var(1), count)
+if (count /= 0) call abort()
+call event_query(var(2), count, stat=stat)
+if (count /= 1 .or. stat /= 0) call abort()
+call event_query (var(3), count)
+if (count /= 0) call abort()
+
+stat = 99
+event post (var(2)[this_image()])
+call event_query(var(1), count)
+if (count /= 0) call abort()
+call event_query(var(2), count)
+if (count /= 2) call abort()
+call event_query(var(2), count)
+if (count /= 2) call abort()
+call event_query(var(3), count)
+if (count /= 0) call abort()
+
+stat = 99
+event wait (var(2))
+call event_query(var(1), count)
+if (count /= 0) call abort()
+call event_query(var(2), count)
+if (count /= 1) call abort()
+call event_query(var(3), count)
+if (count /= 0) call abort()
+
+stat = 99
+event post (var(2))
+call event_query(var(1), count)
+if (count /= 0) call abort()
+call event_query(var(2), count)
+if (count /= 2) call abort()
+call event_query(var(3), count)
+if (count /= 0) call abort()
+
+stat = 99
+event post (var(2))
+call event_query(var(1), count)
+if (count /= 0) call abort()
+call event_query(var(2), count)
+if (count /= 3) call abort()
+call event_query(var(3), count)
+if (count /= 0) call abort()
+
+stat = 99
+event wait (var(2), until_count=2)
+call event_query(var(1), count)
+if (count /= 0) call abort()
+call event_query(var(2), count)
+if (count /= 1) call abort()
+call event_query(var(3), count)
+if (count /= 0) call abort()
+
+stat = 99
+event wait (var(2), stat=stat, until_count=1)
+if (stat /= 0) call abort()
+call event_query(event=var(1), stat=stat, count=count)
+if (count /= 0 .or. stat /= 0) call abort()
+call event_query(event=var(2), stat=stat, count=count)
+if (count /= 0 .or. stat /= 0) call abort()
+call event_query(event=var(3), stat=stat, count=count)
+if (count /= 0 .or. stat /= 0) call abort()
+end
diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog
index 48db71b..4843fd5 100644
--- a/libgfortran/ChangeLog
+++ b/libgfortran/ChangeLog
@@ -1,3 +1,11 @@
+2015-11-26 Tobias Burnus <burnus@net-b.de>
+ Alessandro Fanfarillo <fanfarillo.gcc@gmail.com>
+
+ * caf/libcaf.h (_gfortran_caf_event_post,
+ _gfortran_caf_event_wait,_gfortran_caf_event_query): New prototypes.
+ * caf/single.c (_gfortran_caf_event_post,
+ _gfortran_caf_event_wait,_gfortran_caf_event_query): Implement.
+
2015-11-22 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR libfortran/52251
diff --git a/libgfortran/caf/libcaf.h b/libgfortran/caf/libcaf.h
index 660bd7c..ebda579 100644
--- a/libgfortran/caf/libcaf.h
+++ b/libgfortran/caf/libcaf.h
@@ -57,7 +57,9 @@ typedef enum caf_register_t {
CAF_REGTYPE_COARRAY_ALLOC,
CAF_REGTYPE_LOCK_STATIC,
CAF_REGTYPE_LOCK_ALLOC,
- CAF_REGTYPE_CRITICAL
+ CAF_REGTYPE_CRITICAL,
+ CAF_REGTYPE_EVENT_STATIC,
+ CAF_REGTYPE_EVENT_ALLOC
}
caf_register_t;
@@ -133,5 +135,8 @@ void _gfortran_caf_atomic_op (int, caf_token_t, size_t, int, void *, void *,
void _gfortran_caf_lock (caf_token_t, size_t, int, int *, int *, char *, int);
void _gfortran_caf_unlock (caf_token_t, size_t, int, int *, char *, int);
+void _gfortran_caf_event_post (caf_token_t, size_t, int, int *, char *, int);
+void _gfortran_caf_event_wait (caf_token_t, size_t, int, int *, char *, int);
+void _gfortran_caf_event_query (caf_token_t, size_t, int, int *, int *);
#endif /* LIBCAF_H */
diff --git a/libgfortran/caf/single.c b/libgfortran/caf/single.c
index 6c58286..9c4b343 100644
--- a/libgfortran/caf/single.c
+++ b/libgfortran/caf/single.c
@@ -101,7 +101,8 @@ _gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token,
void *local;
if (type == CAF_REGTYPE_LOCK_STATIC || type == CAF_REGTYPE_LOCK_ALLOC
- || type == CAF_REGTYPE_CRITICAL)
+ || type == CAF_REGTYPE_CRITICAL || type == CAF_REGTYPE_EVENT_STATIC
+ || type == CAF_REGTYPE_EVENT_ALLOC)
local = calloc (size, sizeof (bool));
else
local = malloc (size);
@@ -133,7 +134,8 @@ _gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token,
*stat = 0;
if (type == CAF_REGTYPE_COARRAY_STATIC || type == CAF_REGTYPE_LOCK_STATIC
- || type == CAF_REGTYPE_CRITICAL)
+ || type == CAF_REGTYPE_CRITICAL || type == CAF_REGTYPE_EVENT_STATIC
+ || type == CAF_REGTYPE_EVENT_ALLOC)
{
caf_static_t *tmp = malloc (sizeof (caf_static_t));
tmp->prev = caf_static_list;
@@ -1071,6 +1073,45 @@ _gfortran_caf_atomic_op (int op, caf_token_t token, size_t offset,
*stat = 0;
}
+void
+_gfortran_caf_event_post (caf_token_t token, size_t index,
+ int image_index __attribute__ ((unused)),
+ int *stat, char *errmsg __attribute__ ((unused)),
+ int errmsg_len __attribute__ ((unused)))
+{
+ uint32_t value = 1;
+ uint32_t *event = (uint32_t *) ((char *) TOKEN (token) + index*sizeof(uint32_t));
+ __atomic_fetch_add (event, (uint32_t) value, __ATOMIC_RELAXED);
+
+ if(stat)
+ *stat = 0;
+}
+
+void
+_gfortran_caf_event_wait (caf_token_t token, size_t index,
+ int until_count, int *stat,
+ char *errmsg __attribute__ ((unused)),
+ int errmsg_len __attribute__ ((unused)))
+{
+ uint32_t *event = (uint32_t *) ((char *) TOKEN (token) + index*sizeof(uint32_t));
+ uint32_t value = (uint32_t)-until_count;
+ __atomic_fetch_add (event, (uint32_t) value, __ATOMIC_RELAXED);
+
+ if(stat)
+ *stat = 0;
+}
+
+void
+_gfortran_caf_event_query (caf_token_t token, size_t index,
+ int image_index __attribute__ ((unused)),
+ int *count, int *stat)
+{
+ uint32_t *event = (uint32_t *) ((char *) TOKEN (token) + index*sizeof(uint32_t));
+ __atomic_load (event, (uint32_t *) count, __ATOMIC_RELAXED);
+
+ if(stat)
+ *stat = 0;
+}
void
_gfortran_caf_lock (caf_token_t token, size_t index,
^ permalink raw reply [flat|nested] 15+ messages in thread
* Re: [Fortran, Patch] (RFC, Coarray) Implement TS18508's EVENTS
2015-11-26 16:53 ` Steve Kargl
2015-11-26 18:02 ` Alessandro Fanfarillo
@ 2015-12-02 14:16 ` Alessandro Fanfarillo
2015-12-02 22:00 ` Steve Kargl
1 sibling, 1 reply; 15+ messages in thread
From: Alessandro Fanfarillo @ 2015-12-02 14:16 UTC (permalink / raw)
To: Steve Kargl; +Cc: Tobias Burnus, gcc-patches, gfortran
*PING*
2015-11-26 17:51 GMT+01:00 Steve Kargl <sgk@troutmask.apl.washington.edu>:
> On Wed, Nov 25, 2015 at 06:24:49PM +0100, Alessandro Fanfarillo wrote:
>> Dear all,
>>
>> in attachment the previous patch compatible with the current trunk.
>> The patch also includes the changes introduced in the latest TS 18508.
>>
>> Built and regtested on x86_64-pc-linux-gnu.
>>
>> PS: I will add the test cases in a different patch.
>>
>
> I have now built and regression tested the patch on
> x86_64-*-freebsd and i386-*-freebsd. There were no
> regressions. In reading through the patch, nothing
> jumped out at me as suspicious/wrong. Tobias, this
> is OK to commit. If you don't committed by Sunday,
> I'll do it for you.
>
> --
> steve
^ permalink raw reply [flat|nested] 15+ messages in thread
* Re: [Fortran, Patch] (RFC, Coarray) Implement TS18508's EVENTS
2015-12-02 14:16 ` Alessandro Fanfarillo
@ 2015-12-02 22:00 ` Steve Kargl
2015-12-03 19:46 ` Alessandro Fanfarillo
2015-12-17 12:22 ` Alessandro Fanfarillo
0 siblings, 2 replies; 15+ messages in thread
From: Steve Kargl @ 2015-12-02 22:00 UTC (permalink / raw)
To: Alessandro Fanfarillo; +Cc: Tobias Burnus, gcc-patches, gfortran
Committed as revision 231208.
Alessandro, Tobias, is this a candidate for a commit to
the 5-branch when it is re-opened?
--
steve
On Wed, Dec 02, 2015 at 03:16:05PM +0100, Alessandro Fanfarillo wrote:
> *PING*
>
> 2015-11-26 17:51 GMT+01:00 Steve Kargl <sgk@troutmask.apl.washington.edu>:
> > On Wed, Nov 25, 2015 at 06:24:49PM +0100, Alessandro Fanfarillo wrote:
> >> Dear all,
> >>
> >> in attachment the previous patch compatible with the current trunk.
> >> The patch also includes the changes introduced in the latest TS 18508.
> >>
> >> Built and regtested on x86_64-pc-linux-gnu.
> >>
> >> PS: I will add the test cases in a different patch.
> >>
> >
> > I have now built and regression tested the patch on
> > x86_64-*-freebsd and i386-*-freebsd. There were no
> > regressions. In reading through the patch, nothing
> > jumped out at me as suspicious/wrong. Tobias, this
> > is OK to commit. If you don't committed by Sunday,
> > I'll do it for you.
> >
> > --
> > steve
--
Steve
^ permalink raw reply [flat|nested] 15+ messages in thread
* Re: [Fortran, Patch] (RFC, Coarray) Implement TS18508's EVENTS
2015-12-02 22:00 ` Steve Kargl
@ 2015-12-03 19:46 ` Alessandro Fanfarillo
2015-12-17 12:22 ` Alessandro Fanfarillo
1 sibling, 0 replies; 15+ messages in thread
From: Alessandro Fanfarillo @ 2015-12-03 19:46 UTC (permalink / raw)
To: Steve Kargl; +Cc: Tobias Burnus, gcc-patches, gfortran
Yes please.
Thanks.
2015-12-02 23:00 GMT+01:00 Steve Kargl <sgk@troutmask.apl.washington.edu>:
> Committed as revision 231208.
>
> Alessandro, Tobias, is this a candidate for a commit to
> the 5-branch when it is re-opened?
>
> --
> steve
>
> On Wed, Dec 02, 2015 at 03:16:05PM +0100, Alessandro Fanfarillo wrote:
>> *PING*
>>
>> 2015-11-26 17:51 GMT+01:00 Steve Kargl <sgk@troutmask.apl.washington.edu>:
>> > On Wed, Nov 25, 2015 at 06:24:49PM +0100, Alessandro Fanfarillo wrote:
>> >> Dear all,
>> >>
>> >> in attachment the previous patch compatible with the current trunk.
>> >> The patch also includes the changes introduced in the latest TS 18508.
>> >>
>> >> Built and regtested on x86_64-pc-linux-gnu.
>> >>
>> >> PS: I will add the test cases in a different patch.
>> >>
>> >
>> > I have now built and regression tested the patch on
>> > x86_64-*-freebsd and i386-*-freebsd. There were no
>> > regressions. In reading through the patch, nothing
>> > jumped out at me as suspicious/wrong. Tobias, this
>> > is OK to commit. If you don't committed by Sunday,
>> > I'll do it for you.
>> >
>> > --
>> > steve
>
> --
> Steve
^ permalink raw reply [flat|nested] 15+ messages in thread
* Re: [Fortran, Patch] (RFC, Coarray) Implement TS18508's EVENTS
2015-12-02 22:00 ` Steve Kargl
2015-12-03 19:46 ` Alessandro Fanfarillo
@ 2015-12-17 12:22 ` Alessandro Fanfarillo
2015-12-17 14:57 ` Steve Kargl
1 sibling, 1 reply; 15+ messages in thread
From: Alessandro Fanfarillo @ 2015-12-17 12:22 UTC (permalink / raw)
To: Steve Kargl; +Cc: Tobias Burnus, gcc-patches, gfortran
Hi,
I've noticed that this patch has been applied only on trunk and not on
the gcc-5-branch. Is it a problem to include EVENTS in gcc-5?
2015-12-02 23:00 GMT+01:00 Steve Kargl <sgk@troutmask.apl.washington.edu>:
> Committed as revision 231208.
>
> Alessandro, Tobias, is this a candidate for a commit to
> the 5-branch when it is re-opened?
>
> --
> steve
>
> On Wed, Dec 02, 2015 at 03:16:05PM +0100, Alessandro Fanfarillo wrote:
>> *PING*
>>
>> 2015-11-26 17:51 GMT+01:00 Steve Kargl <sgk@troutmask.apl.washington.edu>:
>> > On Wed, Nov 25, 2015 at 06:24:49PM +0100, Alessandro Fanfarillo wrote:
>> >> Dear all,
>> >>
>> >> in attachment the previous patch compatible with the current trunk.
>> >> The patch also includes the changes introduced in the latest TS 18508.
>> >>
>> >> Built and regtested on x86_64-pc-linux-gnu.
>> >>
>> >> PS: I will add the test cases in a different patch.
>> >>
>> >
>> > I have now built and regression tested the patch on
>> > x86_64-*-freebsd and i386-*-freebsd. There were no
>> > regressions. In reading through the patch, nothing
>> > jumped out at me as suspicious/wrong. Tobias, this
>> > is OK to commit. If you don't committed by Sunday,
>> > I'll do it for you.
>> >
>> > --
>> > steve
>
> --
> Steve
^ permalink raw reply [flat|nested] 15+ messages in thread
* Re: [Fortran, Patch] (RFC, Coarray) Implement TS18508's EVENTS
2015-12-17 12:22 ` Alessandro Fanfarillo
@ 2015-12-17 14:57 ` Steve Kargl
2015-12-17 16:19 ` Alessandro Fanfarillo
0 siblings, 1 reply; 15+ messages in thread
From: Steve Kargl @ 2015-12-17 14:57 UTC (permalink / raw)
To: Alessandro Fanfarillo; +Cc: Tobias Burnus, gcc-patches, gfortran
On Thu, Dec 17, 2015 at 01:22:06PM +0100, Alessandro Fanfarillo wrote:
>
> I've noticed that this patch has been applied only on trunk and not on
> the gcc-5-branch. Is it a problem to include EVENTS in gcc-5?
>
No problem. When I applied the EVENTS patch to trunk,
the 5.3 release was being prepared. I was going to
wait for a week or two after 5.3 came out, then apply
the patch. Now that you have commit access, feel
free to back port the patch. Rememer to post the
patch that you commit to both the fortran and gcc-patches
list.
--
Steve
^ permalink raw reply [flat|nested] 15+ messages in thread
* Re: [Fortran, Patch] (RFC, Coarray) Implement TS18508's EVENTS
2015-12-17 14:57 ` Steve Kargl
@ 2015-12-17 16:19 ` Alessandro Fanfarillo
2016-02-11 23:04 ` Alessandro Fanfarillo
0 siblings, 1 reply; 15+ messages in thread
From: Alessandro Fanfarillo @ 2015-12-17 16:19 UTC (permalink / raw)
To: Steve Kargl; +Cc: Tobias Burnus, gcc-patches, gfortran
Great! Thanks.
2015-12-17 15:57 GMT+01:00 Steve Kargl <sgk@troutmask.apl.washington.edu>:
> On Thu, Dec 17, 2015 at 01:22:06PM +0100, Alessandro Fanfarillo wrote:
>>
>> I've noticed that this patch has been applied only on trunk and not on
>> the gcc-5-branch. Is it a problem to include EVENTS in gcc-5?
>>
>
> No problem. When I applied the EVENTS patch to trunk,
> the 5.3 release was being prepared. I was going to
> wait for a week or two after 5.3 came out, then apply
> the patch. Now that you have commit access, feel
> free to back port the patch. Rememer to post the
> patch that you commit to both the fortran and gcc-patches
> list.
>
> --
> Steve
^ permalink raw reply [flat|nested] 15+ messages in thread
* Re: [Fortran, Patch] (RFC, Coarray) Implement TS18508's EVENTS
2015-12-17 16:19 ` Alessandro Fanfarillo
@ 2016-02-11 23:04 ` Alessandro Fanfarillo
2016-02-12 16:32 ` Alessandro Fanfarillo
0 siblings, 1 reply; 15+ messages in thread
From: Alessandro Fanfarillo @ 2016-02-11 23:04 UTC (permalink / raw)
To: Steve Kargl; +Cc: Tobias Burnus, gcc-patches, gfortran
[-- Attachment #1: Type: text/plain, Size: 983 bytes --]
Dear all,
in attachment the EVENT patch for gcc-5-branch directly back-ported
from the trunk.
Built and regtested on x86_64-pc-linux-gnu. I plan to commit this
patch this evening (Feb 12th, CET).
Cheers,
Alessandro
2015-12-17 17:19 GMT+01:00 Alessandro Fanfarillo <fanfarillo.gcc@gmail.com>:
> Great! Thanks.
>
> 2015-12-17 15:57 GMT+01:00 Steve Kargl <sgk@troutmask.apl.washington.edu>:
>> On Thu, Dec 17, 2015 at 01:22:06PM +0100, Alessandro Fanfarillo wrote:
>>>
>>> I've noticed that this patch has been applied only on trunk and not on
>>> the gcc-5-branch. Is it a problem to include EVENTS in gcc-5?
>>>
>>
>> No problem. When I applied the EVENTS patch to trunk,
>> the 5.3 release was being prepared. I was going to
>> wait for a week or two after 5.3 came out, then apply
>> the patch. Now that you have commit access, feel
>> free to back port the patch. Rememer to post the
>> patch that you commit to both the fortran and gcc-patches
>> list.
>>
>> --
>> Steve
[-- Attachment #2: events_patch_and_tests.diff --]
[-- Type: text/plain, Size: 66579 bytes --]
commit 9504c4c79accddeb6e2386c9bf60d651c3d8f627
Author: Alessandro Fanfarillo <fanfarillo.gcc@gmail.com>
Date: Thu Feb 11 11:24:53 2016 +0000
Events patch backported from gcc-trunk
diff --git ./gcc/fortran/check.c ./gcc/fortran/check.c
index 3196420..049a6fb 100644
--- ./gcc/fortran/check.c
+++ ./gcc/fortran/check.c
@@ -1157,6 +1157,59 @@ gfc_check_atomic_cas (gfc_expr *atom, gfc_expr *old, gfc_expr *compare,
return true;
}
+bool
+gfc_check_event_query (gfc_expr *event, gfc_expr *count, gfc_expr *stat)
+{
+ if (event->ts.type != BT_DERIVED
+ || event->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
+ || event->ts.u.derived->intmod_sym_id != ISOFORTRAN_EVENT_TYPE)
+ {
+ gfc_error ("EVENT argument at %L to the intrinsic EVENT_QUERY "
+ "shall be of type EVENT_TYPE", &event->where);
+ return false;
+ }
+
+ if (!scalar_check (event, 0))
+ return false;
+
+ if (!gfc_check_vardef_context (count, false, false, false, NULL))
+ {
+ gfc_error ("COUNT argument of the EVENT_QUERY intrinsic function at %L "
+ "shall be definable", &count->where);
+ return false;
+ }
+
+ if (!type_check (count, 1, BT_INTEGER))
+ return false;
+
+ int i = gfc_validate_kind (BT_INTEGER, count->ts.kind, false);
+ int j = gfc_validate_kind (BT_INTEGER, gfc_default_integer_kind, false);
+
+ if (gfc_integer_kinds[i].range < gfc_integer_kinds[j].range)
+ {
+ gfc_error ("COUNT argument of the EVENT_QUERY intrinsic function at %L "
+ "shall have at least the range of the default integer",
+ &count->where);
+ return false;
+ }
+
+ if (stat != NULL)
+ {
+ if (!type_check (stat, 2, BT_INTEGER))
+ return false;
+ if (!scalar_check (stat, 2))
+ return false;
+ if (!variable_check (stat, 2, false))
+ return false;
+
+ if (!gfc_notify_std (GFC_STD_F2008_TS, "STAT= argument to %s at %L",
+ gfc_current_intrinsic, &stat->where))
+ return false;
+ }
+
+ return true;
+}
+
bool
gfc_check_atomic_fetch_op (gfc_expr *atom, gfc_expr *value, gfc_expr *old,
diff --git ./gcc/fortran/dump-parse-tree.c ./gcc/fortran/dump-parse-tree.c
index 83ecbaa..c886010 100644
--- ./gcc/fortran/dump-parse-tree.c
+++ ./gcc/fortran/dump-parse-tree.c
@@ -1659,6 +1659,33 @@ show_code_node (int level, gfc_code *c)
}
break;
+ case EXEC_EVENT_POST:
+ case EXEC_EVENT_WAIT:
+ if (c->op == EXEC_EVENT_POST)
+ fputs ("EVENT POST ", dumpfile);
+ else
+ fputs ("EVENT WAIT ", dumpfile);
+
+ fputs ("event-variable=", dumpfile);
+ if (c->expr1 != NULL)
+ show_expr (c->expr1);
+ if (c->expr4 != NULL)
+ {
+ fputs (" until_count=", dumpfile);
+ show_expr (c->expr4);
+ }
+ if (c->expr2 != NULL)
+ {
+ fputs (" stat=", dumpfile);
+ show_expr (c->expr2);
+ }
+ if (c->expr3 != NULL)
+ {
+ fputs (" errmsg=", dumpfile);
+ show_expr (c->expr3);
+ }
+ break;
+
case EXEC_LOCK:
case EXEC_UNLOCK:
if (c->op == EXEC_LOCK)
diff --git ./gcc/fortran/expr.c ./gcc/fortran/expr.c
index c90e823..2e74375 100644
--- ./gcc/fortran/expr.c
+++ ./gcc/fortran/expr.c
@@ -4864,6 +4864,19 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
return false;
}
+ /* TS18508, C702/C203. */
+ if (!alloc_obj
+ && (attr.lock_comp
+ || (e->ts.type == BT_DERIVED
+ && e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+ && e->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)))
+ {
+ if (context)
+ gfc_error ("LOCK_EVENT in variable definition context (%s) at %L",
+ context, &e->where);
+ return false;
+ }
+
/* INTENT(IN) dummy argument. Check this, unless the object itself is the
component of sub-component of a pointer; we need to distinguish
assignment to a pointer component from pointer-assignment to a pointer
diff --git ./gcc/fortran/gfortran.h ./gcc/fortran/gfortran.h
index 9d09de6..1c38d82 100644
--- ./gcc/fortran/gfortran.h
+++ ./gcc/fortran/gfortran.h
@@ -253,7 +253,8 @@ typedef enum
ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD,
ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD,
ST_PROCEDURE, ST_GENERIC, ST_CRITICAL, ST_END_CRITICAL,
- ST_GET_FCN_CHARACTERISTICS, ST_LOCK, ST_UNLOCK, ST_NONE
+ ST_GET_FCN_CHARACTERISTICS, ST_LOCK, ST_UNLOCK, ST_EVENT_POST,
+ ST_EVENT_WAIT,ST_NONE
}
gfc_statement;
@@ -413,6 +414,7 @@ enum gfc_isym_id
GFC_ISYM_ERFC,
GFC_ISYM_ERFC_SCALED,
GFC_ISYM_ETIME,
+ GFC_ISYM_EVENT_QUERY,
GFC_ISYM_EXECUTE_COMMAND_LINE,
GFC_ISYM_EXIT,
GFC_ISYM_EXP,
@@ -847,7 +849,7 @@ typedef struct
entities. */
unsigned alloc_comp:1, pointer_comp:1, proc_pointer_comp:1,
private_comp:1, zero_comp:1, coarray_comp:1, lock_comp:1,
- defined_assign_comp:1, unlimited_polymorphic:1;
+ event_comp:1, defined_assign_comp:1, unlimited_polymorphic:1;
/* This is a temporary selector for SELECT TYPE or an associate
variable for SELECT_TYPE or ASSOCIATE. */
@@ -2330,7 +2332,7 @@ typedef enum
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_LOCK, EXEC_UNLOCK, EXEC_EVENT_POST, EXEC_EVENT_WAIT,
EXEC_OACC_KERNELS_LOOP, EXEC_OACC_PARALLEL_LOOP,
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 ./gcc/fortran/gfortran.texi ./gcc/fortran/gfortran.texi
index a06c5fc..c6b7af5 100644
--- ./gcc/fortran/gfortran.texi
+++ ./gcc/fortran/gfortran.texi
@@ -3306,7 +3306,9 @@ typedef enum caf_register_t {
CAF_REGTYPE_COARRAY_ALLOC,
CAF_REGTYPE_LOCK_STATIC,
CAF_REGTYPE_LOCK_ALLOC,
- CAF_REGTYPE_CRITICAL
+ CAF_REGTYPE_CRITICAL,
+ CAF_REGTYPE_EVENT_STATIC,
+ CAF_REGTYPE_EVENT_ALLOC
}
caf_register_t;
@end verbatim
@@ -3327,6 +3329,9 @@ caf_register_t;
* _gfortran_caf_sendget:: Sending data between remote images
* _gfortran_caf_lock:: Locking a lock variable
* _gfortran_caf_unlock:: Unlocking a lock variable
+* _gfortran_caf_event_post:: Post an event
+* _gfortran_caf_event_wait:: Wait that an event occurred
+* _gfortran_caf_event_query:: Query event count
* _gfortran_caf_sync_all:: All-image barrier
* _gfortran_caf_sync_images:: Barrier for selected images
* _gfortran_caf_sync_memory:: Wait for completion of segment-memory operations
@@ -3480,7 +3485,7 @@ int *stat, char *errmsg, int errmsg_len)}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{size} @tab For normal coarrays, the byte size of the coarray to be
-allocated; for lock types, the number of elements.
+allocated; for lock types and event types, the number of elements.
@item @var{type} @tab one of the caf_register_t types.
@item @var{token} @tab intent(out) An opaque pointer identifying the coarray.
@item @var{stat} @tab intent(out) For allocatable coarrays, stores the STAT=;
@@ -3505,7 +3510,10 @@ image. For lock types, the value shall only used for checking the allocation
status. Note that for critical blocks, the locking is only required on one
image; in the locking statement, the processor shall always pass always an
image index of one for critical-block lock variables
-(@code{CAF_REGTYPE_CRITICAL}).
+(@code{CAF_REGTYPE_CRITICAL}). For lock types and critical-block variables,
+the initial value shall be unlocked (or, respecitively, not in critical
+section) such as the value false; for event types, the initial state should
+be no event, e.g. zero.
@end table
@@ -3525,8 +3533,7 @@ int errmsg_len)}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
-@item @var{stat} @tab intent(out) For allocatable coarrays, stores the STAT=;
-may be NULL
+@item @var{stat} @tab intent(out) Stores the STAT=; may be NULL
@item @var{errmsg} @tab intent(out) When an error occurs, this will be set
to an error message; may be NULL
@item @var{errmsg_len} @tab the buffer size of errmsg.
@@ -3733,8 +3740,7 @@ always 0.
number.
@item @var{aquired_lock} @tab intent(out) If not NULL, it returns whether lock
could be obtained
-@item @var{stat} @tab intent(out) For allocatable coarrays, stores the STAT=;
-may be NULL
+@item @var{stat} @tab intent(out) Stores the STAT=; may be NULL
@item @var{errmsg} @tab intent(out) When an error occurs, this will be set to
an error message; may be NULL
@item @var{errmsg_len} @tab the buffer size of errmsg.
@@ -3746,7 +3752,6 @@ is always zero and the image index is one. Libraries are permitted to use other
images for critical-block locking variables.
@end table
-
@node _gfortran_caf_unlock
@subsection @code{_gfortran_caf_lock} --- Unlocking a lock variable
@cindex Coarray, _gfortran_caf_unlock
@@ -3781,6 +3786,115 @@ is always zero and the image index is one. Libraries are permitted to use other
images for critical-block locking variables.
@end table
+@node _gfortran_caf_event_post
+@subsection @code{_gfortran_caf_event_post} --- Post an event
+@cindex Coarray, _gfortran_caf_event_post
+
+@table @asis
+@item @emph{Description}:
+Increment the event count of the specified event variable.
+
+@item @emph{Syntax}:
+@code{void _gfortran_caf_event_post (caf_token_t token, size_t index,
+int image_index, int *stat, char *errmsg, int errmsg_len)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{token} @tab intent(in) An opaque pointer identifying the coarray.
+@item @var{index} @tab Array index; first array index is 0. For scalars, it is
+always 0.
+@item @var{image_index} @tab The ID of the remote image; must be a positive
+number; zero indicates the current image when accessed noncoindexed.
+@item @var{stat} @tab intent(out) Stores the STAT=; may be NULL
+@item @var{errmsg} @tab intent(out) When an error occurs, this will be set to
+an error message; may be NULL
+@item @var{errmsg_len} @tab the buffer size of errmsg.
+@end multitable
+
+@item @emph{NOTES}
+This acts like an atomic add of one to the remote image's event variable.
+The statement is an image-control statement but does not imply sync memory.
+Still, all preceeding push communications of this image to the specified
+remote image has to be completed before @code{event_wait} on the remote
+image returns.
+@end table
+
+
+
+@node _gfortran_caf_event_wait
+@subsection @code{_gfortran_caf_event_wait} --- Wait that an event occurred
+@cindex Coarray, _gfortran_caf_event_wait
+
+@table @asis
+@item @emph{Description}:
+Wait until the event count has reached at least the specified
+@var{until_count}; if so, atomically decrement the event variable by this
+amount and return.
+
+@item @emph{Syntax}:
+@code{void _gfortran_caf_event_wait (caf_token_t token, size_t index,
+int until_count, int *stat, char *errmsg, int errmsg_len)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{token} @tab intent(in) An opaque pointer identifying the coarray.
+@item @var{index} @tab Array index; first array index is 0. For scalars, it is
+always 0.
+@item @var{until_count} @tab The number of events which have to be available
+before the function returns.
+@item @var{stat} @tab intent(out) Stores the STAT=; may be NULL
+@item @var{errmsg} @tab intent(out) When an error occurs, this will be set to
+an error message; may be NULL
+@item @var{errmsg_len} @tab the buffer size of errmsg.
+@end multitable
+
+@item @emph{NOTES}
+This function only operates on a local coarray. It acts like a loop checking
+atomically the value of the event variable, breaking if the value is greater
+or equal the requested number of counts. Before the function returns, the
+event variable has to be decremented by the requested @var{until_count} value.
+A possible implementation would be a busy loop for a certain number of spins
+(possibly depending on the number of threads relative to the number of available
+cores) followed by other waiting strategy such as a sleeping wait (possibly with
+an increasing number of sleep time) or, if possible, a futex wait.
+
+The statement is an image-control statement but does not imply sync memory.
+Still, all preceeding push communications to this image of images having
+issued a @code{event_push} have to be completed before this function returns.
+@end table
+
+
+
+@node _gfortran_caf_event_query
+@subsection @code{_gfortran_caf_event_query} --- Query event count
+@cindex Coarray, _gfortran_caf_event_query
+
+@table @asis
+@item @emph{Description}:
+Return the event count of the specified event count.
+
+@item @emph{Syntax}:
+@code{void _gfortran_caf_event_query (caf_token_t token, size_t index,
+int image_index, int *count, int *stat)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{token} @tab intent(in) An opaque pointer identifying the coarray.
+@item @var{index} @tab Array index; first array index is 0. For scalars, it is
+always 0.
+@item @var{image_index} @tab The ID of the remote image; must be a positive
+number; zero indicates the current image when accessed noncoindexed.
+@item @var{count} @tab intent(out) The number of events currently posted to
+the event variable
+@item @var{stat} @tab intent(out) Stores the STAT=; may be NULL
+@end multitable
+
+@item @emph{NOTES}
+The typical use is to check the local even variable to only call
+@code{event_wait} when the data is available. However, a coindexed variable
+is permitted; there is no ordering or synchronization implied. It acts like
+an atomic fetch of the value of the event variable.
+@end table
@node _gfortran_caf_sync_all
@subsection @code{_gfortran_caf_sync_all} --- All-image barrier
@@ -3926,7 +4040,7 @@ int image_index, void *value, int *stat, int type, int kind)}
@item @var{offset} @tab By which amount of bytes the actual data is shifted
compared to the base address of the coarray.
@item @var{image_index} @tab The ID of the remote image; must be a positive
-number.
+number; zero indicates the current image when used noncoindexed.
@item @var{value} @tab intent(in) the value to be assigned, passed by reference.
@item @var{stat} @tab intent(out) Stores the status STAT= and may be NULL.
@item @var{type} @tab the data type, i.e. @code{BT_INTEGER} (1) or
@@ -3956,7 +4070,7 @@ int image_index, void *value, int *stat, int type, int kind)}
@item @var{offset} @tab By which amount of bytes the actual data is shifted
compared to the base address of the coarray.
@item @var{image_index} @tab The ID of the remote image; must be a positive
-number.
+number; zero indicates the current image when used noncoindexed.
@item @var{value} @tab intent(out) The variable assigned the atomically
referenced variable.
@item @var{stat} @tab intent(out) Stores the status STAT= and may be NULL.
@@ -3989,7 +4103,7 @@ int type, int kind)}
@item @var{offset} @tab By which amount of bytes the actual data is shifted
compared to the base address of the coarray.
@item @var{image_index} @tab The ID of the remote image; must be a positive
-number.
+number; zero indicates the current image when used noncoindexed.
@item @var{old} @tab intent(out) the value which the atomic variable had
just before the cas operation.
@item @var{compare} @tab intent(in) The value used for comparision.
@@ -4031,7 +4145,7 @@ int image_index, void *value, void *old, int *stat, int type, int kind)}
@item @var{offset} @tab By which amount of bytes the actual data is shifted
compared to the base address of the coarray.
@item @var{image_index} @tab The ID of the remote image; must be a positive
-number.
+number; zero indicates the current image when used noncoindexed.
@item @var{old} @tab intent(out) the value which the atomic variable had
just before the atomic operation.
@item @var{val} @tab intent(in) The new value for the atomic variable,
diff --git ./gcc/fortran/interface.c ./gcc/fortran/interface.c
index 5cbe96a..0ada5ed 100644
--- ./gcc/fortran/interface.c
+++ ./gcc/fortran/interface.c
@@ -2144,6 +2144,21 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
formal->name, &actual->where);
return 0;
}
+
+ /* TS18508, C702/C703. */
+ if (formal->attr.intent != INTENT_INOUT
+ && (((formal->ts.type == BT_DERIVED || formal->ts.type == BT_CLASS)
+ && formal->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+ && formal->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
+ || formal->attr.event_comp))
+
+ {
+ if (where)
+ gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, "
+ "which is EVENT_TYPE or has a EVENT_TYPE component",
+ formal->name, &actual->where);
+ return 0;
+ }
}
/* F2008, C1239/C1240. */
@@ -3377,6 +3392,19 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
break;
}
+ if (a->expr
+ && (a->expr->ts.type == BT_DERIVED || a->expr->ts.type == BT_CLASS)
+ && ((a->expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+ && a->expr->ts.u.derived->intmod_sym_id
+ == ISOFORTRAN_EVENT_TYPE)
+ || gfc_expr_attr (a->expr).event_comp))
+ {
+ gfc_error ("Actual argument of EVENT_TYPE or with EVENT_TYPE "
+ "component at %L requires an explicit interface for "
+ "procedure %qs", &a->expr->where, sym->name);
+ break;
+ }
+
if (a->expr && a->expr->expr_type == EXPR_NULL
&& a->expr->ts.type == BT_UNKNOWN)
{
diff --git ./gcc/fortran/intrinsic.c ./gcc/fortran/intrinsic.c
index a958f8e..3a971cb 100644
--- ./gcc/fortran/intrinsic.c
+++ ./gcc/fortran/intrinsic.c
@@ -3128,6 +3128,13 @@ add_subroutines (void)
GFC_STD_F95, gfc_check_cpu_time, NULL, gfc_resolve_cpu_time,
tm, BT_REAL, dr, REQUIRED, INTENT_OUT);
+ add_sym_3s ("event_query", GFC_ISYM_EVENT_QUERY, CLASS_ATOMIC,
+ BT_UNKNOWN, 0, GFC_STD_F2008_TS,
+ gfc_check_event_query, NULL, gfc_resolve_event_query,
+ "event", BT_INTEGER, di, REQUIRED, INTENT_IN,
+ c, BT_INTEGER, di, OPTIONAL, INTENT_IN,
+ stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
+
/* More G77 compatibility garbage. */
add_sym_2s ("ctime", GFC_ISYM_CTIME, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_ctime_sub, NULL, gfc_resolve_ctime_sub,
diff --git ./gcc/fortran/intrinsic.h ./gcc/fortran/intrinsic.h
index be7f214..2ca41aa 100644
--- ./gcc/fortran/intrinsic.h
+++ ./gcc/fortran/intrinsic.h
@@ -70,6 +70,7 @@ bool gfc_check_dprod (gfc_expr *, gfc_expr *);
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_fgetputc (gfc_expr *, gfc_expr *);
bool gfc_check_fgetput (gfc_expr *);
bool gfc_check_float (gfc_expr *);
@@ -462,6 +463,7 @@ void gfc_resolve_dtime_sub (gfc_code *);
void gfc_resolve_eoshift (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
gfc_expr *);
void gfc_resolve_etime_sub (gfc_code *);
+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 *);
diff --git ./gcc/fortran/iresolve.c ./gcc/fortran/iresolve.c
index 6fa0994..2595826 100644
--- ./gcc/fortran/iresolve.c
+++ ./gcc/fortran/iresolve.c
@@ -2955,6 +2955,12 @@ gfc_resolve_atomic_ref (gfc_code *c)
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
+void
+gfc_resolve_event_query (gfc_code *c)
+{
+ const char *name = "event_query";
+ c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
void
gfc_resolve_mvbits (gfc_code *c)
diff --git ./gcc/fortran/iso-fortran-env.def ./gcc/fortran/iso-fortran-env.def
index eba0b4c..c5fb3ff 100644
--- ./gcc/fortran/iso-fortran-env.def
+++ ./gcc/fortran/iso-fortran-env.def
@@ -123,6 +123,11 @@ NAMED_FUNCTION (ISOFORTRAN_COMPILER_VERSION, "compiler_version", \
NAMED_DERIVED_TYPE (ISOFORTRAN_LOCK_TYPE, "lock_type", \
get_int_kind_from_node (ptr_type_node), GFC_STD_F2008)
+NAMED_DERIVED_TYPE (ISOFORTRAN_EVENT_TYPE, "event_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 ./gcc/fortran/match.c ./gcc/fortran/match.c
index 60c6e65..bf8439a 100644
--- ./gcc/fortran/match.c
+++ ./gcc/fortran/match.c
@@ -1474,6 +1474,8 @@ gfc_match_if (gfc_statement *if_type)
match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE)
match ("end file", gfc_match_endfile, ST_END_FILE)
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)
match ("exit", gfc_match_exit, ST_EXIT)
match ("flush", gfc_match_flush, ST_FLUSH)
match ("forall", match_simple_forall, ST_FORALL)
@@ -2758,6 +2760,202 @@ gfc_match_error_stop (void)
return gfc_match_stopcode (ST_ERROR_STOP);
}
+/* Match EVENT POST/WAIT statement. Syntax:
+ EVENT POST ( event-variable [, sync-stat-list] )
+ EVENT WAIT ( event-variable [, wait-spec-list] )
+ with
+ wait-spec-list is sync-stat-list or until-spec
+ until-spec is UNTIL_COUNT = scalar-int-expr
+ sync-stat is STAT= or ERRMSG=. */
+
+static match
+event_statement (gfc_statement st)
+{
+ match m;
+ gfc_expr *tmp, *eventvar, *until_count, *stat, *errmsg;
+ bool saw_until_count, saw_stat, saw_errmsg;
+
+ tmp = eventvar = until_count = stat = errmsg = NULL;
+ saw_until_count = saw_stat = saw_errmsg = false;
+
+ if (gfc_pure (NULL))
+ {
+ gfc_error ("Image control statement EVENT %s at %C in PURE procedure",
+ st == ST_EVENT_POST ? "POST" : "WAIT");
+ return MATCH_ERROR;
+ }
+
+ gfc_unset_implicit_pure (NULL);
+
+ if (flag_coarray == GFC_FCOARRAY_NONE)
+ {
+ gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
+ return MATCH_ERROR;
+ }
+
+ if (gfc_find_state (COMP_CRITICAL))
+ {
+ gfc_error ("Image control statement EVENT %s at %C in CRITICAL block",
+ st == ST_EVENT_POST ? "POST" : "WAIT");
+ return MATCH_ERROR;
+ }
+
+ if (gfc_find_state (COMP_DO_CONCURRENT))
+ {
+ gfc_error ("Image control statement EVENT %s at %C in DO CONCURRENT "
+ "block", st == ST_EVENT_POST ? "POST" : "WAIT");
+ return MATCH_ERROR;
+ }
+
+ if (gfc_match_char ('(') != MATCH_YES)
+ goto syntax;
+
+ if (gfc_match ("%e", &eventvar) != MATCH_YES)
+ goto syntax;
+ m = gfc_match_char (',');
+ if (m == MATCH_ERROR)
+ goto syntax;
+ if (m == MATCH_NO)
+ {
+ m = gfc_match_char (')');
+ if (m == MATCH_YES)
+ goto done;
+ goto syntax;
+ }
+
+ for (;;)
+ {
+ m = gfc_match (" stat = %v", &tmp);
+ if (m == MATCH_ERROR)
+ goto syntax;
+ if (m == MATCH_YES)
+ {
+ if (saw_stat)
+ {
+ gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
+ goto cleanup;
+ }
+ stat = tmp;
+ saw_stat = true;
+
+ m = gfc_match_char (',');
+ if (m == MATCH_YES)
+ continue;
+
+ tmp = NULL;
+ break;
+ }
+
+ m = gfc_match (" errmsg = %v", &tmp);
+ if (m == MATCH_ERROR)
+ goto syntax;
+ if (m == MATCH_YES)
+ {
+ if (saw_errmsg)
+ {
+ gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
+ goto cleanup;
+ }
+ errmsg = tmp;
+ saw_errmsg = true;
+
+ m = gfc_match_char (',');
+ if (m == MATCH_YES)
+ continue;
+
+ tmp = NULL;
+ break;
+ }
+
+ m = gfc_match (" until_count = %e", &tmp);
+ if (m == MATCH_ERROR || st == ST_EVENT_POST)
+ goto syntax;
+ if (m == MATCH_YES)
+ {
+ if (saw_until_count)
+ {
+ gfc_error ("Redundant UNTIL_COUNT tag found at %L ",
+ &tmp->where);
+ goto cleanup;
+ }
+ until_count = tmp;
+ saw_until_count = true;
+
+ m = gfc_match_char (',');
+ if (m == MATCH_YES)
+ continue;
+
+ tmp = NULL;
+ break;
+ }
+
+ break;
+ }
+
+ if (m == MATCH_ERROR)
+ goto syntax;
+
+ if (gfc_match (" )%t") != MATCH_YES)
+ goto syntax;
+
+done:
+ switch (st)
+ {
+ case ST_EVENT_POST:
+ new_st.op = EXEC_EVENT_POST;
+ break;
+ case ST_EVENT_WAIT:
+ new_st.op = EXEC_EVENT_WAIT;
+ break;
+ default:
+ gcc_unreachable ();
+ }
+
+ new_st.expr1 = eventvar;
+ new_st.expr2 = stat;
+ new_st.expr3 = errmsg;
+ new_st.expr4 = until_count;
+
+ return MATCH_YES;
+
+syntax:
+ gfc_syntax_error (st);
+
+cleanup:
+ if (until_count != tmp)
+ gfc_free_expr (until_count);
+ if (errmsg != tmp)
+ gfc_free_expr (errmsg);
+ if (stat != tmp)
+ gfc_free_expr (stat);
+
+ gfc_free_expr (tmp);
+ gfc_free_expr (eventvar);
+
+ return MATCH_ERROR;
+
+}
+
+
+match
+gfc_match_event_post (void)
+{
+ if (!gfc_notify_std (GFC_STD_F2008_TS, "EVENT POST statement at %C"))
+ return MATCH_ERROR;
+
+ return event_statement (ST_EVENT_POST);
+}
+
+
+match
+gfc_match_event_wait (void)
+{
+ if (!gfc_notify_std (GFC_STD_F2008_TS, "EVENT WAIT statement at %C"))
+ return MATCH_ERROR;
+
+ return event_statement (ST_EVENT_WAIT);
+}
+
/* Match LOCK/UNLOCK statement. Syntax:
LOCK ( lock-variable [ , lock-stat-list ] )
diff --git ./gcc/fortran/match.h ./gcc/fortran/match.h
index 96d3ec1..7427b50 100644
--- ./gcc/fortran/match.h
+++ ./gcc/fortran/match.h
@@ -69,6 +69,8 @@ match gfc_match_assignment (void);
match gfc_match_if (gfc_statement *);
match gfc_match_else (void);
match gfc_match_elseif (void);
+match gfc_match_event_post (void);
+match gfc_match_event_wait (void);
match gfc_match_critical (void);
match gfc_match_block (void);
match gfc_match_associate (void);
diff --git ./gcc/fortran/module.c ./gcc/fortran/module.c
index 2a7e986..3ec24f2 100644
--- ./gcc/fortran/module.c
+++ ./gcc/fortran/module.c
@@ -1889,7 +1889,7 @@ typedef enum
AB_ELEMENTAL, AB_PURE, AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT,
AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE,
AB_ALLOC_COMP, AB_POINTER_COMP, AB_PROC_POINTER_COMP, AB_PRIVATE_COMP,
- AB_VALUE, AB_VOLATILE, AB_PROTECTED, AB_LOCK_COMP,
+ AB_VALUE, AB_VOLATILE, AB_PROTECTED, AB_LOCK_COMP, AB_EVENT_COMP,
AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP,
AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS, AB_CODIMENSION,
AB_COARRAY_COMP, AB_VTYPE, AB_VTAB, AB_CONTIGUOUS, AB_CLASS_POINTER,
@@ -1935,6 +1935,7 @@ static const mstring attr_bits[] =
minit ("ALLOC_COMP", AB_ALLOC_COMP),
minit ("COARRAY_COMP", AB_COARRAY_COMP),
minit ("LOCK_COMP", AB_LOCK_COMP),
+ minit ("EVENT_COMP", AB_EVENT_COMP),
minit ("POINTER_COMP", AB_POINTER_COMP),
minit ("PROC_POINTER_COMP", AB_PROC_POINTER_COMP),
minit ("PRIVATE_COMP", AB_PRIVATE_COMP),
@@ -2117,6 +2118,8 @@ mio_symbol_attribute (symbol_attribute *attr)
MIO_NAME (ab_attribute) (AB_COARRAY_COMP, attr_bits);
if (attr->lock_comp)
MIO_NAME (ab_attribute) (AB_LOCK_COMP, attr_bits);
+ if (attr->event_comp)
+ MIO_NAME (ab_attribute) (AB_EVENT_COMP, attr_bits);
if (attr->zero_comp)
MIO_NAME (ab_attribute) (AB_ZERO_COMP, attr_bits);
if (attr->is_class)
@@ -2269,6 +2272,9 @@ mio_symbol_attribute (symbol_attribute *attr)
case AB_LOCK_COMP:
attr->lock_comp = 1;
break;
+ case AB_EVENT_COMP:
+ attr->event_comp = 1;
+ break;
case AB_POINTER_COMP:
attr->pointer_comp = 1;
break;
diff --git ./gcc/fortran/parse.c ./gcc/fortran/parse.c
index 27ead21..6394e2e 100644
--- ./gcc/fortran/parse.c
+++ ./gcc/fortran/parse.c
@@ -457,6 +457,8 @@ decode_statement (void)
match ("entry% ", gfc_match_entry, ST_ENTRY);
match ("equivalence", gfc_match_equivalence, ST_EQUIVALENCE);
match ("external", gfc_match_external, ST_ATTR_DECL);
+ match ("event post", gfc_match_event_post, ST_EVENT_POST);
+ match ("event wait", gfc_match_event_wait, ST_EVENT_WAIT);
break;
case 'f':
@@ -1323,6 +1325,7 @@ next_statement (void)
case ST_OMP_CANCEL: case ST_OMP_CANCELLATION_POINT: \
case ST_OMP_TARGET_UPDATE: case ST_ERROR_STOP: case ST_SYNC_ALL: \
case ST_SYNC_IMAGES: case ST_SYNC_MEMORY: case ST_LOCK: case ST_UNLOCK: \
+ case ST_EVENT_POST: case ST_EVENT_WAIT: \
case ST_OACC_UPDATE: case ST_OACC_WAIT: case ST_OACC_CACHE: \
case ST_OACC_ENTER_DATA: case ST_OACC_EXIT_DATA
@@ -1628,6 +1631,12 @@ gfc_ascii_statement (gfc_statement st)
case ST_ELSEWHERE:
p = "ELSEWHERE";
break;
+ case ST_EVENT_POST:
+ p = "EVENT POST";
+ break;
+ case ST_EVENT_WAIT:
+ p = "EVENT WAIT";
+ break;
case ST_END_ASSOCIATE:
p = "END ASSOCIATE";
break;
@@ -2608,7 +2617,7 @@ parse_derived (void)
gfc_statement st;
gfc_state_data s;
gfc_symbol *sym;
- gfc_component *c, *lock_comp = NULL;
+ gfc_component *c, *lock_comp = NULL, *event_comp = NULL;
accept_statement (ST_DERIVED_DECL);
push_state (&s, COMP_DERIVED, gfc_new_block);
@@ -2716,8 +2725,8 @@ endType:
sym = gfc_current_block ();
for (c = sym->components; c; c = c->next)
{
- bool coarray, lock_type, allocatable, pointer;
- coarray = lock_type = allocatable = pointer = false;
+ bool coarray, lock_type, event_type, allocatable, pointer;
+ coarray = lock_type = event_type = allocatable = pointer = false;
/* Look for allocatable components. */
if (c->attr.allocatable
@@ -2779,6 +2788,23 @@ endType:
sym->attr.lock_comp = 1;
}
+ /* Looking for event_type components. */
+ if ((c->ts.type == BT_DERIVED
+ && c->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+ && c->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
+ || (c->ts.type == BT_CLASS && c->attr.class_ok
+ && CLASS_DATA (c)->ts.u.derived->from_intmod
+ == INTMOD_ISO_FORTRAN_ENV
+ && CLASS_DATA (c)->ts.u.derived->intmod_sym_id
+ == ISOFORTRAN_EVENT_TYPE)
+ || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.event_comp
+ && !allocatable && !pointer))
+ {
+ event_type = 1;
+ event_comp = c;
+ sym->attr.event_comp = 1;
+ }
+
/* Check for F2008, C1302 - and recall that pointers may not be coarrays
(5.3.14) and that subobjects of coarray are coarray themselves (2.4.7),
unless there are nondirect [allocatable or pointer] components
@@ -2819,6 +2845,43 @@ endType:
"coarray subcomponent)", lock_comp->name, &lock_comp->loc,
sym->name, c->name, &c->loc);
+ /* Similarly for EVENT TYPE. */
+
+ if (pointer && !coarray && event_type)
+ gfc_error ("Component %s at %L of type EVENT_TYPE must have a "
+ "codimension or be a subcomponent of a coarray, "
+ "which is not possible as the component has the "
+ "pointer attribute", c->name, &c->loc);
+ else if (pointer && !coarray && c->ts.type == BT_DERIVED
+ && c->ts.u.derived->attr.event_comp)
+ gfc_error ("Pointer component %s at %L has a noncoarray subcomponent "
+ "of type EVENT_TYPE, which must have a codimension or be a "
+ "subcomponent of a coarray", c->name, &c->loc);
+
+ if (event_type && allocatable && !coarray)
+ gfc_error ("Allocatable component %s at %L of type EVENT_TYPE must have "
+ "a codimension", c->name, &c->loc);
+ else if (event_type && allocatable && c->ts.type == BT_DERIVED
+ && c->ts.u.derived->attr.event_comp)
+ gfc_error ("Allocatable component %s at %L must have a codimension as "
+ "it has a noncoarray subcomponent of type EVENT_TYPE",
+ c->name, &c->loc);
+
+ if (sym->attr.coarray_comp && !coarray && event_type)
+ gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with "
+ "subcomponent of type EVENT_TYPE must have a codimension or "
+ "be a subcomponent of a coarray. (Variables of type %s may "
+ "not have a codimension as already a coarray "
+ "subcomponent exists)", c->name, &c->loc, sym->name);
+
+ if (sym->attr.event_comp && coarray && !event_type)
+ gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with "
+ "subcomponent of type EVENT_TYPE must have a codimension or "
+ "be a subcomponent of a coarray. (Variables of type %s may "
+ "not have a codimension as %s at %L has a codimension or a "
+ "coarray subcomponent)", event_comp->name, &event_comp->loc,
+ sym->name, c->name, &c->loc);
+
/* Look for private components. */
if (sym->component_access == ACCESS_PRIVATE
|| c->attr.access == ACCESS_PRIVATE
diff --git ./gcc/fortran/resolve.c ./gcc/fortran/resolve.c
index bc2be5d..bcaf004 100644
--- ./gcc/fortran/resolve.c
+++ ./gcc/fortran/resolve.c
@@ -6977,6 +6977,21 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
&code->expr3->where, &e->where);
goto failure;
}
+
+ /* Check TS18508, C702/C703. */
+ if (code->expr3->ts.type == BT_DERIVED
+ && ((codimension && gfc_expr_attr (code->expr3).event_comp)
+ || (code->expr3->ts.u.derived->from_intmod
+ == INTMOD_ISO_FORTRAN_ENV
+ && code->expr3->ts.u.derived->intmod_sym_id
+ == ISOFORTRAN_EVENT_TYPE)))
+ {
+ gfc_error ("The source-expr at %L shall neither be of type "
+ "EVENT_TYPE nor have a EVENT_TYPE component if "
+ "allocate-object at %L is a coarray",
+ &code->expr3->where, &e->where);
+ goto failure;
+ }
}
/* Check F08:C629. */
@@ -7028,6 +7043,13 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
no SOURCE exists by setting expr3. */
code->expr3 = gfc_default_initializer (&code->ext.alloc.ts);
}
+ else if (flag_coarray != GFC_FCOARRAY_LIB && e->ts.type == BT_DERIVED
+ && e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+ && e->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
+ {
+ /* We have to zero initialize the integer variable. */
+ code->expr3 = gfc_get_int_expr (gfc_default_integer_kind, &e->where, 0);
+ }
else if (!code->expr3)
{
/* Set up default initializer if needed. */
@@ -8545,21 +8567,40 @@ find_reachable_labels (gfc_code *block)
static void
-resolve_lock_unlock (gfc_code *code)
+resolve_lock_unlock_event (gfc_code *code)
{
if (code->expr1->expr_type == EXPR_FUNCTION
&& code->expr1->value.function.isym
&& code->expr1->value.function.isym->id == GFC_ISYM_CAF_GET)
remove_caf_get_intrinsic (code->expr1);
- if (code->expr1->ts.type != BT_DERIVED
- || code->expr1->expr_type != EXPR_VARIABLE
- || code->expr1->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
- || code->expr1->ts.u.derived->intmod_sym_id != ISOFORTRAN_LOCK_TYPE
- || code->expr1->rank != 0
- || (!gfc_is_coarray (code->expr1) && !gfc_is_coindexed (code->expr1)))
+ if ((code->op == EXEC_LOCK || code->op == EXEC_UNLOCK)
+ && (code->expr1->ts.type != BT_DERIVED
+ || code->expr1->expr_type != EXPR_VARIABLE
+ || code->expr1->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
+ || code->expr1->ts.u.derived->intmod_sym_id != ISOFORTRAN_LOCK_TYPE
+ || code->expr1->rank != 0
+ || (!gfc_is_coarray (code->expr1) &&
+ !gfc_is_coindexed (code->expr1))))
gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
&code->expr1->where);
+ else if ((code->op == EXEC_EVENT_POST || code->op == EXEC_EVENT_WAIT)
+ && (code->expr1->ts.type != BT_DERIVED
+ || code->expr1->expr_type != EXPR_VARIABLE
+ || code->expr1->ts.u.derived->from_intmod
+ != INTMOD_ISO_FORTRAN_ENV
+ || code->expr1->ts.u.derived->intmod_sym_id
+ != ISOFORTRAN_EVENT_TYPE
+ || code->expr1->rank != 0))
+ gfc_error ("Event variable at %L must be a scalar of type EVENT_TYPE",
+ &code->expr1->where);
+ else if (code->op == EXEC_EVENT_POST && !gfc_is_coarray (code->expr1)
+ && !gfc_is_coindexed (code->expr1))
+ gfc_error ("Event variable argument at %L must be a coarray or coindexed",
+ &code->expr1->where);
+ else if (code->op == EXEC_EVENT_WAIT && !gfc_is_coarray (code->expr1))
+ gfc_error ("Event variable argument at %L must be a coarray but not "
+ "coindexed", &code->expr1->where);
/* Check STAT. */
if (code->expr2
@@ -8585,17 +8626,23 @@ resolve_lock_unlock (gfc_code *code)
_("ERRMSG variable")))
return;
- /* Check ACQUIRED_LOCK. */
- if (code->expr4
+ /* Check for LOCK the ACQUIRED_LOCK. */
+ if (code->op != EXEC_EVENT_WAIT && code->expr4
&& (code->expr4->ts.type != BT_LOGICAL || code->expr4->rank != 0
|| code->expr4->expr_type != EXPR_VARIABLE))
gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
"variable", &code->expr4->where);
- if (code->expr4
+ if (code->op != EXEC_EVENT_WAIT && code->expr4
&& !gfc_check_vardef_context (code->expr4, false, false, false,
_("ACQUIRED_LOCK variable")))
return;
+
+ /* Check for EVENT WAIT the UNTIL_COUNT. */
+ if (code->op == EXEC_EVENT_WAIT && code->expr4
+ && (code->expr4->ts.type != BT_INTEGER || code->expr4->rank != 0))
+ gfc_error ("UNTIL_COUNT= argument at %L must be a scalar INTEGER "
+ "expression", &code->expr4->where);
}
@@ -10173,7 +10220,9 @@ gfc_resolve_code (gfc_code *code, gfc_namespace *ns)
case EXEC_LOCK:
case EXEC_UNLOCK:
- resolve_lock_unlock (code);
+ case EXEC_EVENT_POST:
+ case EXEC_EVENT_WAIT:
+ resolve_lock_unlock_event (code);
break;
case EXEC_ENTRY:
@@ -13663,6 +13712,19 @@ resolve_symbol (gfc_symbol *sym)
return;
}
+ /* TS18508, C702/C703. */
+ if (sym->ts.type == BT_DERIVED
+ && ((sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+ && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
+ || sym->ts.u.derived->attr.event_comp)
+ && !sym->attr.codimension && !sym->ts.u.derived->attr.coarray_comp)
+ {
+ gfc_error ("Variable %s at %L of type EVENT_TYPE or with subcomponent of "
+ "type LOCK_TYPE must be a coarray", sym->name,
+ &sym->declared_at);
+ return;
+ }
+
/* An assumed-size array with INTENT(OUT) shall not be of a type for which
default initialization is defined (5.1.2.4.4). */
if (sym->ts.type == BT_DERIVED
@@ -13692,6 +13754,15 @@ resolve_symbol (gfc_symbol *sym)
return;
}
+ /* TS18508. */
+ if (sym->ts.type == BT_DERIVED && sym->attr.dummy
+ && sym->attr.intent == INTENT_OUT && sym->attr.event_comp)
+ {
+ gfc_error ("Dummy argument %qs at %L of EVENT_TYPE shall not be "
+ "INTENT(OUT)", sym->name, &sym->declared_at);
+ return;
+ }
+
/* F2008, C525. */
if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
|| (sym->ts.type == BT_CLASS && sym->attr.class_ok
diff --git ./gcc/fortran/st.c ./gcc/fortran/st.c
index 116af15..03792f8 100644
--- ./gcc/fortran/st.c
+++ ./gcc/fortran/st.c
@@ -118,6 +118,8 @@ gfc_free_statement (gfc_code *p)
case EXEC_SYNC_MEMORY:
case EXEC_LOCK:
case EXEC_UNLOCK:
+ case EXEC_EVENT_POST:
+ case EXEC_EVENT_WAIT:
break;
case EXEC_BLOCK:
diff --git ./gcc/fortran/trans-decl.c ./gcc/fortran/trans-decl.c
index 900015d..901775f 100644
--- ./gcc/fortran/trans-decl.c
+++ ./gcc/fortran/trans-decl.c
@@ -163,6 +163,9 @@ tree gfor_fndecl_caf_atomic_cas;
tree gfor_fndecl_caf_atomic_op;
tree gfor_fndecl_caf_lock;
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_co_broadcast;
tree gfor_fndecl_co_max;
tree gfor_fndecl_co_min;
@@ -3505,6 +3508,21 @@ gfc_build_builtin_function_decls (void)
void_type_node, 6, pvoid_type_node, size_type_node, integer_type_node,
pint_type, pchar_type_node, integer_type_node);
+ gfor_fndecl_caf_event_post = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("caf_event_post")), "R..WW",
+ void_type_node, 6, pvoid_type_node, size_type_node, integer_type_node,
+ pint_type, pchar_type_node, integer_type_node);
+
+ gfor_fndecl_caf_event_wait = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("caf_event_wait")), "R..WW",
+ void_type_node, 6, pvoid_type_node, size_type_node, integer_type_node,
+ pint_type, pchar_type_node, integer_type_node);
+
+ gfor_fndecl_caf_event_query = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("caf_event_query")), "R..WW",
+ void_type_node, 5, pvoid_type_node, size_type_node, integer_type_node,
+ pint_type, pint_type);
+
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,
@@ -4784,7 +4802,7 @@ static void
generate_coarray_sym_init (gfc_symbol *sym)
{
tree tmp, size, decl, token;
- bool is_lock_type;
+ bool is_lock_type, is_event_type;
int reg_type;
if (sym->attr.dummy || sym->attr.allocatable || !sym->attr.codimension
@@ -4800,13 +4818,17 @@ generate_coarray_sym_init (gfc_symbol *sym)
&& sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
&& sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE;
+ is_event_type = sym->ts.type == BT_DERIVED
+ && sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+ && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE;
+
/* FIXME: Workaround for PR middle-end/49106, cf. also PR middle-end/49108
to make sure the variable is not optimized away. */
DECL_PRESERVE_P (DECL_CONTEXT (decl)) = 1;
/* For lock types, we pass the array size as only the library knows the
size of the variable. */
- if (is_lock_type)
+ if (is_lock_type || is_event_type)
size = gfc_index_one_node;
else
size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (decl)));
@@ -4828,6 +4850,8 @@ generate_coarray_sym_init (gfc_symbol *sym)
GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE(decl)));
if (is_lock_type)
reg_type = sym->attr.artificial ? GFC_CAF_CRITICAL : GFC_CAF_LOCK_STATIC;
+ else if (is_event_type)
+ reg_type = GFC_CAF_EVENT_STATIC;
else
reg_type = GFC_CAF_COARRAY_STATIC;
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register, 6, size,
diff --git ./gcc/fortran/trans-expr.c ./gcc/fortran/trans-expr.c
index 510ce9d..60e3477 100644
--- ./gcc/fortran/trans-expr.c
+++ ./gcc/fortran/trans-expr.c
@@ -5616,8 +5616,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
len = cl.backend_decl;
}
- byref = (comp && (comp->attr.dimension || comp->ts.type == BT_CHARACTER))
- || (!comp && gfc_return_by_reference (sym));
+ byref = (comp && (comp->attr.dimension
+ || (comp->ts.type == BT_CHARACTER && !sym->attr.is_bind_c)))
+ || (!comp && gfc_return_by_reference (sym));
if (byref)
{
if (se->direct_byref)
@@ -6443,6 +6444,11 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
{
gfc_se se;
+ if (flag_coarray != GFC_FCOARRAY_LIB && ts->type == BT_DERIVED
+ && ts->u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+ && ts->u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
+ return build_constructor (type, NULL);
+
if (!(expr || pointer || procptr))
return NULL_TREE;
diff --git ./gcc/fortran/trans-intrinsic.c ./gcc/fortran/trans-intrinsic.c
index f497499..6d7389a 100644
--- ./gcc/fortran/trans-intrinsic.c
+++ ./gcc/fortran/trans-intrinsic.c
@@ -9274,6 +9274,154 @@ conv_intrinsic_atomic_cas (gfc_code *code)
return gfc_finish_block (&block);
}
+static tree
+conv_intrinsic_event_query (gfc_code *code)
+{
+ gfc_se se, argse;
+ tree stat = NULL_TREE, stat2 = NULL_TREE;
+ tree count = NULL_TREE, count2 = NULL_TREE;
+
+ gfc_expr *event_expr = code->ext.actual->expr;
+
+ if (code->ext.actual->next->next->expr)
+ {
+ gcc_assert (code->ext.actual->next->next->expr->expr_type
+ == EXPR_VARIABLE);
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr_val (&argse, code->ext.actual->next->next->expr);
+ stat = argse.expr;
+ }
+ else if (flag_coarray == GFC_FCOARRAY_LIB)
+ stat = null_pointer_node;
+
+ if (code->ext.actual->next->expr)
+ {
+ gcc_assert (code->ext.actual->next->expr->expr_type == EXPR_VARIABLE);
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr_val (&argse, code->ext.actual->next->expr);
+ count = argse.expr;
+ }
+
+ gfc_start_block (&se.pre);
+ if (flag_coarray == GFC_FCOARRAY_LIB)
+ {
+ tree tmp, token, image_index;
+ tree index = size_zero_node;
+
+ if (event_expr->expr_type == EXPR_FUNCTION
+ && event_expr->value.function.isym
+ && event_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
+ event_expr = event_expr->value.function.actual->expr;
+
+ tree caf_decl = gfc_get_tree_for_caf_expr (event_expr);
+
+ if (event_expr->symtree->n.sym->ts.type != BT_DERIVED
+ || event_expr->symtree->n.sym->ts.u.derived->from_intmod
+ != INTMOD_ISO_FORTRAN_ENV
+ || event_expr->symtree->n.sym->ts.u.derived->intmod_sym_id
+ != ISOFORTRAN_EVENT_TYPE)
+ {
+ gfc_error ("Sorry, the event component of derived type at %L is not "
+ "yet supported", &event_expr->where);
+ return NULL_TREE;
+ }
+
+ if (gfc_is_coindexed (event_expr))
+ {
+ gfc_error ("The event variable at %L shall not be coindexed ",
+ &event_expr->where);
+ return NULL_TREE;
+ }
+
+ image_index = integer_zero_node;
+
+ gfc_get_caf_token_offset (&token, NULL, caf_decl, NULL_TREE, event_expr);
+
+ /* For arrays, obtain the array index. */
+ if (gfc_expr_attr (event_expr).dimension)
+ {
+ tree desc, tmp, extent, lbound, ubound;
+ gfc_array_ref *ar, ar2;
+ int i;
+
+ /* TODO: Extend this, once DT components are supported. */
+ ar = &event_expr->ref->u.ar;
+ ar2 = *ar;
+ memset (ar, '\0', sizeof (*ar));
+ ar->as = ar2.as;
+ ar->type = AR_FULL;
+
+ gfc_init_se (&argse, NULL);
+ argse.descriptor_only = 1;
+ gfc_conv_expr_descriptor (&argse, event_expr);
+ gfc_add_block_to_block (&se.pre, &argse.pre);
+ desc = argse.expr;
+ *ar = ar2;
+
+ extent = integer_one_node;
+ for (i = 0; i < ar->dimen; i++)
+ {
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr_type (&argse, ar->start[i], integer_type_node);
+ gfc_add_block_to_block (&argse.pre, &argse.pre);
+ lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ integer_type_node, argse.expr,
+ fold_convert(integer_type_node, lbound));
+ tmp = fold_build2_loc (input_location, MULT_EXPR,
+ integer_type_node, extent, tmp);
+ index = fold_build2_loc (input_location, PLUS_EXPR,
+ integer_type_node, index, tmp);
+ if (i < ar->dimen - 1)
+ {
+ ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
+ tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
+ tmp = fold_convert (integer_type_node, tmp);
+ extent = fold_build2_loc (input_location, MULT_EXPR,
+ integer_type_node, extent, tmp);
+ }
+ }
+ }
+
+ if (count != null_pointer_node && TREE_TYPE (count) != integer_type_node)
+ {
+ count2 = count;
+ count = gfc_create_var (integer_type_node, "count");
+ }
+
+ if (stat != null_pointer_node && TREE_TYPE (stat) != integer_type_node)
+ {
+ stat2 = stat;
+ stat = gfc_create_var (integer_type_node, "stat");
+ }
+
+ tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_event_query, 5,
+ token, index, image_index, count
+ ? gfc_build_addr_expr (NULL, count) : count,
+ stat != null_pointer_node
+ ? gfc_build_addr_expr (NULL, stat) : stat);
+ gfc_add_expr_to_block (&se.pre, tmp);
+
+ if (count2 != NULL_TREE)
+ gfc_add_modify (&se.pre, count2,
+ fold_convert (TREE_TYPE (count2), count));
+
+ if (stat2 != NULL_TREE)
+ gfc_add_modify (&se.pre, stat2,
+ fold_convert (TREE_TYPE (stat2), stat));
+
+ return gfc_finish_block (&se.pre);
+ }
+
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr_val (&argse, code->ext.actual->expr);
+ gfc_add_modify (&se.pre, count, fold_convert (TREE_TYPE (count), argse.expr));
+
+ if (stat != NULL_TREE)
+ gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0));
+
+ return gfc_finish_block (&se.pre);
+}
static tree
conv_intrinsic_move_alloc (gfc_code *code)
@@ -9570,6 +9718,10 @@ gfc_conv_intrinsic_subroutine (gfc_code *code)
res = conv_intrinsic_atomic_ref (code);
break;
+ case GFC_ISYM_EVENT_QUERY:
+ res = conv_intrinsic_event_query (code);
+ break;
+
case GFC_ISYM_C_F_POINTER:
case GFC_ISYM_C_F_PROCPOINTER:
res = conv_isocbinding_subroutine (code);
diff --git ./gcc/fortran/trans-stmt.c ./gcc/fortran/trans-stmt.c
index 03f99b5..5609991 100644
--- ./gcc/fortran/trans-stmt.c
+++ ./gcc/fortran/trans-stmt.c
@@ -788,6 +788,7 @@ gfc_trans_lock_unlock (gfc_code *code, gfc_exec_op op)
if (code->expr3)
{
gfc_init_se (&argse, NULL);
+ argse.want_pointer = 1;
gfc_conv_expr (&argse, code->expr3);
gfc_add_block_to_block (&se.pre, &argse.pre);
errmsg = argse.expr;
@@ -863,6 +864,165 @@ gfc_trans_lock_unlock (gfc_code *code, gfc_exec_op op)
return gfc_finish_block (&se.pre);
}
+tree
+gfc_trans_event_post_wait (gfc_code *code, gfc_exec_op op)
+{
+ gfc_se se, argse;
+ tree stat = NULL_TREE, stat2 = NULL_TREE;
+ tree until_count = NULL_TREE;
+
+ if (code->expr2)
+ {
+ gcc_assert (code->expr2->expr_type == EXPR_VARIABLE);
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr_val (&argse, code->expr2);
+ stat = argse.expr;
+ }
+ else if (flag_coarray == GFC_FCOARRAY_LIB)
+ stat = null_pointer_node;
+
+ if (code->expr4)
+ {
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr_val (&argse, code->expr4);
+ until_count = fold_convert (integer_type_node, argse.expr);
+ }
+ else
+ until_count = integer_one_node;
+
+ if (flag_coarray != GFC_FCOARRAY_LIB)
+ {
+ gfc_start_block (&se.pre);
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr_val (&argse, code->expr1);
+
+ if (op == EXEC_EVENT_POST)
+ gfc_add_modify (&se.pre, argse.expr,
+ fold_build2_loc (input_location, PLUS_EXPR,
+ TREE_TYPE (argse.expr), argse.expr,
+ build_int_cst (TREE_TYPE (argse.expr), 1)));
+ else
+ gfc_add_modify (&se.pre, argse.expr,
+ fold_build2_loc (input_location, MINUS_EXPR,
+ TREE_TYPE (argse.expr), argse.expr,
+ fold_convert (TREE_TYPE (argse.expr),
+ until_count)));
+ if (stat != NULL_TREE)
+ gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0));
+
+ return gfc_finish_block (&se.pre);
+ }
+
+ gfc_start_block (&se.pre);
+ tree tmp, token, image_index, errmsg, errmsg_len;
+ tree index = size_zero_node;
+ tree caf_decl = gfc_get_tree_for_caf_expr (code->expr1);
+
+ if (code->expr1->symtree->n.sym->ts.type != BT_DERIVED
+ || code->expr1->symtree->n.sym->ts.u.derived->from_intmod
+ != INTMOD_ISO_FORTRAN_ENV
+ || code->expr1->symtree->n.sym->ts.u.derived->intmod_sym_id
+ != ISOFORTRAN_EVENT_TYPE)
+ {
+ gfc_error ("Sorry, the event component of derived type at %L is not "
+ "yet supported", &code->expr1->where);
+ return NULL_TREE;
+ }
+
+ gfc_get_caf_token_offset (&token, NULL, caf_decl, NULL_TREE, code->expr1);
+
+ if (gfc_is_coindexed (code->expr1))
+ image_index = gfc_caf_get_image_index (&se.pre, code->expr1, caf_decl);
+ else
+ image_index = integer_zero_node;
+
+ /* For arrays, obtain the array index. */
+ if (gfc_expr_attr (code->expr1).dimension)
+ {
+ tree desc, tmp, extent, lbound, ubound;
+ gfc_array_ref *ar, ar2;
+ int i;
+
+ /* TODO: Extend this, once DT components are supported. */
+ ar = &code->expr1->ref->u.ar;
+ ar2 = *ar;
+ memset (ar, '\0', sizeof (*ar));
+ ar->as = ar2.as;
+ ar->type = AR_FULL;
+
+ gfc_init_se (&argse, NULL);
+ argse.descriptor_only = 1;
+ gfc_conv_expr_descriptor (&argse, code->expr1);
+ gfc_add_block_to_block (&se.pre, &argse.pre);
+ desc = argse.expr;
+ *ar = ar2;
+
+ extent = integer_one_node;
+ for (i = 0; i < ar->dimen; i++)
+ {
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr_type (&argse, ar->start[i], integer_type_node);
+ gfc_add_block_to_block (&argse.pre, &argse.pre);
+ lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ integer_type_node, argse.expr,
+ fold_convert(integer_type_node, lbound));
+ tmp = fold_build2_loc (input_location, MULT_EXPR,
+ integer_type_node, extent, tmp);
+ index = fold_build2_loc (input_location, PLUS_EXPR,
+ integer_type_node, index, tmp);
+ if (i < ar->dimen - 1)
+ {
+ ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
+ tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
+ tmp = fold_convert (integer_type_node, tmp);
+ extent = fold_build2_loc (input_location, MULT_EXPR,
+ integer_type_node, extent, tmp);
+ }
+ }
+ }
+
+ /* errmsg. */
+ if (code->expr3)
+ {
+ gfc_init_se (&argse, NULL);
+ argse.want_pointer = 1;
+ gfc_conv_expr (&argse, code->expr3);
+ gfc_add_block_to_block (&se.pre, &argse.pre);
+ errmsg = argse.expr;
+ errmsg_len = fold_convert (integer_type_node, argse.string_length);
+ }
+ else
+ {
+ errmsg = null_pointer_node;
+ errmsg_len = integer_zero_node;
+ }
+
+ if (stat != null_pointer_node && TREE_TYPE (stat) != integer_type_node)
+ {
+ stat2 = stat;
+ stat = gfc_create_var (integer_type_node, "stat");
+ }
+
+ if (op == EXEC_EVENT_POST)
+ tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_event_post, 6,
+ token, index, image_index,
+ stat != null_pointer_node
+ ? gfc_build_addr_expr (NULL, stat) : stat,
+ errmsg, errmsg_len);
+ else
+ tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_event_wait, 6,
+ token, index, until_count,
+ stat != null_pointer_node
+ ? gfc_build_addr_expr (NULL, stat) : stat,
+ errmsg, errmsg_len);
+ gfc_add_expr_to_block (&se.pre, tmp);
+
+ if (stat2 != NULL_TREE)
+ gfc_add_modify (&se.pre, stat2, fold_convert (TREE_TYPE (stat2), stat));
+
+ return gfc_finish_block (&se.pre);
+}
tree
gfc_trans_sync (gfc_code *code, gfc_exec_op type)
@@ -902,6 +1062,7 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type)
{
gcc_assert (code->expr3->expr_type == EXPR_VARIABLE);
gfc_init_se (&argse, NULL);
+ argse.want_pointer = 1;
gfc_conv_expr (&argse, code->expr3);
gfc_conv_string_parameter (&argse);
errmsg = gfc_build_addr_expr (NULL, argse.expr);
diff --git ./gcc/fortran/trans-stmt.h ./gcc/fortran/trans-stmt.h
index 2f2a0b3..9841fb8 100644
--- ./gcc/fortran/trans-stmt.h
+++ ./gcc/fortran/trans-stmt.h
@@ -55,6 +55,7 @@ tree gfc_trans_do_while (gfc_code *);
tree gfc_trans_select (gfc_code *);
tree gfc_trans_sync (gfc_code *, gfc_exec_op);
tree gfc_trans_lock_unlock (gfc_code *, gfc_exec_op);
+tree gfc_trans_event_post_wait (gfc_code *, gfc_exec_op);
tree gfc_trans_forall (gfc_code *);
tree gfc_trans_where (gfc_code *);
tree gfc_trans_allocate (gfc_code *);
diff --git ./gcc/fortran/trans-types.c ./gcc/fortran/trans-types.c
index 4cf980d..5444aaa 100644
--- ./gcc/fortran/trans-types.c
+++ ./gcc/fortran/trans-types.c
@@ -2383,6 +2383,11 @@ gfc_get_derived_type (gfc_symbol * derived)
&& derived->intmod_sym_id == ISOFORTRAN_LOCK_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)
+ return gfc_get_int_type (gfc_default_integer_kind);
+
if (derived && derived->attr.flavor == FL_PROCEDURE
&& derived->attr.generic)
derived = gfc_find_dt_in_generic (derived);
diff --git ./gcc/fortran/trans.c ./gcc/fortran/trans.c
index ff6df84..5897c50 100644
--- ./gcc/fortran/trans.c
+++ ./gcc/fortran/trans.c
@@ -716,7 +716,7 @@ gfc_allocate_using_malloc (stmtblock_t * block, tree pointer,
static void
gfc_allocate_using_lib (stmtblock_t * block, tree pointer, tree size,
tree token, tree status, tree errmsg, tree errlen,
- bool lock_var)
+ bool lock_var, bool event_var)
{
tree tmp, pstat;
@@ -747,7 +747,8 @@ gfc_allocate_using_lib (stmtblock_t * block, tree pointer, tree size,
build_int_cst (size_type_node, 1)),
build_int_cst (integer_type_node,
lock_var ? GFC_CAF_LOCK_ALLOC
- : GFC_CAF_COARRAY_ALLOC),
+ : event_var ? GFC_CAF_EVENT_ALLOC
+ : GFC_CAF_COARRAY_ALLOC),
token, pstat, errmsg, errlen);
tmp = fold_build2_loc (input_location, MODIFY_EXPR,
@@ -819,6 +820,11 @@ gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size, tree token,
== INTMOD_ISO_FORTRAN_ENV
&& expr->ts.u.derived->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE;
+ bool event_var = expr->ts.type == BT_DERIVED
+ && expr->ts.u.derived->from_intmod
+ == INTMOD_ISO_FORTRAN_ENV
+ && expr->ts.u.derived->intmod_sym_id
+ == ISOFORTRAN_EVENT_TYPE;
/* In the front end, we represent the lock variable as pointer. However,
the FE only passes the pointer around and leaves the actual
representation to the library. Hence, we have to convert back to the
@@ -828,7 +834,7 @@ gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size, tree token,
size, TYPE_SIZE_UNIT (ptr_type_node));
gfc_allocate_using_lib (&alloc_block, mem, size, token, status,
- errmsg, errlen, lock_var);
+ errmsg, errlen, lock_var, event_var);
if (status != NULL_TREE)
{
@@ -1844,6 +1850,11 @@ trans_code (gfc_code * code, tree cond)
res = gfc_trans_lock_unlock (code, code->op);
break;
+ case EXEC_EVENT_POST:
+ case EXEC_EVENT_WAIT:
+ res = gfc_trans_event_post_wait (code, code->op);
+ break;
+
case EXEC_FORALL:
res = gfc_trans_forall (code);
break;
diff --git ./gcc/fortran/trans.h ./gcc/fortran/trans.h
index 70d99d0..e6544f9 100644
--- ./gcc/fortran/trans.h
+++ ./gcc/fortran/trans.h
@@ -109,7 +109,9 @@ typedef enum
GFC_CAF_COARRAY_ALLOC,
GFC_CAF_LOCK_STATIC,
GFC_CAF_LOCK_ALLOC,
- GFC_CAF_CRITICAL
+ GFC_CAF_CRITICAL,
+ GFC_CAF_EVENT_STATIC,
+ GFC_CAF_EVENT_ALLOC
}
gfc_coarray_type;
@@ -756,6 +758,9 @@ extern GTY(()) tree gfor_fndecl_caf_atomic_cas;
extern GTY(()) tree gfor_fndecl_caf_atomic_op;
extern GTY(()) tree gfor_fndecl_caf_lock;
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_co_broadcast;
extern GTY(()) tree gfor_fndecl_co_max;
extern GTY(()) tree gfor_fndecl_co_min;
diff --git ./gcc/testsuite/gfortran.dg/coarray/event_1.f90 ./gcc/testsuite/gfortran.dg/coarray/event_1.f90
new file mode 100644
index 0000000..b4385f3
--- /dev/null
+++ ./gcc/testsuite/gfortran.dg/coarray/event_1.f90
@@ -0,0 +1,51 @@
+! { dg-do run }
+!
+! Run-time test for EVENT_TYPE
+!
+use iso_fortran_env, only: event_type
+implicit none
+
+type(event_type), save :: var[*]
+integer :: count, stat
+
+count = -42
+call event_query (var, count)
+if (count /= 0) call abort()
+
+stat = 99
+event post (var, stat=stat)
+if (stat /= 0) call abort()
+call event_query(var, count, stat=stat)
+if (count /= 1 .or. stat /= 0) call abort()
+
+stat = 99
+event post (var[this_image()])
+call event_query(var, count)
+if (count /= 2) call abort()
+
+stat = 99
+event wait (var)
+call event_query(var, count)
+if (count /= 1) call abort()
+
+stat = 99
+event post (var)
+call event_query(var, count)
+if (count /= 2) call abort()
+
+stat = 99
+event post (var)
+call event_query(var, count)
+if (count /= 3) call abort()
+
+stat = 99
+event wait (var, until_count=2)
+call event_query(var, count)
+if (count /= 1) call abort()
+
+stat = 99
+event wait (var, stat=stat, until_count=1)
+if (stat /= 0) call abort()
+call event_query(event=var, stat=stat, count=count)
+if (count /= 0 .or. stat /= 0) call abort()
+end
diff --git ./gcc/testsuite/gfortran.dg/coarray/event_2.f90 ./gcc/testsuite/gfortran.dg/coarray/event_2.f90
new file mode 100644
index 0000000..2d451a5
--- /dev/null
+++ ./gcc/testsuite/gfortran.dg/coarray/event_2.f90
@@ -0,0 +1,89 @@
+! { dg-do run }
+!
+! Run-time test for EVENT_TYPE
+!
+use iso_fortran_env, only: event_type
+implicit none
+
+type(event_type), save, allocatable :: var(:)[:]
+integer :: count, stat
+
+allocate(var(3)[*])
+
+count = -42
+call event_query (var(1), count)
+if (count /= 0) call abort()
+call event_query (var(1), count)
+if (count /= 0) call abort()
+call event_query (var(2), count)
+if (count /= 0) call abort()
+call event_query (var(3), count)
+if (count /= 0) call abort()
+
+stat = 99
+event post (var(2), stat=stat)
+if (stat /= 0) call abort()
+call event_query (var(1), count)
+if (count /= 0) call abort()
+call event_query(var(2), count, stat=stat)
+if (count /= 1 .or. stat /= 0) call abort()
+call event_query (var(3), count)
+if (count /= 0) call abort()
+
+stat = 99
+event post (var(2)[this_image()])
+call event_query(var(1), count)
+if (count /= 0) call abort()
+call event_query(var(2), count)
+if (count /= 2) call abort()
+call event_query(var(2), count)
+if (count /= 2) call abort()
+call event_query(var(3), count)
+if (count /= 0) call abort()
+
+stat = 99
+event wait (var(2))
+call event_query(var(1), count)
+if (count /= 0) call abort()
+call event_query(var(2), count)
+if (count /= 1) call abort()
+call event_query(var(3), count)
+if (count /= 0) call abort()
+
+stat = 99
+event post (var(2))
+call event_query(var(1), count)
+if (count /= 0) call abort()
+call event_query(var(2), count)
+if (count /= 2) call abort()
+call event_query(var(3), count)
+if (count /= 0) call abort()
+
+stat = 99
+event post (var(2))
+call event_query(var(1), count)
+if (count /= 0) call abort()
+call event_query(var(2), count)
+if (count /= 3) call abort()
+call event_query(var(3), count)
+if (count /= 0) call abort()
+
+stat = 99
+event wait (var(2), until_count=2)
+call event_query(var(1), count)
+if (count /= 0) call abort()
+call event_query(var(2), count)
+if (count /= 1) call abort()
+call event_query(var(3), count)
+if (count /= 0) call abort()
+
+stat = 99
+event wait (var(2), stat=stat, until_count=1)
+if (stat /= 0) call abort()
+call event_query(event=var(1), stat=stat, count=count)
+if (count /= 0 .or. stat /= 0) call abort()
+call event_query(event=var(2), stat=stat, count=count)
+if (count /= 0 .or. stat /= 0) call abort()
+call event_query(event=var(3), stat=stat, count=count)
+if (count /= 0 .or. stat /= 0) call abort()
+end
diff --git ./libgfortran/caf/libcaf.h ./libgfortran/caf/libcaf.h
index 660bd7c..ebda579 100644
--- ./libgfortran/caf/libcaf.h
+++ ./libgfortran/caf/libcaf.h
@@ -57,7 +57,9 @@ typedef enum caf_register_t {
CAF_REGTYPE_COARRAY_ALLOC,
CAF_REGTYPE_LOCK_STATIC,
CAF_REGTYPE_LOCK_ALLOC,
- CAF_REGTYPE_CRITICAL
+ CAF_REGTYPE_CRITICAL,
+ CAF_REGTYPE_EVENT_STATIC,
+ CAF_REGTYPE_EVENT_ALLOC
}
caf_register_t;
@@ -133,5 +135,8 @@ void _gfortran_caf_atomic_op (int, caf_token_t, size_t, int, void *, void *,
void _gfortran_caf_lock (caf_token_t, size_t, int, int *, int *, char *, int);
void _gfortran_caf_unlock (caf_token_t, size_t, int, int *, char *, int);
+void _gfortran_caf_event_post (caf_token_t, size_t, int, int *, char *, int);
+void _gfortran_caf_event_wait (caf_token_t, size_t, int, int *, char *, int);
+void _gfortran_caf_event_query (caf_token_t, size_t, int, int *, int *);
#endif /* LIBCAF_H */
diff --git ./libgfortran/caf/single.c ./libgfortran/caf/single.c
index 6c58286..9c4b343 100644
--- ./libgfortran/caf/single.c
+++ ./libgfortran/caf/single.c
@@ -101,7 +101,8 @@ _gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token,
void *local;
if (type == CAF_REGTYPE_LOCK_STATIC || type == CAF_REGTYPE_LOCK_ALLOC
- || type == CAF_REGTYPE_CRITICAL)
+ || type == CAF_REGTYPE_CRITICAL || type == CAF_REGTYPE_EVENT_STATIC
+ || type == CAF_REGTYPE_EVENT_ALLOC)
local = calloc (size, sizeof (bool));
else
local = malloc (size);
@@ -133,7 +134,8 @@ _gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token,
*stat = 0;
if (type == CAF_REGTYPE_COARRAY_STATIC || type == CAF_REGTYPE_LOCK_STATIC
- || type == CAF_REGTYPE_CRITICAL)
+ || type == CAF_REGTYPE_CRITICAL || type == CAF_REGTYPE_EVENT_STATIC
+ || type == CAF_REGTYPE_EVENT_ALLOC)
{
caf_static_t *tmp = malloc (sizeof (caf_static_t));
tmp->prev = caf_static_list;
@@ -1071,6 +1073,45 @@ _gfortran_caf_atomic_op (int op, caf_token_t token, size_t offset,
*stat = 0;
}
+void
+_gfortran_caf_event_post (caf_token_t token, size_t index,
+ int image_index __attribute__ ((unused)),
+ int *stat, char *errmsg __attribute__ ((unused)),
+ int errmsg_len __attribute__ ((unused)))
+{
+ uint32_t value = 1;
+ uint32_t *event = (uint32_t *) ((char *) TOKEN (token) + index*sizeof(uint32_t));
+ __atomic_fetch_add (event, (uint32_t) value, __ATOMIC_RELAXED);
+
+ if(stat)
+ *stat = 0;
+}
+
+void
+_gfortran_caf_event_wait (caf_token_t token, size_t index,
+ int until_count, int *stat,
+ char *errmsg __attribute__ ((unused)),
+ int errmsg_len __attribute__ ((unused)))
+{
+ uint32_t *event = (uint32_t *) ((char *) TOKEN (token) + index*sizeof(uint32_t));
+ uint32_t value = (uint32_t)-until_count;
+ __atomic_fetch_add (event, (uint32_t) value, __ATOMIC_RELAXED);
+
+ if(stat)
+ *stat = 0;
+}
+
+void
+_gfortran_caf_event_query (caf_token_t token, size_t index,
+ int image_index __attribute__ ((unused)),
+ int *count, int *stat)
+{
+ uint32_t *event = (uint32_t *) ((char *) TOKEN (token) + index*sizeof(uint32_t));
+ __atomic_load (event, (uint32_t *) count, __ATOMIC_RELAXED);
+
+ if(stat)
+ *stat = 0;
+}
void
_gfortran_caf_lock (caf_token_t token, size_t index,
[-- Attachment #3: ChangeLog_events.diff --]
[-- Type: text/plain, Size: 3538 bytes --]
ChangeLog update
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 0c81201..3d2c4cf 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,62 @@
+2016-02-11 Tobias Burnus <burnus@net-b.de>
+ Alessandro Fanfarillo <fanfarillo.gcc@gmail.com>
+
+ Backported from mainline
+ 2015-12-02 Tobias Burnus <burnus@net-b.de>
+ Alessandro Fanfarillo <fanfarillo.gcc@gmail.com>
+
+ * check.c (gfc_check_event_query): New function.
+ * dump-parse-tree.c (show_code_node): Handle EXEC_EVENT_POST,
+ EXEC_EVENT_WAIT.
+ * expr.c (gfc_check_vardef_context): New check for event variables
+ definition.
+ * gfortran.h (gfc_statement): Add ST_EVENT_POST, ST_EVENT_WAIT.
+ (gfc_isym_id): GFC_ISYM_EVENT_QUERY.
+ (struct symbol_attribute): New field.
+ (gfc_exec_op): Add EXEC_EVENT_POST and EXEC_EVENT_WAIT.
+ * gfortran.texi: Document about new events functions and minor
+ changes.
+ * interface.c (compare_parameter): New check.
+ (gfc_procedure_use): New check for explicit procedure interface.
+ (add_subroutines): Add event_query.
+ * intrinsic.h (gfc_check_event_query,gfc_resolve_event_query):
+ New prototypes.
+ * iresolve.c (gfc_resolve_event_query): New function.
+ * iso-fortran-env.def (event_type): New type.
+ * match.c (event_statement,gfc_match_event_post,gfc_match_event_wait):
+ New functions.
+ (gfc_match_name): New event post and event wait.
+ * match.h (gfc_match_event_post,gfc_match_event_wait):
+ New prototypes.
+ * module.c (ab_attribute): Add AB_EVENT_COMP.
+ (attr_bits): Likewise.
+ (mio_symbol_attribute): Handle event_comp attribute.
+ * parse.c (decode_statement): Add ST_EVENT_POST, ST_EVENT_WAIT.
+ (next_statement): Add ST_EVENT_POST, ST_EVENT_WAIT.
+ (gfc_ascii_statement): Add ST_EVENT_POST, ST_EVENT_WAIT.
+ (parse_derived): Check for event_type components.
+ * resolve.c (resolve_allocate_expr): Check for event variable def.
+ (resolve_lock_unlock): Renamed to resolve_lock_unlock_event. It
+ includes logic for locks and events.
+ (gfc_resolve_code): Call it.
+ (gfc_resolve_symbol): New check for event variable to be a corray.
+ * st.c (gfc_free_statement): Handle new EXEC_EVENT_POST and
+ EXEC_EVENT_WAIT.
+ * trans-decl.c (gfor_fndecl_caf_event_post,gfor_fndecl_caf_event_wait,
+ gfor_fndecl_caf_event_query): New global variables.
+ (generate_coarray_sym_init): Checking for event_type.
+ (gfc_conv_procedure_call): Check for C bind attribute.
+ * trans-intrinsic.c (conv_intrinsic_event_query): New function.
+ (conv_intrinsic_move_alloc): Call it.
+ * trans-stmt.c (gfc_trans_lock_unlock): Passing address
+ of actual argument.
+ (gfc_trans_sync): Likewise.
+ (gfc_trans_event_post_wait): New function.
+ * trans-stmt.h (gfc_trans_event_post_wait): New prototype.
+ * trans-types.c (gfc_get_derived_type): Integer_kind as event_type.
+ * trans.c (gfc_allocate_using_lib): New argument and logic for events.
+ (gfc_allocate_allocatable): Passing new argument.
+ (trans_code): Handle EXEC_EVENT_POST, EXEC_EVENT_WAIT.
+ * trans.h (gfc_coarray_type): New elements.
+ (gfor_fndecl_caf_event_post,gfor_fndecl_caf_event_wait,
+ gfor_fndecl_caf_event_query): Declare them.
+
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2016-02-11 Tobias Burnus <burnus@net-b.de>
+ Alessandro Fanfarillo <fanfarillo.gcc@gmail.com>
+
+ Backported from mainline
+ 2015-12-02 Tobias Burnus <burnus@net-b.de>
+ Alessandro Fanfarillo <fanfarillo.gcc@gmail.com>
+
+ * gfortran.dg/coarray/event_1.f90: New.
+ * gfortran.dg/coarray/event_2.f90: New.
^ permalink raw reply [flat|nested] 15+ messages in thread
* Re: [Fortran, Patch] (RFC, Coarray) Implement TS18508's EVENTS
2016-02-11 23:04 ` Alessandro Fanfarillo
@ 2016-02-12 16:32 ` Alessandro Fanfarillo
0 siblings, 0 replies; 15+ messages in thread
From: Alessandro Fanfarillo @ 2016-02-12 16:32 UTC (permalink / raw)
To: Steve Kargl; +Cc: Tobias Burnus, gcc-patches, gfortran
Committed on gcc-5-branch as rev. 233379.
2016-02-12 0:04 GMT+01:00 Alessandro Fanfarillo <fanfarillo.gcc@gmail.com>:
> Dear all,
>
> in attachment the EVENT patch for gcc-5-branch directly back-ported
> from the trunk.
>
> Built and regtested on x86_64-pc-linux-gnu. I plan to commit this
> patch this evening (Feb 12th, CET).
>
> Cheers,
>
> Alessandro
>
> 2015-12-17 17:19 GMT+01:00 Alessandro Fanfarillo <fanfarillo.gcc@gmail.com>:
>> Great! Thanks.
>>
>> 2015-12-17 15:57 GMT+01:00 Steve Kargl <sgk@troutmask.apl.washington.edu>:
>>> On Thu, Dec 17, 2015 at 01:22:06PM +0100, Alessandro Fanfarillo wrote:
>>>>
>>>> I've noticed that this patch has been applied only on trunk and not on
>>>> the gcc-5-branch. Is it a problem to include EVENTS in gcc-5?
>>>>
>>>
>>> No problem. When I applied the EVENTS patch to trunk,
>>> the 5.3 release was being prepared. I was going to
>>> wait for a week or two after 5.3 came out, then apply
>>> the patch. Now that you have commit access, feel
>>> free to back port the patch. Rememer to post the
>>> patch that you commit to both the fortran and gcc-patches
>>> list.
>>>
>>> --
>>> Steve
^ permalink raw reply [flat|nested] 15+ messages in thread
end of thread, other threads:[~2016-02-12 16:32 UTC | newest]
Thread overview: 15+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2015-04-29 7:58 [Fortran, Patch] (RFC, Coarray) Implement TS18508's EVENTS Tobias Burnus
2015-11-25 17:30 ` Alessandro Fanfarillo
2015-11-25 19:17 ` Damian Rouson
2015-11-25 22:47 ` Paul Richard Thomas
2015-11-25 23:08 ` Steve Kargl
2015-11-26 16:53 ` Steve Kargl
2015-11-26 18:02 ` Alessandro Fanfarillo
2015-12-02 14:16 ` Alessandro Fanfarillo
2015-12-02 22:00 ` Steve Kargl
2015-12-03 19:46 ` Alessandro Fanfarillo
2015-12-17 12:22 ` Alessandro Fanfarillo
2015-12-17 14:57 ` Steve Kargl
2015-12-17 16:19 ` Alessandro Fanfarillo
2016-02-11 23:04 ` Alessandro Fanfarillo
2016-02-12 16:32 ` Alessandro Fanfarillo
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).