diff options
Diffstat (limited to 'gcc/fortran/openmp.c')
| -rw-r--r-- | gcc/fortran/openmp.c | 276 |
1 files changed, 246 insertions, 30 deletions
diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c index 4af139a..ffdce0b1 100644 --- a/gcc/fortran/openmp.c +++ b/gcc/fortran/openmp.c @@ -90,6 +90,25 @@ gfc_free_omp_clauses (gfc_omp_clauses *c) free (c); } +/* Free oacc_declare structures. */ + +void +gfc_free_oacc_declare_clauses (struct gfc_oacc_declare *oc) +{ + struct gfc_oacc_declare *decl = oc; + + do + { + struct gfc_oacc_declare *next; + + next = decl->next; + gfc_free_omp_clauses (decl->clauses); + free (decl); + decl = next; + } + while (decl); +} + /* Free expression list. */ void gfc_free_expr_list (gfc_expr_list *list) @@ -393,6 +412,109 @@ match_oacc_clause_gang (gfc_omp_clauses *cp) return gfc_match (" %e )", &cp->gang_expr); } +static match +gfc_match_oacc_clause_link (const char *str, gfc_omp_namelist **list) +{ + gfc_omp_namelist *head, *tail, *p; + locus old_loc; + char n[GFC_MAX_SYMBOL_LEN+1]; + gfc_symbol *sym; + match m; + gfc_symtree *st; + + old_loc = gfc_current_locus; + + m = gfc_match (str); + if (m != MATCH_YES) + return m; + + m = gfc_match (" ("); + + for (;;) + { + m = gfc_match_symbol (&sym, 0); + switch (m) + { + case MATCH_YES: + if (sym->attr.in_common) + { + gfc_error_now ("Variable at %C is an element of a COMMON block"); + goto cleanup; + } + gfc_set_sym_referenced (sym); + p = gfc_get_omp_namelist (); + if (head == NULL) + head = tail = p; + else + { + tail->next = p; + tail = tail->next; + } + tail->sym = sym; + tail->expr = NULL; + tail->where = gfc_current_locus; + goto next_item; + case MATCH_NO: + break; + + case MATCH_ERROR: + goto cleanup; + } + + m = gfc_match (" / %n /", n); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO || n[0] == '\0') + goto syntax; + + st = gfc_find_symtree (gfc_current_ns->common_root, n); + if (st == NULL) + { + gfc_error ("COMMON block /%s/ not found at %C", n); + goto cleanup; + } + + for (sym = st->n.common->head; sym; sym = sym->common_next) + { + gfc_set_sym_referenced (sym); + p = gfc_get_omp_namelist (); + if (head == NULL) + head = tail = p; + else + { + tail->next = p; + tail = tail->next; + } + tail->sym = sym; + tail->where = gfc_current_locus; + } + + next_item: + if (gfc_match_char (')') == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + } + + if (gfc_match_omp_eos () != MATCH_YES) + { + gfc_error ("Unexpected junk after !$ACC DECLARE at %C"); + goto cleanup; + } + + while (*list) + list = &(*list)->next; + *list = head; + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in !$ACC DECLARE list at %C"); + +cleanup: + gfc_current_locus = old_loc; + return MATCH_ERROR; +} + #define OMP_CLAUSE_PRIVATE ((uint64_t) 1 << 0) #define OMP_CLAUSE_FIRSTPRIVATE ((uint64_t) 1 << 1) #define OMP_CLAUSE_LASTPRIVATE ((uint64_t) 1 << 2) @@ -453,6 +575,7 @@ match_oacc_clause_gang (gfc_omp_clauses *cp) #define OMP_CLAUSE_DELETE ((uint64_t) 1 << 55) #define OMP_CLAUSE_AUTO ((uint64_t) 1 << 56) #define OMP_CLAUSE_TILE ((uint64_t) 1 << 57) +#define OMP_CLAUSE_LINK ((uint64_t) 1 << 58) /* Helper function for OpenACC and OpenMP clauses involving memory mapping. */ @@ -691,6 +814,11 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, uint64_t mask, true) == MATCH_YES) continue; + if ((mask & OMP_CLAUSE_LINK) + && gfc_match_oacc_clause_link ("link (", + &c->lists[OMP_LIST_LINK]) + == MATCH_YES) + continue; if ((mask & OMP_CLAUSE_OACC_DEVICE) && gfc_match ("device ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], @@ -1176,7 +1304,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, uint64_t mask, | OMP_CLAUSE_CREATE | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_DEVICE_RESIDENT \ | OMP_CLAUSE_PRESENT | OMP_CLAUSE_PRESENT_OR_COPY \ | OMP_CLAUSE_PRESENT_OR_COPYIN | OMP_CLAUSE_PRESENT_OR_COPYOUT \ - | OMP_CLAUSE_PRESENT_OR_CREATE) + | OMP_CLAUSE_PRESENT_OR_CREATE | OMP_CLAUSE_LINK) #define OACC_UPDATE_CLAUSES \ (OMP_CLAUSE_IF | OMP_CLAUSE_ASYNC | OMP_CLAUSE_HOST_SELF \ | OMP_CLAUSE_OACC_DEVICE | OMP_CLAUSE_WAIT) @@ -1293,12 +1421,80 @@ match gfc_match_oacc_declare (void) { gfc_omp_clauses *c; + gfc_omp_namelist *n; + gfc_namespace *ns = gfc_current_ns; + gfc_oacc_declare *new_oc; + bool module_var = false; + locus where = gfc_current_locus; + if (gfc_match_omp_clauses (&c, OACC_DECLARE_CLAUSES, false, false, true) != MATCH_YES) return MATCH_ERROR; - new_st.ext.omp_clauses = c; - new_st.ext.omp_clauses->loc = gfc_current_locus; + for (n = c->lists[OMP_LIST_DEVICE_RESIDENT]; n != NULL; n = n->next) + n->sym->attr.oacc_declare_device_resident = 1; + + for (n = c->lists[OMP_LIST_LINK]; n != NULL; n = n->next) + n->sym->attr.oacc_declare_link = 1; + + for (n = c->lists[OMP_LIST_MAP]; n != NULL; n = n->next) + { + gfc_symbol *s = n->sym; + + if (s->ns->proc_name && s->ns->proc_name->attr.proc == PROC_MODULE) + { + if (n->u.map_op != OMP_MAP_FORCE_ALLOC + && n->u.map_op != OMP_MAP_FORCE_TO) + { + gfc_error ("Invalid clause in module with $!ACC DECLARE at %L", + &where); + return MATCH_ERROR; + } + + module_var = true; + } + + if (s->attr.use_assoc) + { + gfc_error ("Variable is USE-associated with $!ACC DECLARE at %L", + &where); + return MATCH_ERROR; + } + + if ((s->attr.dimension || s->attr.codimension) + && s->attr.dummy && s->as->type != AS_EXPLICIT) + { + gfc_error ("Assumed-size dummy array with $!ACC DECLARE at %L", + &where); + return MATCH_ERROR; + } + + switch (n->u.map_op) + { + case OMP_MAP_FORCE_ALLOC: + s->attr.oacc_declare_create = 1; + break; + + case OMP_MAP_FORCE_TO: + s->attr.oacc_declare_copyin = 1; + break; + + case OMP_MAP_FORCE_DEVICEPTR: + s->attr.oacc_declare_deviceptr = 1; + break; + + default: + break; + } + } + + new_oc = gfc_get_oacc_declare (); + new_oc->next = ns->oacc_declare; + new_oc->module_var = module_var; + new_oc->clauses = c; + new_oc->loc = gfc_current_locus; + ns->oacc_declare = new_oc; + return MATCH_YES; } @@ -2870,7 +3066,7 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, static const char *clause_names[] = { "PRIVATE", "FIRSTPRIVATE", "LASTPRIVATE", "COPYPRIVATE", "SHARED", "COPYIN", "UNIFORM", "ALIGNED", "LINEAR", "DEPEND", "MAP", - "TO", "FROM", "REDUCTION", "DEVICE_RESIDENT", "USE_DEVICE", + "TO", "FROM", "REDUCTION", "DEVICE_RESIDENT", "LINK", "USE_DEVICE", "CACHE" }; if (omp_clauses == NULL) @@ -4613,44 +4809,64 @@ resolve_oacc_loop (gfc_code *code) resolve_oacc_nested_loops (code, do_code, collapse, "collapsed"); } - void gfc_resolve_oacc_declare (gfc_namespace *ns) { int list; gfc_omp_namelist *n; - locus loc; + gfc_oacc_declare *oc; - if (ns->oacc_declare_clauses == NULL) + if (ns->oacc_declare == NULL) return; - loc = ns->oacc_declare_clauses->loc; + for (oc = ns->oacc_declare; oc; oc = oc->next) + { + for (list = 0; list <= OMP_LIST_NUM; list++) + for (n = oc->clauses->lists[list]; n; n = n->next) + { + n->sym->mark = 0; + if (n->sym->attr.flavor == FL_PARAMETER) + { + gfc_error ("PARAMETER object %qs is not allowed at %L", + n->sym->name, &oc->loc); + continue; + } - for (list = OMP_LIST_DEVICE_RESIDENT; - list <= OMP_LIST_DEVICE_RESIDENT; list++) - for (n = ns->oacc_declare_clauses->lists[list]; n; n = n->next) - { - n->sym->mark = 0; - if (n->sym->attr.flavor == FL_PARAMETER) - gfc_error ("PARAMETER object %qs is not allowed at %L", n->sym->name, &loc); - } + if (n->expr && n->expr->ref->type == REF_ARRAY) + { + gfc_error ("Array sections: %qs not allowed in" + " $!ACC DECLARE at %L", n->sym->name, &oc->loc); + continue; + } + } - for (list = OMP_LIST_DEVICE_RESIDENT; - list <= OMP_LIST_DEVICE_RESIDENT; list++) - for (n = ns->oacc_declare_clauses->lists[list]; n; n = n->next) - { - if (n->sym->mark) - gfc_error ("Symbol %qs present on multiple clauses at %L", - n->sym->name, &loc); - else - n->sym->mark = 1; - } + for (n = oc->clauses->lists[OMP_LIST_DEVICE_RESIDENT]; n; n = n->next) + check_array_not_assumed (n->sym, oc->loc, "DEVICE_RESIDENT"); + } - for (n = ns->oacc_declare_clauses->lists[OMP_LIST_DEVICE_RESIDENT]; n; - n = n->next) - check_array_not_assumed (n->sym, loc, "DEVICE_RESIDENT"); -} + for (oc = ns->oacc_declare; oc; oc = oc->next) + { + for (list = 0; list <= OMP_LIST_NUM; list++) + for (n = oc->clauses->lists[list]; n; n = n->next) + { + if (n->sym->mark) + { + gfc_error ("Symbol %qs present on multiple clauses at %L", + n->sym->name, &oc->loc); + continue; + } + else + n->sym->mark = 1; + } + } + for (oc = ns->oacc_declare; oc; oc = oc->next) + { + for (list = 0; list <= OMP_LIST_NUM; list++) + for (n = oc->clauses->lists[list]; n; n = n->next) + n->sym->mark = 0; + } +} void gfc_resolve_oacc_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED) |