diff options
author | I'm not telling you my name, idiot <git_is@stupid.com> | 2020-09-23 18:14:20 +0200 |
---|---|---|
committer | I'm not telling you my name, idiot <git_is@stupid.com> | 2020-09-23 18:14:20 +0200 |
commit | bef0a39f2f8e87780f990d12fa71f5ed0039267a (patch) | |
tree | ce8138e924d9bfff3ce0b63aa4c29397fbfaa1a5 /gcc | |
parent | 9044db88d634c631920eaa9f66c0275adf18fdf5 (diff) | |
download | gcc-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.h | 3 | ||||
-rw-r--r-- | gcc/fortran/dump-parse-tree.c | 2 | ||||
-rw-r--r-- | gcc/fortran/frontend-passes.c | 122 | ||||
-rw-r--r-- | gcc/fortran/gfortran.h | 1 | ||||
-rw-r--r-- | gcc/fortran/intrinsic.c | 10 | ||||
-rw-r--r-- | gcc/fortran/intrinsic.h | 6 | ||||
-rw-r--r-- | gcc/fortran/iresolve.c | 98 | ||||
-rw-r--r-- | gcc/fortran/lang.opt | 5 | ||||
-rw-r--r-- | gcc/fortran/resolve.c | 67 | ||||
-rw-r--r-- | gcc/fortran/trans-array.c | 288 | ||||
-rw-r--r-- | gcc/fortran/trans-array.h | 13 | ||||
-rw-r--r-- | gcc/fortran/trans-decl.c | 296 | ||||
-rw-r--r-- | gcc/fortran/trans-expr.c | 22 | ||||
-rw-r--r-- | gcc/fortran/trans-intrinsic.c | 181 | ||||
-rw-r--r-- | gcc/fortran/trans-stmt.c | 100 | ||||
-rw-r--r-- | gcc/fortran/trans-types.c | 51 | ||||
-rw-r--r-- | gcc/fortran/trans.c | 22 | ||||
-rw-r--r-- | gcc/fortran/trans.h | 18 |
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. */ |