From: Alessandro Fanfarillo <fanfarillo.gcc@gmail.com>
To: gfortran <fortran@gcc.gnu.org>
Subject: [Fortran] Help with intrinsic function returning array
Date: Wed, 11 May 2016 21:36:00 -0000 [thread overview]
Message-ID: <CAHqFgjUTo2Vkz9cf2sooasrNq0-WhY0FieaH4-OBzNs3iFBEjA@mail.gmail.com> (raw)
[-- Attachment #1: Type: text/plain, Size: 1296 bytes --]
Dear all,
I'm encountering some difficulties with implementing the intrinsic
function "failed_images" defined in the latest TS-18508
(http://isotc.iso.org/livelink/livelink?func=ll&objId=17288706&objAction=Open).
The idea is to call the external _gfortran_caf_failed_images function
(implemented in OpenCoarrays) than returns a rank-1 integer array
representing the list of coarray images that have been failed
(detected by the calling images).
Of course, the number of failed images is not known a-priori by the
user, thus the list should be stored in an allocatable array.
So far, I pass by reference the variable representing the list length
to the _gfortran_caf_failed_images function; once returned, this value
contains the number of elements composing the array.
Then, I manually build a temporary array, setting the right
bounds,type,data and offset.
What I would like to do is to assign this temporary array to the
variable on the lhs of the assignment.
I noticed several routines that manage the situation of a function
returning an array but it is not clear to me how to adapt them to my
situation.
In attachment you can find what I've done so far; the function that
I'm referring to is gfc_conv_intrinsic_failed_images.
Thanks in advance for your support.
Regards,
Alessandro
[-- Attachment #2: third_patch.diff --]
[-- Type: text/plain, Size: 21180 bytes --]
commit b909d0508434b9b9479fd3fd18fc6110d35d0c11
Author: Alessandro Fanfarillo <fanfarillo@ing.uniroma2.it>
Date: Tue May 3 11:46:03 2016 -0600
Third patch
diff --git ./gcc/fortran/check.c ./gcc/fortran/check.c
index 05133c32..680090c 100644
--- ./gcc/fortran/check.c
+++ ./gcc/fortran/check.c
@@ -1210,6 +1210,62 @@ gfc_check_event_query (gfc_expr *event, gfc_expr *count, gfc_expr *stat)
return true;
}
+bool
+gfc_check_image_status (gfc_expr *image, gfc_expr *team)
+{
+ if (!type_check (image, 1, BT_INTEGER))
+ return false;
+
+ if(team)
+ {
+ gfc_error ("TEAM argument of the IMAGE_STATUS intrinsic function at %L "
+ "not yet supported",
+ &team->where);
+ return false;
+ }
+
+ int i = gfc_validate_kind (BT_INTEGER, image->ts.kind, false);
+ int j = gfc_validate_kind (BT_INTEGER, gfc_default_integer_kind, false);
+
+ if (gfc_integer_kinds[i].range < gfc_integer_kinds[j].range)
+ {
+ gfc_error ("IMAGE argument of the IMAGE_STATUS intrinsic function at %L "
+ "shall have at least the range of the default integer",
+ &image->where);
+ return false;
+ }
+
+ return true;
+}
+
+bool
+gfc_check_failed_images (gfc_expr *team, gfc_expr *kind)
+{
+ if (team)
+ {
+ gfc_error ("TEAM argument of the FAILED_IMAGES intrinsic function at %L "
+ "not yet supported",
+ &team->where);
+ return false;
+ }
+
+ if (kind)
+ {
+ int i = gfc_validate_kind (BT_INTEGER, kind->ts.kind, false);
+ int j = gfc_validate_kind (BT_INTEGER, gfc_default_integer_kind, false);
+
+ if (gfc_integer_kinds[i].range < gfc_integer_kinds[j].range)
+ {
+ gfc_error ("KIND argument of the FAILED_IMAGES intrinsic function at %L "
+ "shall have at least the range of the default integer",
+ &kind->where);
+ return false;
+ }
+ }
+
+ 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 8d50d75..3a8769c 100644
--- ./gcc/fortran/dump-parse-tree.c
+++ ./gcc/fortran/dump-parse-tree.c
@@ -1627,6 +1627,9 @@ show_code_node (int level, gfc_code *c)
break;
+ case EXEC_FAIL_IMAGE:
+ fputs ("FAIL IMAGE ", dumpfile);
+
case EXEC_SYNC_ALL:
fputs ("SYNC ALL ", dumpfile);
if (c->expr2 != NULL)
diff --git ./gcc/fortran/gfortran.h ./gcc/fortran/gfortran.h
index a0fb5fd..569a564 100644
--- ./gcc/fortran/gfortran.h
+++ ./gcc/fortran/gfortran.h
@@ -242,7 +242,7 @@ enum gfc_statement
ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD,
ST_PROCEDURE, ST_GENERIC, ST_CRITICAL, ST_END_CRITICAL,
ST_GET_FCN_CHARACTERISTICS, ST_LOCK, ST_UNLOCK, ST_EVENT_POST,
- ST_EVENT_WAIT,ST_NONE
+ ST_EVENT_WAIT,ST_FAIL_IMAGE,ST_NONE
};
/* Types of interfaces that we can have. Assignment interfaces are
@@ -400,6 +400,7 @@ enum gfc_isym_id
GFC_ISYM_EXP,
GFC_ISYM_EXPONENT,
GFC_ISYM_EXTENDS_TYPE_OF,
+ GFC_ISYM_FAILED_IMAGES,
GFC_ISYM_FDATE,
GFC_ISYM_FE_RUNTIME_ERROR,
GFC_ISYM_FGET,
@@ -443,6 +444,7 @@ enum gfc_isym_id
GFC_ISYM_IEOR,
GFC_ISYM_IERRNO,
GFC_ISYM_IMAGE_INDEX,
+ GFC_ISYM_IMAGE_STATUS,
GFC_ISYM_INDEX,
GFC_ISYM_INT,
GFC_ISYM_INT2,
@@ -2371,7 +2373,7 @@ enum gfc_exec_op
EXEC_OPEN, EXEC_CLOSE, EXEC_WAIT,
EXEC_READ, EXEC_WRITE, EXEC_IOLENGTH, EXEC_TRANSFER, EXEC_DT_END,
EXEC_BACKSPACE, EXEC_ENDFILE, EXEC_INQUIRE, EXEC_REWIND, EXEC_FLUSH,
- EXEC_LOCK, EXEC_UNLOCK, EXEC_EVENT_POST, EXEC_EVENT_WAIT,
+ EXEC_LOCK, EXEC_UNLOCK, EXEC_EVENT_POST, EXEC_EVENT_WAIT, EXEC_FAIL_IMAGE,
EXEC_OACC_KERNELS_LOOP, EXEC_OACC_PARALLEL_LOOP, EXEC_OACC_ROUTINE,
EXEC_OACC_PARALLEL, EXEC_OACC_KERNELS, EXEC_OACC_DATA, EXEC_OACC_HOST_DATA,
EXEC_OACC_LOOP, EXEC_OACC_UPDATE, EXEC_OACC_WAIT, EXEC_OACC_CACHE,
diff --git ./gcc/fortran/intrinsic.c ./gcc/fortran/intrinsic.c
index 1d7503d..8dfb568 100644
--- ./gcc/fortran/intrinsic.c
+++ ./gcc/fortran/intrinsic.c
@@ -1823,6 +1823,10 @@ add_functions (void)
a, BT_UNKNOWN, 0, REQUIRED,
mo, BT_UNKNOWN, 0, REQUIRED);
+ add_sym_2 ("failed_images", GFC_ISYM_FAILED_IMAGES, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER,
+ dd, GFC_STD_F2008_TS, gfc_check_failed_images, NULL,
+ gfc_resolve_failed_images, "team", BT_INTEGER, di, OPTIONAL, "kind", BT_INTEGER, di, OPTIONAL);
+
add_sym_0 ("fdate", GFC_ISYM_FDATE, CLASS_IMPURE, ACTUAL_NO, BT_CHARACTER,
dc, GFC_STD_GNU, NULL, NULL, gfc_resolve_fdate);
@@ -2023,7 +2027,11 @@ add_functions (void)
add_sym_2 ("image_index", GFC_ISYM_IMAGE_INDEX, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008,
gfc_check_image_index, gfc_simplify_image_index, gfc_resolve_image_index,
ca, BT_REAL, dr, REQUIRED, sub, BT_INTEGER, ii, REQUIRED);
-
+
+ add_sym_2 ("image_status", GFC_ISYM_IMAGE_STATUS, CLASS_ELEMENTAL, ACTUAL_YES, BT_INTEGER,
+ di, GFC_STD_F2008_TS, gfc_check_image_status, NULL,
+ gfc_resolve_image_status, "image", BT_INTEGER, di, REQUIRED, "team", BT_INTEGER, di, OPTIONAL);
+
/* The resolution function for INDEX is called gfc_resolve_index_func
because the name gfc_resolve_index is already used in resolve.c. */
add_sym_4 ("index", GFC_ISYM_INDEX, CLASS_ELEMENTAL, ACTUAL_YES,
@@ -3170,7 +3178,7 @@ add_subroutines (void)
"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 f228976..bb49b7d 100644
--- ./gcc/fortran/intrinsic.h
+++ ./gcc/fortran/intrinsic.h
@@ -71,6 +71,7 @@ bool gfc_check_dshift (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_eoshift (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_dtime_etime (gfc_expr *);
bool gfc_check_event_query (gfc_expr *, gfc_expr *, gfc_expr *);
+bool gfc_check_failed_images (gfc_expr *, gfc_expr *);
bool gfc_check_fgetputc (gfc_expr *, gfc_expr *);
bool gfc_check_fgetput (gfc_expr *);
bool gfc_check_float (gfc_expr *);
@@ -92,6 +93,7 @@ bool gfc_check_ibits (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_ichar_iachar (gfc_expr *, gfc_expr *);
bool gfc_check_idnint (gfc_expr *);
bool gfc_check_ieor (gfc_expr *, gfc_expr *);
+bool gfc_check_image_status (gfc_expr *, gfc_expr *);
bool gfc_check_index (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_int (gfc_expr *, gfc_expr *);
bool gfc_check_intconv (gfc_expr *);
@@ -467,6 +469,7 @@ void gfc_resolve_event_query (gfc_code *);
void gfc_resolve_exp (gfc_expr *, gfc_expr *);
void gfc_resolve_exponent (gfc_expr *, gfc_expr *);
void gfc_resolve_extends_type_of (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_failed_images (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_fdate (gfc_expr *);
void gfc_resolve_floor (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_fnum (gfc_expr *, gfc_expr *);
@@ -490,6 +493,7 @@ void gfc_resolve_ibclr (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_ibits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_ibset (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_image_index (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_image_status (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_index_func (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
gfc_expr *);
void gfc_resolve_ierrno (gfc_expr *);
diff --git ./gcc/fortran/iresolve.c ./gcc/fortran/iresolve.c
index ecea1c3..d338e5b 100644
--- ./gcc/fortran/iresolve.c
+++ ./gcc/fortran/iresolve.c
@@ -2577,6 +2577,25 @@ gfc_resolve_tanh (gfc_expr *f, gfc_expr *x)
= gfc_get_string ("__tanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
}
+void
+gfc_resolve_failed_images (gfc_expr *f, gfc_expr *team ATTRIBUTE_UNUSED,
+ gfc_expr *kind ATTRIBUTE_UNUSED)
+{
+ static char failed_images[] = "failed_images";
+ f->ts.type = BT_INTEGER;
+ f->ts.kind = gfc_default_integer_kind;
+ f->value.function.name = failed_images;
+}
+
+void
+gfc_resolve_image_status (gfc_expr *f, gfc_expr *image, gfc_expr *team ATTRIBUTE_UNUSED)
+{
+ static char image_status[] = "image_status";
+ f->ts.type = BT_INTEGER;
+ f->ts.kind = gfc_default_integer_kind;
+ f->ts = image->ts;
+ f->value.function.name = image_status;
+}
void
gfc_resolve_image_index (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
diff --git ./gcc/fortran/match.c ./gcc/fortran/match.c
index 2490f85..20aa371 100644
--- ./gcc/fortran/match.c
+++ ./gcc/fortran/match.c
@@ -1472,6 +1472,7 @@ gfc_match_if (gfc_statement *if_type)
match ("event post", gfc_match_event_post, ST_EVENT_POST)
match ("event wait", gfc_match_event_wait, ST_EVENT_WAIT)
match ("exit", gfc_match_exit, ST_EXIT)
+ match ("fail image", gfc_match_fail_image, ST_FAIL_IMAGE)
match ("flush", gfc_match_flush, ST_FLUSH)
match ("forall", match_simple_forall, ST_FORALL)
match ("go to", gfc_match_goto, ST_GOTO)
@@ -2951,6 +2952,41 @@ gfc_match_event_wait (void)
return event_statement (ST_EVENT_WAIT);
}
+/* Match a FAIl IMAGE statement */
+
+static match
+fail_image_statement (gfc_statement st)
+{
+ if (flag_coarray == GFC_FCOARRAY_NONE)
+ {
+ gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
+ return MATCH_ERROR;
+ }
+
+ if (gfc_match_char ('(') == MATCH_YES)
+ goto syntax;
+
+ if(st == ST_FAIL_IMAGE)
+ new_st.op = EXEC_FAIL_IMAGE;
+ else
+ gcc_unreachable();
+
+ return MATCH_YES;
+
+ syntax:
+ gfc_syntax_error (st);
+
+ return MATCH_ERROR;
+}
+
+match
+gfc_match_fail_image (void)
+{
+ /* if (!gfc_notify_std (GFC_STD_F2008_TS, "FAIL IMAGE statement at %C")) */
+ /* return MATCH_ERROR; */
+
+ return fail_image_statement (ST_FAIL_IMAGE);
+}
/* Match LOCK/UNLOCK statement. Syntax:
LOCK ( lock-variable [ , lock-stat-list ] )
diff --git ./gcc/fortran/match.h ./gcc/fortran/match.h
index c3033ad..9497f4e 100644
--- ./gcc/fortran/match.h
+++ ./gcc/fortran/match.h
@@ -71,6 +71,7 @@ match gfc_match_else (void);
match gfc_match_elseif (void);
match gfc_match_event_post (void);
match gfc_match_event_wait (void);
+match gfc_match_fail_image (void);
match gfc_match_critical (void);
match gfc_match_block (void);
match gfc_match_associate (void);
diff --git ./gcc/fortran/parse.c ./gcc/fortran/parse.c
index 7bce47f..99ebc07 100644
--- ./gcc/fortran/parse.c
+++ ./gcc/fortran/parse.c
@@ -482,6 +482,7 @@ decode_statement (void)
break;
case 'f':
+ match ("fail image", gfc_match_fail_image, ST_FAIL_IMAGE);
match ("final", gfc_match_final_decl, ST_FINAL);
match ("flush", gfc_match_flush, ST_FLUSH);
match ("format", gfc_match_format, ST_FORMAT);
@@ -1350,7 +1351,7 @@ next_statement (void)
case ST_OMP_CANCEL: case ST_OMP_CANCELLATION_POINT: \
case ST_OMP_TARGET_UPDATE: case ST_ERROR_STOP: case ST_SYNC_ALL: \
case ST_SYNC_IMAGES: case ST_SYNC_MEMORY: case ST_LOCK: case ST_UNLOCK: \
- case ST_EVENT_POST: case ST_EVENT_WAIT: \
+ case ST_EVENT_POST: case ST_EVENT_WAIT: case ST_FAIL_IMAGE: \
case ST_OACC_UPDATE: case ST_OACC_WAIT: case ST_OACC_CACHE: \
case ST_OACC_ENTER_DATA: case ST_OACC_EXIT_DATA
@@ -1663,6 +1664,9 @@ gfc_ascii_statement (gfc_statement st)
case ST_EVENT_WAIT:
p = "EVENT WAIT";
break;
+ case ST_FAIL_IMAGE:
+ p = "FAIL IMAGE";
+ break;
case ST_END_ASSOCIATE:
p = "END ASSOCIATE";
break;
diff --git ./gcc/fortran/resolve.c ./gcc/fortran/resolve.c
index f5cd588..4509da0 100644
--- ./gcc/fortran/resolve.c
+++ ./gcc/fortran/resolve.c
@@ -8743,6 +8743,11 @@ find_reachable_labels (gfc_code *block)
}
}
+static void
+resolve_fail_image (gfc_code *code)
+{
+ return;
+}
static void
resolve_lock_unlock_event (gfc_code *code)
@@ -10473,6 +10478,10 @@ start:
resolve_lock_unlock_event (code);
break;
+ case EXEC_FAIL_IMAGE:
+ resolve_fail_image (code);
+ break;
+
case EXEC_ENTRY:
/* Keep track of which entry we are up to. */
current_entry_id = code->ext.entry->id;
diff --git ./gcc/fortran/st.c ./gcc/fortran/st.c
index 7395497..b3a6721 100644
--- ./gcc/fortran/st.c
+++ ./gcc/fortran/st.c
@@ -120,6 +120,7 @@ gfc_free_statement (gfc_code *p)
case EXEC_UNLOCK:
case EXEC_EVENT_POST:
case EXEC_EVENT_WAIT:
+ case EXEC_FAIL_IMAGE:
break;
case EXEC_BLOCK:
diff --git ./gcc/fortran/trans-decl.c ./gcc/fortran/trans-decl.c
index 309baf1..f9c76aa 100644
--- ./gcc/fortran/trans-decl.c
+++ ./gcc/fortran/trans-decl.c
@@ -150,6 +150,9 @@ tree gfor_fndecl_caf_unlock;
tree gfor_fndecl_caf_event_post;
tree gfor_fndecl_caf_event_wait;
tree gfor_fndecl_caf_event_query;
+tree gfor_fndecl_caf_fail_image;
+tree gfor_fndecl_caf_failed_images;
+tree gfor_fndecl_caf_image_status;
tree gfor_fndecl_co_broadcast;
tree gfor_fndecl_co_max;
tree gfor_fndecl_co_min;
@@ -3611,6 +3614,18 @@ gfc_build_builtin_function_decls (void)
void_type_node, 5, pvoid_type_node, size_type_node, integer_type_node,
pint_type, pint_type);
+ gfor_fndecl_caf_fail_image = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("caf_fail_image")), "R",
+ void_type_node, 1, pvoid_type_node);
+
+ gfor_fndecl_caf_failed_images = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("caf_failed_images")), "WRR",
+ pvoid_type_node, 3, pvoid_type_node, integer_type_node, integer_type_node);
+
+ gfor_fndecl_caf_image_status = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("caf_image_status")), "RR",
+ integer_type_node, 2, integer_type_node, integer_type_node);
+
gfor_fndecl_co_broadcast = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("caf_co_broadcast")), "W.WW",
void_type_node, 5, pvoid_type_node, integer_type_node,
diff --git ./gcc/fortran/trans-intrinsic.c ./gcc/fortran/trans-intrinsic.c
index 1aaf4e2..e37c938 100644
--- ./gcc/fortran/trans-intrinsic.c
+++ ./gcc/fortran/trans-intrinsic.c
@@ -1647,6 +1647,113 @@ trans_this_image (gfc_se * se, gfc_expr *expr)
m, lbound));
}
+static void
+gfc_conv_intrinsic_failed_images (gfc_se *se, gfc_expr *expr)
+{
+ tree tmp,type,res_var,size_var,desc,offset,ubound,stride;
+ stmtblock_t temp_post;
+ gfc_se argse, loopse;
+ gfc_loopinfo loop;
+ gfc_expr array_expr;
+ gfc_ss *tmp_ss;
+ tree parm, parmtype;
+ gfc_array_info *info;
+
+ /* If mem is NULL, we call gfc_allocate_using_malloc or
+ gfc_allocate_using_lib. */
+
+ size_var = gfc_create_var (gfc_array_index_type, "arr");
+ /* res_var = gfc_create_var (pvoid_type_node, "res"); */
+ type = gfc_typenode_for_spec (&expr->ts);
+
+ if (flag_coarray == GFC_FCOARRAY_LIB)
+ {
+ res_var = build_call_expr_loc (input_location, gfor_fndecl_caf_failed_images, 3,
+ gfc_build_addr_expr (build_pointer_type (type), size_var),
+ build_int_cst (integer_type_node, -1),
+ build_int_cst (integer_type_node, -1));
+
+ /* se->expr = res_var; */
+
+ loop.ss = gfc_get_array_ss (gfc_ss_terminator, NULL, 1,
+ GFC_SS_SECTION);
+ tmp_ss = gfc_walk_expr (expr);
+
+ loop.ss->info->type = GFC_SS_SECTION;
+
+ gfc_init_loopinfo (&loop);
+ gfc_add_ss_to_loop (&loop, tmp_ss);
+ loop.dimen = 1;
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type, gfc_index_one_node,
+ gfc_index_one_node);
+
+ loop.to[0] = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type,
+ size_var, tmp);
+ loop.from[0] = gfc_index_one_node;
+
+ /* parmtype = gfc_get_element_type (integer_type_node); */
+ parmtype = type;
+ parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, 0,
+ loop.from, loop.to, 0,
+ GFC_ARRAY_UNKNOWN, false);
+ parm = gfc_create_var (parmtype, "parm");
+ tmp = gfc_conv_descriptor_dtype (parm);
+ gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (parmtype));
+
+ gfc_conv_descriptor_data_set (&loop.pre, parm, res_var);
+
+ tmp = gfc_conv_array_lbound (parm, 0);
+
+ gfc_conv_descriptor_lbound_set (&loop.pre, parm, gfc_index_zero_node, tmp);
+
+ ubound = gfc_conv_array_ubound (parm, 0);
+
+ gfc_conv_descriptor_ubound_set (&loop.pre, parm, gfc_index_zero_node, size_var);
+
+ stride = gfc_conv_array_stride (parm, 0);
+
+ gfc_conv_descriptor_stride_set (&loop.pre, parm, gfc_index_zero_node, gfc_index_one_node);
+
+ /* tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp), */
+ /* gfc_index_zero_node, tmp); */
+ /* tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp), */
+ /* tmp, gfc_index_one_node); */
+ /* offset = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp), */
+ /* gfc_index_zero_node, tmp); */
+
+ offset = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
+ gfc_index_zero_node, tmp);
+
+ gfc_conv_descriptor_offset_set (&loop.pre, parm, offset);
+
+ se->expr = gfc_conv_descriptor_data_get (parm);
+
+ gfc_add_block_to_block (&se->pre, &loop.pre);
+ gfc_add_block_to_block (&se->post, &loop.post);
+ }
+ /* tmp = gfc_finish_block (&alloc_block); */
+}
+
+static void
+gfc_conv_intrinsic_image_status (gfc_se *se, gfc_expr *expr)
+{
+ unsigned int num_args;
+ tree *args,tmp,rettype,res;
+
+ num_args = gfc_intrinsic_argument_list_length (expr);
+ args = XALLOCAVEC (tree, num_args);
+
+ gfc_conv_intrinsic_function_args (se, expr, args, num_args);
+
+ if (flag_coarray == GFC_FCOARRAY_LIB)
+ {
+ tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_image_status, 2,
+ args[0], build_int_cst (integer_type_node, -1));
+ se->expr = tmp;
+ }
+}
static void
trans_image_index (gfc_se * se, gfc_expr *expr)
@@ -8299,10 +8406,18 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
trans_this_image (se, expr);
break;
+ case GFC_ISYM_FAILED_IMAGES:
+ gfc_conv_intrinsic_failed_images (se, expr);
+ break;
+
case GFC_ISYM_IMAGE_INDEX:
trans_image_index (se, expr);
break;
+ case GFC_ISYM_IMAGE_STATUS:
+ gfc_conv_intrinsic_image_status (se, expr);
+ break;
+
case GFC_ISYM_NUM_IMAGES:
trans_num_images (se, expr);
break;
diff --git ./gcc/fortran/trans-stmt.c ./gcc/fortran/trans-stmt.c
index 2fc43ed..76e3135 100644
--- ./gcc/fortran/trans-stmt.c
+++ ./gcc/fortran/trans-stmt.c
@@ -674,6 +674,31 @@ gfc_trans_stop (gfc_code *code, bool error_stop)
return gfc_finish_block (&se.pre);
}
+/* Translate the FAIL IMAGE statement. We have to translate this statement
+ to a runtime library call. */
+
+tree
+gfc_trans_fail_image (gfc_code *code)
+{
+ tree gfc_int4_type_node = gfc_get_int_type (4);
+ gfc_se se;
+ tree tmp;
+
+ /* Start a new block for this statement. */
+ gfc_init_se (&se, NULL);
+ gfc_start_block (&se.pre);
+
+ tmp = build_int_cst (gfc_int4_type_node, 0);
+ tmp = build_call_expr_loc (input_location,
+ gfor_fndecl_caf_fail_image, 1,
+ build_int_cst (pchar_type_node, 0));
+
+ gfc_add_expr_to_block (&se.pre, tmp);
+
+ gfc_add_block_to_block (&se.pre, &se.post);
+
+ return gfc_finish_block (&se.pre);
+}
tree
gfc_trans_lock_unlock (gfc_code *code, gfc_exec_op op)
diff --git ./gcc/fortran/trans-stmt.h ./gcc/fortran/trans-stmt.h
index f9c8e74..4b5b4fc 100644
--- ./gcc/fortran/trans-stmt.h
+++ ./gcc/fortran/trans-stmt.h
@@ -56,6 +56,7 @@ tree gfc_trans_select (gfc_code *);
tree gfc_trans_sync (gfc_code *, gfc_exec_op);
tree gfc_trans_lock_unlock (gfc_code *, gfc_exec_op);
tree gfc_trans_event_post_wait (gfc_code *, gfc_exec_op);
+tree gfc_trans_fail_image (gfc_code *);
tree gfc_trans_forall (gfc_code *);
tree gfc_trans_where (gfc_code *);
tree gfc_trans_allocate (gfc_code *);
diff --git ./gcc/fortran/trans.c ./gcc/fortran/trans.c
index c6688d3..db0aa49 100644
--- ./gcc/fortran/trans.c
+++ ./gcc/fortran/trans.c
@@ -1828,6 +1828,10 @@ trans_code (gfc_code * code, tree cond)
res = gfc_trans_event_post_wait (code, code->op);
break;
+ case EXEC_FAIL_IMAGE:
+ res = gfc_trans_fail_image (code);
+ break;
+
case EXEC_FORALL:
res = gfc_trans_forall (code);
break;
diff --git ./gcc/fortran/trans.h ./gcc/fortran/trans.h
index 512615a..c6b142f 100644
--- ./gcc/fortran/trans.h
+++ ./gcc/fortran/trans.h
@@ -776,6 +776,9 @@ extern GTY(()) tree gfor_fndecl_caf_unlock;
extern GTY(()) tree gfor_fndecl_caf_event_post;
extern GTY(()) tree gfor_fndecl_caf_event_wait;
extern GTY(()) tree gfor_fndecl_caf_event_query;
+extern GTY(()) tree gfor_fndecl_caf_fail_image;
+extern GTY(()) tree gfor_fndecl_caf_failed_images;
+extern GTY(()) tree gfor_fndecl_caf_image_status;
extern GTY(()) tree gfor_fndecl_co_broadcast;
extern GTY(()) tree gfor_fndecl_co_max;
extern GTY(()) tree gfor_fndecl_co_min;
next reply other threads:[~2016-05-11 21:36 UTC|newest]
Thread overview: 7+ messages / expand[flat|nested] mbox.gz Atom feed top
2016-05-11 21:36 Alessandro Fanfarillo [this message]
2016-05-16 20:07 ` Mikael Morin
2016-05-17 3:30 ` Alessandro Fanfarillo
2016-05-17 19:47 ` Mikael Morin
2016-05-17 20:21 ` Alessandro Fanfarillo
2016-05-18 20:11 ` Mikael Morin
2016-05-19 17:57 ` Alessandro Fanfarillo
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=CAHqFgjUTo2Vkz9cf2sooasrNq0-WhY0FieaH4-OBzNs3iFBEjA@mail.gmail.com \
--to=fanfarillo.gcc@gmail.com \
--cc=fortran@gcc.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
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).