diff options
Diffstat (limited to 'gcc/fortran')
| -rw-r--r-- | gcc/fortran/dump-parse-tree.c | 51 | ||||
| -rw-r--r-- | gcc/fortran/gfortran.h | 9 | ||||
| -rw-r--r-- | gcc/fortran/match.c | 18 | ||||
| -rw-r--r-- | gcc/fortran/openmp.c | 307 | ||||
| -rw-r--r-- | gcc/fortran/st.c | 2 | ||||
| -rw-r--r-- | gcc/fortran/trans-openmp.c | 198 |
6 files changed, 491 insertions, 94 deletions
diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c index 874e6d4..93ff572 100644 --- a/gcc/fortran/dump-parse-tree.c +++ b/gcc/fortran/dump-parse-tree.c @@ -1298,10 +1298,55 @@ show_code (int level, gfc_code *c) } static void +show_iterator (gfc_namespace *ns) +{ + for (gfc_symbol *sym = ns->proc_name; sym; sym = sym->tlink) + { + gfc_constructor *c; + if (sym != ns->proc_name) + fputc (',', dumpfile); + fputs (sym->name, dumpfile); + fputc ('=', dumpfile); + c = gfc_constructor_first (sym->value->value.constructor); + show_expr (c->expr); + fputc (':', dumpfile); + c = gfc_constructor_next (c); + show_expr (c->expr); + c = gfc_constructor_next (c); + if (c) + { + fputc (':', dumpfile); + show_expr (c->expr); + } + } +} + +static void show_omp_namelist (int list_type, gfc_omp_namelist *n) { + gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns; + gfc_omp_namelist *n2 = n; for (; n; n = n->next) { + gfc_current_ns = ns_curr; + if (list_type == OMP_LIST_AFFINITY || list_type == OMP_LIST_DEPEND) + { + gfc_current_ns = n->u2.ns ? n->u2.ns : ns_curr; + if (n->u2.ns != ns_iter) + { + if (n != n2) + fputs (list_type == OMP_LIST_AFFINITY + ? ") AFFINITY(" : ") DEPEND(", dumpfile); + if (n->u2.ns) + { + fputs ("ITERATOR(", dumpfile); + show_iterator (n->u2.ns); + fputc (')', dumpfile); + fputc (list_type == OMP_LIST_AFFINITY ? ':' : ',', dumpfile); + } + } + ns_iter = n->u2.ns; + } if (list_type == OMP_LIST_REDUCTION) switch (n->u.reduction_op) { @@ -1321,8 +1366,8 @@ show_omp_namelist (int list_type, gfc_omp_namelist *n) case OMP_REDUCTION_IOR: fputs ("ior:", dumpfile); break; case OMP_REDUCTION_IEOR: fputs ("ieor:", dumpfile); break; case OMP_REDUCTION_USER: - if (n->udr) - fprintf (dumpfile, "%s:", n->udr->udr->name); + if (n->u2.udr) + fprintf (dumpfile, "%s:", n->u2.udr->udr->name); break; default: break; } @@ -1387,6 +1432,7 @@ show_omp_namelist (int list_type, gfc_omp_namelist *n) if (n->next) fputc (',', dumpfile); } + gfc_current_ns = ns_curr; } @@ -1610,6 +1656,7 @@ show_omp_clauses (gfc_omp_clauses *omp_clauses) case OMP_LIST_SHARED: type = "SHARED"; break; case OMP_LIST_COPYIN: type = "COPYIN"; break; case OMP_LIST_UNIFORM: type = "UNIFORM"; break; + case OMP_LIST_AFFINITY: type = "AFFINITY"; break; case OMP_LIST_ALIGNED: type = "ALIGNED"; break; case OMP_LIST_LINEAR: type = "LINEAR"; break; case OMP_LIST_DEPEND: type = "DEPEND"; break; diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index bab785b..55fba04 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -1257,7 +1257,11 @@ typedef struct gfc_omp_namelist struct gfc_common_head *common; bool lastprivate_conditional; } u; - struct gfc_omp_namelist_udr *udr; + union + { + struct gfc_omp_namelist_udr *udr; + gfc_namespace *ns; + } u2; struct gfc_omp_namelist *next; locus where; } @@ -1275,6 +1279,7 @@ enum OMP_LIST_SHARED, OMP_LIST_COPYIN, OMP_LIST_UNIFORM, + OMP_LIST_AFFINITY, OMP_LIST_ALIGNED, OMP_LIST_LINEAR, OMP_LIST_DEPEND, @@ -3321,7 +3326,7 @@ void gfc_free_iterator (gfc_iterator *, int); void gfc_free_forall_iterator (gfc_forall_iterator *); void gfc_free_alloc_list (gfc_alloc *); void gfc_free_namelist (gfc_namelist *); -void gfc_free_omp_namelist (gfc_omp_namelist *); +void gfc_free_omp_namelist (gfc_omp_namelist *, bool); void gfc_free_equiv (gfc_equiv *); void gfc_free_equiv_until (gfc_equiv *, gfc_equiv *); void gfc_free_data (gfc_data *); diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 393755e..2946201 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -5470,20 +5470,22 @@ gfc_free_namelist (gfc_namelist *name) /* Free an OpenMP namelist structure. */ void -gfc_free_omp_namelist (gfc_omp_namelist *name) +gfc_free_omp_namelist (gfc_omp_namelist *name, bool free_ns) { gfc_omp_namelist *n; for (; name; name = n) { gfc_free_expr (name->expr); - if (name->udr) - { - if (name->udr->combiner) - gfc_free_statement (name->udr->combiner); - if (name->udr->initializer) - gfc_free_statement (name->udr->initializer); - free (name->udr); + if (free_ns) + gfc_free_namespace (name->u2.ns); + else if (name->u2.udr) + { + if (name->u2.udr->combiner) + gfc_free_statement (name->u2.udr->combiner); + if (name->u2.udr->initializer) + gfc_free_statement (name->u2.udr->initializer); + free (name->u2.udr); } n = name->next; free (name); diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c index cf4d7ba..4ed6a0d 100644 --- a/gcc/fortran/openmp.c +++ b/gcc/fortran/openmp.c @@ -25,6 +25,7 @@ along with GCC; see the file COPYING3. If not see #include "arith.h" #include "match.h" #include "parse.h" +#include "constructor.h" #include "diagnostic.h" #include "gomp-constants.h" @@ -103,7 +104,8 @@ gfc_free_omp_clauses (gfc_omp_clauses *c) gfc_free_expr (c->num_workers_expr); gfc_free_expr (c->vector_length_expr); for (i = 0; i < OMP_LIST_NUM; i++) - gfc_free_omp_namelist (c->lists[i]); + gfc_free_omp_namelist (c->lists[i], + i == OMP_LIST_AFFINITY || i == OMP_LIST_DEPEND); gfc_free_expr_list (c->wait_list); gfc_free_expr_list (c->tile_list); free (CONST_CAST (char *, c->critical_name)); @@ -355,7 +357,7 @@ syntax: gfc_error ("Syntax error in OpenMP variable list at %C"); cleanup: - gfc_free_omp_namelist (head); + gfc_free_omp_namelist (head, false); gfc_current_locus = old_loc; return MATCH_ERROR; } @@ -445,7 +447,7 @@ syntax: gfc_error ("Syntax error in OpenMP variable list at %C"); cleanup: - gfc_free_omp_namelist (head); + gfc_free_omp_namelist (head, false); gfc_current_locus = old_loc; return MATCH_ERROR; } @@ -552,7 +554,7 @@ syntax: gfc_error ("Syntax error in OpenMP DEPEND SINK list at %C"); cleanup: - gfc_free_omp_namelist (head); + gfc_free_omp_namelist (head, false); gfc_current_locus = old_loc; return MATCH_ERROR; } @@ -843,6 +845,7 @@ enum omp_mask1 OMP_CLAUSE_CAPTURE, /* OpenMP 5.0. */ OMP_CLAUSE_MEMORDER, /* OpenMP 5.0. */ OMP_CLAUSE_DETACH, /* OpenMP 5.0. */ + OMP_CLAUSE_AFFINITY, /* OpenMP 5.0. */ OMP_CLAUSE_NOWAIT, /* This must come last. */ OMP_MASK1_LAST @@ -996,6 +999,132 @@ gfc_match_omp_map_clause (gfc_omp_namelist **list, gfc_omp_map_op map_op, return false; } +static match +gfc_match_iterator (gfc_namespace **ns, bool permit_var) +{ + locus old_loc = gfc_current_locus; + + if (gfc_match ("iterator ( ") != MATCH_YES) + return MATCH_NO; + + gfc_typespec ts; + gfc_symbol *last = NULL; + gfc_expr *begin, *end, *step; + *ns = gfc_build_block_ns (gfc_current_ns); + char name[GFC_MAX_SYMBOL_LEN + 1]; + while (true) + { + locus prev_loc = gfc_current_locus; + if (gfc_match_type_spec (&ts) == MATCH_YES + && gfc_match (" :: ") == MATCH_YES) + { + if (ts.type != BT_INTEGER) + { + gfc_error ("Expected INTEGER type at %L", &prev_loc); + return MATCH_ERROR; + } + permit_var = false; + } + else + { + ts.type = BT_INTEGER; + ts.kind = gfc_default_integer_kind; + gfc_current_locus = prev_loc; + } + prev_loc = gfc_current_locus; + if (gfc_match_name (name) != MATCH_YES) + { + gfc_error ("Expected identifier at %C"); + goto failed; + } + if (gfc_find_symtree ((*ns)->sym_root, name)) + { + gfc_error ("Same identifier %qs specified again at %C", name); + goto failed; + } + + gfc_symbol *sym = gfc_new_symbol (name, *ns); + if (last) + last->tlink = sym; + else + (*ns)->proc_name = sym; + last = sym; + sym->declared_at = prev_loc; + sym->ts = ts; + sym->attr.flavor = FL_VARIABLE; + sym->attr.artificial = 1; + sym->attr.referenced = 1; + sym->refs++; + gfc_symtree *st = gfc_new_symtree (&(*ns)->sym_root, name); + st->n.sym = sym; + + prev_loc = gfc_current_locus; + if (gfc_match (" = ") != MATCH_YES) + goto failed; + permit_var = false; + begin = end = step = NULL; + if (gfc_match ("%e : ", &begin) != MATCH_YES + || gfc_match ("%e ", &end) != MATCH_YES) + { + gfc_error ("Expected range-specification at %C"); + gfc_free_expr (begin); + gfc_free_expr (end); + return MATCH_ERROR; + } + if (':' == gfc_peek_ascii_char ()) + { + step = gfc_get_expr (); + if (gfc_match (": %e ", &step) != MATCH_YES) + { + gfc_free_expr (begin); + gfc_free_expr (end); + gfc_free_expr (step); + goto failed; + } + } + + gfc_expr *e = gfc_get_expr (); + e->where = prev_loc; + e->expr_type = EXPR_ARRAY; + e->ts = ts; + e->rank = 1; + e->shape = gfc_get_shape (1); + mpz_init_set_ui (e->shape[0], step ? 3 : 2); + gfc_constructor_append_expr (&e->value.constructor, begin, &begin->where); + gfc_constructor_append_expr (&e->value.constructor, end, &end->where); + if (step) + gfc_constructor_append_expr (&e->value.constructor, step, &step->where); + sym->value = e; + + if (gfc_match (") ") == MATCH_YES) + break; + if (gfc_match (", ") != MATCH_YES) + goto failed; + } + return MATCH_YES; + +failed: + gfc_namespace *prev_ns = NULL; + for (gfc_namespace *it = gfc_current_ns->contained; it; it = it->sibling) + { + if (it == *ns) + { + if (prev_ns) + prev_ns->sibling = it->sibling; + else + gfc_current_ns->contained = it->sibling; + gfc_free_namespace (it); + break; + } + prev_ns = it; + } + *ns = NULL; + if (!permit_var) + return MATCH_ERROR; + gfc_current_locus = old_loc; + return MATCH_NO; +} + /* reduction ( reduction-modifier, reduction-operator : variable-list ) in_reduction ( reduction-operator : variable-list ) task_reduction ( reduction-operator : variable-list ) */ @@ -1138,7 +1267,7 @@ gfc_match_omp_clause_reduction (char pc, gfc_omp_clauses *c, bool openacc, *head = NULL; gfc_error_now ("!$OMP DECLARE REDUCTION %s not found at %L", buffer, &old_loc); - gfc_free_omp_namelist (n); + gfc_free_omp_namelist (n, false); } else for (n = *head; n; n = n->next) @@ -1146,8 +1275,8 @@ gfc_match_omp_clause_reduction (char pc, gfc_omp_clauses *c, bool openacc, n->u.reduction_op = rop; if (udr) { - n->udr = gfc_get_omp_namelist_udr (); - n->udr->udr = udr; + n->u2.udr = gfc_get_omp_namelist_udr (); + n->u2.udr->udr = udr; } } return MATCH_YES; @@ -1202,7 +1331,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, if (end_colon && gfc_match (" %e )", &alignment) != MATCH_YES) { - gfc_free_omp_namelist (*head); + gfc_free_omp_namelist (*head, false); gfc_current_locus = old_loc; *head = NULL; break; @@ -1230,6 +1359,36 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, needs_space = true; continue; } + if ((mask & OMP_CLAUSE_AFFINITY) + && gfc_match ("affinity ( ") == MATCH_YES) + { + gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns; + match m = gfc_match_iterator (&ns_iter, true); + if (m == MATCH_ERROR) + break; + if (m == MATCH_YES && gfc_match (" : ") != MATCH_YES) + { + gfc_error ("Expected %<:%> at %C"); + break; + } + if (ns_iter) + gfc_current_ns = ns_iter; + head = NULL; + m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_AFFINITY], + false, NULL, &head, true); + gfc_current_ns = ns_curr; + if (m == MATCH_ERROR) + break; + if (ns_iter) + { + for (gfc_omp_namelist *n = *head; n; n = n->next) + { + n->u2.ns = ns_iter; + ns_iter->refs++; + } + } + continue; + } if ((mask & OMP_CLAUSE_ASYNC) && !c->async && gfc_match ("async") == MATCH_YES) @@ -1374,6 +1533,12 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, if ((mask & OMP_CLAUSE_DEPEND) && gfc_match ("depend ( ") == MATCH_YES) { + gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns; + match m_it = gfc_match_iterator (&ns_iter, false); + if (m_it == MATCH_ERROR) + break; + if (m_it == MATCH_YES && gfc_match (" , ") != MATCH_YES) + break; match m = MATCH_YES; gfc_omp_depend_op depend_op = OMP_DEPEND_OUT; if (gfc_match ("inout") == MATCH_YES) @@ -1389,11 +1554,24 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, else if (!c->depend_source && gfc_match ("source )") == MATCH_YES) { + if (m_it == MATCH_YES) + { + gfc_error ("ITERATOR may not be combined with SOURCE " + "at %C"); + gfc_free_omp_clauses (c); + return MATCH_ERROR; + } c->depend_source = true; continue; } else if (gfc_match ("sink : ") == MATCH_YES) { + if (m_it == MATCH_YES) + { + gfc_error ("ITERATOR may not be combined with SINK " + "at %C"); + break; + } if (gfc_match_omp_depend_sink (&c->lists[OMP_LIST_DEPEND]) == MATCH_YES) continue; @@ -1402,19 +1580,26 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, else m = MATCH_NO; head = NULL; - if (m == MATCH_YES - && gfc_match_omp_variable_list (" : ", - &c->lists[OMP_LIST_DEPEND], - false, NULL, &head, - true) == MATCH_YES) + if (ns_iter) + gfc_current_ns = ns_iter; + if (m == MATCH_YES) + m = gfc_match_omp_variable_list (" : ", + &c->lists[OMP_LIST_DEPEND], + false, NULL, &head, true); + gfc_current_ns = ns_curr; + if (m == MATCH_YES) { gfc_omp_namelist *n; for (n = *head; n; n = n->next) - n->u.depend_op = depend_op; + { + n->u.depend_op = depend_op; + n->u2.ns = ns_iter; + if (ns_iter) + ns_iter->refs++; + } continue; } - else - gfc_current_locus = old_loc; + break; } if ((mask & OMP_CLAUSE_DETACH) && !openacc @@ -1666,7 +1851,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, end_colon = true; else if (gfc_match (" )") != MATCH_YES) { - gfc_free_omp_namelist (*head); + gfc_free_omp_namelist (*head, false); gfc_current_locus = old_loc; *head = NULL; break; @@ -1674,7 +1859,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, } if (end_colon && gfc_match (" %e )", &step) != MATCH_YES) { - gfc_free_omp_namelist (*head); + gfc_free_omp_namelist (*head, false); gfc_current_locus = old_loc; *head = NULL; break; @@ -2844,7 +3029,7 @@ cleanup: | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF | OMP_CLAUSE_DEFAULT \ | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL | OMP_CLAUSE_MERGEABLE \ | OMP_CLAUSE_DEPEND | OMP_CLAUSE_PRIORITY | OMP_CLAUSE_IN_REDUCTION \ - | OMP_CLAUSE_DETACH) + | OMP_CLAUSE_DETACH | OMP_CLAUSE_AFFINITY) #define OMP_TASKLOOP_CLAUSES \ (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \ | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF \ @@ -3097,14 +3282,14 @@ gfc_match_omp_flush (void) { gfc_error ("List specified together with memory order clause in FLUSH " "directive at %C"); - gfc_free_omp_namelist (list); + gfc_free_omp_namelist (list, false); gfc_free_omp_clauses (c); return MATCH_ERROR; } if (gfc_match_omp_eos () != MATCH_YES) { gfc_error ("Unexpected junk after $OMP FLUSH statement at %C"); - gfc_free_omp_namelist (list); + gfc_free_omp_namelist (list, false); gfc_free_omp_clauses (c); return MATCH_ERROR; } @@ -4252,14 +4437,13 @@ gfc_match_omp_taskloop_simd (void) match gfc_match_omp_taskwait (void) { - if (gfc_match_omp_eos () != MATCH_YES) + if (gfc_match_omp_eos () == MATCH_YES) { - gfc_error ("Unexpected junk after TASKWAIT clause at %C"); - return MATCH_ERROR; + new_st.op = EXEC_OMP_TASKWAIT; + new_st.ext.omp_clauses = NULL; + return MATCH_YES; } - new_st.op = EXEC_OMP_TASKWAIT; - new_st.ext.omp_clauses = NULL; - return MATCH_YES; + return match_omp (EXEC_OMP_TASKWAIT, omp_mask (OMP_CLAUSE_DEPEND)); } @@ -4825,7 +5009,7 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, gfc_omp_linear_op linear_op = OMP_LINEAR_DEFAULT; static const char *clause_names[] = { "PRIVATE", "FIRSTPRIVATE", "LASTPRIVATE", "COPYPRIVATE", "SHARED", - "COPYIN", "UNIFORM", "ALIGNED", "LINEAR", "DEPEND", "MAP", + "COPYIN", "UNIFORM", "AFFINITY", "ALIGNED", "LINEAR", "DEPEND", "MAP", "TO", "FROM", "INCLUSIVE", "EXCLUSIVE", "REDUCTION", "REDUCTION" /*inscan*/, "REDUCTION" /*task*/, "IN_REDUCTION", "TASK_REDUCTION", @@ -5273,6 +5457,7 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, } } break; + case OMP_LIST_AFFINITY: case OMP_LIST_DEPEND: case OMP_LIST_MAP: case OMP_LIST_TO: @@ -5280,6 +5465,40 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, case OMP_LIST_CACHE: for (; n != NULL; n = n->next) { + if ((list == OMP_LIST_DEPEND || list == OMP_LIST_AFFINITY) + && n->u2.ns && !n->u2.ns->resolved) + { + n->u2.ns->resolved = 1; + for (gfc_symbol *sym = n->u2.ns->proc_name; sym; + sym = sym->tlink) + { + gfc_constructor *c; + c = gfc_constructor_first (sym->value->value.constructor); + if (!gfc_resolve_expr (c->expr) + || c->expr->ts.type != BT_INTEGER + || c->expr->rank != 0) + gfc_error ("Scalar integer expression for range begin" + " expected at %L", &c->expr->where); + c = gfc_constructor_next (c); + if (!gfc_resolve_expr (c->expr) + || c->expr->ts.type != BT_INTEGER + || c->expr->rank != 0) + gfc_error ("Scalar integer expression for range end " + "expected at %L", &c->expr->where); + c = gfc_constructor_next (c); + if (c && (!gfc_resolve_expr (c->expr) + || c->expr->ts.type != BT_INTEGER + || c->expr->rank != 0)) + gfc_error ("Scalar integer expression for range step " + "expected at %L", &c->expr->where); + else if (c + && c->expr->expr_type == EXPR_CONSTANT + && mpz_cmp_si (c->expr->value.integer, 0) == 0) + gfc_error ("Nonzero range step expected at %L", + &c->expr->where); + } + } + if (list == OMP_LIST_DEPEND) { if (n->u.depend_op == OMP_DEPEND_SINK_FIRST @@ -5421,7 +5640,8 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, n->sym->name, name, &n->where); break; } - else if (list == OMP_LIST_DEPEND + else if ((list == OMP_LIST_DEPEND + || list == OMP_LIST_AFFINITY) && ar->start[i] && ar->start[i]->expr_type == EXPR_CONSTANT && ar->end[i] @@ -5429,9 +5649,11 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, && mpz_cmp (ar->start[i]->value.integer, ar->end[i]->value.integer) > 0) { - gfc_error ("%qs in DEPEND clause at %L is a " + gfc_error ("%qs in %s clause at %L is a " "zero size array section", - n->sym->name, &n->where); + n->sym->name, + list == OMP_LIST_DEPEND + ? "DEPEND" : "AFFINITY", &n->where); break; } } @@ -5675,23 +5897,23 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, break; } if (!bad) - n->udr = NULL; + n->u2.udr = NULL; else { const char *udr_name = NULL; - if (n->udr) + if (n->u2.udr) { - udr_name = n->udr->udr->name; - n->udr->udr + udr_name = n->u2.udr->udr->name; + n->u2.udr->udr = gfc_find_omp_udr (NULL, udr_name, &n->sym->ts); - if (n->udr->udr == NULL) + if (n->u2.udr->udr == NULL) { - free (n->udr); - n->udr = NULL; + free (n->u2.udr); + n->u2.udr = NULL; } } - if (n->udr == NULL) + if (n->u2.udr == NULL) { if (udr_name == NULL) switch (n->u.reduction_op) @@ -5730,14 +5952,14 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, } else { - gfc_omp_udr *udr = n->udr->udr; + gfc_omp_udr *udr = n->u2.udr->udr; n->u.reduction_op = OMP_REDUCTION_USER; - n->udr->combiner + n->u2.udr->combiner = resolve_omp_udr_clause (n, udr->combiner_ns, udr->omp_out, udr->omp_in); if (udr->initializer_ns) - n->udr->initializer + n->u2.udr->initializer = resolve_omp_udr_clause (n, udr->initializer_ns, udr->omp_priv, @@ -7369,6 +7591,7 @@ gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns) case EXEC_OMP_TARGET_PARALLEL: case EXEC_OMP_TARGET_TEAMS: case EXEC_OMP_TASK: + case EXEC_OMP_TASKWAIT: case EXEC_OMP_TEAMS: case EXEC_OMP_WORKSHARE: case EXEC_OMP_DEPOBJ: diff --git a/gcc/fortran/st.c b/gcc/fortran/st.c index 02a81da..7d0e2c1 100644 --- a/gcc/fortran/st.c +++ b/gcc/fortran/st.c @@ -268,7 +268,7 @@ gfc_free_statement (gfc_code *p) break; case EXEC_OMP_FLUSH: - gfc_free_omp_namelist (p->ext.omp_namelist); + gfc_free_omp_namelist (p->ext.omp_namelist, false); break; case EXEC_OMP_BARRIER: diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c index 44542d9..7ea7aa3 100644 --- a/gcc/fortran/trans-openmp.c +++ b/gcc/fortran/trans-openmp.c @@ -35,6 +35,7 @@ along with GCC; see the file COPYING3. If not see #include "trans-array.h" #include "trans-const.h" #include "arith.h" +#include "constructor.h" #include "gomp-constants.h" #include "omp-general.h" #include "omp-low.h" @@ -1910,7 +1911,7 @@ gfc_trans_omp_array_reduction_or_udr (tree c, gfc_omp_namelist *n, locus where) locus old_loc = gfc_current_locus; const char *iname; bool t; - gfc_omp_udr *udr = n->udr ? n->udr->udr : NULL; + gfc_omp_udr *udr = n->u2.udr ? n->u2.udr->udr : NULL; decl = OMP_CLAUSE_DECL (c); gfc_current_locus = where; @@ -2029,9 +2030,9 @@ gfc_trans_omp_array_reduction_or_udr (tree c, gfc_omp_namelist *n, locus where) t = gfc_resolve_expr (e2); gcc_assert (t); } - else if (n->udr->initializer->op == EXEC_ASSIGN) + else if (n->u2.udr->initializer->op == EXEC_ASSIGN) { - e2 = gfc_copy_expr (n->udr->initializer->expr2); + e2 = gfc_copy_expr (n->u2.udr->initializer->expr2); t = gfc_resolve_expr (e2); gcc_assert (t); } @@ -2040,7 +2041,7 @@ gfc_trans_omp_array_reduction_or_udr (tree c, gfc_omp_namelist *n, locus where) struct omp_udr_find_orig_data cd; cd.omp_udr = udr; cd.omp_orig_seen = false; - gfc_code_walker (&n->udr->initializer, + gfc_code_walker (&n->u2.udr->initializer, gfc_dummy_code_callback, omp_udr_find_orig, &cd); if (cd.omp_orig_seen) OMP_CLAUSE_REDUCTION_OMP_ORIG_REF (c) = 1; @@ -2090,11 +2091,11 @@ gfc_trans_omp_array_reduction_or_udr (tree c, gfc_omp_namelist *n, locus where) iname = "ieor"; break; case ERROR_MARK: - if (n->udr->combiner->op == EXEC_ASSIGN) + if (n->u2.udr->combiner->op == EXEC_ASSIGN) { gfc_free_expr (e3); - e3 = gfc_copy_expr (n->udr->combiner->expr1); - e4 = gfc_copy_expr (n->udr->combiner->expr2); + e3 = gfc_copy_expr (n->u2.udr->combiner->expr1); + e4 = gfc_copy_expr (n->u2.udr->combiner->expr2); t = gfc_resolve_expr (e3); gcc_assert (t); t = gfc_resolve_expr (e4); @@ -2144,7 +2145,7 @@ gfc_trans_omp_array_reduction_or_udr (tree c, gfc_omp_namelist *n, locus where) if (e2) stmt = gfc_trans_assignment (e1, e2, false, false); else - stmt = gfc_trans_call (n->udr->initializer, false, + stmt = gfc_trans_call (n->u2.udr->initializer, false, NULL_TREE, NULL_TREE, false); if (TREE_CODE (stmt) != BIND_EXPR) stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); @@ -2157,7 +2158,7 @@ gfc_trans_omp_array_reduction_or_udr (tree c, gfc_omp_namelist *n, locus where) if (e4) stmt = gfc_trans_assignment (e3, e4, false, true); else - stmt = gfc_trans_call (n->udr->combiner, false, + stmt = gfc_trans_call (n->u2.udr->combiner, false, NULL_TREE, NULL_TREE, false); if (TREE_CODE (stmt) != BIND_EXPR) stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); @@ -2433,13 +2434,76 @@ gfc_trans_omp_array_section (stmtblock_t *block, gfc_omp_namelist *n, } static tree +handle_iterator (gfc_namespace *ns, stmtblock_t *iter_block, tree block) +{ + tree list = NULL_TREE; + for (gfc_symbol *sym = ns->proc_name; sym; sym = sym->tlink) + { + gfc_constructor *c; + gfc_se se; + + tree last = make_tree_vec (6); + tree iter_var = gfc_get_symbol_decl (sym); + tree type = TREE_TYPE (iter_var); + TREE_VEC_ELT (last, 0) = iter_var; + DECL_CHAIN (iter_var) = BLOCK_VARS (block); + BLOCK_VARS (block) = iter_var; + + /* begin */ + c = gfc_constructor_first (sym->value->value.constructor); + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, c->expr); + gfc_add_block_to_block (iter_block, &se.pre); + gfc_add_block_to_block (iter_block, &se.post); + TREE_VEC_ELT (last, 1) = fold_convert (type, + gfc_evaluate_now (se.expr, + iter_block)); + /* end */ + c = gfc_constructor_next (c); + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, c->expr); + gfc_add_block_to_block (iter_block, &se.pre); + gfc_add_block_to_block (iter_block, &se.post); + TREE_VEC_ELT (last, 2) = fold_convert (type, + gfc_evaluate_now (se.expr, + iter_block)); + /* step */ + c = gfc_constructor_next (c); + tree step; + if (c) + { + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, c->expr); + gfc_add_block_to_block (iter_block, &se.pre); + gfc_add_block_to_block (iter_block, &se.post); + gfc_conv_expr (&se, c->expr); + step = fold_convert (type, + gfc_evaluate_now (se.expr, + iter_block)); + } + else + step = build_int_cst (type, 1); + TREE_VEC_ELT (last, 3) = step; + /* orig_step */ + TREE_VEC_ELT (last, 4) = save_expr (step); + TREE_CHAIN (last) = list; + list = last; + } + return list; +} + +static tree gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, locus where, bool declare_simd = false, bool openacc = false) { - tree omp_clauses = NULL_TREE, chunk_size, c; + tree omp_clauses = NULL_TREE, prev_clauses, chunk_size, c; + tree iterator = NULL_TREE; + tree tree_block = NULL_TREE; + stmtblock_t iter_block; int list, ifc; enum omp_clause_code clause_code; + gfc_omp_namelist *prev = NULL; gfc_se se; if (clauses == NULL) @@ -2642,10 +2706,38 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, } } break; + case OMP_LIST_AFFINITY: case OMP_LIST_DEPEND: + iterator = NULL_TREE; + prev = NULL; + prev_clauses = omp_clauses; for (; n != NULL; n = n->next) { - if (n->u.depend_op == OMP_DEPEND_SINK_FIRST) + if (iterator && prev->u2.ns != n->u2.ns) + { + BLOCK_SUBBLOCKS (tree_block) = gfc_finish_block (&iter_block); + TREE_VEC_ELT (iterator, 5) = tree_block; + for (tree c = omp_clauses; c != prev_clauses; + c = OMP_CLAUSE_CHAIN (c)) + OMP_CLAUSE_DECL (c) = build_tree_list (iterator, + OMP_CLAUSE_DECL (c)); + prev_clauses = omp_clauses; + iterator = NULL_TREE; + } + if (n->u2.ns && (!prev || prev->u2.ns != n->u2.ns)) + { + gfc_init_block (&iter_block); + tree_block = make_node (BLOCK); + TREE_USED (tree_block) = 1; + BLOCK_VARS (tree_block) = NULL_TREE; + iterator = handle_iterator (n->u2.ns, block, + tree_block); + } + if (!iterator) + gfc_init_block (&iter_block); + prev = n; + if (list == OMP_LIST_DEPEND + && n->u.depend_op == OMP_DEPEND_SINK_FIRST) { tree vec = NULL_TREE; unsigned int i; @@ -2699,7 +2791,10 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, if (!n->sym->attr.referenced) continue; - tree node = build_omp_clause (input_location, OMP_CLAUSE_DEPEND); + tree node = build_omp_clause (input_location, + list == OMP_LIST_DEPEND + ? OMP_CLAUSE_DEPEND + : OMP_CLAUSE_AFFINITY); if (n->expr == NULL || n->expr->ref->u.ar.type == AR_FULL) { tree decl = gfc_trans_omp_variable (n->sym, false); @@ -2733,35 +2828,47 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, gfc_conv_expr_descriptor (&se, n->expr); ptr = gfc_conv_array_data (se.expr); } - gfc_add_block_to_block (block, &se.pre); - gfc_add_block_to_block (block, &se.post); + gfc_add_block_to_block (&iter_block, &se.pre); + gfc_add_block_to_block (&iter_block, &se.post); ptr = fold_convert (build_pointer_type (char_type_node), ptr); OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr); } - switch (n->u.depend_op) - { - case OMP_DEPEND_IN: - OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_IN; - break; - case OMP_DEPEND_OUT: - OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_OUT; - break; - case OMP_DEPEND_INOUT: - OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_INOUT; - break; - case OMP_DEPEND_MUTEXINOUTSET: - OMP_CLAUSE_DEPEND_KIND (node) - = OMP_CLAUSE_DEPEND_MUTEXINOUTSET; - break; - case OMP_DEPEND_DEPOBJ: - OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_DEPOBJ; - break; - default: - gcc_unreachable (); - } + if (list == OMP_LIST_DEPEND) + switch (n->u.depend_op) + { + case OMP_DEPEND_IN: + OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_IN; + break; + case OMP_DEPEND_OUT: + OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_OUT; + break; + case OMP_DEPEND_INOUT: + OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_INOUT; + break; + case OMP_DEPEND_MUTEXINOUTSET: + OMP_CLAUSE_DEPEND_KIND (node) + = OMP_CLAUSE_DEPEND_MUTEXINOUTSET; + break; + case OMP_DEPEND_DEPOBJ: + OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_DEPOBJ; + break; + default: + gcc_unreachable (); + } + if (!iterator) + gfc_add_block_to_block (block, &iter_block); omp_clauses = gfc_trans_add_clause (node, omp_clauses); } + if (iterator) + { + BLOCK_SUBBLOCKS (tree_block) = gfc_finish_block (&iter_block); + TREE_VEC_ELT (iterator, 5) = tree_block; + for (tree c = omp_clauses; c != prev_clauses; + c = OMP_CLAUSE_CHAIN (c)) + OMP_CLAUSE_DECL (c) = build_tree_list (iterator, + OMP_CLAUSE_DECL (c)); + } break; case OMP_LIST_MAP: for (; n != NULL; n = n->next) @@ -5857,10 +5964,23 @@ gfc_trans_omp_taskgroup (gfc_code *code) } static tree -gfc_trans_omp_taskwait (void) +gfc_trans_omp_taskwait (gfc_code *code) { - tree decl = builtin_decl_explicit (BUILT_IN_GOMP_TASKWAIT); - return build_call_expr_loc (input_location, decl, 0); + if (!code->ext.omp_clauses) + { + tree decl = builtin_decl_explicit (BUILT_IN_GOMP_TASKWAIT); + return build_call_expr_loc (input_location, decl, 0); + } + stmtblock_t block; + gfc_start_block (&block); + tree stmt = make_node (OMP_TASK); + TREE_TYPE (stmt) = void_type_node; + OMP_TASK_BODY (stmt) = NULL_TREE; + OMP_TASK_CLAUSES (stmt) = gfc_trans_omp_clauses (&block, + code->ext.omp_clauses, + code->loc); + gfc_add_expr_to_block (&block, stmt); + return gfc_finish_block (&block); } static tree @@ -6492,7 +6612,7 @@ gfc_trans_omp_directive (gfc_code *code) case EXEC_OMP_TASKLOOP_SIMD: return gfc_trans_omp_taskloop (code); case EXEC_OMP_TASKWAIT: - return gfc_trans_omp_taskwait (); + return gfc_trans_omp_taskwait (code); case EXEC_OMP_TASKYIELD: return gfc_trans_omp_taskyield (); case EXEC_OMP_TEAMS: |