aboutsummaryrefslogtreecommitdiff
path: root/gcc
diff options
context:
space:
mode:
authorI'm not telling you my name, idiot <git_is@stupid.com>2020-09-23 18:14:20 +0200
committerI'm not telling you my name, idiot <git_is@stupid.com>2020-09-23 18:14:20 +0200
commitbef0a39f2f8e87780f990d12fa71f5ed0039267a (patch)
treece8138e924d9bfff3ce0b63aa4c29397fbfaa1a5 /gcc
parent9044db88d634c631920eaa9f66c0275adf18fdf5 (diff)
downloadgcc-bef0a39f2f8e87780f990d12fa71f5ed0039267a.zip
gcc-bef0a39f2f8e87780f990d12fa71f5ed0039267a.tar.gz
gcc-bef0a39f2f8e87780f990d12fa71f5ed0039267a.tar.bz2
Initial commit of coarray_native branch.
Diffstat (limited to 'gcc')
-rw-r--r--gcc/flag-types.h3
-rw-r--r--gcc/fortran/dump-parse-tree.c2
-rw-r--r--gcc/fortran/frontend-passes.c122
-rw-r--r--gcc/fortran/gfortran.h1
-rw-r--r--gcc/fortran/intrinsic.c10
-rw-r--r--gcc/fortran/intrinsic.h6
-rw-r--r--gcc/fortran/iresolve.c98
-rw-r--r--gcc/fortran/lang.opt5
-rw-r--r--gcc/fortran/resolve.c67
-rw-r--r--gcc/fortran/trans-array.c288
-rw-r--r--gcc/fortran/trans-array.h13
-rw-r--r--gcc/fortran/trans-decl.c296
-rw-r--r--gcc/fortran/trans-expr.c22
-rw-r--r--gcc/fortran/trans-intrinsic.c181
-rw-r--r--gcc/fortran/trans-stmt.c100
-rw-r--r--gcc/fortran/trans-types.c51
-rw-r--r--gcc/fortran/trans.c22
-rw-r--r--gcc/fortran/trans.h18
18 files changed, 1155 insertions, 150 deletions
diff --git a/gcc/flag-types.h b/gcc/flag-types.h
index 852ea76..51e698d 100644
--- a/gcc/flag-types.h
+++ b/gcc/flag-types.h
@@ -346,7 +346,8 @@ enum gfc_fcoarray
{
GFC_FCOARRAY_NONE = 0,
GFC_FCOARRAY_SINGLE,
- GFC_FCOARRAY_LIB
+ GFC_FCOARRAY_LIB,
+ GFC_FCOARRAY_NATIVE
};
diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c
index 6e265f4..acff75a 100644
--- a/gcc/fortran/dump-parse-tree.c
+++ b/gcc/fortran/dump-parse-tree.c
@@ -1060,7 +1060,7 @@ show_symbol (gfc_symbol *sym)
if (sym == NULL)
return;
- fprintf (dumpfile, "|| symbol: '%s' ", sym->name);
+ fprintf (dumpfile, "|| symbol: '%s' %p ", sym->name, (void *) &(sym->backend_decl));
len = strlen (sym->name);
for (i=len; i<12; i++)
fputc(' ', dumpfile);
diff --git a/gcc/fortran/frontend-passes.c b/gcc/fortran/frontend-passes.c
index 83f6fd8..c573731 100644
--- a/gcc/fortran/frontend-passes.c
+++ b/gcc/fortran/frontend-passes.c
@@ -57,6 +57,7 @@ static int call_external_blas (gfc_code **, int *, void *);
static int matmul_temp_args (gfc_code **, int *,void *data);
static int index_interchange (gfc_code **, int*, void *);
static bool is_fe_temp (gfc_expr *e);
+static void rewrite_co_reduce (gfc_namespace *);
#ifdef CHECKING_P
static void check_locus (gfc_namespace *);
@@ -179,6 +180,9 @@ gfc_run_passes (gfc_namespace *ns)
if (flag_realloc_lhs)
realloc_strings (ns);
+
+ if (flag_coarray == GFC_FCOARRAY_NATIVE)
+ rewrite_co_reduce (ns);
}
#ifdef CHECKING_P
@@ -5895,3 +5899,121 @@ gfc_fix_implicit_pure (gfc_namespace *ns)
return changed;
}
+
+/* Callback function. Create a wrapper around VALUE functions. */
+
+static int
+co_reduce_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, void *data)
+{
+ gfc_code *co = *c;
+ gfc_expr *oper;
+ gfc_symbol *op_sym;
+ gfc_symbol *arg1, *arg2;
+ gfc_namespace *parent_ns;
+ gfc_namespace *proc_ns;
+ gfc_symbol *proc_sym;
+ gfc_symtree *f1t, *f2t;
+ gfc_symbol *f1, *f2;
+ gfc_code *assign;
+ gfc_expr *e1, *e2;
+ char name[GFC_MAX_SYMBOL_LEN + 1];
+ static int num;
+
+ if (co->op != EXEC_CALL || co->resolved_isym == NULL
+ || co->resolved_isym->id != GFC_ISYM_CO_REDUCE)
+ return 0;
+
+ oper = co->ext.actual->next->expr;
+ op_sym = oper->symtree->n.sym;
+ arg1 = op_sym->formal->sym;
+ arg2 = op_sym->formal->next->sym;
+
+ parent_ns = (gfc_namespace *) data;
+
+ /* Generate the wrapper around the function. */
+ proc_ns = gfc_get_namespace (parent_ns, 0);
+ snprintf (name, GFC_MAX_SYMBOL_LEN, "__coreduce_%d_%s", num++, op_sym->name);
+ gfc_get_symbol (name, proc_ns, &proc_sym);
+ proc_sym->attr.flavor = FL_PROCEDURE;
+ proc_sym->attr.subroutine = 1;
+ proc_sym->attr.referenced = 1;
+ proc_sym->attr.access = ACCESS_PRIVATE;
+ gfc_commit_symbol (proc_sym);
+ proc_ns->proc_name = proc_sym;
+
+ /* Make up the formal arguments. */
+ gfc_get_sym_tree (arg1->name, proc_ns, &f1t, false);
+ f1 = f1t->n.sym;
+ f1->ts = arg1->ts;
+ f1->attr.flavor = FL_VARIABLE;
+ f1->attr.dummy = 1;
+ f1->attr.intent = INTENT_INOUT;
+ f1->attr.fe_temp = 1;
+ f1->declared_at = arg1->declared_at;
+ f1->attr.referenced = 1;
+ proc_sym->formal = gfc_get_formal_arglist ();
+ proc_sym->formal->sym = f1;
+ gfc_commit_symbol (f1);
+
+ gfc_get_sym_tree (arg2->name, proc_ns, &f2t, false);
+ f2 = f2t->n.sym;
+ f2->ts = arg2->ts;
+ f2->attr.flavor = FL_VARIABLE;
+ f2->attr.dummy = 1;
+ f2->attr.intent = INTENT_IN;
+ f2->attr.fe_temp = 1;
+ f2->declared_at = arg2->declared_at;
+ f2->attr.referenced = 1;
+ proc_sym->formal->next = gfc_get_formal_arglist ();
+ proc_sym->formal->next->sym = f2;
+ gfc_commit_symbol (f2);
+
+ /* Generate the assignment statement. */
+ assign = gfc_get_code (EXEC_ASSIGN);
+
+ e1 = gfc_lval_expr_from_sym (f1);
+ e2 = gfc_get_expr ();
+ e2->where = proc_sym->declared_at;
+ e2->expr_type = EXPR_FUNCTION;
+ e2->symtree = f2t;
+ e2->ts = arg1->ts;
+ e2->value.function.esym = op_sym;
+ e2->value.function.actual = gfc_get_actual_arglist ();
+ e2->value.function.actual->expr = gfc_lval_expr_from_sym (f1);
+ e2->value.function.actual->next = gfc_get_actual_arglist ();
+ e2->value.function.actual->next->expr = gfc_lval_expr_from_sym (f2);
+ assign->expr1 = e1;
+ assign->expr2 = e2;
+ assign->loc = proc_sym->declared_at;
+
+ proc_ns->code = assign;
+
+ /* And hang it into the sibling list. */
+ proc_ns->sibling = parent_ns->contained;
+ parent_ns->contained = proc_ns;
+
+ /* ... and finally replace the call in the statement. */
+
+ oper->symtree->n.sym = proc_sym;
+ proc_sym->refs ++;
+ return 0;
+}
+
+/* Rewrite functions for co_reduce for a consistent calling
+ signature. This is only necessary if any of the functions
+ has a VALUE argument. */
+
+static void
+rewrite_co_reduce (gfc_namespace *global_ns)
+{
+ gfc_namespace *ns;
+
+ gfc_code_walker (&global_ns->code, co_reduce_code, dummy_expr_callback,
+ (void *) global_ns);
+
+ for (ns = global_ns->contained; ns; ns = ns->sibling)
+ gfc_code_walker (&ns->code, co_reduce_code, dummy_expr_callback,
+ (void *) global_ns);
+
+ return;
+}
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index d0cea83..6940c24 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2010,6 +2010,7 @@ typedef struct gfc_array_ref
int dimen; /* # of components in the reference */
int codimen;
bool in_allocate; /* For coarray checks. */
+ bool native_coarray_argument;
gfc_expr *team;
gfc_expr *stat;
locus where;
diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index ef33587..6a5b3e9 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -3734,7 +3734,7 @@ add_subroutines (void)
/* Coarray collectives. */
add_sym_4s ("co_broadcast", GFC_ISYM_CO_BROADCAST, CLASS_IMPURE,
BT_UNKNOWN, 0, GFC_STD_F2018,
- gfc_check_co_broadcast, NULL, NULL,
+ gfc_check_co_broadcast, NULL, gfc_resolve_co_broadcast,
a, BT_REAL, dr, REQUIRED, INTENT_INOUT,
"source_image", BT_INTEGER, di, REQUIRED, INTENT_IN,
stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
@@ -3742,7 +3742,7 @@ add_subroutines (void)
add_sym_4s ("co_max", GFC_ISYM_CO_MAX, CLASS_IMPURE,
BT_UNKNOWN, 0, GFC_STD_F2018,
- gfc_check_co_minmax, NULL, NULL,
+ gfc_check_co_minmax, NULL, gfc_resolve_co_max,
a, BT_REAL, dr, REQUIRED, INTENT_INOUT,
result_image, BT_INTEGER, di, OPTIONAL, INTENT_IN,
stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
@@ -3750,7 +3750,7 @@ add_subroutines (void)
add_sym_4s ("co_min", GFC_ISYM_CO_MIN, CLASS_IMPURE,
BT_UNKNOWN, 0, GFC_STD_F2018,
- gfc_check_co_minmax, NULL, NULL,
+ gfc_check_co_minmax, NULL, gfc_resolve_co_min,
a, BT_REAL, dr, REQUIRED, INTENT_INOUT,
result_image, BT_INTEGER, di, OPTIONAL, INTENT_IN,
stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
@@ -3758,7 +3758,7 @@ add_subroutines (void)
add_sym_4s ("co_sum", GFC_ISYM_CO_SUM, CLASS_IMPURE,
BT_UNKNOWN, 0, GFC_STD_F2018,
- gfc_check_co_sum, NULL, NULL,
+ gfc_check_co_sum, NULL, gfc_resolve_co_sum,
a, BT_REAL, dr, REQUIRED, INTENT_INOUT,
result_image, BT_INTEGER, di, OPTIONAL, INTENT_IN,
stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
@@ -3766,7 +3766,7 @@ add_subroutines (void)
add_sym_5s ("co_reduce", GFC_ISYM_CO_REDUCE, CLASS_IMPURE,
BT_UNKNOWN, 0, GFC_STD_F2018,
- gfc_check_co_reduce, NULL, NULL,
+ gfc_check_co_reduce, NULL, gfc_resolve_co_reduce,
a, BT_REAL, dr, REQUIRED, INTENT_INOUT,
"operator", BT_INTEGER, di, REQUIRED, INTENT_IN,
result_image, BT_INTEGER, di, OPTIONAL, INTENT_IN,
diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h
index 166ae79..2ca566c 100644
--- a/gcc/fortran/intrinsic.h
+++ b/gcc/fortran/intrinsic.h
@@ -677,7 +677,11 @@ void gfc_resolve_system_sub (gfc_code *);
void gfc_resolve_ttynam_sub (gfc_code *);
void gfc_resolve_umask_sub (gfc_code *);
void gfc_resolve_unlink_sub (gfc_code *);
-
+void gfc_resolve_co_sum (gfc_code *);
+void gfc_resolve_co_min (gfc_code *);
+void gfc_resolve_co_max (gfc_code *);
+void gfc_resolve_co_reduce (gfc_code *);
+void gfc_resolve_co_broadcast (gfc_code *);
/* The findloc() subroutine requires the most arguments: six. */
diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c
index 7376961..844891e 100644
--- a/gcc/fortran/iresolve.c
+++ b/gcc/fortran/iresolve.c
@@ -36,6 +36,7 @@ along with GCC; see the file COPYING3. If not see
#include "constructor.h"
#include "arith.h"
#include "trans.h"
+#include "options.h"
/* Given printf-like arguments, return a stable version of the result string.
@@ -4030,3 +4031,100 @@ gfc_resolve_unlink_sub (gfc_code *c)
name = gfc_get_string (PREFIX ("unlink_i%d_sub"), kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
+
+/* Resolve the CO_SUM et al. intrinsic subroutines. */
+
+static void
+gfc_resolve_co_collective (gfc_code *c, const char *oper)
+{
+ int kind;
+ gfc_expr *e;
+ const char *name;
+
+ if (flag_coarray != GFC_FCOARRAY_NATIVE)
+ name = gfc_get_string (PREFIX ("caf_co_sum"));
+ else
+ {
+ e = c->ext.actual->expr;
+ kind = e->ts.kind;
+
+ name = gfc_get_string (PREFIX ("nca_collsub_%s_%s_%c%d"), oper,
+ e->rank ? "array" : "scalar",
+ gfc_type_letter (e->ts.type), kind);
+ }
+
+ c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+/* Resolve CO_SUM. */
+
+void
+gfc_resolve_co_sum (gfc_code *c)
+{
+ gfc_resolve_co_collective (c, "sum");
+}
+
+/* Resolve CO_MIN. */
+
+void
+gfc_resolve_co_min (gfc_code *c)
+{
+ gfc_resolve_co_collective (c, "min");
+}
+
+/* Resolve CO_MAX. */
+
+void
+gfc_resolve_co_max (gfc_code *c)
+{
+ gfc_resolve_co_collective (c, "max");
+}
+
+/* Resolve CO_REDUCE. */
+
+void
+gfc_resolve_co_reduce (gfc_code *c)
+{
+ gfc_expr *e;
+ const char *name;
+
+ if (flag_coarray != GFC_FCOARRAY_NATIVE)
+ name = gfc_get_string (PREFIX ("caf_co_reduce"));
+
+ else
+ {
+ e = c->ext.actual->expr;
+ if (e->ts.type == BT_CHARACTER)
+ name = gfc_get_string (PREFIX ("nca_collsub_reduce_%s%c%d"),
+ e->rank ? "array" : "scalar",
+ gfc_type_letter (e->ts.type), e->ts.kind);
+ else
+ name = gfc_get_string (PREFIX ("nca_collsub_reduce_%s"),
+ e->rank ? "array" : "scalar" );
+ }
+
+ c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+void
+gfc_resolve_co_broadcast (gfc_code * c)
+{
+ gfc_expr *e;
+ const char *name;
+
+ if (flag_coarray != GFC_FCOARRAY_NATIVE)
+ name = gfc_get_string (PREFIX ("caf_co_broadcast"));
+ else
+ {
+ e = c->ext.actual->expr;
+ if (e->ts.type == BT_CHARACTER)
+ name = gfc_get_string (PREFIX ("nca_collsub_broadcast_%s%c%d"),
+ e->rank ? "array" : "scalar",
+ gfc_type_letter (e->ts.type), e->ts.kind);
+ else
+ name = gfc_get_string (PREFIX ("nca_collsub_broadcast_%s"),
+ e->rank ? "array" : "scalar" );
+ }
+
+ c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt
index da4b1aa..e267fb0 100644
--- a/gcc/fortran/lang.opt
+++ b/gcc/fortran/lang.opt
@@ -761,7 +761,7 @@ Copy array sections into a contiguous block on procedure entry.
fcoarray=
Fortran RejectNegative Joined Enum(gfc_fcoarray) Var(flag_coarray) Init(GFC_FCOARRAY_NONE)
--fcoarray=<none|single|lib> Specify which coarray parallelization should be used.
+-fcoarray=<none|single|lib|native> Specify which coarray parallelization should be used.
Enum
Name(gfc_fcoarray) Type(enum gfc_fcoarray) UnknownError(Unrecognized option: %qs)
@@ -775,6 +775,9 @@ Enum(gfc_fcoarray) String(single) Value(GFC_FCOARRAY_SINGLE)
EnumValue
Enum(gfc_fcoarray) String(lib) Value(GFC_FCOARRAY_LIB)
+EnumValue
+Enum(gfc_fcoarray) String(native) Value(GFC_FCOARRAY_NATIVE)
+
fcheck=
Fortran RejectNegative JoinedOrMissing
-fcheck=[...] Specify which runtime checks are to be performed.
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index f4ce49f..6d6984b 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -3585,6 +3585,53 @@ resolve_specific_s (gfc_code *c)
return false;
}
+/* Fix up references to native coarrays in call - element references
+ have to be converted to full references if the coarray has to be
+ passed fully. */
+
+static void
+fixup_coarray_args (gfc_symbol *sym, gfc_actual_arglist *actual)
+{
+ gfc_formal_arglist *formal, *f;
+ gfc_actual_arglist *a;
+
+ formal = gfc_sym_get_dummy_args (sym);
+
+ if (formal == NULL)
+ return;
+
+ for (a = actual, f = formal; a && f; a = a->next, f = f->next)
+ {
+ if (a->expr == NULL || f->sym == NULL)
+ continue;
+ if (a->expr->expr_type == EXPR_VARIABLE
+ && a->expr->symtree->n.sym->attr.codimension
+ && f->sym->attr.codimension)
+ {
+ gfc_ref *r;
+ for (r = a->expr->ref; r; r = r->next)
+ {
+ if (r->type == REF_ARRAY && r->u.ar.codimen)
+ {
+ gfc_array_ref *ar = &r->u.ar;
+ int i, eff_dimen = ar->dimen + ar->codimen;
+
+ for (i = ar->dimen; i < eff_dimen; i++)
+ {
+ ar->dimen_type[i] = DIMEN_RANGE;
+ gcc_assert (ar->start[i] == NULL);
+ gcc_assert (ar->end[i] == NULL);
+ }
+
+ if (ar->type == AR_ELEMENT)
+ ar->type = !ar->dimen ? AR_FULL : AR_SECTION;
+
+ ar->native_coarray_argument = true;
+ }
+ }
+ }
+ }
+}
/* Resolve a subroutine call not known to be generic nor specific. */
@@ -3615,7 +3662,7 @@ resolve_unknown_s (gfc_code *c)
found:
gfc_procedure_use (sym, &c->ext.actual, &c->loc);
-
+
c->resolved_sym = sym;
return pure_subroutine (sym, sym->name, &c->loc);
@@ -3740,6 +3787,9 @@ resolve_call (gfc_code *c)
/* Typebound procedure: Assume the worst. */
gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
+ if (flag_coarray == GFC_FCOARRAY_NATIVE)
+ fixup_coarray_args (csym, c->ext.actual);
+
return t;
}
@@ -10117,7 +10167,7 @@ resolve_critical (gfc_code *code)
char name[GFC_MAX_SYMBOL_LEN];
static int serial = 0;
- if (flag_coarray != GFC_FCOARRAY_LIB)
+ if (flag_coarray != GFC_FCOARRAY_LIB && flag_coarray != GFC_FCOARRAY_NATIVE)
return;
symtree = gfc_find_symtree (gfc_current_ns->sym_root,
@@ -10154,6 +10204,19 @@ resolve_critical (gfc_code *code)
symtree->n.sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind,
NULL, 1);
gfc_commit_symbols();
+
+ if (flag_coarray == GFC_FCOARRAY_NATIVE)
+ {
+ gfc_ref *r = gfc_get_ref ();
+ r->type = REF_ARRAY;
+ r->u.ar.type = AR_ELEMENT;
+ r->u.ar.as = code->resolved_sym->as;
+ for (int i = 0; i < code->resolved_sym->as->corank; i++)
+ r->u.ar.dimen_type [i] = DIMEN_THIS_IMAGE;
+
+ code->expr1 = gfc_lval_expr_from_sym (code->resolved_sym);
+ code->expr1->ref = r;
+ }
}
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 6566c47..9013f19 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -2940,6 +2940,60 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
gfc_add_loop_ss_code (nested_loop, nested_loop->ss, subscript, where);
}
+static tree
+gfc_add_strides (tree expr, tree desc, int beg, int end)
+{
+ int i;
+ tree tmp, stride;
+ tmp = gfc_index_zero_node;
+ for (i = beg; i < end; i++)
+ {
+ stride = gfc_conv_array_stride (desc, i);
+ tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE(tmp),
+ tmp, stride);
+ }
+ return fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE(expr),
+ expr, tmp);
+}
+
+/* This function calculates the new offset via
+ new_offset = offset + this_image ()
+ * arrray.stride[first_codimension]
+ + sum (remaining codimension offsets)
+ If offset is a pointer, we also need to multiply it by the size.*/
+static tree
+gfc_native_coarray_add_this_image_offset (tree offset, tree desc,
+ gfc_array_ref *ar, int is_pointer,
+ int subtract)
+{
+ tree tmp, off;
+ /* Calculate the actual offset. */
+ tmp = build_call_expr_loc (input_location, gfor_fndecl_nca_this_image,
+ 1, integer_zero_node);
+ tmp = convert (TREE_TYPE(gfc_index_zero_node), tmp);
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE(tmp), tmp,
+ build_int_cst (TREE_TYPE(tmp), subtract));
+ tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE(tmp),
+ gfc_conv_array_stride (desc, ar->dimen), tmp);
+ /* We also need to add the missing strides once to compensate for the
+ offset, that is to large now. The loop starts at sym->as.rank+1
+ because we need to skip the first corank stride */
+ off = gfc_add_strides (tmp, desc, ar->as->rank + 1,
+ ar->as->rank + ar->as->corank);
+ if (is_pointer)
+ {
+ /* Remove pointer and array from type in order to get the raw base type. */
+ tmp = TREE_TYPE(TREE_TYPE(TREE_TYPE(offset)));
+ /* And get the size of that base type. */
+ tmp = convert (TREE_TYPE(off), size_in_bytes_loc (input_location, tmp));
+ tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE(off),
+ off, tmp);
+ return fold_build_pointer_plus_loc (input_location, offset, tmp);
+ }
+ else
+ return fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE(offset),
+ offset, off);
+}
/* Translate expressions for the descriptor and data pointer of a SS. */
/*GCC ARRAYS*/
@@ -2951,6 +3005,7 @@ gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
gfc_ss_info *ss_info;
gfc_array_info *info;
tree tmp;
+ gfc_ref *ref;
ss_info = ss->info;
info = &ss_info->data.array;
@@ -2982,10 +3037,18 @@ gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
}
/* Also the data pointer. */
tmp = gfc_conv_array_data (se.expr);
+ /* If we have a native coarray with implied this_image (), add the
+ appropriate offset to the data pointer. */
+ ref = ss_info->expr->ref;
+ if (flag_coarray == GFC_FCOARRAY_NATIVE && ref
+ && ref->u.ar.dimen_type[ref->u.ar.dimen + ref->u.ar.codimen - 1]
+ == DIMEN_THIS_IMAGE)
+ tmp = gfc_native_coarray_add_this_image_offset (tmp, se.expr, &ref->u.ar, 1, 1);
/* If this is a variable or address of a variable we use it directly.
Otherwise we must evaluate it now to avoid breaking dependency
analysis by pulling the expressions for elemental array indices
inside the loop. */
+
if (!(DECL_P (tmp)
|| (TREE_CODE (tmp) == ADDR_EXPR
&& DECL_P (TREE_OPERAND (tmp, 0)))))
@@ -2993,6 +3056,15 @@ gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
info->data = tmp;
tmp = gfc_conv_array_offset (se.expr);
+ /* If we have a native coarray, adjust the offset to remove the
+ offset for the codimensions. */
+ // TODO: check whether the recipient is a coarray, if it is, disable
+ // all of this
+ if (flag_coarray == GFC_FCOARRAY_NATIVE && ref
+ && ref->u.ar.dimen_type[ref->u.ar.dimen + ref->u.ar.codimen - 1]
+ == DIMEN_THIS_IMAGE)
+ tmp = gfc_add_strides (tmp, se.expr, ref->u.ar.as->rank,
+ ref->u.ar.as->rank + ref->u.ar.as->corank);
info->offset = gfc_evaluate_now (tmp, block);
/* Make absolutely sure that the saved_offset is indeed saved
@@ -3593,6 +3665,7 @@ build_array_ref (tree desc, tree offset, tree decl, tree vptr)
}
+
/* Build an array reference. se->expr already holds the array descriptor.
This should be either a variable, indirect variable reference or component
reference. For arrays which do not have a descriptor, se->expr will be
@@ -3612,8 +3685,20 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr,
gfc_se tmpse;
gfc_symbol * sym = expr->symtree->n.sym;
char *var_name = NULL;
+ bool need_impl_this_image;
+ int eff_dimen;
+
+ need_impl_this_image =
+ ar->dimen_type[ar->dimen + ar->codimen - 1] == DIMEN_THIS_IMAGE;
+
+ if (flag_coarray == GFC_FCOARRAY_NATIVE
+ && !need_impl_this_image)
+ eff_dimen = ar->dimen + ar->codimen - 1;
+ else
+ eff_dimen = ar->dimen - 1;
- if (ar->dimen == 0)
+
+ if (flag_coarray != GFC_FCOARRAY_NATIVE && ar->dimen == 0)
{
gcc_assert (ar->codimen || sym->attr.select_rank_temporary
|| (ar->as && ar->as->corank));
@@ -3681,7 +3766,7 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr,
/* Calculate the offsets from all the dimensions. Make sure to associate
the final offset so that we form a chain of loop invariant summands. */
- for (n = ar->dimen - 1; n >= 0; n--)
+ for (n = eff_dimen; n >= 0; n--)
{
/* Calculate the index for this dimension. */
gfc_init_se (&indexse, se);
@@ -3753,6 +3838,9 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr,
add_to_offset (&cst_offset, &offset, tmp);
}
+ if (flag_coarray == GFC_FCOARRAY_NATIVE && need_impl_this_image)
+ offset = gfc_native_coarray_add_this_image_offset (offset, se->expr, ar, 0, 0);
+
if (!integer_zerop (cst_offset))
offset = fold_build2_loc (input_location, PLUS_EXPR,
gfc_array_index_type, offset, cst_offset);
@@ -5423,7 +5511,7 @@ gfc_conv_descriptor_cosize (tree desc, int rank, int corank)
} */
/*GCC ARRAYS*/
-static tree
+tree
gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
stmtblock_t * descriptor_block, tree * overflow,
@@ -5441,6 +5529,8 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
tree elsecase;
tree cond;
tree var;
+ tree conv_lbound;
+ tree conv_ubound;
stmtblock_t thenblock;
stmtblock_t elseblock;
gfc_expr *ubound;
@@ -5454,7 +5544,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
/* Set the dtype before the alloc, because registration of coarrays needs
it initialized. */
- if (expr->ts.type == BT_CHARACTER
+ if (expr && expr->ts.type == BT_CHARACTER
&& expr->ts.deferred
&& VAR_P (expr->ts.u.cl->backend_decl))
{
@@ -5462,7 +5552,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
tmp = gfc_conv_descriptor_dtype (descriptor);
gfc_add_modify (pblock, tmp, gfc_get_dtype_rank_type (rank, type));
}
- else if (expr->ts.type == BT_CHARACTER
+ else if (expr && expr->ts.type == BT_CHARACTER
&& expr->ts.deferred
&& TREE_CODE (descriptor) == COMPONENT_REF)
{
@@ -5494,9 +5584,6 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
for (n = 0; n < rank; n++)
{
- tree conv_lbound;
- tree conv_ubound;
-
/* We have 3 possibilities for determining the size of the array:
lower == NULL => lbound = 1, ubound = upper[n]
upper[n] = NULL => lbound = 1, ubound = lower[n]
@@ -5646,6 +5733,15 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
}
gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
gfc_rank_cst[n], se.expr);
+ conv_lbound = se.expr;
+ if (flag_coarray == GFC_FCOARRAY_NATIVE)
+ {
+
+ tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+ se.expr, stride);
+ offset = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type, offset, tmp);
+ }
if (n < rank + corank - 1)
{
@@ -5655,6 +5751,18 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
gfc_add_block_to_block (pblock, &se.pre);
gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
gfc_rank_cst[n], se.expr);
+ gfc_conv_descriptor_stride_set (descriptor_block, descriptor,
+ gfc_rank_cst[n], stride);
+ conv_ubound = se.expr;
+ if (flag_coarray == GFC_FCOARRAY_NATIVE)
+ {
+ size = gfc_conv_array_extent_dim (conv_lbound, conv_ubound,
+ &or_expr);
+ size = gfc_evaluate_now (size, descriptor_block);
+ stride = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, stride, size);
+ stride = gfc_evaluate_now (stride, descriptor_block);
+ }
}
}
@@ -5688,7 +5796,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
/* Convert to size_t. */
*element_size = fold_convert (size_type_node, tmp);
- if (rank == 0)
+ if (rank == 0 && !(flag_coarray == GFC_FCOARRAY_NATIVE && corank))
return *element_size;
*nelems = gfc_evaluate_now (stride, pblock);
@@ -5773,6 +5881,38 @@ retrieve_last_ref (gfc_ref **ref_in, gfc_ref **prev_ref_in)
return true;
}
+int
+gfc_native_coarray_get_allocation_type (gfc_symbol * sym)
+{
+ bool is_lock_type, is_event_type;
+ is_lock_type = sym->ts.type == BT_DERIVED
+ && 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;
+
+ if (is_lock_type)
+ return GFC_NCA_LOCK_COARRAY;
+ else if (is_event_type)
+ return GFC_NCA_EVENT_COARRAY;
+ else
+ return GFC_NCA_NORMAL_COARRAY;
+}
+
+void
+gfc_allocate_native_coarray (stmtblock_t *b, tree decl, tree size, int corank,
+ int alloc_type)
+{
+ gfc_add_expr_to_block (b,
+ build_call_expr_loc (input_location, gfor_fndecl_nca_coarray_allocate,
+ 4, gfc_build_addr_expr (pvoid_type_node, decl),
+ size, build_int_cst (integer_type_node, corank),
+ build_int_cst (integer_type_node, alloc_type)));
+
+}
+
/* Initializes the descriptor and generates a call to _gfor_allocate. Does
the work for an ALLOCATE statement. */
/*GCC ARRAYS*/
@@ -5784,6 +5924,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
bool e3_has_nodescriptor)
{
tree tmp;
+ tree allocation;
tree pointer;
tree offset = NULL_TREE;
tree token = NULL_TREE;
@@ -5914,7 +6055,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
expr3_elem_size, nelems, expr3, e3_arr_desc,
e3_has_nodescriptor, expr, &element_size);
- if (dimension)
+ if (dimension || (flag_coarray == GFC_FCOARRAY_NATIVE && coarray))
{
var_overflow = gfc_create_var (integer_type_node, "overflow");
gfc_add_modify (&se->pre, var_overflow, overflow);
@@ -5956,7 +6097,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
pointer = gfc_conv_descriptor_data_get (se->expr);
STRIP_NOPS (pointer);
- if (allocatable)
+ if (allocatable && !(flag_coarray == GFC_FCOARRAY_NATIVE && coarray))
{
not_prev_allocated = gfc_create_var (logical_type_node,
"not_prev_allocated");
@@ -5969,8 +6110,17 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
gfc_start_block (&elseblock);
+ if (coarray && flag_coarray == GFC_FCOARRAY_NATIVE)
+ {
+ tree elem_size
+ = size_in_bytes (gfc_get_element_type (TREE_TYPE(se->expr)));
+ int alloc_type
+ = gfc_native_coarray_get_allocation_type (expr->symtree->n.sym);
+ gfc_allocate_native_coarray (&elseblock, se->expr, elem_size,
+ ref->u.ar.as->corank, alloc_type);
+ }
/* The allocatable variant takes the old pointer as first argument. */
- if (allocatable)
+ else if (allocatable)
gfc_allocate_allocatable (&elseblock, pointer, size, token,
status, errmsg, errlen, label_finish, expr,
coref != NULL ? coref->u.ar.as->corank : 0);
@@ -5987,13 +6137,12 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
cond = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
logical_type_node, var_overflow, integer_zero_node),
PRED_FORTRAN_OVERFLOW);
- tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
+ allocation = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
error, gfc_finish_block (&elseblock));
}
else
- tmp = gfc_finish_block (&elseblock);
+ allocation = gfc_finish_block (&elseblock);
- gfc_add_expr_to_block (&se->pre, tmp);
/* Update the array descriptor with the offset and the span. */
if (dimension)
@@ -6004,6 +6153,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
}
set_descriptor = gfc_finish_block (&set_descriptor_block);
+
if (status != NULL_TREE)
{
cond = fold_build2_loc (input_location, EQ_EXPR,
@@ -6014,14 +6164,25 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
logical_type_node, cond, not_prev_allocated);
- gfc_add_expr_to_block (&se->pre,
- fold_build3_loc (input_location, COND_EXPR, void_type_node,
+ set_descriptor = fold_build3_loc (input_location, COND_EXPR, void_type_node,
cond,
set_descriptor,
- build_empty_stmt (input_location)));
+ build_empty_stmt (input_location));
+ }
+
+ // For native coarrays, the size must be set before the allocation routine
+ // can be called.
+ if (coarray && flag_coarray == GFC_FCOARRAY_NATIVE)
+ {
+ gfc_add_expr_to_block (&se->pre, set_descriptor);
+ gfc_add_expr_to_block (&se->pre, allocation);
}
else
+ {
+ gfc_add_expr_to_block (&se->pre, allocation);
gfc_add_expr_to_block (&se->pre, set_descriptor);
+ }
+
return true;
}
@@ -6524,6 +6685,7 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
bool optional_arg;
gfc_array_spec *as;
bool is_classarray = IS_CLASS_ARRAY (sym);
+ int eff_dimen;
/* Do nothing for pointer and allocatable arrays. */
if ((sym->ts.type != BT_CLASS && sym->attr.pointer)
@@ -6638,8 +6800,13 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
offset = gfc_index_zero_node;
size = gfc_index_one_node;
+ if (flag_coarray == GFC_FCOARRAY_NATIVE)
+ eff_dimen = as->rank + as->corank;
+ else
+ eff_dimen = as->rank;
+
/* Evaluate the bounds of the array. */
- for (n = 0; n < as->rank; n++)
+ for (n = 0; n < eff_dimen; n++)
{
if (checkparm || !as->upper[n])
{
@@ -6724,7 +6891,7 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
gfc_array_index_type, offset, tmp);
/* The size of this dimension, and the stride of the next. */
- if (n + 1 < as->rank)
+ if (n + 1 < eff_dimen)
{
stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
@@ -6879,20 +7046,35 @@ gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
return;
}
+ /* if it's a coarray with implicit this_image, add that to the offset. */
+ ref = expr->ref;
+ if (flag_coarray == GFC_FCOARRAY_NATIVE && ref && ref->type == REF_ARRAY
+ && ref->u.ar.dimen_type[ref->u.ar.dimen + ref->u.ar.codimen - 1]
+ == DIMEN_THIS_IMAGE
+ && !ref->u.ar.native_coarray_argument)
+ offset = gfc_native_coarray_add_this_image_offset (offset, desc,
+ &ref->u.ar, 0, 1);
+
tmp = build_array_ref (desc, offset, NULL, NULL);
/* Offset the data pointer for pointer assignments from arrays with
subreferences; e.g. my_integer => my_type(:)%integer_component. */
if (subref)
{
- /* Go past the array reference. */
+ /* Go past the array reference. */
for (ref = expr->ref; ref; ref = ref->next)
- if (ref->type == REF_ARRAY &&
- ref->u.ar.type != AR_ELEMENT)
- {
- ref = ref->next;
- break;
- }
+ {
+ if (ref->type == REF_ARRAY &&
+ ref->u.ar.type != AR_ELEMENT)
+ {
+ ref = ref->next;
+ break;
+ }
+ else if (flag_coarray == GFC_FCOARRAY_NATIVE && ref->type == REF_ARRAY &&
+ ref->u.ar.dimen_type[ref->u.ar.dimen +ref->u.ar.codimen -1]
+ == DIMEN_THIS_IMAGE)
+ tmp = gfc_native_coarray_add_this_image_offset (tmp, desc, &ref->u.ar, 0, 1);
+ }
/* Calculate the offset for each subsequent subreference. */
for (; ref; ref = ref->next)
@@ -6955,7 +7137,10 @@ gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
gfc_array_index_type, stride, itmp);
stride = gfc_evaluate_now (stride, block);
}
-
+ if (flag_coarray == GFC_FCOARRAY_NATIVE &&
+ ref->u.ar.dimen_type[ref->u.ar.dimen +ref->u.ar.codimen -1]
+ == DIMEN_THIS_IMAGE)
+ tmp = gfc_native_coarray_add_this_image_offset (tmp, desc, &ref->u.ar, 0, 1);
/* Apply the index to obtain the array element. */
tmp = gfc_build_array_ref (tmp, index, NULL);
break;
@@ -7306,6 +7491,13 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
else
full = gfc_full_array_ref_p (info->ref, NULL);
+ if (flag_coarray == GFC_FCOARRAY_NATIVE &&
+ info->ref->type == REF_ARRAY &&
+ info->ref->u.ar.dimen_type[info->ref->u.ar.dimen
+ + info->ref->u.ar.codimen - 1] ==
+ DIMEN_THIS_IMAGE)
+ full = 0;
+
if (full && !transposed_dims (ss))
{
if (se->direct_byref && !se->byref_noassign)
@@ -7540,9 +7732,19 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
tree to;
tree base;
tree offset;
-
+#if 0 /* TK */
ndim = info->ref ? info->ref->u.ar.dimen : ss->dimen;
-
+#else
+ if (info->ref)
+ {
+ if (info->ref->u.ar.native_coarray_argument)
+ ndim = info->ref->u.ar.dimen + info->ref->u.ar.codimen;
+ else
+ ndim = info->ref->u.ar.dimen;
+ }
+ else
+ ndim = ss->dimen;
+#endif
if (se->want_coarray)
{
gfc_array_ref *ar = &info->ref->u.ar;
@@ -7911,7 +8113,15 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
expr->ts.u.cl->backend_decl = tmp;
se->string_length = tmp;
}
-
+#if 0
+ if (flag_coarray == GFC_FCOARRAY_NATIVE && fsym && fsym->attr.codimension && sym)
+ {
+ gfc_init_se (se, NULL);
+ tmp = gfc_get_symbol_decl (sym);
+ se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
+ return;
+ }
+#endif
/* Is this the result of the enclosing procedure? */
this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
if (this_array_result
@@ -7919,6 +8129,10 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
&& (sym->backend_decl != parent))
this_array_result = false;
+#if 1 /* TK */
+ if (flag_coarray == GFC_FCOARRAY_NATIVE && fsym && fsym->attr.codimension)
+ g77 = false;
+#endif
/* Passing address of the array if it is not pointer or assumed-shape. */
if (full_array_var && g77 && !this_array_result
&& sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
@@ -8053,8 +8267,8 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
{
/* Every other type of array. */
se->want_pointer = 1;
- gfc_conv_expr_descriptor (se, expr);
+ gfc_conv_expr_descriptor (se, expr);
if (size)
array_parameter_size (build_fold_indirect_ref_loc (input_location,
se->expr),
@@ -10869,9 +11083,15 @@ gfc_walk_array_ref (gfc_ss * ss, gfc_expr * expr, gfc_ref * ref)
case AR_SECTION:
newss = gfc_get_array_ss (ss, expr, 0, GFC_SS_SECTION);
newss->info->data.array.ref = ref;
-
+#if 1 /* TK */
+ int eff_dimen;
+ if (ar->native_coarray_argument)
+ eff_dimen = ar->dimen + ar->codimen;
+ else
+ eff_dimen = ar->dimen;
+#endif
/* We add SS chains for all the subscripts in the section. */
- for (n = 0; n < ar->dimen; n++)
+ for (n = 0; n < eff_dimen; n++)
{
gfc_ss *indexss;
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index e561605..0bfd1b0 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -23,6 +23,15 @@ along with GCC; see the file COPYING3. If not see
bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree, tree,
tree, tree *, gfc_expr *, tree, bool);
+enum gfc_coarray_allocation_type {
+ GFC_NCA_NORMAL_COARRAY = 3,
+ GFC_NCA_LOCK_COARRAY,
+ GFC_NCA_EVENT_COARRAY
+};
+int gfc_native_coarray_get_allocation_type (gfc_symbol *);
+
+void gfc_allocate_native_coarray (stmtblock_t *, tree, tree, int, int);
+
/* Allow the bounds of a loop to be set from a callee's array spec. */
void gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping *,
gfc_se *, gfc_array_spec *);
@@ -57,6 +66,10 @@ tree gfc_bcast_alloc_comp (gfc_symbol *, gfc_expr *, int, tree,
tree gfc_deallocate_alloc_comp_no_caf (gfc_symbol *, tree, int);
tree gfc_reassign_alloc_comp_caf (gfc_symbol *, tree, tree);
+tree gfc_array_init_size (tree, int, int, tree *, gfc_expr **, gfc_expr **,
+ stmtblock_t *, stmtblock_t *, tree *, tree, tree *,
+ gfc_expr *, tree, bool, gfc_expr *, tree *);
+
tree gfc_copy_alloc_comp (gfc_symbol *, tree, tree, int, int);
tree gfc_copy_only_alloc_comp (gfc_symbol *, tree, tree, int);
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 9224277..1973c4d 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -170,6 +170,21 @@ tree gfor_fndecl_co_reduce;
tree gfor_fndecl_co_sum;
tree gfor_fndecl_caf_is_present;
+/* Native coarray functions. */
+
+tree gfor_fndecl_nca_master;
+tree gfor_fndecl_nca_coarray_allocate;
+tree gfor_fndecl_nca_coarray_free;
+tree gfor_fndecl_nca_this_image;
+tree gfor_fndecl_nca_num_images;
+tree gfor_fndecl_nca_sync_all;
+tree gfor_fndecl_nca_sync_images;
+tree gfor_fndecl_nca_lock;
+tree gfor_fndecl_nca_unlock;
+tree gfor_fndecl_nca_reduce_scalar;
+tree gfor_fndecl_nca_reduce_array;
+tree gfor_fndecl_nca_broadcast_scalar;
+tree gfor_fndecl_nca_broadcast_array;
/* Math functions. Many other math functions are handled in
trans-intrinsic.c. */
@@ -961,6 +976,7 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym)
tree type;
int dim;
int nest;
+ int eff_dimen;
gfc_namespace* procns;
symbol_attribute *array_attr;
gfc_array_spec *as;
@@ -1031,8 +1047,12 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym)
else
gfc_add_decl_to_function (token);
}
+
+ eff_dimen = flag_coarray == GFC_FCOARRAY_NATIVE
+ ? GFC_TYPE_ARRAY_RANK (type) + GFC_TYPE_ARRAY_CORANK (type)
+ : GFC_TYPE_ARRAY_RANK (type);
- for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++)
+ for (dim = 0; dim < eff_dimen; dim++)
{
if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
{
@@ -1054,22 +1074,30 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym)
TREE_NO_WARNING (GFC_TYPE_ARRAY_STRIDE (type, dim)) = 1;
}
}
- for (dim = GFC_TYPE_ARRAY_RANK (type);
- dim < GFC_TYPE_ARRAY_RANK (type) + GFC_TYPE_ARRAY_CORANK (type); dim++)
- {
- if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
- {
- GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
- TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 1;
- }
- /* Don't try to use the unknown ubound for the last coarray dimension. */
- if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
- && dim < GFC_TYPE_ARRAY_RANK (type) + GFC_TYPE_ARRAY_CORANK (type) - 1)
- {
- GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
- TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 1;
- }
- }
+
+ if (flag_coarray != GFC_FCOARRAY_NATIVE)
+ for (dim = GFC_TYPE_ARRAY_RANK (type);
+ dim < GFC_TYPE_ARRAY_RANK (type) + GFC_TYPE_ARRAY_CORANK (type);
+ dim++)
+ {
+ if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
+ {
+ GFC_TYPE_ARRAY_LBOUND (type, dim)
+ = create_index_var ("lbound", nest);
+ TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 1;
+ }
+ /* Don't try to use the unknown ubound for the last coarray
+ dimension. */
+ if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
+ && dim < GFC_TYPE_ARRAY_RANK (type)
+ + GFC_TYPE_ARRAY_CORANK (type) - 1)
+ {
+ GFC_TYPE_ARRAY_UBOUND (type, dim)
+ = create_index_var ("ubound", nest);
+ TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 1;
+ }
+ }
+
if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE)
{
GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type,
@@ -1202,6 +1230,10 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
|| (as && as->type == AS_ASSUMED_RANK))
return dummy;
+ if (flag_coarray == GFC_FCOARRAY_NATIVE && sym->attr.codimension
+ && sym->attr.allocatable)
+ return dummy;
+
/* Add to list of variables if not a fake result variable.
These symbols are set on the symbol only, not on the class component. */
if (sym->attr.result || sym->attr.dummy)
@@ -1504,7 +1536,6 @@ add_attributes_to_decl (symbol_attribute sym_attr, tree list)
static void build_function_decl (gfc_symbol * sym, bool global);
-
/* Return the decl for a gfc_symbol, create it if it doesn't already
exist. */
@@ -1820,7 +1851,7 @@ gfc_get_symbol_decl (gfc_symbol * sym)
}
/* Remember this variable for allocation/cleanup. */
- if (sym->attr.dimension || sym->attr.allocatable || sym->attr.codimension
+ if (sym->attr.dimension || sym->attr.codimension || sym->attr.allocatable
|| (sym->ts.type == BT_CLASS &&
(CLASS_DATA (sym)->attr.dimension
|| CLASS_DATA (sym)->attr.allocatable))
@@ -1869,6 +1900,9 @@ gfc_get_symbol_decl (gfc_symbol * sym)
gcc_assert (!sym->value || sym->value->expr_type == EXPR_NULL);
}
+ if (flag_coarray == GFC_FCOARRAY_NATIVE && sym->attr.codimension)
+ TREE_STATIC(decl) = 1;
+
gfc_finish_var_decl (decl, sym);
if (sym->ts.type == BT_CHARACTER)
@@ -3693,6 +3727,7 @@ void
gfc_build_builtin_function_decls (void)
{
tree gfc_int8_type_node = gfc_get_int_type (8);
+ tree pint_type = build_pointer_type (integer_type_node);
gfor_fndecl_stop_numeric = gfc_build_library_function_decl (
get_identifier (PREFIX("stop_numeric")),
@@ -3820,9 +3855,8 @@ gfc_build_builtin_function_decls (void)
/* Coarray library calls. */
if (flag_coarray == GFC_FCOARRAY_LIB)
{
- tree pint_type, pppchar_type;
+ tree pppchar_type;
- pint_type = build_pointer_type (integer_type_node);
pppchar_type
= build_pointer_type (build_pointer_type (pchar_type_node));
@@ -4062,6 +4096,64 @@ gfc_build_builtin_function_decls (void)
integer_type_node, 3, pvoid_type_node, integer_type_node,
pvoid_type_node);
}
+ else if (flag_coarray == GFC_FCOARRAY_NATIVE)
+ {
+ gfor_fndecl_nca_master = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("nca_master")), ".r", integer_type_node, 1,
+ build_pointer_type (build_function_type_list (void_type_node, NULL_TREE)));
+ gfor_fndecl_nca_coarray_allocate = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("nca_coarray_alloc")), "..RRR", integer_type_node, 4,
+ pvoid_type_node, integer_type_node, integer_type_node, integer_type_node,
+ NULL_TREE);
+ gfor_fndecl_nca_coarray_free = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("nca_coarray_free")), "..RR", integer_type_node, 3,
+ pvoid_type_node, integer_type_node, integer_type_node, NULL_TREE);
+ gfor_fndecl_nca_this_image = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("nca_coarray_this_image")), ".X", integer_type_node, 1,
+ integer_type_node, NULL_TREE);
+ DECL_PURE_P (gfor_fndecl_nca_this_image) = 1;
+ gfor_fndecl_nca_num_images = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("nca_coarray_num_images")), ".X", integer_type_node, 1,
+ integer_type_node, NULL_TREE);
+ DECL_PURE_P (gfor_fndecl_nca_num_images) = 1;
+ gfor_fndecl_nca_sync_all = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("nca_coarray_sync_all")), ".X", void_type_node, 1,
+ build_pointer_type (integer_type_node), NULL_TREE);
+ gfor_fndecl_nca_sync_images = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("nca_sync_images")), ".RRXXX", void_type_node,
+ 5, integer_type_node, pint_type, pint_type,
+ pchar_type_node, size_type_node, NULL_TREE);
+ gfor_fndecl_nca_lock = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("nca_lock")), ".w", void_type_node, 1,
+ pvoid_type_node, NULL_TREE);
+ gfor_fndecl_nca_unlock = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("nca_unlock")), ".w", void_type_node, 1,
+ pvoid_type_node, NULL_TREE);
+
+ gfor_fndecl_nca_reduce_scalar =
+ gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("nca_collsub_reduce_scalar")), ".wrW",
+ void_type_node, 3, pvoid_type_node,
+ build_pointer_type (build_function_type_list (void_type_node,
+ pvoid_type_node, pvoid_type_node, NULL_TREE)),
+ pint_type, NULL_TREE);
+
+ gfor_fndecl_nca_reduce_array =
+ gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("nca_collsub_reduce_array")), ".wrWR",
+ void_type_node, 4, pvoid_type_node,
+ build_pointer_type (build_function_type_list (void_type_node,
+ pvoid_type_node, pvoid_type_node, NULL_TREE)),
+ pint_type, integer_type_node, NULL_TREE);
+
+ gfor_fndecl_nca_broadcast_scalar = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX ("nca_collsub_broadcast_scalar")), ".w..",
+ void_type_node, 3, pvoid_type_node, size_type_node, integer_type_node);
+ gfor_fndecl_nca_broadcast_array = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX ("nca_collsub_broadcast_array")), ".W.",
+ void_type_node, 2, pvoid_type_node, integer_type_node);
+ }
+
gfc_build_intrinsic_function_decls ();
gfc_build_intrinsic_lib_fndecls ();
@@ -4538,6 +4630,76 @@ get_proc_result (gfc_symbol* sym)
}
+void
+gfc_trans_native_coarray (stmtblock_t * init, stmtblock_t *cleanup, gfc_symbol * sym)
+{
+ tree tmp, decl;
+ tree overflow = build_int_cst (integer_type_node, 0), nelems, element_size; //All unused
+ tree offset;
+ tree elem_size;
+ int alloc_type;
+
+ decl = sym->backend_decl;
+
+ TREE_STATIC(decl) = 1;
+
+ /* Tell the library to handle arrays of locks and event types seperatly. */
+ alloc_type = gfc_native_coarray_get_allocation_type (sym);
+
+ if (init)
+ {
+ gfc_array_init_size (decl, sym->as->rank, sym->as->corank, &offset,
+ sym->as->lower, sym->as->upper, init,
+ init, &overflow,
+ NULL_TREE, &nelems, NULL,
+ NULL_TREE, true, NULL, &element_size);
+ gfc_conv_descriptor_offset_set (init, decl, offset);
+ elem_size = size_in_bytes (gfc_get_element_type (TREE_TYPE(decl)));
+ gfc_allocate_native_coarray (init, decl, elem_size, sym->as->corank,
+ alloc_type);
+ }
+
+ if (cleanup)
+ {
+ tmp = build_call_expr_loc (input_location, gfor_fndecl_nca_coarray_free,
+ 2, gfc_build_addr_expr (pvoid_type_node, decl),
+ build_int_cst (integer_type_node, alloc_type),
+ build_int_cst (integer_type_node,
+ sym->as->corank));
+ gfc_add_expr_to_block (cleanup, tmp);
+ }
+}
+
+static void
+finish_coarray_constructor_function (tree *, tree *);
+
+static void
+generate_coarray_constructor_function (tree *, tree *);
+
+static void
+gfc_trans_native_coarray_static (gfc_symbol * sym)
+{
+ tree save_fn_decl, fndecl;
+ generate_coarray_constructor_function (&save_fn_decl, &fndecl);
+ gfc_trans_native_coarray (&caf_init_block, NULL, sym);
+ finish_coarray_constructor_function (&save_fn_decl, &fndecl);
+}
+
+static void
+gfc_trans_native_coarray_inline (gfc_wrapped_block * block, gfc_symbol * sym)
+{
+ stmtblock_t init, cleanup;
+
+ gfc_init_block (&init);
+ gfc_init_block (&cleanup);
+
+ gfc_trans_native_coarray (&init, &cleanup, sym);
+
+ gfc_add_init_cleanup (block, gfc_finish_block (&init), gfc_finish_block (&cleanup));
+}
+
+
+
/* Generate function entry and exit code, and add it to the function body.
This includes:
Allocation and initialization of array variables.
@@ -4833,7 +4995,8 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
gfc_trans_deferred_array (sym, block);
}
}
- else if (sym->attr.codimension
+ else if (flag_coarray != GFC_FCOARRAY_NATIVE
+ && sym->attr.codimension
&& TREE_STATIC (sym->backend_decl))
{
gfc_init_block (&tmpblock);
@@ -4843,6 +5006,11 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
NULL_TREE);
continue;
}
+ else if (flag_coarray == GFC_FCOARRAY_NATIVE
+ && sym->attr.codimension)
+ {
+ gfc_trans_native_coarray_inline (block, sym);
+ }
else
{
gfc_save_backend_locus (&loc);
@@ -5333,6 +5501,10 @@ gfc_create_module_variable (gfc_symbol * sym)
&& sym->fn_result_spec));
DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
rest_of_decl_compilation (decl, 1, 0);
+
+ if (flag_coarray == GFC_FCOARRAY_NATIVE && sym->attr.codimension)
+ gfc_trans_native_coarray_static (sym);
+
gfc_module_add_decl (cur_module, decl);
/* Also add length of strings. */
@@ -5730,64 +5902,82 @@ generate_coarray_sym_init (gfc_symbol *sym)
}
-/* Generate constructor function to initialize static, nonallocatable
- coarrays. */
static void
-generate_coarray_init (gfc_namespace * ns __attribute((unused)))
+generate_coarray_constructor_function (tree *save_fn_decl, tree *fndecl)
{
- tree fndecl, tmp, decl, save_fn_decl;
+ tree tmp, decl;
- save_fn_decl = current_function_decl;
+ *save_fn_decl = current_function_decl;
push_function_context ();
tmp = build_function_type_list (void_type_node, NULL_TREE);
- fndecl = build_decl (input_location, FUNCTION_DECL,
- create_tmp_var_name ("_caf_init"), tmp);
+ *fndecl = build_decl (input_location, FUNCTION_DECL,
+ create_tmp_var_name (flag_coarray == GFC_FCOARRAY_LIB ? "_caf_init" : "_nca_init"), tmp);
- DECL_STATIC_CONSTRUCTOR (fndecl) = 1;
- SET_DECL_INIT_PRIORITY (fndecl, DEFAULT_INIT_PRIORITY);
+ DECL_STATIC_CONSTRUCTOR (*fndecl) = 1;
+ SET_DECL_INIT_PRIORITY (*fndecl, DEFAULT_INIT_PRIORITY);
decl = build_decl (input_location, RESULT_DECL, NULL_TREE, void_type_node);
DECL_ARTIFICIAL (decl) = 1;
DECL_IGNORED_P (decl) = 1;
- DECL_CONTEXT (decl) = fndecl;
- DECL_RESULT (fndecl) = decl;
+ DECL_CONTEXT (decl) = *fndecl;
+ DECL_RESULT (*fndecl) = decl;
- pushdecl (fndecl);
- current_function_decl = fndecl;
- announce_function (fndecl);
+ pushdecl (*fndecl);
+ current_function_decl = *fndecl;
+ announce_function (*fndecl);
- rest_of_decl_compilation (fndecl, 0, 0);
- make_decl_rtl (fndecl);
- allocate_struct_function (fndecl, false);
+ rest_of_decl_compilation (*fndecl, 0, 0);
+ make_decl_rtl (*fndecl);
+ allocate_struct_function (*fndecl, false);
pushlevel ();
gfc_init_block (&caf_init_block);
+}
- gfc_traverse_ns (ns, generate_coarray_sym_init);
+static void
+finish_coarray_constructor_function (tree *save_fn_decl, tree *fndecl)
+{
+ tree decl;
- DECL_SAVED_TREE (fndecl) = gfc_finish_block (&caf_init_block);
+ DECL_SAVED_TREE (*fndecl) = gfc_finish_block (&caf_init_block);
decl = getdecls ();
poplevel (1, 1);
- BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
+ BLOCK_SUPERCONTEXT (DECL_INITIAL (*fndecl)) = *fndecl;
- DECL_SAVED_TREE (fndecl)
- = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
- DECL_INITIAL (fndecl));
- dump_function (TDI_original, fndecl);
+ DECL_SAVED_TREE (*fndecl)
+ = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (*fndecl),
+ DECL_INITIAL (*fndecl));
+ dump_function (TDI_original, *fndecl);
cfun->function_end_locus = input_location;
set_cfun (NULL);
- if (decl_function_context (fndecl))
- (void) cgraph_node::create (fndecl);
+ if (decl_function_context (*fndecl))
+ (void) cgraph_node::create (*fndecl);
else
- cgraph_node::finalize_function (fndecl, true);
+ cgraph_node::finalize_function (*fndecl, true);
pop_function_context ();
- current_function_decl = save_fn_decl;
+ current_function_decl = *save_fn_decl;
+}
+
+/* Generate constructor function to initialize static, nonallocatable
+ coarrays. */
+
+static void
+generate_coarray_init (gfc_namespace * ns)
+{
+ tree save_fn_decl, fndecl;
+
+ generate_coarray_constructor_function (&save_fn_decl, &fndecl);
+
+ gfc_traverse_ns (ns, generate_coarray_sym_init);
+
+ finish_coarray_constructor_function (&save_fn_decl, &fndecl);
+
}
@@ -6470,7 +6660,11 @@ create_main_function (tree fndecl)
}
/* Call MAIN__(). */
- tmp = build_call_expr_loc (input_location,
+ if (flag_coarray == GFC_FCOARRAY_NATIVE)
+ tmp = build_call_expr_loc (input_location, gfor_fndecl_nca_master, 1,
+ gfc_build_addr_expr (NULL, fndecl));
+ else
+ tmp = build_call_expr_loc (input_location,
fndecl, 0);
gfc_add_expr_to_block (&body, tmp);
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 36ff9b5..9979980 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -2622,8 +2622,14 @@ gfc_maybe_dereference_var (gfc_symbol *sym, tree var, bool descriptor_only_p,
}
else if (!sym->attr.value)
{
+
+ /* Do not derefernce native coarray dummies. */
+ if (false && flag_coarray == GFC_FCOARRAY_NATIVE
+ && sym->attr.codimension && sym->attr.dummy)
+ return var;
+
/* Dereference temporaries for class array dummy arguments. */
- if (sym->attr.dummy && is_classarray
+ else if (sym->attr.dummy && is_classarray
&& GFC_ARRAY_TYPE_P (TREE_TYPE (var)))
{
if (!descriptor_only_p)
@@ -2635,6 +2641,7 @@ gfc_maybe_dereference_var (gfc_symbol *sym, tree var, bool descriptor_only_p,
/* Dereference non-character scalar dummy arguments. */
if (sym->attr.dummy && !sym->attr.dimension
&& !(sym->attr.codimension && sym->attr.allocatable)
+ && !(sym->attr.codimension && flag_coarray == GFC_FCOARRAY_NATIVE)
&& (sym->ts.type != BT_CLASS
|| (!CLASS_DATA (sym)->attr.dimension
&& !(CLASS_DATA (sym)->attr.codimension
@@ -2670,6 +2677,7 @@ gfc_maybe_dereference_var (gfc_symbol *sym, tree var, bool descriptor_only_p,
|| CLASS_DATA (sym)->attr.allocatable
|| CLASS_DATA (sym)->attr.class_pointer))
var = build_fold_indirect_ref_loc (input_location, var);
+
/* And the case where a non-dummy, non-result, non-function,
non-allotable and non-pointer classarray is present. This case was
previously covered by the first if, but with introducing the
@@ -5528,7 +5536,10 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
nodesc_arg = nodesc_arg || !comp->attr.always_explicit;
else
nodesc_arg = nodesc_arg || !sym->attr.always_explicit;
-
+#if 0
+ if (flag_coarray == GFC_FCOARRAY_NATIVE && fsym->attr.codimension)
+ nodesc_arg = false;
+#endif
/* Class array expressions are sometimes coming completely unadorned
with either arrayspec or _data component. Correct that here.
OOP-TODO: Move this to the frontend. */
@@ -5720,7 +5731,10 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
parmse.want_coarray = 1;
scalar = false;
}
-
+#if 0
+ if (flag_coarray == GFC_FCOARRAY_NATIVE && fsym->attr.codimension)
+ scalar = false;
+#endif
/* A scalar or transformational function. */
if (scalar)
{
@@ -6233,7 +6247,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
else
gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym,
sym->name, NULL);
-
+
/* Unallocated allocatable arrays and unassociated pointer arrays
need their dtype setting if they are argument associated with
assumed rank dummies. */
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 32fe988..b418321 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -41,6 +41,7 @@ along with GCC; see the file COPYING3. If not see
#include "trans-array.h"
#include "dependency.h" /* For CAF array alias analysis. */
/* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
+#include "trans-stmt.h"
/* This maps Fortran intrinsic math functions to external library or GCC
builtin functions. */
@@ -2363,7 +2364,6 @@ conv_caf_send (gfc_code *code) {
return gfc_finish_block (&block);
}
-
static void
trans_this_image (gfc_se * se, gfc_expr *expr)
{
@@ -2394,14 +2394,18 @@ trans_this_image (gfc_se * se, gfc_expr *expr)
}
else
tmp = integer_zero_node;
- tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
- tmp);
+ tmp = build_call_expr_loc (input_location,
+ flag_coarray == GFC_FCOARRAY_NATIVE ?
+ gfor_fndecl_nca_this_image :
+ gfor_fndecl_caf_this_image,
+ 1, tmp);
se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind),
tmp);
return;
}
/* Coarray-argument version: THIS_IMAGE(coarray [, dim]). */
+ /* TODO: NCA handle native coarrays. */
type = gfc_get_int_type (gfc_default_integer_kind);
corank = gfc_get_corank (expr->value.function.actual->expr);
@@ -2490,8 +2494,11 @@ trans_this_image (gfc_se * se, gfc_expr *expr)
*/
/* this_image () - 1. */
- tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
- integer_zero_node);
+ tmp = build_call_expr_loc (input_location,
+ flag_coarray == GFC_FCOARRAY_NATIVE
+ ? gfor_fndecl_nca_this_image
+ : gfor_fndecl_caf_this_image,
+ 1, integer_zero_node);
tmp = fold_build2_loc (input_location, MINUS_EXPR, type,
fold_convert (type, tmp), build_int_cst (type, 1));
if (corank == 1)
@@ -2774,7 +2781,10 @@ trans_image_index (gfc_se * se, gfc_expr *expr)
num_images = build_int_cst (type, 1);
else
{
- tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2,
+ tmp = build_call_expr_loc (input_location,
+ flag_coarray == GFC_FCOARRAY_NATIVE
+ ? gfor_fndecl_nca_num_images
+ : gfor_fndecl_caf_num_images, 2,
integer_zero_node,
build_int_cst (integer_type_node, -1));
num_images = fold_convert (type, tmp);
@@ -2819,8 +2829,13 @@ trans_num_images (gfc_se * se, gfc_expr *expr)
}
else
failed = build_int_cst (integer_type_node, -1);
- tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2,
- distance, failed);
+
+ if (flag_coarray == GFC_FCOARRAY_NATIVE)
+ tmp = build_call_expr_loc (input_location, gfor_fndecl_nca_num_images, 1,
+ distance);
+ else
+ tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2,
+ distance, failed);
se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
}
@@ -3264,7 +3279,10 @@ conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr)
tree cosize;
cosize = gfc_conv_descriptor_cosize (desc, arg->expr->rank, corank);
- tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images,
+ tmp = build_call_expr_loc (input_location,
+ flag_coarray == GFC_FCOARRAY_NATIVE
+ ? gfor_fndecl_nca_num_images
+ : gfor_fndecl_caf_num_images,
2, integer_zero_node,
build_int_cst (integer_type_node, -1));
tmp = fold_build2_loc (input_location, MINUS_EXPR,
@@ -3280,7 +3298,9 @@ conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr)
else if (flag_coarray != GFC_FCOARRAY_SINGLE)
{
/* ubound = lbound + num_images() - 1. */
- tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images,
+ tmp = build_call_expr_loc (input_location,
+ flag_coarray == GFC_FCOARRAY_NATIVE ? gfor_fndecl_nca_num_images :
+ gfor_fndecl_caf_num_images,
2, integer_zero_node,
build_int_cst (integer_type_node, -1));
tmp = fold_build2_loc (input_location, MINUS_EXPR,
@@ -11004,6 +11024,136 @@ gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
}
}
+/* Helper function - advance to the next argument. */
+
+static tree
+trans_argument (gfc_actual_arglist **curr_al, stmtblock_t *blk,
+ stmtblock_t *postblk, gfc_se *argse, tree def)
+{
+ if (!(*curr_al)->expr)
+ return def;
+ if ((*curr_al)->expr->rank > 0)
+ gfc_conv_expr_descriptor (argse, (*curr_al)->expr);
+ else
+ gfc_conv_expr (argse, (*curr_al)->expr);
+ gfc_add_block_to_block (blk, &argse->pre);
+ gfc_add_block_to_block (postblk, &argse->post);
+ *curr_al = (*curr_al)->next;
+ return argse->expr;
+}
+
+/* Convert CO_REDUCE for native coarrays. */
+
+static tree
+conv_nca_reduce (gfc_code *code, stmtblock_t *blk, stmtblock_t *postblk)
+{
+ gfc_actual_arglist *curr_al;
+ tree var, reduce_op, result_image, elem_size;
+ gfc_se argse;
+ int is_array;
+
+ curr_al = code->ext.actual;
+
+ gfc_init_se (&argse, NULL);
+ argse.want_pointer = 1;
+ is_array = curr_al->expr->rank > 0;
+ var = trans_argument (&curr_al, blk, postblk, &argse, NULL_TREE);
+
+ gfc_init_se (&argse, NULL);
+ argse.want_pointer = 1;
+ reduce_op = trans_argument (&curr_al, blk, postblk, &argse, NULL_TREE);
+
+ gfc_init_se (&argse, NULL);
+ argse.want_pointer = 1;
+ result_image = trans_argument (&curr_al, blk, postblk, &argse,
+ null_pointer_node);
+
+ if (is_array)
+ return build_call_expr_loc (input_location, gfor_fndecl_nca_reduce_array,
+ 3, var, reduce_op, result_image);
+
+ elem_size = size_in_bytes(TREE_TYPE(TREE_TYPE(var)));
+ return build_call_expr_loc (input_location, gfor_fndecl_nca_reduce_scalar, 4,
+ var, elem_size, reduce_op, result_image);
+}
+
+static tree
+conv_nca_broadcast (gfc_code *code, stmtblock_t *blk, stmtblock_t *postblk)
+{
+ gfc_actual_arglist *curr_al;
+ tree var, source_image, elem_size;
+ gfc_se argse;
+ int is_array;
+
+ curr_al = code->ext.actual;
+
+ gfc_init_se (&argse, NULL);
+ argse.want_pointer = 1;
+ is_array = curr_al->expr->rank > 0;
+ var = trans_argument (&curr_al, blk, postblk, &argse, NULL_TREE);
+
+ gfc_init_se (&argse, NULL);
+ argse.want_pointer = 0;
+ source_image = trans_argument (&curr_al, blk, postblk, &argse, NULL_TREE);
+
+ if (is_array)
+ return build_call_expr_loc (input_location, gfor_fndecl_nca_broadcast_array,
+ 2, var, source_image);
+
+ elem_size = size_in_bytes(TREE_TYPE(TREE_TYPE(var)));
+ return build_call_expr_loc (input_location, gfor_fndecl_nca_broadcast_scalar,
+ 3, var, elem_size, source_image);
+}
+
+static tree conv_co_collective (gfc_code *);
+
+/* Convert collective subroutines for native coarrays. */
+
+static tree
+conv_nca_collective (gfc_code *code)
+{
+
+ switch (code->resolved_isym->id)
+ {
+ case GFC_ISYM_CO_REDUCE:
+ {
+ stmtblock_t block, postblock;
+ tree fcall;
+
+ gfc_start_block (&block);
+ gfc_init_block (&postblock);
+ fcall = conv_nca_reduce (code, &block, &postblock);
+ gfc_add_expr_to_block (&block, fcall);
+ gfc_add_block_to_block (&block, &postblock);
+ return gfc_finish_block (&block);
+ }
+ case GFC_ISYM_CO_SUM:
+ case GFC_ISYM_CO_MIN:
+ case GFC_ISYM_CO_MAX:
+ return gfc_trans_call (code, false, NULL_TREE, NULL_TREE, false);
+
+ case GFC_ISYM_CO_BROADCAST:
+ {
+ stmtblock_t block, postblock;
+ tree fcall;
+
+ gfc_start_block (&block);
+ gfc_init_block (&postblock);
+ fcall = conv_nca_broadcast (code, &block, &postblock);
+ gfc_add_expr_to_block (&block, fcall);
+ gfc_add_block_to_block (&block, &postblock);
+ return gfc_finish_block (&block);
+ }
+#if 0
+ case GFC_ISYM_CO_BROADCAST:
+ return conv_co_collective (code);
+#endif
+ default:
+ gfc_internal_error ("Invalid or unsupported isym");
+ break;
+ }
+}
+
static tree
conv_co_collective (gfc_code *code)
{
@@ -11111,7 +11261,13 @@ conv_co_collective (gfc_code *code)
errmsg_len = build_zero_cst (size_type_node);
}
+ /* For native coarrays, we only come here for CO_BROADCAST. */
+
+ gcc_assert (code->resolved_isym->id == GFC_ISYM_CO_BROADCAST
+ || flag_coarray != GFC_FCOARRAY_NATIVE);
+
/* Generate the function call. */
+
switch (code->resolved_isym->id)
{
case GFC_ISYM_CO_BROADCAST:
@@ -12104,7 +12260,10 @@ gfc_conv_intrinsic_subroutine (gfc_code *code)
case GFC_ISYM_CO_MAX:
case GFC_ISYM_CO_REDUCE:
case GFC_ISYM_CO_SUM:
- res = conv_co_collective (code);
+ if (flag_coarray == GFC_FCOARRAY_NATIVE)
+ res = conv_nca_collective (code);
+ else
+ res = conv_co_collective (code);
break;
case GFC_ISYM_FREE:
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 1f183b9..4897fa1 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -830,7 +830,9 @@ gfc_trans_lock_unlock (gfc_code *code, gfc_exec_op op)
/* Short cut: For single images without STAT= or LOCK_ACQUIRED
return early. (ERRMSG= is always untouched for -fcoarray=single.) */
- if (!code->expr2 && !code->expr4 && flag_coarray != GFC_FCOARRAY_LIB)
+ if (!code->expr2 && !code->expr4
+ && !(flag_coarray == GFC_FCOARRAY_LIB
+ || flag_coarray == GFC_FCOARRAY_NATIVE))
return NULL_TREE;
if (code->expr2)
@@ -990,6 +992,29 @@ gfc_trans_lock_unlock (gfc_code *code, gfc_exec_op op)
return gfc_finish_block (&se.pre);
}
+ else if (flag_coarray == GFC_FCOARRAY_NATIVE)
+ {
+ gfc_se arg;
+ stmtblock_t res;
+ tree call;
+ tree tmp;
+
+ gfc_init_se (&arg, NULL);
+ gfc_start_block (&res);
+ gfc_conv_expr (&arg, code->expr1);
+ gfc_add_block_to_block (&res, &arg.pre);
+ call = build_call_expr_loc (input_location, op == EXEC_LOCK ?
+ gfor_fndecl_nca_lock
+ : gfor_fndecl_nca_unlock,
+ 1, fold_convert (pvoid_type_node,
+ gfc_build_addr_expr (NULL, arg.expr)));
+ gfc_add_expr_to_block (&res, call);
+ gfc_add_block_to_block (&res, &arg.post);
+ tmp = gfc_trans_memory_barrier ();
+ gfc_add_expr_to_block (&res, tmp);
+
+ return gfc_finish_block (&res);
+ }
if (stat != NULL_TREE)
gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0));
@@ -1183,7 +1208,8 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type)
/* Short cut: For single images without bound checking or without STAT=,
return early. (ERRMSG= is always untouched for -fcoarray=single.) */
if (!code->expr2 && !(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
- && flag_coarray != GFC_FCOARRAY_LIB)
+ && flag_coarray != GFC_FCOARRAY_LIB
+ && flag_coarray != GFC_FCOARRAY_NATIVE)
return NULL_TREE;
gfc_init_se (&se, NULL);
@@ -1206,7 +1232,7 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type)
else
stat = null_pointer_node;
- if (code->expr3 && flag_coarray == GFC_FCOARRAY_LIB)
+ if (code->expr3 && (flag_coarray == GFC_FCOARRAY_LIB || flag_coarray == GFC_FCOARRAY_NATIVE))
{
gcc_assert (code->expr3->expr_type == EXPR_VARIABLE);
gfc_init_se (&argse, NULL);
@@ -1216,7 +1242,7 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type)
errmsg = gfc_build_addr_expr (NULL, argse.expr);
errmsglen = fold_convert (size_type_node, argse.string_length);
}
- else if (flag_coarray == GFC_FCOARRAY_LIB)
+ else if (flag_coarray == GFC_FCOARRAY_LIB || flag_coarray == GFC_FCOARRAY_NATIVE)
{
errmsg = null_pointer_node;
errmsglen = build_int_cst (size_type_node, 0);
@@ -1229,7 +1255,7 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type)
{
tree images2 = fold_convert (integer_type_node, images);
tree cond;
- if (flag_coarray != GFC_FCOARRAY_LIB)
+ if (flag_coarray != GFC_FCOARRAY_LIB && flag_coarray != GFC_FCOARRAY_NATIVE)
cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
images, build_int_cst (TREE_TYPE (images), 1));
else
@@ -1253,17 +1279,13 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type)
/* Per F2008, 8.5.1, a SYNC MEMORY is implied by calling the
image control statements SYNC IMAGES and SYNC ALL. */
- if (flag_coarray == GFC_FCOARRAY_LIB)
+ if (flag_coarray == GFC_FCOARRAY_LIB || flag_coarray == GFC_FCOARRAY_NATIVE)
{
- tmp = gfc_build_string_const (strlen ("memory")+1, "memory"),
- tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
- gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
- tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
- ASM_VOLATILE_P (tmp) = 1;
+ tmp = gfc_trans_memory_barrier ();
gfc_add_expr_to_block (&se.pre, tmp);
}
- if (flag_coarray != GFC_FCOARRAY_LIB)
+ if (flag_coarray != GFC_FCOARRAY_LIB && flag_coarray != GFC_FCOARRAY_NATIVE)
{
/* Set STAT to zero. */
if (code->expr2)
@@ -1285,8 +1307,14 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type)
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_memory,
3, stat, errmsg, errmsglen);
else
- tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all,
- 3, stat, errmsg, errmsglen);
+ {
+ if (flag_coarray == GFC_FCOARRAY_LIB)
+ tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all,
+ 3, stat, errmsg, errmsglen);
+ else
+ tmp = build_call_expr_loc (input_location, gfor_fndecl_nca_sync_all,
+ 1, stat);
+ }
gfc_add_expr_to_block (&se.pre, tmp);
}
@@ -1351,7 +1379,10 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type)
if (TREE_TYPE (stat) == integer_type_node)
stat = gfc_build_addr_expr (NULL, stat);
- tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_images,
+ tmp = build_call_expr_loc (input_location,
+ flag_coarray == GFC_FCOARRAY_NATIVE
+ ? gfor_fndecl_nca_sync_images
+ : gfor_fndecl_caf_sync_images,
5, fold_convert (integer_type_node, len),
images, stat, errmsg, errmsglen);
gfc_add_expr_to_block (&se.pre, tmp);
@@ -1360,7 +1391,10 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type)
{
tree tmp_stat = gfc_create_var (integer_type_node, "stat");
- tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_images,
+ tmp = build_call_expr_loc (input_location,
+ flag_coarray == GFC_FCOARRAY_NATIVE
+ ? gfor_fndecl_nca_sync_images
+ : gfor_fndecl_caf_sync_images,
5, fold_convert (integer_type_node, len),
images, gfc_build_addr_expr (NULL, tmp_stat),
errmsg, errmsglen);
@@ -1596,6 +1630,11 @@ gfc_trans_critical (gfc_code *code)
gfc_add_expr_to_block (&block, tmp);
}
+ else if (flag_coarray == GFC_FCOARRAY_NATIVE)
+ {
+ tmp = gfc_trans_lock_unlock (code, EXEC_LOCK);
+ gfc_add_expr_to_block (&block, tmp);
+ }
tmp = gfc_trans_code (code->block->next);
gfc_add_expr_to_block (&block, tmp);
@@ -1620,6 +1659,11 @@ gfc_trans_critical (gfc_code *code)
gfc_add_expr_to_block (&block, tmp);
}
+ else if (flag_coarray == GFC_FCOARRAY_NATIVE)
+ {
+ tmp = gfc_trans_lock_unlock (code, EXEC_UNLOCK);
+ gfc_add_expr_to_block (&block, tmp);
+ }
return gfc_finish_block (&block);
}
@@ -7169,6 +7213,7 @@ gfc_trans_deallocate (gfc_code *code)
tree apstat, pstat, stat, errmsg, errlen, tmp;
tree label_finish, label_errmsg;
stmtblock_t block;
+ bool is_native_coarray = false;
pstat = apstat = stat = errmsg = errlen = tmp = NULL_TREE;
label_finish = label_errmsg = NULL_TREE;
@@ -7254,8 +7299,27 @@ gfc_trans_deallocate (gfc_code *code)
? GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY : 0);
}
}
+ else if (flag_coarray == GFC_FCOARRAY_NATIVE)
+ {
+ gfc_ref *ref, *last;
- if (expr->rank || is_coarray_array)
+ for (ref = expr->ref, last = ref; ref; last = ref, ref = ref->next);
+ ref = last;
+ if (ref->type == REF_ARRAY && ref->u.ar.codimen)
+ {
+ gfc_symbol *sym = expr->symtree->n.sym;
+ int alloc_type = gfc_native_coarray_get_allocation_type (sym);
+ tmp = build_call_expr_loc (input_location,
+ gfor_fndecl_nca_coarray_free,
+ 2, gfc_build_addr_expr (pvoid_type_node, se.expr),
+ build_int_cst (integer_type_node,
+ alloc_type));
+ gfc_add_expr_to_block (&block, tmp);
+ is_native_coarray = true;
+ }
+ }
+
+ if ((expr->rank || is_coarray_array) && !is_native_coarray)
{
gfc_ref *ref;
@@ -7344,7 +7408,7 @@ gfc_trans_deallocate (gfc_code *code)
gfc_reset_len (&se.pre, al->expr);
}
}
- else
+ else if (!is_native_coarray)
{
tmp = gfc_deallocate_scalar_with_status (se.expr, pstat, label_finish,
false, al->expr,
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index 26fdb28..f100d34 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -1345,6 +1345,10 @@ gfc_is_nodesc_array (gfc_symbol * sym)
gcc_assert (array_attr->dimension || array_attr->codimension);
+ /* We need a descriptor for native coarrays. */
+ if (flag_coarray == GFC_FCOARRAY_NATIVE && sym->as && sym->as->corank)
+ return 0;
+
/* We only want local arrays. */
if ((sym->ts.type != BT_CLASS && sym->attr.pointer)
|| (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer)
@@ -1381,12 +1385,18 @@ gfc_build_array_type (tree type, gfc_array_spec * as,
tree ubound[GFC_MAX_DIMENSIONS];
int n, corank;
- /* Assumed-shape arrays do not have codimension information stored in the
- descriptor. */
- corank = MAX (as->corank, codim);
- if (as->type == AS_ASSUMED_SHAPE ||
- (as->type == AS_ASSUMED_RANK && akind == GFC_ARRAY_ALLOCATABLE))
- corank = codim;
+ /* For -fcoarray=lib, assumed-shape arrays do not have codimension
+ information stored in the descriptor. */
+ if (flag_coarray != GFC_FCOARRAY_NATIVE)
+ {
+ corank = MAX (as->corank, codim);
+
+ if (as->type == AS_ASSUMED_SHAPE ||
+ (as->type == AS_ASSUMED_RANK && akind == GFC_ARRAY_ALLOCATABLE))
+ corank = codim;
+ }
+ else
+ corank = as->corank;
if (as->type == AS_ASSUMED_RANK)
for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
@@ -1427,7 +1437,7 @@ gfc_build_array_type (tree type, gfc_array_spec * as,
corank, lbound, ubound, 0, akind,
restricted);
}
-
+
/* Returns the struct descriptor_dimension type. */
static tree
@@ -1598,7 +1608,7 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed,
/* We don't use build_array_type because this does not include
lang-specific information (i.e. the bounds of the array) when checking
for duplicates. */
- if (as->rank)
+ if (as->rank || (flag_coarray == GFC_FCOARRAY_NATIVE && as->corank))
type = make_node (ARRAY_TYPE);
else
type = build_variant_type_copy (etype);
@@ -1665,6 +1675,7 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed,
if (packed == PACKED_NO || packed == PACKED_PARTIAL)
known_stride = 0;
}
+
for (n = as->rank; n < as->rank + as->corank; n++)
{
expr = as->lower[n];
@@ -1672,7 +1683,7 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed,
tmp = gfc_conv_mpz_to_tree (expr->value.integer,
gfc_index_integer_kind);
else
- tmp = NULL_TREE;
+ tmp = NULL_TREE;
GFC_TYPE_ARRAY_LBOUND (type, n) = tmp;
expr = as->upper[n];
@@ -1680,16 +1691,16 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed,
tmp = gfc_conv_mpz_to_tree (expr->value.integer,
gfc_index_integer_kind);
else
- tmp = NULL_TREE;
+ tmp = NULL_TREE;
if (n < as->rank + as->corank - 1)
- GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
+ GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
}
- if (known_offset)
- {
- GFC_TYPE_ARRAY_OFFSET (type) =
- gfc_conv_mpz_to_tree (offset, gfc_index_integer_kind);
- }
+ if (flag_coarray == GFC_FCOARRAY_NATIVE && as->rank == 0 && as->corank != 0)
+ GFC_TYPE_ARRAY_OFFSET (type) = NULL_TREE;
+ else if (known_offset)
+ GFC_TYPE_ARRAY_OFFSET (type) =
+ gfc_conv_mpz_to_tree (offset, gfc_index_integer_kind);
else
GFC_TYPE_ARRAY_OFFSET (type) = NULL_TREE;
@@ -1714,7 +1725,7 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed,
build_qualified_type (GFC_TYPE_ARRAY_DATAPTR_TYPE (type),
TYPE_QUAL_RESTRICT);
- if (as->rank == 0)
+ if (as->rank == 0 && (flag_coarray != GFC_FCOARRAY_NATIVE || as->corank == 0))
{
if (packed != PACKED_STATIC || flag_coarray == GFC_FCOARRAY_LIB)
{
@@ -1982,7 +1993,7 @@ gfc_get_array_type_bounds (tree etype, int dimen, int codimen, tree * lbound,
/* TODO: known offsets for descriptors. */
GFC_TYPE_ARRAY_OFFSET (fat_type) = NULL_TREE;
- if (dimen == 0)
+ if (flag_coarray != GFC_FCOARRAY_NATIVE && dimen == 0)
{
arraytype = build_pointer_type (etype);
if (restricted)
@@ -2281,6 +2292,10 @@ gfc_sym_type (gfc_symbol * sym)
: GFC_ARRAY_POINTER;
else if (sym->attr.allocatable)
akind = GFC_ARRAY_ALLOCATABLE;
+
+ /* FIXME: For normal coarrays, we pass a bool to an int here.
+ Is this really intended? */
+
type = gfc_build_array_type (type, sym->as, akind, restricted,
sym->attr.contiguous, false);
}
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index ed05426..2b60550 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -47,6 +47,21 @@ static gfc_file *gfc_current_backend_file;
const char gfc_msg_fault[] = N_("Array reference out of bounds");
const char gfc_msg_wrong_return[] = N_("Incorrect function return value");
+/* Insert a memory barrier into the code. */
+
+tree
+gfc_trans_memory_barrier (void)
+{
+ tree tmp;
+
+ tmp = gfc_build_string_const (strlen ("memory")+1, "memory"),
+ tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
+ gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
+ tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
+ ASM_VOLATILE_P (tmp) = 1;
+
+ return tmp;
+}
/* Return a location_t suitable for 'tree' for a gfortran locus. The way the
parser works in gfortran, loc->lb->location contains only the line number
@@ -403,15 +418,16 @@ gfc_build_array_ref (tree base, tree offset, tree decl, tree vptr)
tree tmp;
tree span = NULL_TREE;
- if (GFC_ARRAY_TYPE_P (type) && GFC_TYPE_ARRAY_RANK (type) == 0)
+ if (GFC_ARRAY_TYPE_P (type) && GFC_TYPE_ARRAY_RANK (type) == 0
+ && flag_coarray != GFC_FCOARRAY_NATIVE)
{
gcc_assert (GFC_TYPE_ARRAY_CORANK (type) > 0);
return fold_convert (TYPE_MAIN_VARIANT (type), base);
}
- /* Scalar coarray, there is nothing to do. */
- if (TREE_CODE (type) != ARRAY_TYPE)
+ /* Scalar library coarray, there is nothing to do. */
+ if (TREE_CODE (type) != ARRAY_TYPE && flag_coarray != GFC_FCOARRAY_NATIVE)
{
gcc_assert (decl == NULL_TREE);
gcc_assert (integer_zerop (offset));
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index d257963..974785f 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -501,6 +501,9 @@ void gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr,
bool add_clobber = false);
void gfc_conv_expr_type (gfc_se * se, gfc_expr *, tree);
+/* Insert a memory barrier into the code. */
+
+tree gfc_trans_memory_barrier (void);
/* trans-expr.c */
tree gfc_conv_scalar_to_descriptor (gfc_se *, tree, symbol_attribute);
@@ -890,6 +893,21 @@ extern GTY(()) tree gfor_fndecl_co_reduce;
extern GTY(()) tree gfor_fndecl_co_sum;
extern GTY(()) tree gfor_fndecl_caf_is_present;
+
+/* Native coarray library function decls. */
+extern GTY(()) tree gfor_fndecl_nca_this_image;
+extern GTY(()) tree gfor_fndecl_nca_num_images;
+extern GTY(()) tree gfor_fndecl_nca_coarray_allocate;
+extern GTY(()) tree gfor_fndecl_nca_coarray_free;
+extern GTY(()) tree gfor_fndecl_nca_sync_images;
+extern GTY(()) tree gfor_fndecl_nca_sync_all;
+extern GTY(()) tree gfor_fndecl_nca_lock;
+extern GTY(()) tree gfor_fndecl_nca_unlock;
+extern GTY(()) tree gfor_fndecl_nca_reduce_scalar;
+extern GTY(()) tree gfor_fndecl_nca_reduce_array;
+extern GTY(()) tree gfor_fndecl_nca_broadcast_scalar;
+extern GTY(()) tree gfor_fndecl_nca_broadcast_array;
+
/* Math functions. Many other math functions are handled in
trans-intrinsic.c. */