| /* OpenMP directive matching and resolving. |
| Copyright (C) 2005-2019 Free Software Foundation, Inc. |
| Contributed by Jakub Jelinek |
| |
| This file is part of GCC. |
| |
| GCC is free software; you can redistribute it and/or modify it under |
| the terms of the GNU General Public License as published by the Free |
| Software Foundation; either version 3, or (at your option) any later |
| version. |
| |
| GCC is distributed in the hope that it will be useful, but WITHOUT ANY |
| WARRANTY; without even the implied warranty of MERCHANTABILITY or |
| FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License |
| for more details. |
| |
| You should have received a copy of the GNU General Public License |
| along with GCC; see the file COPYING3. If not see |
| <http://www.gnu.org/licenses/>. */ |
| |
| #include "config.h" |
| #include "system.h" |
| #include "coretypes.h" |
| #include "gfortran.h" |
| #include "arith.h" |
| #include "match.h" |
| #include "parse.h" |
| #include "diagnostic.h" |
| #include "gomp-constants.h" |
| |
| /* Match an end of OpenMP directive. End of OpenMP directive is optional |
| whitespace, followed by '\n' or comment '!'. */ |
| |
| match |
| gfc_match_omp_eos (void) |
| { |
| locus old_loc; |
| char c; |
| |
| old_loc = gfc_current_locus; |
| gfc_gobble_whitespace (); |
| |
| c = gfc_next_ascii_char (); |
| switch (c) |
| { |
| case '!': |
| do |
| c = gfc_next_ascii_char (); |
| while (c != '\n'); |
| /* Fall through */ |
| |
| case '\n': |
| return MATCH_YES; |
| } |
| |
| gfc_current_locus = old_loc; |
| return MATCH_NO; |
| } |
| |
| /* Free an omp_clauses structure. */ |
| |
| void |
| gfc_free_omp_clauses (gfc_omp_clauses *c) |
| { |
| int i; |
| if (c == NULL) |
| return; |
| |
| gfc_free_expr (c->if_expr); |
| gfc_free_expr (c->final_expr); |
| gfc_free_expr (c->num_threads); |
| gfc_free_expr (c->chunk_size); |
| gfc_free_expr (c->safelen_expr); |
| gfc_free_expr (c->simdlen_expr); |
| gfc_free_expr (c->num_teams); |
| gfc_free_expr (c->device); |
| gfc_free_expr (c->thread_limit); |
| gfc_free_expr (c->dist_chunk_size); |
| gfc_free_expr (c->grainsize); |
| gfc_free_expr (c->hint); |
| gfc_free_expr (c->num_tasks); |
| gfc_free_expr (c->priority); |
| for (i = 0; i < OMP_IF_LAST; i++) |
| gfc_free_expr (c->if_exprs[i]); |
| gfc_free_expr (c->async_expr); |
| gfc_free_expr (c->gang_num_expr); |
| gfc_free_expr (c->gang_static_expr); |
| gfc_free_expr (c->worker_expr); |
| gfc_free_expr (c->vector_expr); |
| gfc_free_expr (c->num_gangs_expr); |
| 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_expr_list (c->wait_list); |
| gfc_free_expr_list (c->tile_list); |
| free (CONST_CAST (char *, c->critical_name)); |
| 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) |
| { |
| gfc_expr_list *n; |
| |
| for (; list; list = n) |
| { |
| n = list->next; |
| free (list); |
| } |
| } |
| |
| /* Free an !$omp declare simd construct list. */ |
| |
| void |
| gfc_free_omp_declare_simd (gfc_omp_declare_simd *ods) |
| { |
| if (ods) |
| { |
| gfc_free_omp_clauses (ods->clauses); |
| free (ods); |
| } |
| } |
| |
| void |
| gfc_free_omp_declare_simd_list (gfc_omp_declare_simd *list) |
| { |
| while (list) |
| { |
| gfc_omp_declare_simd *current = list; |
| list = list->next; |
| gfc_free_omp_declare_simd (current); |
| } |
| } |
| |
| /* Free an !$omp declare reduction. */ |
| |
| void |
| gfc_free_omp_udr (gfc_omp_udr *omp_udr) |
| { |
| if (omp_udr) |
| { |
| gfc_free_omp_udr (omp_udr->next); |
| gfc_free_namespace (omp_udr->combiner_ns); |
| if (omp_udr->initializer_ns) |
| gfc_free_namespace (omp_udr->initializer_ns); |
| free (omp_udr); |
| } |
| } |
| |
| |
| static gfc_omp_udr * |
| gfc_find_omp_udr (gfc_namespace *ns, const char *name, gfc_typespec *ts) |
| { |
| gfc_symtree *st; |
| |
| if (ns == NULL) |
| ns = gfc_current_ns; |
| do |
| { |
| gfc_omp_udr *omp_udr; |
| |
| st = gfc_find_symtree (ns->omp_udr_root, name); |
| if (st != NULL) |
| { |
| for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next) |
| if (ts == NULL) |
| return omp_udr; |
| else if (gfc_compare_types (&omp_udr->ts, ts)) |
| { |
| if (ts->type == BT_CHARACTER) |
| { |
| if (omp_udr->ts.u.cl->length == NULL) |
| return omp_udr; |
| if (ts->u.cl->length == NULL) |
| continue; |
| if (gfc_compare_expr (omp_udr->ts.u.cl->length, |
| ts->u.cl->length, |
| INTRINSIC_EQ) != 0) |
| continue; |
| } |
| return omp_udr; |
| } |
| } |
| |
| /* Don't escape an interface block. */ |
| if (ns && !ns->has_import_set |
| && ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY) |
| break; |
| |
| ns = ns->parent; |
| } |
| while (ns != NULL); |
| |
| return NULL; |
| } |
| |
| |
| /* Match a variable/common block list and construct a namelist from it. */ |
| |
| static match |
| gfc_match_omp_variable_list (const char *str, gfc_omp_namelist **list, |
| bool allow_common, bool *end_colon = NULL, |
| gfc_omp_namelist ***headp = NULL, |
| bool allow_sections = false) |
| { |
| gfc_omp_namelist *head, *tail, *p; |
| locus old_loc, cur_loc; |
| char n[GFC_MAX_SYMBOL_LEN+1]; |
| gfc_symbol *sym; |
| match m; |
| gfc_symtree *st; |
| |
| head = tail = NULL; |
| |
| old_loc = gfc_current_locus; |
| |
| m = gfc_match (str); |
| if (m != MATCH_YES) |
| return m; |
| |
| for (;;) |
| { |
| cur_loc = gfc_current_locus; |
| m = gfc_match_symbol (&sym, 1); |
| switch (m) |
| { |
| case MATCH_YES: |
| gfc_expr *expr; |
| expr = NULL; |
| if (allow_sections && gfc_peek_ascii_char () == '(') |
| { |
| gfc_current_locus = cur_loc; |
| m = gfc_match_variable (&expr, 0); |
| switch (m) |
| { |
| case MATCH_ERROR: |
| goto cleanup; |
| case MATCH_NO: |
| goto syntax; |
| default: |
| break; |
| } |
| } |
| 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 = expr; |
| tail->where = cur_loc; |
| goto next_item; |
| case MATCH_NO: |
| break; |
| case MATCH_ERROR: |
| goto cleanup; |
| } |
| |
| if (!allow_common) |
| goto syntax; |
| |
| m = gfc_match (" / %n /", n); |
| if (m == MATCH_ERROR) |
| goto cleanup; |
| if (m == MATCH_NO) |
| 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 = cur_loc; |
| } |
| |
| next_item: |
| if (end_colon && gfc_match_char (':') == MATCH_YES) |
| { |
| *end_colon = true; |
| break; |
| } |
| if (gfc_match_char (')') == MATCH_YES) |
| break; |
| if (gfc_match_char (',') != MATCH_YES) |
| goto syntax; |
| } |
| |
| while (*list) |
| list = &(*list)->next; |
| |
| *list = head; |
| if (headp) |
| *headp = list; |
| return MATCH_YES; |
| |
| syntax: |
| gfc_error ("Syntax error in OpenMP variable list at %C"); |
| |
| cleanup: |
| gfc_free_omp_namelist (head); |
| gfc_current_locus = old_loc; |
| return MATCH_ERROR; |
| } |
| |
| /* Match a variable/procedure/common block list and construct a namelist |
| from it. */ |
| |
| static match |
| gfc_match_omp_to_link (const char *str, gfc_omp_namelist **list) |
| { |
| gfc_omp_namelist *head, *tail, *p; |
| locus old_loc, cur_loc; |
| char n[GFC_MAX_SYMBOL_LEN+1]; |
| gfc_symbol *sym; |
| match m; |
| gfc_symtree *st; |
| |
| head = tail = NULL; |
| |
| old_loc = gfc_current_locus; |
| |
| m = gfc_match (str); |
| if (m != MATCH_YES) |
| return m; |
| |
| for (;;) |
| { |
| cur_loc = gfc_current_locus; |
| m = gfc_match_symbol (&sym, 1); |
| switch (m) |
| { |
| case MATCH_YES: |
| p = gfc_get_omp_namelist (); |
| if (head == NULL) |
| head = tail = p; |
| else |
| { |
| tail->next = p; |
| tail = tail->next; |
| } |
| tail->sym = sym; |
| tail->where = cur_loc; |
| 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) |
| 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; |
| } |
| p = gfc_get_omp_namelist (); |
| if (head == NULL) |
| head = tail = p; |
| else |
| { |
| tail->next = p; |
| tail = tail->next; |
| } |
| tail->u.common = st->n.common; |
| tail->where = cur_loc; |
| |
| next_item: |
| if (gfc_match_char (')') == MATCH_YES) |
| break; |
| if (gfc_match_char (',') != MATCH_YES) |
| goto syntax; |
| } |
| |
| while (*list) |
| list = &(*list)->next; |
| |
| *list = head; |
| return MATCH_YES; |
| |
| syntax: |
| gfc_error ("Syntax error in OpenMP variable list at %C"); |
| |
| cleanup: |
| gfc_free_omp_namelist (head); |
| gfc_current_locus = old_loc; |
| return MATCH_ERROR; |
| } |
| |
| /* Match depend(sink : ...) construct a namelist from it. */ |
| |
| static match |
| gfc_match_omp_depend_sink (gfc_omp_namelist **list) |
| { |
| gfc_omp_namelist *head, *tail, *p; |
| locus old_loc, cur_loc; |
| gfc_symbol *sym; |
| |
| head = tail = NULL; |
| |
| old_loc = gfc_current_locus; |
| |
| for (;;) |
| { |
| cur_loc = gfc_current_locus; |
| switch (gfc_match_symbol (&sym, 1)) |
| { |
| case MATCH_YES: |
| gfc_set_sym_referenced (sym); |
| p = gfc_get_omp_namelist (); |
| if (head == NULL) |
| { |
| head = tail = p; |
| head->u.depend_op = OMP_DEPEND_SINK_FIRST; |
| } |
| else |
| { |
| tail->next = p; |
| tail = tail->next; |
| tail->u.depend_op = OMP_DEPEND_SINK; |
| } |
| tail->sym = sym; |
| tail->expr = NULL; |
| tail->where = cur_loc; |
| if (gfc_match_char ('+') == MATCH_YES) |
| { |
| if (gfc_match_literal_constant (&tail->expr, 0) != MATCH_YES) |
| goto syntax; |
| } |
| else if (gfc_match_char ('-') == MATCH_YES) |
| { |
| if (gfc_match_literal_constant (&tail->expr, 0) != MATCH_YES) |
| goto syntax; |
| tail->expr = gfc_uminus (tail->expr); |
| } |
| break; |
| case MATCH_NO: |
| goto syntax; |
| case MATCH_ERROR: |
| goto cleanup; |
| } |
| |
| if (gfc_match_char (')') == MATCH_YES) |
| break; |
| if (gfc_match_char (',') != MATCH_YES) |
| goto syntax; |
| } |
| |
| while (*list) |
| list = &(*list)->next; |
| |
| *list = head; |
| return MATCH_YES; |
| |
| syntax: |
| gfc_error ("Syntax error in OpenMP DEPEND SINK list at %C"); |
| |
| cleanup: |
| gfc_free_omp_namelist (head); |
| gfc_current_locus = old_loc; |
| return MATCH_ERROR; |
| } |
| |
| static match |
| match_oacc_expr_list (const char *str, gfc_expr_list **list, |
| bool allow_asterisk) |
| { |
| gfc_expr_list *head, *tail, *p; |
| locus old_loc; |
| gfc_expr *expr; |
| match m; |
| |
| head = tail = NULL; |
| |
| old_loc = gfc_current_locus; |
| |
| m = gfc_match (str); |
| if (m != MATCH_YES) |
| return m; |
| |
| for (;;) |
| { |
| m = gfc_match_expr (&expr); |
| if (m == MATCH_YES || allow_asterisk) |
| { |
| p = gfc_get_expr_list (); |
| if (head == NULL) |
| head = tail = p; |
| else |
| { |
| tail->next = p; |
| tail = tail->next; |
| } |
| if (m == MATCH_YES) |
| tail->expr = expr; |
| else if (gfc_match (" *") != MATCH_YES) |
| goto syntax; |
| goto next_item; |
| } |
| if (m == MATCH_ERROR) |
| goto cleanup; |
| goto syntax; |
| |
| next_item: |
| if (gfc_match_char (')') == MATCH_YES) |
| break; |
| if (gfc_match_char (',') != MATCH_YES) |
| goto syntax; |
| } |
| |
| while (*list) |
| list = &(*list)->next; |
| |
| *list = head; |
| return MATCH_YES; |
| |
| syntax: |
| gfc_error ("Syntax error in OpenACC expression list at %C"); |
| |
| cleanup: |
| gfc_free_expr_list (head); |
| gfc_current_locus = old_loc; |
| return MATCH_ERROR; |
| } |
| |
| static match |
| match_oacc_clause_gwv (gfc_omp_clauses *cp, unsigned gwv) |
| { |
| match ret = MATCH_YES; |
| |
| if (gfc_match (" ( ") != MATCH_YES) |
| return MATCH_NO; |
| |
| if (gwv == GOMP_DIM_GANG) |
| { |
| /* The gang clause accepts two optional arguments, num and static. |
| The num argument may either be explicit (num: <val>) or |
| implicit without (<val> without num:). */ |
| |
| while (ret == MATCH_YES) |
| { |
| if (gfc_match (" static :") == MATCH_YES) |
| { |
| if (cp->gang_static) |
| return MATCH_ERROR; |
| else |
| cp->gang_static = true; |
| if (gfc_match_char ('*') == MATCH_YES) |
| cp->gang_static_expr = NULL; |
| else if (gfc_match (" %e ", &cp->gang_static_expr) != MATCH_YES) |
| return MATCH_ERROR; |
| } |
| else |
| { |
| if (cp->gang_num_expr) |
| return MATCH_ERROR; |
| |
| /* The 'num' argument is optional. */ |
| gfc_match (" num :"); |
| |
| if (gfc_match (" %e ", &cp->gang_num_expr) != MATCH_YES) |
| return MATCH_ERROR; |
| } |
| |
| ret = gfc_match (" , "); |
| } |
| } |
| else if (gwv == GOMP_DIM_WORKER) |
| { |
| /* The 'num' argument is optional. */ |
| gfc_match (" num :"); |
| |
| if (gfc_match (" %e ", &cp->worker_expr) != MATCH_YES) |
| return MATCH_ERROR; |
| } |
| else if (gwv == GOMP_DIM_VECTOR) |
| { |
| /* The 'length' argument is optional. */ |
| gfc_match (" length :"); |
| |
| if (gfc_match (" %e ", &cp->vector_expr) != MATCH_YES) |
| return MATCH_ERROR; |
| } |
| else |
| gfc_fatal_error ("Unexpected OpenACC parallelism."); |
| |
| return gfc_match (" )"); |
| } |
| |
| static match |
| gfc_match_oacc_clause_link (const char *str, gfc_omp_namelist **list) |
| { |
| gfc_omp_namelist *head = NULL; |
| gfc_omp_namelist *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; |
| } |
| |
| /* OpenMP 4.5 clauses. */ |
| enum omp_mask1 |
| { |
| OMP_CLAUSE_PRIVATE, |
| OMP_CLAUSE_FIRSTPRIVATE, |
| OMP_CLAUSE_LASTPRIVATE, |
| OMP_CLAUSE_COPYPRIVATE, |
| OMP_CLAUSE_SHARED, |
| OMP_CLAUSE_COPYIN, |
| OMP_CLAUSE_REDUCTION, |
| OMP_CLAUSE_IF, |
| OMP_CLAUSE_NUM_THREADS, |
| OMP_CLAUSE_SCHEDULE, |
| OMP_CLAUSE_DEFAULT, |
| OMP_CLAUSE_ORDERED, |
| OMP_CLAUSE_COLLAPSE, |
| OMP_CLAUSE_UNTIED, |
| OMP_CLAUSE_FINAL, |
| OMP_CLAUSE_MERGEABLE, |
| OMP_CLAUSE_ALIGNED, |
| OMP_CLAUSE_DEPEND, |
| OMP_CLAUSE_INBRANCH, |
| OMP_CLAUSE_LINEAR, |
| OMP_CLAUSE_NOTINBRANCH, |
| OMP_CLAUSE_PROC_BIND, |
| OMP_CLAUSE_SAFELEN, |
| OMP_CLAUSE_SIMDLEN, |
| OMP_CLAUSE_UNIFORM, |
| OMP_CLAUSE_DEVICE, |
| OMP_CLAUSE_MAP, |
| OMP_CLAUSE_TO, |
| OMP_CLAUSE_FROM, |
| OMP_CLAUSE_NUM_TEAMS, |
| OMP_CLAUSE_THREAD_LIMIT, |
| OMP_CLAUSE_DIST_SCHEDULE, |
| OMP_CLAUSE_DEFAULTMAP, |
| OMP_CLAUSE_GRAINSIZE, |
| OMP_CLAUSE_HINT, |
| OMP_CLAUSE_IS_DEVICE_PTR, |
| OMP_CLAUSE_LINK, |
| OMP_CLAUSE_NOGROUP, |
| OMP_CLAUSE_NUM_TASKS, |
| OMP_CLAUSE_PRIORITY, |
| OMP_CLAUSE_SIMD, |
| OMP_CLAUSE_THREADS, |
| OMP_CLAUSE_USE_DEVICE_PTR, |
| OMP_CLAUSE_NOWAIT, |
| /* This must come last. */ |
| OMP_MASK1_LAST |
| }; |
| |
| /* OpenACC 2.0 specific clauses. */ |
| enum omp_mask2 |
| { |
| OMP_CLAUSE_ASYNC, |
| OMP_CLAUSE_NUM_GANGS, |
| OMP_CLAUSE_NUM_WORKERS, |
| OMP_CLAUSE_VECTOR_LENGTH, |
| OMP_CLAUSE_COPY, |
| OMP_CLAUSE_COPYOUT, |
| OMP_CLAUSE_CREATE, |
| OMP_CLAUSE_PRESENT, |
| OMP_CLAUSE_DEVICEPTR, |
| OMP_CLAUSE_GANG, |
| OMP_CLAUSE_WORKER, |
| OMP_CLAUSE_VECTOR, |
| OMP_CLAUSE_SEQ, |
| OMP_CLAUSE_INDEPENDENT, |
| OMP_CLAUSE_USE_DEVICE, |
| OMP_CLAUSE_DEVICE_RESIDENT, |
| OMP_CLAUSE_HOST_SELF, |
| OMP_CLAUSE_WAIT, |
| OMP_CLAUSE_DELETE, |
| OMP_CLAUSE_AUTO, |
| OMP_CLAUSE_TILE, |
| OMP_CLAUSE_IF_PRESENT, |
| OMP_CLAUSE_FINALIZE, |
| /* This must come last. */ |
| OMP_MASK2_LAST |
| }; |
| |
| struct omp_inv_mask; |
| |
| /* Customized bitset for up to 128-bits. |
| The two enums above provide bit numbers to use, and which of the |
| two enums it is determines which of the two mask fields is used. |
| Supported operations are defining a mask, like: |
| #define XXX_CLAUSES \ |
| (omp_mask (OMP_CLAUSE_XXX) | OMP_CLAUSE_YYY | OMP_CLAUSE_ZZZ) |
| oring such bitsets together or removing selected bits: |
| (XXX_CLAUSES | YYY_CLAUSES) & ~(omp_mask (OMP_CLAUSE_VVV)) |
| and testing individual bits: |
| if (mask & OMP_CLAUSE_UUU) */ |
| |
| struct omp_mask { |
| const uint64_t mask1; |
| const uint64_t mask2; |
| inline omp_mask (); |
| inline omp_mask (omp_mask1); |
| inline omp_mask (omp_mask2); |
| inline omp_mask (uint64_t, uint64_t); |
| inline omp_mask operator| (omp_mask1) const; |
| inline omp_mask operator| (omp_mask2) const; |
| inline omp_mask operator| (omp_mask) const; |
| inline omp_mask operator& (const omp_inv_mask &) const; |
| inline bool operator& (omp_mask1) const; |
| inline bool operator& (omp_mask2) const; |
| inline omp_inv_mask operator~ () const; |
| }; |
| |
| struct omp_inv_mask : public omp_mask { |
| inline omp_inv_mask (const omp_mask &); |
| }; |
| |
| omp_mask::omp_mask () : mask1 (0), mask2 (0) |
| { |
| } |
| |
| omp_mask::omp_mask (omp_mask1 m) : mask1 (((uint64_t) 1) << m), mask2 (0) |
| { |
| } |
| |
| omp_mask::omp_mask (omp_mask2 m) : mask1 (0), mask2 (((uint64_t) 1) << m) |
| { |
| } |
| |
| omp_mask::omp_mask (uint64_t m1, uint64_t m2) : mask1 (m1), mask2 (m2) |
| { |
| } |
| |
| omp_mask |
| omp_mask::operator| (omp_mask1 m) const |
| { |
| return omp_mask (mask1 | (((uint64_t) 1) << m), mask2); |
| } |
| |
| omp_mask |
| omp_mask::operator| (omp_mask2 m) const |
| { |
| return omp_mask (mask1, mask2 | (((uint64_t) 1) << m)); |
| } |
| |
| omp_mask |
| omp_mask::operator| (omp_mask m) const |
| { |
| return omp_mask (mask1 | m.mask1, mask2 | m.mask2); |
| } |
| |
| omp_mask |
| omp_mask::operator& (const omp_inv_mask &m) const |
| { |
| return omp_mask (mask1 & ~m.mask1, mask2 & ~m.mask2); |
| } |
| |
| bool |
| omp_mask::operator& (omp_mask1 m) const |
| { |
| return (mask1 & (((uint64_t) 1) << m)) != 0; |
| } |
| |
| bool |
| omp_mask::operator& (omp_mask2 m) const |
| { |
| return (mask2 & (((uint64_t) 1) << m)) != 0; |
| } |
| |
| omp_inv_mask |
| omp_mask::operator~ () const |
| { |
| return omp_inv_mask (*this); |
| } |
| |
| omp_inv_mask::omp_inv_mask (const omp_mask &m) : omp_mask (m) |
| { |
| } |
| |
| /* Helper function for OpenACC and OpenMP clauses involving memory |
| mapping. */ |
| |
| static bool |
| gfc_match_omp_map_clause (gfc_omp_namelist **list, gfc_omp_map_op map_op) |
| { |
| gfc_omp_namelist **head = NULL; |
| if (gfc_match_omp_variable_list ("", list, false, NULL, &head, true) |
| == MATCH_YES) |
| { |
| gfc_omp_namelist *n; |
| for (n = *head; n; n = n->next) |
| n->u.map_op = map_op; |
| return true; |
| } |
| |
| return false; |
| } |
| |
| /* Match OpenMP and OpenACC directive clauses. MASK is a bitmask of |
| clauses that are allowed for a particular directive. */ |
| |
| static match |
| gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, |
| bool first = true, bool needs_space = true, |
| bool openacc = false) |
| { |
| gfc_omp_clauses *c = gfc_get_omp_clauses (); |
| locus old_loc; |
| |
| gcc_checking_assert (OMP_MASK1_LAST <= 64 && OMP_MASK2_LAST <= 64); |
| *cp = NULL; |
| while (1) |
| { |
| if ((first || gfc_match_char (',') != MATCH_YES) |
| && (needs_space && gfc_match_space () != MATCH_YES)) |
| break; |
| needs_space = false; |
| first = false; |
| gfc_gobble_whitespace (); |
| bool end_colon; |
| gfc_omp_namelist **head; |
| old_loc = gfc_current_locus; |
| char pc = gfc_peek_ascii_char (); |
| switch (pc) |
| { |
| case 'a': |
| end_colon = false; |
| head = NULL; |
| if ((mask & OMP_CLAUSE_ALIGNED) |
| && gfc_match_omp_variable_list ("aligned (", |
| &c->lists[OMP_LIST_ALIGNED], |
| false, &end_colon, |
| &head) == MATCH_YES) |
| { |
| gfc_expr *alignment = NULL; |
| gfc_omp_namelist *n; |
| |
| if (end_colon && gfc_match (" %e )", &alignment) != MATCH_YES) |
| { |
| gfc_free_omp_namelist (*head); |
| gfc_current_locus = old_loc; |
| *head = NULL; |
| break; |
| } |
| for (n = *head; n; n = n->next) |
| if (n->next && alignment) |
| n->expr = gfc_copy_expr (alignment); |
| else |
| n->expr = alignment; |
| continue; |
| } |
| if ((mask & OMP_CLAUSE_ASYNC) |
| && !c->async |
| && gfc_match ("async") == MATCH_YES) |
| { |
| c->async = true; |
| match m = gfc_match (" ( %e )", &c->async_expr); |
| if (m == MATCH_ERROR) |
| { |
| gfc_current_locus = old_loc; |
| break; |
| } |
| else if (m == MATCH_NO) |
| { |
| c->async_expr |
| = gfc_get_constant_expr (BT_INTEGER, |
| gfc_default_integer_kind, |
| &gfc_current_locus); |
| mpz_set_si (c->async_expr->value.integer, GOMP_ASYNC_NOVAL); |
| needs_space = true; |
| } |
| continue; |
| } |
| if ((mask & OMP_CLAUSE_AUTO) |
| && !c->par_auto |
| && gfc_match ("auto") == MATCH_YES) |
| { |
| c->par_auto = true; |
| needs_space = true; |
| continue; |
| } |
| break; |
| case 'c': |
| if ((mask & OMP_CLAUSE_COLLAPSE) |
| && !c->collapse) |
| { |
| gfc_expr *cexpr = NULL; |
| match m = gfc_match ("collapse ( %e )", &cexpr); |
| |
| if (m == MATCH_YES) |
| { |
| int collapse; |
| if (gfc_extract_int (cexpr, &collapse, -1)) |
| collapse = 1; |
| else if (collapse <= 0) |
| { |
| gfc_error_now ("COLLAPSE clause argument not" |
| " constant positive integer at %C"); |
| collapse = 1; |
| } |
| c->collapse = collapse; |
| gfc_free_expr (cexpr); |
| continue; |
| } |
| } |
| if ((mask & OMP_CLAUSE_COPY) |
| && gfc_match ("copy ( ") == MATCH_YES |
| && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], |
| OMP_MAP_TOFROM)) |
| continue; |
| if (mask & OMP_CLAUSE_COPYIN) |
| { |
| if (openacc) |
| { |
| if (gfc_match ("copyin ( ") == MATCH_YES |
| && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], |
| OMP_MAP_TO)) |
| continue; |
| } |
| else if (gfc_match_omp_variable_list ("copyin (", |
| &c->lists[OMP_LIST_COPYIN], |
| true) == MATCH_YES) |
| continue; |
| } |
| if ((mask & OMP_CLAUSE_COPYOUT) |
| && gfc_match ("copyout ( ") == MATCH_YES |
| && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], |
| OMP_MAP_FROM)) |
| continue; |
| if ((mask & OMP_CLAUSE_COPYPRIVATE) |
| && gfc_match_omp_variable_list ("copyprivate (", |
| &c->lists[OMP_LIST_COPYPRIVATE], |
| true) == MATCH_YES) |
| continue; |
| if ((mask & OMP_CLAUSE_CREATE) |
| && gfc_match ("create ( ") == MATCH_YES |
| && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], |
| OMP_MAP_ALLOC)) |
| continue; |
| break; |
| case 'd': |
| if ((mask & OMP_CLAUSE_DEFAULT) |
| && c->default_sharing == OMP_DEFAULT_UNKNOWN) |
| { |
| if (gfc_match ("default ( none )") == MATCH_YES) |
| c->default_sharing = OMP_DEFAULT_NONE; |
| else if (openacc) |
| { |
| if (gfc_match ("default ( present )") == MATCH_YES) |
| c->default_sharing = OMP_DEFAULT_PRESENT; |
| } |
| else |
| { |
| if (gfc_match ("default ( firstprivate )") == MATCH_YES) |
| c->default_sharing = OMP_DEFAULT_FIRSTPRIVATE; |
| else if (gfc_match ("default ( private )") == MATCH_YES) |
| c->default_sharing = OMP_DEFAULT_PRIVATE; |
| else if (gfc_match ("default ( shared )") == MATCH_YES) |
| c->default_sharing = OMP_DEFAULT_SHARED; |
| } |
| if (c->default_sharing != OMP_DEFAULT_UNKNOWN) |
| continue; |
| } |
| if ((mask & OMP_CLAUSE_DEFAULTMAP) |
| && !c->defaultmap |
| && gfc_match ("defaultmap ( tofrom : scalar )") == MATCH_YES) |
| { |
| c->defaultmap = true; |
| continue; |
| } |
| if ((mask & OMP_CLAUSE_DELETE) |
| && gfc_match ("delete ( ") == MATCH_YES |
| && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], |
| OMP_MAP_RELEASE)) |
| continue; |
| if ((mask & OMP_CLAUSE_DEPEND) |
| && gfc_match ("depend ( ") == MATCH_YES) |
| { |
| match m = MATCH_YES; |
| gfc_omp_depend_op depend_op = OMP_DEPEND_OUT; |
| if (gfc_match ("inout") == MATCH_YES) |
| depend_op = OMP_DEPEND_INOUT; |
| else if (gfc_match ("in") == MATCH_YES) |
| depend_op = OMP_DEPEND_IN; |
| else if (gfc_match ("out") == MATCH_YES) |
| depend_op = OMP_DEPEND_OUT; |
| else if (!c->depend_source |
| && gfc_match ("source )") == MATCH_YES) |
| { |
| c->depend_source = true; |
| continue; |
| } |
| else if (gfc_match ("sink : ") == MATCH_YES) |
| { |
| if (gfc_match_omp_depend_sink (&c->lists[OMP_LIST_DEPEND]) |
| == MATCH_YES) |
| continue; |
| m = MATCH_NO; |
| } |
| 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) |
| { |
| gfc_omp_namelist *n; |
| for (n = *head; n; n = n->next) |
| n->u.depend_op = depend_op; |
| continue; |
| } |
| else |
| gfc_current_locus = old_loc; |
| } |
| if ((mask & OMP_CLAUSE_DEVICE) |
| && !openacc |
| && c->device == NULL |
| && gfc_match ("device ( %e )", &c->device) == MATCH_YES) |
| continue; |
| if ((mask & OMP_CLAUSE_DEVICE) |
| && openacc |
| && gfc_match ("device ( ") == MATCH_YES |
| && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], |
| OMP_MAP_FORCE_TO)) |
| continue; |
| if ((mask & OMP_CLAUSE_DEVICEPTR) |
| && gfc_match ("deviceptr ( ") == MATCH_YES |
| && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], |
| OMP_MAP_FORCE_DEVICEPTR)) |
| continue; |
| if ((mask & OMP_CLAUSE_DEVICE_RESIDENT) |
| && gfc_match_omp_variable_list |
| ("device_resident (", |
| &c->lists[OMP_LIST_DEVICE_RESIDENT], true) == MATCH_YES) |
| continue; |
| if ((mask & OMP_CLAUSE_DIST_SCHEDULE) |
| && c->dist_sched_kind == OMP_SCHED_NONE |
| && gfc_match ("dist_schedule ( static") == MATCH_YES) |
| { |
| match m = MATCH_NO; |
| c->dist_sched_kind = OMP_SCHED_STATIC; |
| m = gfc_match (" , %e )", &c->dist_chunk_size); |
| if (m != MATCH_YES) |
| m = gfc_match_char (')'); |
| if (m != MATCH_YES) |
| { |
| c->dist_sched_kind = OMP_SCHED_NONE; |
| gfc_current_locus = old_loc; |
| } |
| else |
| continue; |
| } |
| break; |
| case 'f': |
| if ((mask & OMP_CLAUSE_FINAL) |
| && c->final_expr == NULL |
| && gfc_match ("final ( %e )", &c->final_expr) == MATCH_YES) |
| continue; |
| if ((mask & OMP_CLAUSE_FINALIZE) |
| && !c->finalize |
| && gfc_match ("finalize") == MATCH_YES) |
| { |
| c->finalize = true; |
| needs_space = true; |
| continue; |
| } |
| if ((mask & OMP_CLAUSE_FIRSTPRIVATE) |
| && gfc_match_omp_variable_list ("firstprivate (", |
| &c->lists[OMP_LIST_FIRSTPRIVATE], |
| true) == MATCH_YES) |
| continue; |
| if ((mask & OMP_CLAUSE_FROM) |
| && gfc_match_omp_variable_list ("from (", |
| &c->lists[OMP_LIST_FROM], false, |
| NULL, &head, true) == MATCH_YES) |
| continue; |
| break; |
| case 'g': |
| if ((mask & OMP_CLAUSE_GANG) |
| && !c->gang |
| && gfc_match ("gang") == MATCH_YES) |
| { |
| c->gang = true; |
| match m = match_oacc_clause_gwv (c, GOMP_DIM_GANG); |
| if (m == MATCH_ERROR) |
| { |
| gfc_current_locus = old_loc; |
| break; |
| } |
| else if (m == MATCH_NO) |
| needs_space = true; |
| continue; |
| } |
| if ((mask & OMP_CLAUSE_GRAINSIZE) |
| && c->grainsize == NULL |
| && gfc_match ("grainsize ( %e )", &c->grainsize) == MATCH_YES) |
| continue; |
| break; |
| case 'h': |
| if ((mask & OMP_CLAUSE_HINT) |
| && c->hint == NULL |
| && gfc_match ("hint ( %e )", &c->hint) == MATCH_YES) |
| continue; |
| if ((mask & OMP_CLAUSE_HOST_SELF) |
| && gfc_match ("host ( ") == MATCH_YES |
| && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], |
| OMP_MAP_FORCE_FROM)) |
| continue; |
| break; |
| case 'i': |
| if ((mask & OMP_CLAUSE_IF) |
| && c->if_expr == NULL |
| && gfc_match ("if ( ") == MATCH_YES) |
| { |
| if (gfc_match ("%e )", &c->if_expr) == MATCH_YES) |
| continue; |
| if (!openacc) |
| { |
| /* This should match the enum gfc_omp_if_kind order. */ |
| static const char *ifs[OMP_IF_LAST] = { |
| " parallel : %e )", |
| " task : %e )", |
| " taskloop : %e )", |
| " target : %e )", |
| " target data : %e )", |
| " target update : %e )", |
| " target enter data : %e )", |
| " target exit data : %e )" }; |
| int i; |
| for (i = 0; i < OMP_IF_LAST; i++) |
| if (c->if_exprs[i] == NULL |
| && gfc_match (ifs[i], &c->if_exprs[i]) == MATCH_YES) |
| break; |
| if (i < OMP_IF_LAST) |
| continue; |
| } |
| gfc_current_locus = old_loc; |
| } |
| if ((mask & OMP_CLAUSE_IF_PRESENT) |
| && !c->if_present |
| && gfc_match ("if_present") == MATCH_YES) |
| { |
| c->if_present = true; |
| needs_space = true; |
| continue; |
| } |
| if ((mask & OMP_CLAUSE_INBRANCH) |
| && !c->inbranch |
| && !c->notinbranch |
| && gfc_match ("inbranch") == MATCH_YES) |
| { |
| c->inbranch = needs_space = true; |
| continue; |
| } |
| if ((mask & OMP_CLAUSE_INDEPENDENT) |
| && !c->independent |
| && gfc_match ("independent") == MATCH_YES) |
| { |
| c->independent = true; |
| needs_space = true; |
| continue; |
| } |
| if ((mask & OMP_CLAUSE_IS_DEVICE_PTR) |
| && gfc_match_omp_variable_list |
| ("is_device_ptr (", |
| &c->lists[OMP_LIST_IS_DEVICE_PTR], false) == MATCH_YES) |
| continue; |
| break; |
| case 'l': |
| if ((mask & OMP_CLAUSE_LASTPRIVATE) |
| && gfc_match_omp_variable_list ("lastprivate (", |
| &c->lists[OMP_LIST_LASTPRIVATE], |
| true) == MATCH_YES) |
| continue; |
| end_colon = false; |
| head = NULL; |
| if ((mask & OMP_CLAUSE_LINEAR) |
| && gfc_match ("linear (") == MATCH_YES) |
| { |
| gfc_omp_linear_op linear_op = OMP_LINEAR_DEFAULT; |
| gfc_expr *step = NULL; |
| |
| if (gfc_match_omp_variable_list (" ref (", |
| &c->lists[OMP_LIST_LINEAR], |
| false, NULL, &head) |
| == MATCH_YES) |
| linear_op = OMP_LINEAR_REF; |
| else if (gfc_match_omp_variable_list (" val (", |
| &c->lists[OMP_LIST_LINEAR], |
| false, NULL, &head) |
| == MATCH_YES) |
| linear_op = OMP_LINEAR_VAL; |
| else if (gfc_match_omp_variable_list (" uval (", |
| &c->lists[OMP_LIST_LINEAR], |
| false, NULL, &head) |
| == MATCH_YES) |
| linear_op = OMP_LINEAR_UVAL; |
| else if (gfc_match_omp_variable_list ("", |
| &c->lists[OMP_LIST_LINEAR], |
| false, &end_colon, &head) |
| == MATCH_YES) |
| linear_op = OMP_LINEAR_DEFAULT; |
| else |
| { |
| gfc_current_locus = old_loc; |
| break; |
| } |
| if (linear_op != OMP_LINEAR_DEFAULT) |
| { |
| if (gfc_match (" :") == MATCH_YES) |
| end_colon = true; |
| else if (gfc_match (" )") != MATCH_YES) |
| { |
| gfc_free_omp_namelist (*head); |
| gfc_current_locus = old_loc; |
| *head = NULL; |
| break; |
| } |
| } |
| if (end_colon && gfc_match (" %e )", &step) != MATCH_YES) |
| { |
| gfc_free_omp_namelist (*head); |
| gfc_current_locus = old_loc; |
| *head = NULL; |
| break; |
| } |
| else if (!end_colon) |
| { |
| step = gfc_get_constant_expr (BT_INTEGER, |
| gfc_default_integer_kind, |
| &old_loc); |
| mpz_set_si (step->value.integer, 1); |
| } |
| (*head)->expr = step; |
| if (linear_op != OMP_LINEAR_DEFAULT) |
| for (gfc_omp_namelist *n = *head; n; n = n->next) |
| n->u.linear_op = linear_op; |
| continue; |
| } |
| if ((mask & OMP_CLAUSE_LINK) |
| && openacc |
| && (gfc_match_oacc_clause_link ("link (", |
| &c->lists[OMP_LIST_LINK]) |
| == MATCH_YES)) |
| continue; |
| else if ((mask & OMP_CLAUSE_LINK) |
| && !openacc |
| && (gfc_match_omp_to_link ("link (", |
| &c->lists[OMP_LIST_LINK]) |
| == MATCH_YES)) |
| continue; |
| break; |
| case 'm': |
| if ((mask & OMP_CLAUSE_MAP) |
| && gfc_match ("map ( ") == MATCH_YES) |
| { |
| locus old_loc2 = gfc_current_locus; |
| bool always = false; |
| gfc_omp_map_op map_op = OMP_MAP_TOFROM; |
| if (gfc_match ("always , ") == MATCH_YES) |
| always = true; |
| if (gfc_match ("alloc : ") == MATCH_YES) |
| map_op = OMP_MAP_ALLOC; |
| else if (gfc_match ("tofrom : ") == MATCH_YES) |
| map_op = always ? OMP_MAP_ALWAYS_TOFROM : OMP_MAP_TOFROM; |
| else if (gfc_match ("to : ") == MATCH_YES) |
| map_op = always ? OMP_MAP_ALWAYS_TO : OMP_MAP_TO; |
| else if (gfc_match ("from : ") == MATCH_YES) |
| map_op = always ? OMP_MAP_ALWAYS_FROM : OMP_MAP_FROM; |
| else if (gfc_match ("release : ") == MATCH_YES) |
| map_op = OMP_MAP_RELEASE; |
| else if (gfc_match ("delete : ") == MATCH_YES) |
| map_op = OMP_MAP_DELETE; |
| else if (always) |
| { |
| gfc_current_locus = old_loc2; |
| always = false; |
| } |
| head = NULL; |
| if (gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_MAP], |
| false, NULL, &head, |
| true) == MATCH_YES) |
| { |
| gfc_omp_namelist *n; |
| for (n = *head; n; n = n->next) |
| n->u.map_op = map_op; |
| continue; |
| } |
| else |
| gfc_current_locus = old_loc; |
| } |
| if ((mask & OMP_CLAUSE_MERGEABLE) && !c->mergeable |
| && gfc_match ("mergeable") == MATCH_YES) |
| { |
| c->mergeable = needs_space = true; |
| continue; |
| } |
| break; |
| case 'n': |
| if ((mask & OMP_CLAUSE_NOGROUP) |
| && !c->nogroup |
| && gfc_match ("nogroup") == MATCH_YES) |
| { |
| c->nogroup = needs_space = true; |
| continue; |
| } |
| if ((mask & OMP_CLAUSE_NOTINBRANCH) |
| && !c->notinbranch |
| && !c->inbranch |
| && gfc_match ("notinbranch") == MATCH_YES) |
| { |
| c->notinbranch = needs_space = true; |
| continue; |
| } |
| if ((mask & OMP_CLAUSE_NOWAIT) |
| && !c->nowait |
| && gfc_match ("nowait") == MATCH_YES) |
| { |
| c->nowait = needs_space = true; |
| continue; |
| } |
| if ((mask & OMP_CLAUSE_NUM_GANGS) |
| && c->num_gangs_expr == NULL |
| && gfc_match ("num_gangs ( %e )", |
| &c->num_gangs_expr) == MATCH_YES) |
| continue; |
| if ((mask & OMP_CLAUSE_NUM_TASKS) |
| && c->num_tasks == NULL |
| && gfc_match ("num_tasks ( %e )", &c->num_tasks) == MATCH_YES) |
| continue; |
| if ((mask & OMP_CLAUSE_NUM_TEAMS) |
| && c->num_teams == NULL |
| && gfc_match ("num_teams ( %e )", &c->num_teams) == MATCH_YES) |
| continue; |
| if ((mask & OMP_CLAUSE_NUM_THREADS) |
| && c->num_threads == NULL |
| && (gfc_match ("num_threads ( %e )", &c->num_threads) |
| == MATCH_YES)) |
| continue; |
| if ((mask & OMP_CLAUSE_NUM_WORKERS) |
| && c->num_workers_expr == NULL |
| && gfc_match ("num_workers ( %e )", |
| &c->num_workers_expr) == MATCH_YES) |
| continue; |
| break; |
| case 'o': |
| if ((mask & OMP_CLAUSE_ORDERED) |
| && !c->ordered |
| && gfc_match ("ordered") == MATCH_YES) |
| { |
| gfc_expr *cexpr = NULL; |
| match m = gfc_match (" ( %e )", &cexpr); |
| |
| c->ordered = true; |
| if (m == MATCH_YES) |
| { |
| int ordered = 0; |
| if (gfc_extract_int (cexpr, &ordered, -1)) |
| ordered = 0; |
| else if (ordered <= 0) |
| { |
| gfc_error_now ("ORDERED clause argument not" |
| " constant positive integer at %C"); |
| ordered = 0; |
| } |
| c->orderedc = ordered; |
| gfc_free_expr (cexpr); |
| continue; |
| } |
| |
| needs_space = true; |
| continue; |
| } |
| break; |
| case 'p': |
| if ((mask & OMP_CLAUSE_COPY) |
| && gfc_match ("pcopy ( ") == MATCH_YES |
| && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], |
| OMP_MAP_TOFROM)) |
| continue; |
| if ((mask & OMP_CLAUSE_COPYIN) |
| && gfc_match ("pcopyin ( ") == MATCH_YES |
| && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], |
| OMP_MAP_TO)) |
| continue; |
| if ((mask & OMP_CLAUSE_COPYOUT) |
| && gfc_match ("pcopyout ( ") == MATCH_YES |
| && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], |
| OMP_MAP_FROM)) |
| continue; |
| if ((mask & OMP_CLAUSE_CREATE) |
| && gfc_match ("pcreate ( ") == MATCH_YES |
| && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], |
| OMP_MAP_ALLOC)) |
| continue; |
| if ((mask & OMP_CLAUSE_PRESENT) |
| && gfc_match ("present ( ") == MATCH_YES |
| && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], |
| OMP_MAP_FORCE_PRESENT)) |
| continue; |
| if ((mask & OMP_CLAUSE_COPY) |
| && gfc_match ("present_or_copy ( ") == MATCH_YES |
| && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], |
| OMP_MAP_TOFROM)) |
| continue; |
| if ((mask & OMP_CLAUSE_COPYIN) |
| && gfc_match ("present_or_copyin ( ") == MATCH_YES |
| && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], |
| OMP_MAP_TO)) |
| continue; |
| if ((mask & OMP_CLAUSE_COPYOUT) |
| && gfc_match ("present_or_copyout ( ") == MATCH_YES |
| && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], |
| OMP_MAP_FROM)) |
| continue; |
| if ((mask & OMP_CLAUSE_CREATE) |
| && gfc_match ("present_or_create ( ") == MATCH_YES |
| && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], |
| OMP_MAP_ALLOC)) |
| continue; |
| if ((mask & OMP_CLAUSE_PRIORITY) |
| && c->priority == NULL |
| && gfc_match ("priority ( %e )", &c->priority) == MATCH_YES) |
| continue; |
| if ((mask & OMP_CLAUSE_PRIVATE) |
| && gfc_match_omp_variable_list ("private (", |
| &c->lists[OMP_LIST_PRIVATE], |
| true) == MATCH_YES) |
| continue; |
| if ((mask & OMP_CLAUSE_PROC_BIND) |
| && c->proc_bind == OMP_PROC_BIND_UNKNOWN) |
| { |
| if (gfc_match ("proc_bind ( master )") == MATCH_YES) |
| c->proc_bind = OMP_PROC_BIND_MASTER; |
| else if (gfc_match ("proc_bind ( spread )") == MATCH_YES) |
| c->proc_bind = OMP_PROC_BIND_SPREAD; |
| else if (gfc_match ("proc_bind ( close )") == MATCH_YES) |
| c->proc_bind = OMP_PROC_BIND_CLOSE; |
| if (c->proc_bind != OMP_PROC_BIND_UNKNOWN) |
| continue; |
| } |
| break; |
| case 'r': |
| if ((mask & OMP_CLAUSE_REDUCTION) |
| && gfc_match ("reduction ( ") == MATCH_YES) |
| { |
| gfc_omp_reduction_op rop = OMP_REDUCTION_NONE; |
| char buffer[GFC_MAX_SYMBOL_LEN + 3]; |
| if (gfc_match_char ('+') == MATCH_YES) |
| rop = OMP_REDUCTION_PLUS; |
| else if (gfc_match_char ('*') == MATCH_YES) |
| rop = OMP_REDUCTION_TIMES; |
| else if (gfc_match_char ('-') == MATCH_YES) |
| rop = OMP_REDUCTION_MINUS; |
| else if (gfc_match (".and.") == MATCH_YES) |
| rop = OMP_REDUCTION_AND; |
| else if (gfc_match (".or.") == MATCH_YES) |
| rop = OMP_REDUCTION_OR; |
| else if (gfc_match (".eqv.") == MATCH_YES) |
| rop = OMP_REDUCTION_EQV; |
| else if (gfc_match (".neqv.") == MATCH_YES) |
| rop = OMP_REDUCTION_NEQV; |
| if (rop != OMP_REDUCTION_NONE) |
| snprintf (buffer, sizeof buffer, "operator %s", |
| gfc_op2string ((gfc_intrinsic_op) rop)); |
| else if (gfc_match_defined_op_name (buffer + 1, 1) == MATCH_YES) |
| { |
| buffer[0] = '.'; |
| strcat (buffer, "."); |
| } |
| else if (gfc_match_name (buffer) == MATCH_YES) |
| { |
| gfc_symbol *sym; |
| const char *n = buffer; |
| |
| gfc_find_symbol (buffer, NULL, 1, &sym); |
| if (sym != NULL) |
| { |
| if (sym->attr.intrinsic) |
| n = sym->name; |
| else if ((sym->attr.flavor != FL_UNKNOWN |
| && sym->attr.flavor != FL_PROCEDURE) |
| || sym->attr.external |
| || sym->attr.generic |
| || sym->attr.entry |
| || sym->attr.result |
| || sym->attr.dummy |
| || sym->attr.subroutine |
| || sym->attr.pointer |
| || sym->attr.target |
| || sym->attr.cray_pointer |
| || sym->attr.cray_pointee |
| || (sym->attr.proc != PROC_UNKNOWN |
| && sym->attr.proc != PROC_INTRINSIC) |
| || sym->attr.if_source != IFSRC_UNKNOWN |
| || sym == sym->ns->proc_name) |
| { |
| sym = NULL; |
| n = NULL; |
| } |
| else |
| n = sym->name; |
| } |
| if (n == NULL) |
| rop = OMP_REDUCTION_NONE; |
| else if (strcmp (n, "max") == 0) |
| rop = OMP_REDUCTION_MAX; |
| else if (strcmp (n, "min") == 0) |
| rop = OMP_REDUCTION_MIN; |
| else if (strcmp (n, "iand") == 0) |
| rop = OMP_REDUCTION_IAND; |
| else if (strcmp (n, "ior") == 0) |
| rop = OMP_REDUCTION_IOR; |
| else if (strcmp (n, "ieor") == 0) |
| rop = OMP_REDUCTION_IEOR; |
| if (rop != OMP_REDUCTION_NONE |
| && sym != NULL |
| && ! sym->attr.intrinsic |
| && ! sym->attr.use_assoc |
| && ((sym->attr.flavor == FL_UNKNOWN |
| && !gfc_add_flavor (&sym->attr, FL_PROCEDURE, |
| sym->name, NULL)) |
| || !gfc_add_intrinsic (&sym->attr, NULL))) |
| rop = OMP_REDUCTION_NONE; |
| } |
| else |
| buffer[0] = '\0'; |
| gfc_omp_udr *udr |
| = (buffer[0] |
| ? gfc_find_omp_udr (gfc_current_ns, buffer, NULL) : NULL); |
| gfc_omp_namelist **head = NULL; |
| if (rop == OMP_REDUCTION_NONE && udr) |
| rop = OMP_REDUCTION_USER; |
| |
| if (gfc_match_omp_variable_list (" :", |
| &c->lists[OMP_LIST_REDUCTION], |
| false, NULL, &head, |
| openacc) == MATCH_YES) |
| { |
| gfc_omp_namelist *n; |
| if (rop == OMP_REDUCTION_NONE) |
| { |
| n = *head; |
| *head = NULL; |
| gfc_error_now ("!$OMP DECLARE REDUCTION %s not found " |
| "at %L", buffer, &old_loc); |
| gfc_free_omp_namelist (n); |
| } |
| else |
| for (n = *head; n; n = n->next) |
| { |
| n->u.reduction_op = rop; |
| if (udr) |
| { |
| n->udr = gfc_get_omp_namelist_udr (); |
| n->udr->udr = udr; |
| } |
| } |
| continue; |
| } |
| else |
| gfc_current_locus = old_loc; |
| } |
| break; |
| case 's': |
| if ((mask & OMP_CLAUSE_SAFELEN) |
| && c->safelen_expr == NULL |
| && gfc_match ("safelen ( %e )", &c->safelen_expr) == MATCH_YES) |
| continue; |
| if ((mask & OMP_CLAUSE_SCHEDULE) |
| && c->sched_kind == OMP_SCHED_NONE |
| && gfc_match ("schedule ( ") == MATCH_YES) |
| { |
| int nmodifiers = 0; |
| locus old_loc2 = gfc_current_locus; |
| do |
| { |
| if (gfc_match ("simd") == MATCH_YES) |
| { |
| c->sched_simd = true; |
| nmodifiers++; |
| } |
| else if (gfc_match ("monotonic") == MATCH_YES) |
| { |
| c->sched_monotonic = true; |
| nmodifiers++; |
| } |
| else if (gfc_match ("nonmonotonic") == MATCH_YES) |
| { |
| c->sched_nonmonotonic = true; |
| nmodifiers++; |
| } |
| else |
| { |
| if (nmodifiers) |
| gfc_current_locus = old_loc2; |
| break; |
| } |
| if (nmodifiers == 1 |
| && gfc_match (" , ") == MATCH_YES) |
| continue; |
| else if (gfc_match (" : ") == MATCH_YES) |
| break; |
| gfc_current_locus = old_loc2; |
| break; |
| } |
| while (1); |
| if (gfc_match ("static") == MATCH_YES) |
| c->sched_kind = OMP_SCHED_STATIC; |
| else if (gfc_match ("dynamic") == MATCH_YES) |
| c->sched_kind = OMP_SCHED_DYNAMIC; |
| else if (gfc_match ("guided") == MATCH_YES) |
| c->sched_kind = OMP_SCHED_GUIDED; |
| else if (gfc_match ("runtime") == MATCH_YES) |
| c->sched_kind = OMP_SCHED_RUNTIME; |
| else if (gfc_match ("auto") == MATCH_YES) |
| c->sched_kind = OMP_SCHED_AUTO; |
| if (c->sched_kind != OMP_SCHED_NONE) |
| { |
| match m = MATCH_NO; |
| if (c->sched_kind != OMP_SCHED_RUNTIME |
| && c->sched_kind != OMP_SCHED_AUTO) |
| m = gfc_match (" , %e )", &c->chunk_size); |
| if (m != MATCH_YES) |
| m = gfc_match_char (')'); |
| if (m != MATCH_YES) |
| c->sched_kind = OMP_SCHED_NONE; |
| } |
| if (c->sched_kind != OMP_SCHED_NONE) |
| continue; |
| else |
| gfc_current_locus = old_loc; |
| } |
| if ((mask & OMP_CLAUSE_HOST_SELF) |
| && gfc_match ("self ( ") == MATCH_YES |
| && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], |
| OMP_MAP_FORCE_FROM)) |
| continue; |
| if ((mask & OMP_CLAUSE_SEQ) |
| && !c->seq |
| && gfc_match ("seq") == MATCH_YES) |
| { |
| c->seq = true; |
| needs_space = true; |
| continue; |
| } |
| if ((mask & OMP_CLAUSE_SHARED) |
| && gfc_match_omp_variable_list ("shared (", |
| &c->lists[OMP_LIST_SHARED], |
| true) == MATCH_YES) |
| continue; |
| if ((mask & OMP_CLAUSE_SIMDLEN) |
| && c->simdlen_expr == NULL |
| && gfc_match ("simdlen ( %e )", &c->simdlen_expr) == MATCH_YES) |
| continue; |
| if ((mask & OMP_CLAUSE_SIMD) |
| && !c->simd |
| && gfc_match ("simd") == MATCH_YES) |
| { |
| c->simd = needs_space = true; |
| continue; |
| } |
| break; |
| case 't': |
| if ((mask & OMP_CLAUSE_THREAD_LIMIT) |
| && c->thread_limit == NULL |
| && gfc_match ("thread_limit ( %e )", |
| &c->thread_limit) == MATCH_YES) |
| continue; |
| if ((mask & OMP_CLAUSE_THREADS) |
| && !c->threads |
| && gfc_match ("threads") == MATCH_YES) |
| { |
| c->threads = needs_space = true; |
| continue; |
| } |
| if ((mask & OMP_CLAUSE_TILE) |
| && !c->tile_list |
| && match_oacc_expr_list ("tile (", &c->tile_list, |
| true) == MATCH_YES) |
| continue; |
| if ((mask & OMP_CLAUSE_TO) && (mask & OMP_CLAUSE_LINK)) |
| { |
| if (gfc_match_omp_to_link ("to (", &c->lists[OMP_LIST_TO]) |
| == MATCH_YES) |
| continue; |
| } |
| else if ((mask & OMP_CLAUSE_TO) |
| && gfc_match_omp_variable_list ("to (", |
| &c->lists[OMP_LIST_TO], false, |
| NULL, &head, true) == MATCH_YES) |
| continue; |
| break; |
| case 'u': |
| if ((mask & OMP_CLAUSE_UNIFORM) |
| && gfc_match_omp_variable_list ("uniform (", |
| &c->lists[OMP_LIST_UNIFORM], |
| false) == MATCH_YES) |
| continue; |
| if ((mask & OMP_CLAUSE_UNTIED) |
| && !c->untied |
| && gfc_match ("untied") == MATCH_YES) |
| { |
| c->untied = needs_space = true; |
| continue; |
| } |
| if ((mask & OMP_CLAUSE_USE_DEVICE) |
| && gfc_match_omp_variable_list ("use_device (", |
| &c->lists[OMP_LIST_USE_DEVICE], |
| true) == MATCH_YES) |
| continue; |
| if ((mask & OMP_CLAUSE_USE_DEVICE_PTR) |
| && gfc_match_omp_variable_list |
| ("use_device_ptr (", |
| &c->lists[OMP_LIST_USE_DEVICE_PTR], false) == MATCH_YES) |
| continue; |
| break; |
| case 'v': |
| /* VECTOR_LENGTH must be matched before VECTOR, because the latter |
| doesn't unconditionally match '('. */ |
| if ((mask & OMP_CLAUSE_VECTOR_LENGTH) |
| && c->vector_length_expr == NULL |
| && (gfc_match ("vector_length ( %e )", &c->vector_length_expr) |
| == MATCH_YES)) |
| continue; |
| if ((mask & OMP_CLAUSE_VECTOR) |
| && !c->vector |
| && gfc_match ("vector") == MATCH_YES) |
| { |
| c->vector = true; |
| match m = match_oacc_clause_gwv (c, GOMP_DIM_VECTOR); |
| if (m == MATCH_ERROR) |
| { |
| gfc_current_locus = old_loc; |
| break; |
| } |
| if (m == MATCH_NO) |
| needs_space = true; |
| continue; |
| } |
| break; |
| case 'w': |
| if ((mask & OMP_CLAUSE_WAIT) |
| && gfc_match ("wait") == MATCH_YES) |
| { |
| match m = match_oacc_expr_list (" (", &c->wait_list, false); |
| if (m == MATCH_ERROR) |
| { |
| gfc_current_locus = old_loc; |
| break; |
| } |
| else if (m == MATCH_NO) |
| { |
| gfc_expr *expr |
| = gfc_get_constant_expr (BT_INTEGER, |
| gfc_default_integer_kind, |
| &gfc_current_locus); |
| mpz_set_si (expr->value.integer, GOMP_ASYNC_NOVAL); |
| gfc_expr_list **expr_list = &c->wait_list; |
| while (*expr_list) |
| expr_list = &(*expr_list)->next; |
| *expr_list = gfc_get_expr_list (); |
| (*expr_list)->expr = expr; |
| needs_space = true; |
| } |
| continue; |
| } |
| if ((mask & OMP_CLAUSE_WORKER) |
| && !c->worker |
| && gfc_match ("worker") == MATCH_YES) |
| { |
| c->worker = true; |
| match m = match_oacc_clause_gwv (c, GOMP_DIM_WORKER); |
| if (m == MATCH_ERROR) |
| { |
| gfc_current_locus = old_loc; |
| break; |
| } |
| else if (m == MATCH_NO) |
| needs_space = true; |
| continue; |
| } |
| break; |
| } |
| break; |
| } |
| |
| if (gfc_match_omp_eos () != MATCH_YES) |
| { |
| gfc_free_omp_clauses (c); |
| return MATCH_ERROR; |
| } |
| |
| *cp = c; |
| return MATCH_YES; |
| } |
| |
| |
| #define OACC_PARALLEL_CLAUSES \ |
| (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \ |
| | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_REDUCTION \ |
| | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \ |
| | OMP_CLAUSE_CREATE | OMP_CLAUSE_PRESENT | OMP_CLAUSE_DEVICEPTR \ |
| | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_DEFAULT \ |
| | OMP_CLAUSE_WAIT) |
| #define OACC_KERNELS_CLAUSES \ |
| (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \ |
| | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_DEVICEPTR \ |
| | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \ |
| | OMP_CLAUSE_CREATE | OMP_CLAUSE_PRESENT | OMP_CLAUSE_DEFAULT \ |
| | OMP_CLAUSE_WAIT) |
| #define OACC_DATA_CLAUSES \ |
| (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_COPY \ |
| | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_CREATE \ |
| | OMP_CLAUSE_PRESENT) |
| #define OACC_LOOP_CLAUSES \ |
| (omp_mask (OMP_CLAUSE_COLLAPSE) | OMP_CLAUSE_GANG | OMP_CLAUSE_WORKER \ |
| | OMP_CLAUSE_VECTOR | OMP_CLAUSE_SEQ | OMP_CLAUSE_INDEPENDENT \ |
| | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_AUTO \ |
| | OMP_CLAUSE_TILE) |
| #define OACC_PARALLEL_LOOP_CLAUSES \ |
| (OACC_LOOP_CLAUSES | OACC_PARALLEL_CLAUSES) |
| #define OACC_KERNELS_LOOP_CLAUSES \ |
| (OACC_LOOP_CLAUSES | OACC_KERNELS_CLAUSES) |
| #define OACC_HOST_DATA_CLAUSES omp_mask (OMP_CLAUSE_USE_DEVICE) |
| #define OACC_DECLARE_CLAUSES \ |
| (omp_mask (OMP_CLAUSE_COPY) | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \ |
| | OMP_CLAUSE_CREATE | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_DEVICE_RESIDENT \ |
| | OMP_CLAUSE_PRESENT \ |
| | OMP_CLAUSE_LINK) |
| #define OACC_UPDATE_CLAUSES \ |
| (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_HOST_SELF \ |
| | OMP_CLAUSE_DEVICE | OMP_CLAUSE_WAIT | OMP_CLAUSE_IF_PRESENT) |
| #define OACC_ENTER_DATA_CLAUSES \ |
| (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \ |
| | OMP_CLAUSE_COPYIN | OMP_CLAUSE_CREATE) |
| #define OACC_EXIT_DATA_CLAUSES \ |
| (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \ |
| | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_DELETE | OMP_CLAUSE_FINALIZE) |
| #define OACC_WAIT_CLAUSES \ |
| omp_mask (OMP_CLAUSE_ASYNC) |
| #define OACC_ROUTINE_CLAUSES \ |
| (omp_mask (OMP_CLAUSE_GANG) | OMP_CLAUSE_WORKER | OMP_CLAUSE_VECTOR \ |
| | OMP_CLAUSE_SEQ) |
| |
| |
| static match |
| match_acc (gfc_exec_op op, const omp_mask mask) |
| { |
| gfc_omp_clauses *c; |
| if (gfc_match_omp_clauses (&c, mask, false, false, true) != MATCH_YES) |
| return MATCH_ERROR; |
| new_st.op = op; |
| new_st.ext.omp_clauses = c; |
| return MATCH_YES; |
| } |
| |
| match |
| gfc_match_oacc_parallel_loop (void) |
| { |
| return match_acc (EXEC_OACC_PARALLEL_LOOP, OACC_PARALLEL_LOOP_CLAUSES); |
| } |
| |
| |
| match |
| gfc_match_oacc_parallel (void) |
| { |
| return match_acc (EXEC_OACC_PARALLEL, OACC_PARALLEL_CLAUSES); |
| } |
| |
| |
| match |
| gfc_match_oacc_kernels_loop (void) |
| { |
| return match_acc (EXEC_OACC_KERNELS_LOOP, OACC_KERNELS_LOOP_CLAUSES); |
| } |
| |
| |
| match |
| gfc_match_oacc_kernels (void) |
| { |
| return match_acc (EXEC_OACC_KERNELS, OACC_KERNELS_CLAUSES); |
| } |
| |
| |
| match |
| gfc_match_oacc_data (void) |
| { |
| return match_acc (EXEC_OACC_DATA, OACC_DATA_CLAUSES); |
| } |
| |
| |
| match |
| gfc_match_oacc_host_data (void) |
| { |
| return match_acc (EXEC_OACC_HOST_DATA, OACC_HOST_DATA_CLAUSES); |
| } |
| |
| |
| match |
| gfc_match_oacc_loop (void) |
| { |
| return match_acc (EXEC_OACC_LOOP, OACC_LOOP_CLAUSES); |
| } |
| |
| |
| 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; |
| |
| 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_ALLOC && n->u.map_op != OMP_MAP_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: |
| case OMP_MAP_ALLOC: |
| s->attr.oacc_declare_create = 1; |
| break; |
| |
| case OMP_MAP_FORCE_TO: |
| case OMP_MAP_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; |
| } |
| |
| |
| match |
| gfc_match_oacc_update (void) |
| { |
| gfc_omp_clauses *c; |
| locus here = gfc_current_locus; |
| |
| if (gfc_match_omp_clauses (&c, OACC_UPDATE_CLAUSES, false, false, true) |
| != MATCH_YES) |
| return MATCH_ERROR; |
| |
| if (!c->lists[OMP_LIST_MAP]) |
| { |
| gfc_error ("%<acc update%> must contain at least one " |
| "%<device%> or %<host%> or %<self%> clause at %L", &here); |
| return MATCH_ERROR; |
| } |
| |
| new_st.op = EXEC_OACC_UPDATE; |
| new_st.ext.omp_clauses = c; |
| return MATCH_YES; |
| } |
| |
| |
| match |
| gfc_match_oacc_enter_data (void) |
| { |
| return match_acc (EXEC_OACC_ENTER_DATA, OACC_ENTER_DATA_CLAUSES); |
| } |
| |
| |
| match |
| gfc_match_oacc_exit_data (void) |
| { |
| return match_acc (EXEC_OACC_EXIT_DATA, OACC_EXIT_DATA_CLAUSES); |
| } |
| |
| |
| match |
| gfc_match_oacc_wait (void) |
| { |
| gfc_omp_clauses *c = gfc_get_omp_clauses (); |
| gfc_expr_list *wait_list = NULL, *el; |
| bool space = true; |
| match m; |
| |
| m = match_oacc_expr_list (" (", &wait_list, true); |
| if (m == MATCH_ERROR) |
| return m; |
| else if (m == MATCH_YES) |
| space = false; |
| |
| if (gfc_match_omp_clauses (&c, OACC_WAIT_CLAUSES, space, space, true) |
| == MATCH_ERROR) |
| return MATCH_ERROR; |
| |
| if (wait_list) |
| for (el = wait_list; el; el = el->next) |
| { |
| if (el->expr == NULL) |
| { |
| gfc_error ("Invalid argument to !$ACC WAIT at %C"); |
| return MATCH_ERROR; |
| } |
| |
| if (!gfc_resolve_expr (el->expr) |
| || el->expr->ts.type != BT_INTEGER || el->expr->rank != 0) |
| { |
| gfc_error ("WAIT clause at %L requires a scalar INTEGER expression", |
| &el->expr->where); |
| |
| return MATCH_ERROR; |
| } |
| } |
| c->wait_list = wait_list; |
| new_st.op = EXEC_OACC_WAIT; |
| new_st.ext.omp_clauses = c; |
| return MATCH_YES; |
| } |
| |
| |
| match |
| gfc_match_oacc_cache (void) |
| { |
| gfc_omp_clauses *c = gfc_get_omp_clauses (); |
| /* The OpenACC cache directive explicitly only allows "array elements or |
| subarrays", which we're currently not checking here. Either check this |
| after the call of gfc_match_omp_variable_list, or add something like a |
| only_sections variant next to its allow_sections parameter. */ |
| match m = gfc_match_omp_variable_list (" (", |
| &c->lists[OMP_LIST_CACHE], true, |
| NULL, NULL, true); |
| if (m != MATCH_YES) |
| { |
| gfc_free_omp_clauses(c); |
| return m; |
| } |
| |
| if (gfc_current_state() != COMP_DO |
| && gfc_current_state() != COMP_DO_CONCURRENT) |
| { |
| gfc_error ("ACC CACHE directive must be inside of loop %C"); |
| gfc_free_omp_clauses(c); |
| return MATCH_ERROR; |
| } |
| |
| new_st.op = EXEC_OACC_CACHE; |
| new_st.ext.omp_clauses = c; |
| return MATCH_YES; |
| } |
| |
| /* Determine the OpenACC 'routine' directive's level of parallelism. */ |
| |
| static oacc_routine_lop |
| gfc_oacc_routine_lop (gfc_omp_clauses *clauses) |
| { |
| oacc_routine_lop ret = OACC_ROUTINE_LOP_SEQ; |
| |
| if (clauses) |
| { |
| unsigned n_lop_clauses = 0; |
| |
| if (clauses->gang) |
| { |
| ++n_lop_clauses; |
| ret = OACC_ROUTINE_LOP_GANG; |
| } |
| if (clauses->worker) |
| { |
| ++n_lop_clauses; |
| ret = OACC_ROUTINE_LOP_WORKER; |
| } |
| if (clauses->vector) |
| { |
| ++n_lop_clauses; |
| ret = OACC_ROUTINE_LOP_VECTOR; |
| } |
| if (clauses->seq) |
| { |
| ++n_lop_clauses; |
| ret = OACC_ROUTINE_LOP_SEQ; |
| } |
| |
| if (n_lop_clauses > 1) |
| ret = OACC_ROUTINE_LOP_ERROR; |
| } |
| |
| return ret; |
| } |
| |
| match |
| gfc_match_oacc_routine (void) |
| { |
| locus old_loc; |
| match m; |
| gfc_intrinsic_sym *isym = NULL; |
| gfc_symbol *sym = NULL; |
| gfc_omp_clauses *c = NULL; |
| gfc_oacc_routine_name *n = NULL; |
| oacc_routine_lop lop = OACC_ROUTINE_LOP_NONE; |
| |
| old_loc = gfc_current_locus; |
| |
| m = gfc_match (" ("); |
| |
| if (gfc_current_ns->proc_name |
| && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY |
| && m == MATCH_YES) |
| { |
| gfc_error ("Only the !$ACC ROUTINE form without " |
| "list is allowed in interface block at %C"); |
| goto cleanup; |
| } |
| |
| if (m == MATCH_YES) |
| { |
| char buffer[GFC_MAX_SYMBOL_LEN + 1]; |
| |
| m = gfc_match_name (buffer); |
| if (m == MATCH_YES) |
| { |
| gfc_symtree *st = NULL; |
| |
| /* First look for an intrinsic symbol. */ |
| isym = gfc_find_function (buffer); |
| if (!isym) |
| isym = gfc_find_subroutine (buffer); |
| /* If no intrinsic symbol found, search the current namespace. */ |
| if (!isym) |
| st = gfc_find_symtree (gfc_current_ns->sym_root, buffer); |
| if (st) |
| { |
| sym = st->n.sym; |
| /* If the name in a 'routine' directive refers to the containing |
| subroutine or function, then make sure that we'll later handle |
| this accordingly. */ |
| if (gfc_current_ns->proc_name != NULL |
| && strcmp (sym->name, gfc_current_ns->proc_name->name) == 0) |
| sym = NULL; |
| } |
| |
| if (isym == NULL && st == NULL) |
| { |
| gfc_error ("Invalid NAME %qs in !$ACC ROUTINE ( NAME ) at %C", |
| buffer); |
| gfc_current_locus = old_loc; |
| return MATCH_ERROR; |
| } |
| } |
| else |
| { |
| gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C"); |
| gfc_current_locus = old_loc; |
| return MATCH_ERROR; |
| } |
| |
| if (gfc_match_char (')') != MATCH_YES) |
| { |
| gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, expecting" |
| " ')' after NAME"); |
| gfc_current_locus = old_loc; |
| return MATCH_ERROR; |
| } |
| } |
| |
| if (gfc_match_omp_eos () != MATCH_YES |
| && (gfc_match_omp_clauses (&c, OACC_ROUTINE_CLAUSES, false, false, true) |
| != MATCH_YES)) |
| return MATCH_ERROR; |
| |
| lop = gfc_oacc_routine_lop (c); |
| if (lop == OACC_ROUTINE_LOP_ERROR) |
| { |
| gfc_error ("Multiple loop axes specified for routine at %C"); |
| goto cleanup; |
| } |
| |
| if (isym != NULL) |
| { |
| /* Diagnose any OpenACC 'routine' directive that doesn't match the |
| (implicit) one with a 'seq' clause. */ |
| if (c && (c->gang || c->worker || c->vector)) |
| { |
| gfc_error ("Intrinsic symbol specified in !$ACC ROUTINE ( NAME )" |
| " at %C marked with incompatible GANG, WORKER, or VECTOR" |
| " clause"); |
| goto cleanup; |
| } |
| } |
| else if (sym != NULL) |
| { |
| bool add = true; |
| |
| /* For a repeated OpenACC 'routine' directive, diagnose if it doesn't |
| match the first one. */ |
| for (gfc_oacc_routine_name *n_p = gfc_current_ns->oacc_routine_names; |
| n_p; |
| n_p = n_p->next) |
| if (n_p->sym == sym) |
| { |
| add = false; |
| if (lop != gfc_oacc_routine_lop (n_p->clauses)) |
| { |
| gfc_error ("!$ACC ROUTINE already applied at %C"); |
| goto cleanup; |
| } |
| } |
| |
| if (add) |
| { |
| sym->attr.oacc_routine_lop = lop; |
| |
| n = gfc_get_oacc_routine_name (); |
| n->sym = sym; |
| n->clauses = c; |
| n->next = gfc_current_ns->oacc_routine_names; |
| n->loc = old_loc; |
| gfc_current_ns->oacc_routine_names = n; |
| } |
| } |
| else if (gfc_current_ns->proc_name) |
| { |
| /* For a repeated OpenACC 'routine' directive, diagnose if it doesn't |
| match the first one. */ |
| oacc_routine_lop lop_p = gfc_current_ns->proc_name->attr.oacc_routine_lop; |
| if (lop_p != OACC_ROUTINE_LOP_NONE |
| && lop != lop_p) |
| { |
| gfc_error ("!$ACC ROUTINE already applied at %C"); |
| goto cleanup; |
| } |
| |
| if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr, |
| gfc_current_ns->proc_name->name, |
| &old_loc)) |
| goto cleanup; |
| gfc_current_ns->proc_name->attr.oacc_routine_lop = lop; |
| } |
| else |
| /* Something has gone wrong, possibly a syntax error. */ |
| goto cleanup; |
| |
| if (n) |
| n->clauses = c; |
| else if (gfc_current_ns->oacc_routine) |
| gfc_current_ns->oacc_routine_clauses = c; |
| |
| new_st.op = EXEC_OACC_ROUTINE; |
| new_st.ext.omp_clauses = c; |
| return MATCH_YES; |
| |
| cleanup: |
| gfc_current_locus = old_loc; |
| return MATCH_ERROR; |
| } |
| |
| |
| #define OMP_PARALLEL_CLAUSES \ |
| (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \ |
| | OMP_CLAUSE_SHARED | OMP_CLAUSE_COPYIN | OMP_CLAUSE_REDUCTION \ |
| | OMP_CLAUSE_IF | OMP_CLAUSE_NUM_THREADS | OMP_CLAUSE_DEFAULT \ |
| | OMP_CLAUSE_PROC_BIND) |
| #define OMP_DECLARE_SIMD_CLAUSES \ |
| (omp_mask (OMP_CLAUSE_SIMDLEN) | OMP_CLAUSE_LINEAR \ |
| | OMP_CLAUSE_UNIFORM | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_INBRANCH \ |
| | OMP_CLAUSE_NOTINBRANCH) |
| #define OMP_DO_CLAUSES \ |
| (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \ |
| | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \ |
| | OMP_CLAUSE_SCHEDULE | OMP_CLAUSE_ORDERED | OMP_CLAUSE_COLLAPSE \ |
| | OMP_CLAUSE_LINEAR) |
| #define OMP_SECTIONS_CLAUSES \ |
| (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \ |
| | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION) |
| #define OMP_SIMD_CLAUSES \ |
| (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_LASTPRIVATE \ |
| | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_SAFELEN \ |
| | OMP_CLAUSE_LINEAR | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_SIMDLEN) |
| #define OMP_TASK_CLAUSES \ |
| (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \ |
| | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF | OMP_CLAUSE_DEFAULT \ |
| | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL | OMP_CLAUSE_MERGEABLE \ |
| | OMP_CLAUSE_DEPEND | OMP_CLAUSE_PRIORITY) |
| #define OMP_TASKLOOP_CLAUSES \ |
| (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \ |
| | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF \ |
| | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL \ |
| | OMP_CLAUSE_MERGEABLE | OMP_CLAUSE_PRIORITY | OMP_CLAUSE_GRAINSIZE \ |
| | OMP_CLAUSE_NUM_TASKS | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_NOGROUP) |
| #define OMP_TARGET_CLAUSES \ |
| (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \ |
| | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_PRIVATE \ |
| | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_DEFAULTMAP \ |
| | OMP_CLAUSE_IS_DEVICE_PTR) |
| #define OMP_TARGET_DATA_CLAUSES \ |
| (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \ |
| | OMP_CLAUSE_USE_DEVICE_PTR) |
| #define OMP_TARGET_ENTER_DATA_CLAUSES \ |
| (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \ |
| | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT) |
| #define OMP_TARGET_EXIT_DATA_CLAUSES \ |
| (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \ |
| | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT) |
| #define OMP_TARGET_UPDATE_CLAUSES \ |
| (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_IF | OMP_CLAUSE_TO \ |
| | OMP_CLAUSE_FROM | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT) |
| #define OMP_TEAMS_CLAUSES \ |
| (omp_mask (OMP_CLAUSE_NUM_TEAMS) | OMP_CLAUSE_THREAD_LIMIT \ |
| | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \ |
| | OMP_CLAUSE_SHARED | OMP_CLAUSE_REDUCTION) |
| #define OMP_DISTRIBUTE_CLAUSES \ |
| (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \ |
| | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_DIST_SCHEDULE) |
| #define OMP_SINGLE_CLAUSES \ |
| (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE) |
| #define OMP_ORDERED_CLAUSES \ |
| (omp_mask (OMP_CLAUSE_THREADS) | OMP_CLAUSE_SIMD) |
| #define OMP_DECLARE_TARGET_CLAUSES \ |
| (omp_mask (OMP_CLAUSE_TO) | OMP_CLAUSE_LINK) |
| |
| |
| static match |
| match_omp (gfc_exec_op op, const omp_mask mask) |
| { |
| gfc_omp_clauses *c; |
| if (gfc_match_omp_clauses (&c, mask) != MATCH_YES) |
| return MATCH_ERROR; |
| new_st.op = op; |
| new_st.ext.omp_clauses = c; |
| return MATCH_YES; |
| } |
| |
| |
| match |
| gfc_match_omp_critical (void) |
| { |
| char n[GFC_MAX_SYMBOL_LEN+1]; |
| gfc_omp_clauses *c = NULL; |
| |
| if (gfc_match (" ( %n )", n) != MATCH_YES) |
| { |
| n[0] = '\0'; |
| if (gfc_match_omp_eos () != MATCH_YES) |
| { |
| gfc_error ("Unexpected junk after $OMP CRITICAL statement at %C"); |
| return MATCH_ERROR; |
| } |
| } |
| else if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_HINT)) != MATCH_YES) |
| return MATCH_ERROR; |
| |
| new_st.op = EXEC_OMP_CRITICAL; |
| new_st.ext.omp_clauses = c; |
| if (n[0]) |
| c->critical_name = xstrdup (n); |
| return MATCH_YES; |
| } |
| |
| |
| match |
| gfc_match_omp_end_critical (void) |
| { |
| char n[GFC_MAX_SYMBOL_LEN+1]; |
| |
| if (gfc_match (" ( %n )", n) != MATCH_YES) |
| n[0] = '\0'; |
| if (gfc_match_omp_eos () != MATCH_YES) |
| { |
| gfc_error ("Unexpected junk after $OMP CRITICAL statement at %C"); |
| return MATCH_ERROR; |
| } |
| |
| new_st.op = EXEC_OMP_END_CRITICAL; |
| new_st.ext.omp_name = n[0] ? xstrdup (n) : NULL; |
| return MATCH_YES; |
| } |
| |
| |
| match |
| gfc_match_omp_distribute (void) |
| { |
| return match_omp (EXEC_OMP_DISTRIBUTE, OMP_DISTRIBUTE_CLAUSES); |
| } |
| |
| |
| match |
| gfc_match_omp_distribute_parallel_do (void) |
| { |
| return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO, |
| (OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES |
| | OMP_DO_CLAUSES) |
| & ~(omp_mask (OMP_CLAUSE_ORDERED)) |
| & ~(omp_mask (OMP_CLAUSE_LINEAR))); |
| } |
| |
| |
| match |
| gfc_match_omp_distribute_parallel_do_simd (void) |
| { |
| return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD, |
| (OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES |
| | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES) |
| & ~(omp_mask (OMP_CLAUSE_ORDERED))); |
| } |
| |
| |
| match |
| gfc_match_omp_distribute_simd (void) |
| { |
| return match_omp (EXEC_OMP_DISTRIBUTE_SIMD, |
| OMP_DISTRIBUTE_CLAUSES | OMP_SIMD_CLAUSES); |
| } |
| |
| |
| match |
| gfc_match_omp_do (void) |
| { |
| return match_omp (EXEC_OMP_DO, OMP_DO_CLAUSES); |
| } |
| |
| |
| match |
| gfc_match_omp_do_simd (void) |
| { |
| return match_omp (EXEC_OMP_DO_SIMD, OMP_DO_CLAUSES | OMP_SIMD_CLAUSES); |
| } |
| |
| |
| match |
| gfc_match_omp_flush (void) |
| { |
| gfc_omp_namelist *list = NULL; |
| gfc_match_omp_variable_list (" (", &list, true); |
| if (gfc_match_omp_eos () != MATCH_YES) |
| { |
| gfc_error ("Unexpected junk after $OMP FLUSH statement at %C"); |
| gfc_free_omp_namelist (list); |
| return MATCH_ERROR; |
| } |
| new_st.op = EXEC_OMP_FLUSH; |
| new_st.ext.omp_namelist = list; |
| return MATCH_YES; |
| } |
| |
| |
| match |
| gfc_match_omp_declare_simd (void) |
| { |
| locus where = gfc_current_locus; |
| gfc_symbol *proc_name; |
| gfc_omp_clauses *c; |
| gfc_omp_declare_simd *ods; |
| bool needs_space = false; |
| |
| switch (gfc_match (" ( %s ) ", &proc_name)) |
| { |
| case MATCH_YES: break; |
| case MATCH_NO: proc_name = NULL; needs_space = true; break; |
| case MATCH_ERROR: return MATCH_ERROR; |
| } |
| |
| if (gfc_match_omp_clauses (&c, OMP_DECLARE_SIMD_CLAUSES, true, |
| needs_space) != MATCH_YES) |
| return MATCH_ERROR; |
| |
| if (gfc_current_ns->is_block_data) |
| { |
| gfc_free_omp_clauses (c); |
| return MATCH_YES; |
| } |
| |
| ods = gfc_get_omp_declare_simd (); |
| ods->where = where; |
| ods->proc_name = proc_name; |
| ods->clauses = c; |
| ods->next = gfc_current_ns->omp_declare_simd; |
| gfc_current_ns->omp_declare_simd = ods; |
| return MATCH_YES; |
| } |
| |
| |
| static bool |
| match_udr_expr (gfc_symtree *omp_sym1, gfc_symtree *omp_sym2) |
| { |
| match m; |
| locus old_loc = gfc_current_locus; |
| char sname[GFC_MAX_SYMBOL_LEN + 1]; |
| gfc_symbol *sym; |
| gfc_namespace *ns = gfc_current_ns; |
| gfc_expr *lvalue = NULL, *rvalue = NULL; |
| gfc_symtree *st; |
| gfc_actual_arglist *arglist; |
| |
| m = gfc_match (" %v =", &lvalue); |
| if (m != MATCH_YES) |
| gfc_current_locus = old_loc; |
| else |
| { |
| m = gfc_match (" %e )", &rvalue); |
| if (m == MATCH_YES) |
| { |
| ns->code = gfc_get_code (EXEC_ASSIGN); |
| ns->code->expr1 = lvalue; |
| ns->code->expr2 = rvalue; |
| ns->code->loc = old_loc; |
| return true; |
| } |
| |
| gfc_current_locus = old_loc; |
| gfc_free_expr (lvalue); |
| } |
| |
| m = gfc_match (" %n", sname); |
| if (m != MATCH_YES) |
| return false; |
| |
| if (strcmp (sname, omp_sym1->name) == 0 |
| || strcmp (sname, omp_sym2->name) == 0) |
| return false; |
| |
| gfc_current_ns = ns->parent; |
| if (gfc_get_ha_sym_tree (sname, &st)) |
| return false; |
| |
| sym = st->n.sym; |
| if (sym->attr.flavor != FL_PROCEDURE |
| && sym->attr.flavor != FL_UNKNOWN) |
| return false; |
| |
| if (!sym->attr.generic |
| && !sym->attr.subroutine |
| && !sym->attr.function) |
| { |
| if (!(sym->attr.external && !sym->attr.referenced)) |
| { |
| /* ...create a symbol in this scope... */ |
| if (sym->ns != gfc_current_ns |
| && gfc_get_sym_tree (sname, NULL, &st, false) == 1) |
| return false; |
| |
| if (sym != st->n.sym) |
| sym = st->n.sym; |
| } |
| |
| /* ...and then to try to make the symbol into a subroutine. */ |
| if (!gfc_add_subroutine (&sym->attr, sym->name, NULL)) |
| return false; |
| } |
| |
| gfc_set_sym_referenced (sym); |
| gfc_gobble_whitespace (); |
| if (gfc_peek_ascii_char () != '(') |
| return false; |
| |
| gfc_current_ns = ns; |
| m = gfc_match_actual_arglist (1, &arglist); |
| if (m != MATCH_YES) |
| return false; |
| |
| if (gfc_match_char (')') != MATCH_YES) |
| return false; |
| |
| ns->code = gfc_get_code (EXEC_CALL); |
| ns->code->symtree = st; |
| ns->code->ext.actual = arglist; |
| ns->code->loc = old_loc; |
| return true; |
| } |
| |
| static bool |
| gfc_omp_udr_predef (gfc_omp_reduction_op rop, const char *name, |
| gfc_typespec *ts, const char **n) |
| { |
| if (!gfc_numeric_ts (ts) && ts->type != BT_LOGICAL) |
| return false; |
| |
| switch (rop) |
| { |
| case OMP_REDUCTION_PLUS: |
| case OMP_REDUCTION_MINUS: |
| case OMP_REDUCTION_TIMES: |
| return ts->type != BT_LOGICAL; |
| case OMP_REDUCTION_AND: |
| case OMP_REDUCTION_OR: |
| case OMP_REDUCTION_EQV: |
| case OMP_REDUCTION_NEQV: |
| return ts->type == BT_LOGICAL; |
| case OMP_REDUCTION_USER: |
| if (name[0] != '.' && (ts->type == BT_INTEGER || ts->type == BT_REAL)) |
| { |
| gfc_symbol *sym; |
| |
| gfc_find_symbol (name, NULL, 1, &sym); |
| if (sym != NULL) |
| { |
| if (sym->attr.intrinsic) |
| *n = sym->name; |
| else if ((sym->attr.flavor != FL_UNKNOWN |
| && sym->attr.flavor != FL_PROCEDURE) |
| || sym->attr.external |
| || sym->attr.generic |
| || sym->attr.entry |
| || sym->attr.result |
| || sym->attr.dummy |
| || sym->attr.subroutine |
| || sym->attr.pointer |
| || sym->attr.target |
| || sym->attr.cray_pointer |
| || sym->attr.cray_pointee |
| || (sym->attr.proc != PROC_UNKNOWN |
| && sym->attr.proc != PROC_INTRINSIC) |
| || sym->attr.if_source != IFSRC_UNKNOWN |
| || sym == sym->ns->proc_name) |
| *n = NULL; |
| else |
| *n = sym->name; |
| } |
| else |
| *n = name; |
| if (*n |
| && (strcmp (*n, "max") == 0 || strcmp (*n, "min") == 0)) |
| return true; |
| else if (*n |
| && ts->type == BT_INTEGER |
| && (strcmp (*n, "iand") == 0 |
| || strcmp (*n, "ior") == 0 |
| || strcmp (*n, "ieor") == 0)) |
| return true; |
| } |
| break; |
| default: |
| break; |
| } |
| return false; |
| } |
| |
| gfc_omp_udr * |
| gfc_omp_udr_find (gfc_symtree *st, gfc_typespec *ts) |
| { |
| gfc_omp_udr *omp_udr; |
| |
| if (st == NULL) |
| return NULL; |
| |
| for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next) |
| if (omp_udr->ts.type == ts->type |
| || ((omp_udr->ts.type == BT_DERIVED || omp_udr->ts.type == BT_CLASS) |
| && (ts->type == BT_DERIVED || ts->type == BT_CLASS))) |
| { |
| if (omp_udr->ts.type == BT_DERIVED || omp_udr->ts.type == BT_CLASS) |
| { |
| if (strcmp (omp_udr->ts.u.derived->name, ts->u.derived->name) == 0) |
| return omp_udr; |
| } |
| else if (omp_udr->ts.kind == ts->kind) |
| { |
| if (omp_udr->ts.type == BT_CHARACTER) |
| { |
| if (omp_udr->ts.u.cl->length == NULL |
| || ts->u.cl->length == NULL) |
| return omp_udr; |
| if (omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT) |
| return omp_udr; |
| if (ts->u.cl->length->expr_type != EXPR_CONSTANT) |
| return omp_udr; |
| if (omp_udr->ts.u.cl->length->ts.type != BT_INTEGER) |
| return omp_udr; |
| if (ts->u.cl->length->ts.type != BT_INTEGER) |
| return omp_udr; |
| if (gfc_compare_expr (omp_udr->ts.u.cl->length, |
| ts->u.cl->length, INTRINSIC_EQ) != 0) |
| continue; |
| } |
| return omp_udr; |
| } |
| } |
| return NULL; |
| } |
| |
| match |
| gfc_match_omp_declare_reduction (void) |
| { |
| match m; |
| gfc_intrinsic_op op; |
| char name[GFC_MAX_SYMBOL_LEN + 3]; |
| auto_vec<gfc_typespec, 5> tss; |
| gfc_typespec ts; |
| unsigned int i; |
| gfc_symtree *st; |
| locus where = gfc_current_locus; |
| locus end_loc = gfc_current_locus; |
| bool end_loc_set = false; |
| gfc_omp_reduction_op rop = OMP_REDUCTION_NONE; |
| |
| if (gfc_match_char ('(') != MATCH_YES) |
| return MATCH_ERROR; |
| |
| m = gfc_match (" %o : ", &op); |
| if (m == MATCH_ERROR) |
| return MATCH_ERROR; |
| if (m == MATCH_YES) |
| { |
| snprintf (name, sizeof name, "operator %s", gfc_op2string (op)); |
| rop = (gfc_omp_reduction_op) op; |
| } |
| else |
| { |
| m = gfc_match_defined_op_name (name + 1, 1); |
| if (m == MATCH_ERROR) |
| return MATCH_ERROR; |
| if (m == MATCH_YES) |
| { |
| name[0] = '.'; |
| strcat (name, "."); |
| if (gfc_match (" : ") != MATCH_YES) |
| return MATCH_ERROR; |
| } |
| else |
| { |
| if (gfc_match (" %n : ", name) != MATCH_YES) |
| return MATCH_ERROR; |
| } |
| rop = OMP_REDUCTION_USER; |
| } |
| |
| m = gfc_match_type_spec (&ts); |
| if (m != MATCH_YES) |
| return MATCH_ERROR; |
| /* Treat len=: the same as len=*. */ |
| if (ts.type == BT_CHARACTER) |
| ts.deferred = false; |
| tss.safe_push (ts); |
| |
| while (gfc_match_char (',') == MATCH_YES) |
| { |
| m = gfc_match_type_spec (&ts); |
| if (m != MATCH_YES) |
| return MATCH_ERROR; |
| tss.safe_push (ts); |
| } |
| if (gfc_match_char (':') != MATCH_YES) |
| return MATCH_ERROR; |
| |
| st = gfc_find_symtree (gfc_current_ns->omp_udr_root, name); |
| for (i = 0; i < tss.length (); i++) |
| { |
| gfc_symtree *omp_out, *omp_in; |
| gfc_symtree *omp_priv = NULL, *omp_orig = NULL; |
| gfc_namespace *combiner_ns, *initializer_ns = NULL; |
| gfc_omp_udr *prev_udr, *omp_udr; |
| const char *predef_name = NULL; |
| |
| omp_udr = gfc_get_omp_udr (); |
| omp_udr->name = gfc_get_string ("%s", name); |
| omp_udr->rop = rop; |
| omp_udr->ts = tss[i]; |
| omp_udr->where = where; |
| |
| gfc_current_ns = combiner_ns = gfc_get_namespace (gfc_current_ns, 1); |
| combiner_ns->proc_name = combiner_ns->parent->proc_name; |
| |
| gfc_get_sym_tree ("omp_out", combiner_ns, &omp_out, false); |
| gfc_get_sym_tree ("omp_in", combiner_ns, &omp_in, false); |
| combiner_ns->omp_udr_ns = 1; |
| omp_out->n.sym->ts = tss[i]; |
| omp_in->n.sym->ts = tss[i]; |
| omp_out->n.sym->attr.omp_udr_artificial_var = 1; |
| omp_in->n.sym->attr.omp_udr_artificial_var = 1; |
| omp_out->n.sym->attr.flavor = FL_VARIABLE; |
| omp_in->n.sym->attr.flavor = FL_VARIABLE; |
| gfc_commit_symbols (); |
| omp_udr->combiner_ns = combiner_ns; |
| omp_udr->omp_out = omp_out->n.sym; |
| omp_udr->omp_in = omp_in->n.sym; |
| |
| locus old_loc = gfc_current_locus; |
| |
| if (!match_udr_expr (omp_out, omp_in)) |
| { |
| syntax: |
| gfc_current_locus = old_loc; |
| gfc_current_ns = combiner_ns->parent; |
| gfc_undo_symbols (); |
| gfc_free_omp_udr (omp_udr); |
| return MATCH_ERROR; |
| } |
| |
| if (gfc_match (" initializer ( ") == MATCH_YES) |
| { |
| gfc_current_ns = combiner_ns->parent; |
| initializer_ns = gfc_get_namespace (gfc_current_ns, 1); |
| gfc_current_ns = initializer_ns; |
| initializer_ns->proc_name = initializer_ns->parent->proc_name; |
| |
| gfc_get_sym_tree ("omp_priv", initializer_ns, &omp_priv, false); |
| gfc_get_sym_tree ("omp_orig", initializer_ns, &omp_orig, false); |
| initializer_ns->omp_udr_ns = 1; |
| omp_priv->n.sym->ts = tss[i]; |
| omp_orig->n.sym->ts = tss[i]; |
| omp_priv->n.sym->attr.omp_udr_artificial_var = 1; |
| omp_orig->n.sym->attr.omp_udr_artificial_var = 1; |
| omp_priv->n.sym->attr.flavor = FL_VARIABLE; |
| omp_orig->n.sym->attr.flavor = FL_VARIABLE; |
| gfc_commit_symbols (); |
| omp_udr->initializer_ns = initializer_ns; |
| omp_udr->omp_priv = omp_priv->n.sym; |
| omp_udr->omp_orig = omp_orig->n.sym; |
| |
| if (!match_udr_expr (omp_priv, omp_orig)) |
| goto syntax; |
| } |
| |
| gfc_current_ns = combiner_ns->parent; |
| if (!end_loc_set) |
| { |
| end_loc_set = true; |
| end_loc = gfc_current_locus; |
| } |
| gfc_current_locus = old_loc; |
| |
| prev_udr = gfc_omp_udr_find (st, &tss[i]); |
| if (gfc_omp_udr_predef (rop, name, &tss[i], &predef_name) |
| /* Don't error on !$omp declare reduction (min : integer : ...) |
| just yet, there could be integer :: min afterwards, |
| making it valid. When the UDR is resolved, we'll get |
| to it again. */ |
| && (rop != OMP_REDUCTION_USER || name[0] == '.')) |
| { |
| if (predef_name) |
| gfc_error_now ("Redefinition of predefined %s " |
| "!$OMP DECLARE REDUCTION at %L", |
| predef_name, &where); |
| else |
| gfc_error_now ("Redefinition of predefined " |
| "!$OMP DECLARE REDUCTION at %L", &where); |
| } |
| else if (prev_udr) |
| { |
| gfc_error_now ("Redefinition of !$OMP DECLARE REDUCTION at %L", |
| &where); |
| gfc_error_now ("Previous !$OMP DECLARE REDUCTION at %L", |
| &prev_udr->where); |
| } |
| else if (st) |
| { |
| omp_udr->next = st->n.omp_udr; |
| st->n.omp_udr = omp_udr; |
| } |
| else |
| { |
| st = gfc_new_symtree (&gfc_current_ns->omp_udr_root, name); |
| st->n.omp_udr = omp_udr; |
| } |
| } |
| |
| if (end_loc_set) |
| { |
| gfc_current_locus = end_loc; |
| if (gfc_match_omp_eos () != MATCH_YES) |
| { |
| gfc_error ("Unexpected junk after !$OMP DECLARE REDUCTION at %C"); |
| gfc_current_locus = where; |
| return MATCH_ERROR; |
| } |
| |
| return MATCH_YES; |
| } |
| gfc_clear_error (); |
| return MATCH_ERROR; |
| } |
| |
| |
| match |
| gfc_match_omp_declare_target (void) |
| { |
| locus old_loc; |
| match m; |
| gfc_omp_clauses *c = NULL; |
| int list; |
| gfc_omp_namelist *n; |
| gfc_symbol *s; |
| |
| old_loc = gfc_current_locus; |
| |
| if (gfc_current_ns->proc_name |
| && gfc_match_omp_eos () == MATCH_YES) |
| { |
| if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr, |
| gfc_current_ns->proc_name->name, |
| &old_loc)) |
| goto cleanup; |
| return MATCH_YES; |
| } |
| |
| if (gfc_current_ns->proc_name |
| && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY) |
| { |
| gfc_error ("Only the !$OMP DECLARE TARGET form without " |
| "clauses is allowed in interface block at %C"); |
| goto cleanup; |
| } |
| |
| m = gfc_match (" ("); |
| if (m == MATCH_YES) |
| { |
| c = gfc_get_omp_clauses (); |
| gfc_current_locus = old_loc; |
| m = gfc_match_omp_to_link (" (", &c->lists[OMP_LIST_TO]); |
| if (m != MATCH_YES) |
| goto syntax; |
| if (gfc_match_omp_eos () != MATCH_YES) |
| { |
| gfc_error ("Unexpected junk after !$OMP DECLARE TARGET at %C"); |
| goto cleanup; |
| } |
| } |
| else if (gfc_match_omp_clauses (&c, OMP_DECLARE_TARGET_CLAUSES) != MATCH_YES) |
| return MATCH_ERROR; |
| |
| gfc_buffer_error (false); |
| |
| for (list = OMP_LIST_TO; list != OMP_LIST_NUM; |
| list = (list == OMP_LIST_TO ? OMP_LIST_LINK : OMP_LIST_NUM)) |
| for (n = c->lists[list]; n; n = n->next) |
| if (n->sym) |
| n->sym->mark = 0; |
| else if (n->u.common->head) |
| n->u.common->head->mark = 0; |
| |
| for (list = OMP_LIST_TO; list != OMP_LIST_NUM; |
| list = (list == OMP_LIST_TO ? OMP_LIST_LINK : OMP_LIST_NUM)) |
| for (n = c->lists[list]; n; n = n->next) |
| if (n->sym) |
| { |
| if (n->sym->attr.in_common) |
| gfc_error_now ("OMP DECLARE TARGET variable at %L is an " |
| "element of a COMMON block", &n->where); |
| else if (n->sym->attr.omp_declare_target |
| && n->sym->attr.omp_declare_target_link |
| && list != OMP_LIST_LINK) |
| gfc_error_now ("OMP DECLARE TARGET variable at %L previously " |
| "mentioned in LINK clause and later in TO clause", |
| &n->where); |
| else if (n->sym->attr.omp_declare_target |
| && !n->sym->attr.omp_declare_target_link |
| && list == OMP_LIST_LINK) |
| gfc_error_now ("OMP DECLARE TARGET variable at %L previously " |
| "mentioned in TO clause and later in LINK clause", |
| &n->where); |
| else if (n->sym->mark) |
| gfc_error_now ("Variable at %L mentioned multiple times in " |
| "clauses of the same OMP DECLARE TARGET directive", |
| &n->where); |
| else if (gfc_add_omp_declare_target (&n->sym->attr, n->sym->name, |
| &n->sym->declared_at)) |
| { |
| if (list == OMP_LIST_LINK) |
| gfc_add_omp_declare_target_link (&n->sym->attr, n->sym->name, |
| &n->sym->declared_at); |
| } |
| n->sym->mark = 1; |
| } |
| else if (n->u.common->omp_declare_target |
| && n->u.common->omp_declare_target_link |
| && list != OMP_LIST_LINK) |
| gfc_error_now ("OMP DECLARE TARGET COMMON at %L previously " |
| "mentioned in LINK clause and later in TO clause", |
| &n->where); |
| else if (n->u.common->omp_declare_target |
| && !n->u.common->omp_declare_target_link |
| && list == OMP_LIST_LINK) |
| gfc_error_now ("OMP DECLARE TARGET COMMON at %L previously " |
| "mentioned in TO clause and later in LINK clause", |
| &n->where); |
| else if (n->u.common->head && n->u.common->head->mark) |
| gfc_error_now ("COMMON at %L mentioned multiple times in " |
| "clauses of the same OMP DECLARE TARGET directive", |
| &n->where); |
| else |
| { |
| n->u.common->omp_declare_target = 1; |
| n->u.common->omp_declare_target_link = (list == OMP_LIST_LINK); |
| for (s = n->u.common->head; s; s = s->common_next) |
| { |
| s->mark = 1; |
| if (gfc_add_omp_declare_target (&s->attr, s->name, |
| &s->declared_at)) |
| { |
| if (list == OMP_LIST_LINK) |
| gfc_add_omp_declare_target_link (&s->attr, s->name, |
| &s->declared_at); |
| } |
| } |
| } |
| |
| gfc_buffer_error (true); |
| |
| if (c) |
| gfc_free_omp_clauses (c); |
| return MATCH_YES; |
| |
| syntax: |
| gfc_error ("Syntax error in !$OMP DECLARE TARGET list at %C"); |
| |
| cleanup: |
| gfc_current_locus = old_loc; |
| if (c) |
| gfc_free_omp_clauses (c); |
| return MATCH_ERROR; |
| } |
| |
| |
| match |
| gfc_match_omp_threadprivate (void) |
| { |
| 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 (" ("); |
| if (m != MATCH_YES) |
| return m; |
| |
| for (;;) |
| { |
| m = gfc_match_symbol (&sym, 0); |
| switch (m) |
| { |
| case MATCH_YES: |
| if (sym->attr.in_common) |
| gfc_error_now ("Threadprivate variable at %C is an element of " |
| "a COMMON block"); |
| else if (!gfc_add_threadprivate (&sym->attr, sym->name, &sym->declared_at)) |
| goto cleanup; |
| 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; |
| } |
| st->n.common->threadprivate = 1; |
| for (sym = st->n.common->head; sym; sym = sym->common_next) |
| if (!gfc_add_threadprivate (&sym->attr, sym->name, &sym->declared_at)) |
| goto cleanup; |
| |
| 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 OMP THREADPRIVATE at %C"); |
| goto cleanup; |
| } |
| |
| return MATCH_YES; |
| |
| syntax: |
| gfc_error ("Syntax error in !$OMP THREADPRIVATE list at %C"); |
| |
| cleanup: |
| gfc_current_locus = old_loc; |
| return MATCH_ERROR; |
| } |
| |
| |
| match |
| gfc_match_omp_parallel (void) |
| { |
| return match_omp (EXEC_OMP_PARALLEL, OMP_PARALLEL_CLAUSES); |
| } |
| |
| |
| match |
| gfc_match_omp_parallel_do (void) |
| { |
| return match_omp (EXEC_OMP_PARALLEL_DO, |
| OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES); |
| } |
| |
| |
| match |
| gfc_match_omp_parallel_do_simd (void) |
| { |
| return match_omp (EXEC_OMP_PARALLEL_DO_SIMD, |
| OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES); |
| } |
| |
| |
| match |
| gfc_match_omp_parallel_sections (void) |
| { |
| return match_omp (EXEC_OMP_PARALLEL_SECTIONS, |
| OMP_PARALLEL_CLAUSES | OMP_SECTIONS_CLAUSES); |
| } |
| |
| |
| match |
| gfc_match_omp_parallel_workshare (void) |
| { |
| return match_omp (EXEC_OMP_PARALLEL_WORKSHARE, OMP_PARALLEL_CLAUSES); |
| } |
| |
| |
| match |
| gfc_match_omp_sections (void) |
| { |
| return match_omp (EXEC_OMP_SECTIONS, OMP_SECTIONS_CLAUSES); |
| } |
| |
| |
| match |
| gfc_match_omp_simd (void) |
| { |
| return match_omp (EXEC_OMP_SIMD, OMP_SIMD_CLAUSES); |
| } |
| |
| |
| match |
| gfc_match_omp_single (void) |
| { |
| return match_omp (EXEC_OMP_SINGLE, OMP_SINGLE_CLAUSES); |
| } |
| |
| |
| match |
| gfc_match_omp_target (void) |
| { |
| return match_omp (EXEC_OMP_TARGET, OMP_TARGET_CLAUSES); |
| } |
| |
| |
| match |
| gfc_match_omp_target_data (void) |
| { |
| return match_omp (EXEC_OMP_TARGET_DATA, OMP_TARGET_DATA_CLAUSES); |
| } |
| |
| |
| match |
| gfc_match_omp_target_enter_data (void) |
| { |
| return match_omp (EXEC_OMP_TARGET_ENTER_DATA, OMP_TARGET_ENTER_DATA_CLAUSES); |
| } |
| |
| |
| match |
| gfc_match_omp_target_exit_data (void) |
| { |
| return match_omp (EXEC_OMP_TARGET_EXIT_DATA, OMP_TARGET_EXIT_DATA_CLAUSES); |
| } |
| |
| |
| match |
| gfc_match_omp_target_parallel (void) |
| { |
| return match_omp (EXEC_OMP_TARGET_PARALLEL, |
| (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES) |
| & ~(omp_mask (OMP_CLAUSE_COPYIN))); |
| } |
| |
| |
| match |
| gfc_match_omp_target_parallel_do (void) |
| { |
| return match_omp (EXEC_OMP_TARGET_PARALLEL_DO, |
| (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES |
| | OMP_DO_CLAUSES) & ~(omp_mask (OMP_CLAUSE_COPYIN))); |
| } |
| |
| |
| match |
| gfc_match_omp_target_parallel_do_simd (void) |
| { |
| return match_omp (EXEC_OMP_TARGET_PARALLEL_DO_SIMD, |
| (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES |
| | OMP_SIMD_CLAUSES) & ~(omp_mask (OMP_CLAUSE_COPYIN))); |
| } |
| |
| |
| match |
| gfc_match_omp_target_simd (void) |
| { |
| return match_omp (EXEC_OMP_TARGET_SIMD, |
| OMP_TARGET_CLAUSES | OMP_SIMD_CLAUSES); |
| } |
| |
| |
| match |
| gfc_match_omp_target_teams (void) |
| { |
| return match_omp (EXEC_OMP_TARGET_TEAMS, |
| OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES); |
| } |
| |
| |
| match |
| gfc_match_omp_target_teams_distribute (void) |
| { |
| return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE, |
| OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES |
| | OMP_DISTRIBUTE_CLAUSES); |
| } |
| |
| |
| match |
| gfc_match_omp_target_teams_distribute_parallel_do (void) |
| { |
| return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO, |
| (OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES |
| | OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES |
| | OMP_DO_CLAUSES) |
| & ~(omp_mask (OMP_CLAUSE_ORDERED)) |
| & ~(omp_mask (OMP_CLAUSE_LINEAR))); |
| } |
| |
| |
| match |
| gfc_match_omp_target_teams_distribute_parallel_do_simd (void) |
| { |
| return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD, |
| (OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES |
| | OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES |
| | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES) |
| & ~(omp_mask (OMP_CLAUSE_ORDERED))); |
| } |
| |
| |
| match |
| gfc_match_omp_target_teams_distribute_simd (void) |
| { |
| return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD, |
| OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES |
| | OMP_DISTRIBUTE_CLAUSES | OMP_SIMD_CLAUSES); |
| } |
| |
| |
| match |
| gfc_match_omp_target_update (void) |
| { |
| return match_omp (EXEC_OMP_TARGET_UPDATE, OMP_TARGET_UPDATE_CLAUSES); |
| } |
| |
| |
| match |
| gfc_match_omp_task (void) |
| { |
| return match_omp (EXEC_OMP_TASK, OMP_TASK_CLAUSES); |
| } |
| |
| |
| match |
| gfc_match_omp_taskloop (void) |
| { |
| return match_omp (EXEC_OMP_TASKLOOP, OMP_TASKLOOP_CLAUSES); |
| } |
| |
| |
| match |
| gfc_match_omp_taskloop_simd (void) |
| { |
| return match_omp (EXEC_OMP_TASKLOOP_SIMD, |
| (OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES) |
| & ~(omp_mask (OMP_CLAUSE_REDUCTION))); |
| } |
| |
| |
| match |
| gfc_match_omp_taskwait (void) |
| { |
| 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; |
| } |
| |
| |
| match |
| gfc_match_omp_taskyield (void) |
| { |
| if (gfc_match_omp_eos () != MATCH_YES) |
| { |
| gfc_error ("Unexpected junk after TASKYIELD clause at %C"); |
| return MATCH_ERROR; |
| } |
| new_st.op = EXEC_OMP_TASKYIELD; |
| new_st.ext.omp_clauses = NULL; |
| return MATCH_YES; |
| } |
| |
| |
| match |
| gfc_match_omp_teams (void) |
| { |
| return match_omp (EXEC_OMP_TEAMS, OMP_TEAMS_CLAUSES); |
| } |
| |
| |
| match |
| gfc_match_omp_teams_distribute (void) |
| { |
| return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE, |
| OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES); |
| } |
| |
| |
| match |
| gfc_match_omp_teams_distribute_parallel_do (void) |
| { |
| return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO, |
| (OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES |
| | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES) |
| & ~(omp_mask (OMP_CLAUSE_ORDERED)) |
| & ~(omp_mask (OMP_CLAUSE_LINEAR))); |
| } |
| |
| |
| match |
| gfc_match_omp_teams_distribute_parallel_do_simd (void) |
| { |
| return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD, |
| (OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES |
| | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES |
| | OMP_SIMD_CLAUSES) & ~(omp_mask (OMP_CLAUSE_ORDERED))); |
| } |
| |
| |
| match |
| gfc_match_omp_teams_distribute_simd (void) |
| { |
| return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_SIMD, |
| OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES |
| | OMP_SIMD_CLAUSES); |
| } |
| |
| |
| match |
| gfc_match_omp_workshare (void) |
| { |
| if (gfc_match_omp_eos () != MATCH_YES) |
| { |
| gfc_error ("Unexpected junk after $OMP WORKSHARE statement at %C"); |
| return MATCH_ERROR; |
| } |
| new_st.op = EXEC_OMP_WORKSHARE; |
| new_st.ext.omp_clauses = gfc_get_omp_clauses (); |
| return MATCH_YES; |
| } |
| |
| |
| match |
| gfc_match_omp_master (void) |
| { |
| if (gfc_match_omp_eos () != MATCH_YES) |
| { |
| gfc_error ("Unexpected junk after $OMP MASTER statement at %C"); |
| return MATCH_ERROR; |
| } |
| new_st.op = EXEC_OMP_MASTER; |
| new_st.ext.omp_clauses = NULL; |
| return MATCH_YES; |
| } |
| |
| |
| match |
| gfc_match_omp_ordered (void) |
| { |
| return match_omp (EXEC_OMP_ORDERED, OMP_ORDERED_CLAUSES); |
| } |
| |
| |
| match |
| gfc_match_omp_ordered_depend (void) |
| { |
| return match_omp (EXEC_OMP_ORDERED, omp_mask (OMP_CLAUSE_DEPEND)); |
| } |
| |
| |
| static match |
| gfc_match_omp_oacc_atomic (bool omp_p) |
| { |
| gfc_omp_atomic_op op = GFC_OMP_ATOMIC_UPDATE; |
| int seq_cst = 0; |
| if (gfc_match ("% seq_cst") == MATCH_YES) |
| seq_cst = 1; |
| locus old_loc = gfc_current_locus; |
| if (seq_cst && gfc_match_char (',') == MATCH_YES) |
| seq_cst = 2; |
| if (seq_cst == 2 |
| || gfc_match_space () == MATCH_YES) |
| { |
| gfc_gobble_whitespace (); |
| if (gfc_match ("update") == MATCH_YES) |
| op = GFC_OMP_ATOMIC_UPDATE; |
| else if (gfc_match ("read") == MATCH_YES) |
| op = GFC_OMP_ATOMIC_READ; |
| else if (gfc_match ("write") == MATCH_YES) |
| op = GFC_OMP_ATOMIC_WRITE; |
| else if (gfc_match ("capture") == MATCH_YES) |
| op = GFC_OMP_ATOMIC_CAPTURE; |
| else |
| { |
| if (seq_cst == 2) |
| gfc_current_locus = old_loc; |
| goto finish; |
| } |
| if (!seq_cst |
| && (gfc_match (", seq_cst") == MATCH_YES |
| || gfc_match ("% seq_cst") == MATCH_YES)) |
| seq_cst = 1; |
| } |
| finish: |
| if (gfc_match_omp_eos () != MATCH_YES) |
| { |
| gfc_error ("Unexpected junk after $OMP ATOMIC statement at %C"); |
| return MATCH_ERROR; |
| } |
| new_st.op = (omp_p ? EXEC_OMP_ATOMIC : EXEC_OACC_ATOMIC); |
| if (seq_cst) |
| op = (gfc_omp_atomic_op) (op | GFC_OMP_ATOMIC_SEQ_CST); |
| new_st.ext.omp_atomic = op; |
| return MATCH_YES; |
| } |
| |
| match |
| gfc_match_oacc_atomic (void) |
| { |
| return gfc_match_omp_oacc_atomic (false); |
| } |
| |
| match |
| gfc_match_omp_atomic (void) |
| { |
| return gfc_match_omp_oacc_atomic (true); |
| } |
| |
| match |
| gfc_match_omp_barrier (void) |
| { |
| if (gfc_match_omp_eos () != MATCH_YES) |
| { |
| gfc_error ("Unexpected junk after $OMP BARRIER statement at %C"); |
| return MATCH_ERROR; |
| } |
| new_st.op = EXEC_OMP_BARRIER; |
| new_st.ext.omp_clauses = NULL; |
| return MATCH_YES; |
| } |
| |
| |
| match |
| gfc_match_omp_taskgroup (void) |
| { |
| if (gfc_match_omp_eos () != MATCH_YES) |
| { |
| gfc_error ("Unexpected junk after $OMP TASKGROUP statement at %C"); |
| return MATCH_ERROR; |
| } |
| new_st.op = EXEC_OMP_TASKGROUP; |
| return MATCH_YES; |
| } |
| |
| |
| static enum gfc_omp_cancel_kind |
| gfc_match_omp_cancel_kind (void) |
| { |
| if (gfc_match_space () != MATCH_YES) |
| return OMP_CANCEL_UNKNOWN; |
| if (gfc_match ("parallel") == MATCH_YES) |
| return OMP_CANCEL_PARALLEL; |
| if (gfc_match ("sections") == MATCH_YES) |
| return OMP_CANCEL_SECTIONS; |
| if (gfc_match ("do") == MATCH_YES) |
| return OMP_CANCEL_DO; |
| if (gfc_match ("taskgroup") == MATCH_YES) |
| return OMP_CANCEL_TASKGROUP; |
| return OMP_CANCEL_UNKNOWN; |
| } |
| |
| |
| match |
| gfc_match_omp_cancel (void) |
| { |
| gfc_omp_clauses *c; |
| enum gfc_omp_cancel_kind kind = gfc_match_omp_cancel_kind (); |
| if (kind == OMP_CANCEL_UNKNOWN) |
| return MATCH_ERROR; |
| if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_IF), false) != MATCH_YES) |
| return MATCH_ERROR; |
| c->cancel = kind; |
| new_st.op = EXEC_OMP_CANCEL; |
| new_st.ext.omp_clauses = c; |
| return MATCH_YES; |
| } |
| |
| |
| match |
| gfc_match_omp_cancellation_point (void) |
| { |
| gfc_omp_clauses *c; |
| enum gfc_omp_cancel_kind kind = gfc_match_omp_cancel_kind (); |
| if (kind == OMP_CANCEL_UNKNOWN) |
| return MATCH_ERROR; |
| if (gfc_match_omp_eos () != MATCH_YES) |
| { |
| gfc_error ("Unexpected junk after $OMP CANCELLATION POINT statement " |
| "at %C"); |
| return MATCH_ERROR; |
| } |
| c = gfc_get_omp_clauses (); |
| c->cancel = kind; |
| new_st.op = EXEC_OMP_CANCELLATION_POINT; |
| new_st.ext.omp_clauses = c; |
| return MATCH_YES; |
| } |
| |
| |
| match |
| gfc_match_omp_end_nowait (void) |
| { |
| bool nowait = false; |
| if (gfc_match ("% nowait") == MATCH_YES) |
| nowait = true; |
| if (gfc_match_omp_eos () != MATCH_YES) |
| { |
| gfc_error ("Unexpected junk after NOWAIT clause at %C"); |
| return MATCH_ERROR; |
| } |
| new_st.op = EXEC_OMP_END_NOWAIT; |
| new_st.ext.omp_bool = nowait; |
| return MATCH_YES; |
| } |
| |
| |
| match |
| gfc_match_omp_end_single (void) |
| { |
| gfc_omp_clauses *c; |
| if (gfc_match ("% nowait") == MATCH_YES) |
| { |
| new_st.op = EXEC_OMP_END_NOWAIT; |
| new_st.ext.omp_bool = true; |
| return MATCH_YES; |
| } |
| if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_COPYPRIVATE)) |
| != MATCH_YES) |
| return MATCH_ERROR; |
| new_st.op = EXEC_OMP_END_SINGLE; |
| new_st.ext.omp_clauses = c; |
| return MATCH_YES; |
| } |
| |
| |
| static bool |
| oacc_is_loop (gfc_code *code) |
| { |
| return code->op == EXEC_OACC_PARALLEL_LOOP |
| || code->op == EXEC_OACC_KERNELS_LOOP |
| || code->op == EXEC_OACC_LOOP; |
| } |
| |
| static void |
| resolve_scalar_int_expr (gfc_expr *expr, const char *clause) |
| { |
| if (!gfc_resolve_expr (expr) |
| || expr->ts.type != BT_INTEGER |
| || expr->rank != 0) |
| gfc_error ("%s clause at %L requires a scalar INTEGER expression", |
| clause, &expr->where); |
| } |
| |
| static void |
| resolve_positive_int_expr (gfc_expr *expr, const char *clause) |
| { |
| resolve_scalar_int_expr (expr, clause); |
| if (expr->expr_type == EXPR_CONSTANT |
| && expr->ts.type == BT_INTEGER |
| && mpz_sgn (expr->value.integer) <= 0) |
| gfc_warning (0, "INTEGER expression of %s clause at %L must be positive", |
| clause, &expr->where); |
| } |
| |
| static void |
| resolve_nonnegative_int_expr (gfc_expr *expr, const char *clause) |
| { |
| resolve_scalar_int_expr (expr, clause); |
| if (expr->expr_type == EXPR_CONSTANT |
| && expr->ts.type == BT_INTEGER |
| && mpz_sgn (expr->value.integer) < 0) |
| gfc_warning (0, "INTEGER expression of %s clause at %L must be " |
| "non-negative", clause, &expr->where); |
| } |
| |
| /* Emits error when symbol is pointer, cray pointer or cray pointee |
| of derived of polymorphic type. */ |
| |
| static void |
| check_symbol_not_pointer (gfc_symbol *sym, locus loc, const char *name) |
| { |
| if (sym->ts.type == BT_DERIVED && sym->attr.pointer) |
| gfc_error ("POINTER object %qs of derived type in %s clause at %L", |
| sym->name, name, &loc); |
| if (sym->ts.type == BT_DERIVED && sym->attr.cray_pointer) |
| gfc_error ("Cray pointer object %qs of derived type in %s clause at %L", |
| sym->name, name, &loc); |
| if (sym->ts.type == BT_DERIVED && sym->attr.cray_pointee) |
| gfc_error ("Cray pointee object %qs of derived type in %s clause at %L", |
| sym->name, name, &loc); |
| |
| if ((sym->ts.type == BT_ASSUMED && sym->attr.pointer) |
| || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) |
| && CLASS_DATA (sym)->attr.pointer)) |
| gfc_error ("POINTER object %qs of polymorphic type in %s clause at %L", |
| sym->name, name, &loc); |
| if ((sym->ts.type == BT_ASSUMED && sym->attr.cray_pointer) |
| || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) |
| && CLASS_DATA (sym)->attr.cray_pointer)) |
| gfc_error ("Cray pointer object %qs of polymorphic type in %s clause at %L", |
| sym->name, name, &loc); |
| if ((sym->ts.type == BT_ASSUMED && sym->attr.cray_pointee) |
| || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) |
| && CLASS_DATA (sym)->attr.cray_pointee)) |
| gfc_error ("Cray pointee object %qs of polymorphic type in %s clause at %L", |
| sym->name, name, &loc); |
| } |
| |
| /* Emits error when symbol represents assumed size/rank array. */ |
| |
| static void |
| check_array_not_assumed (gfc_symbol *sym, locus loc, const char *name) |
| { |
| if (sym->as && sym->as->type == AS_ASSUMED_SIZE) |
| gfc_error ("Assumed size array %qs in %s clause at %L", |
| sym->name, name, &loc); |
| if (sym->as && sym->as->type == AS_ASSUMED_RANK) |
| gfc_error ("Assumed rank array %qs in %s clause at %L", |
| sym->name, name, &loc); |
| if (sym->as && sym->as->type == AS_DEFERRED && sym->attr.pointer |
| && !sym->attr.contiguous) |
| gfc_error ("Noncontiguous deferred shape array %qs in %s clause at %L", |
| sym->name, name, &loc); |
| } |
| |
| static void |
| resolve_oacc_data_clauses (gfc_symbol *sym, locus loc, const char *name) |
| { |
| if (sym->ts.type == BT_DERIVED && sym->attr.allocatable) |
| gfc_error ("ALLOCATABLE object %qs of derived type in %s clause at %L", |
| sym->name, name, &loc); |
| if ((sym->ts.type == BT_ASSUMED && sym->attr.allocatable) |
| || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) |
| && CLASS_DATA (sym)->attr.allocatable)) |
| gfc_error ("ALLOCATABLE object %qs of polymorphic type " |
| "in %s clause at %L", sym->name, name, &loc); |
| check_symbol_not_pointer (sym, loc, name); |
| check_array_not_assumed (sym, loc, name); |
| } |
| |
| static void |
| resolve_oacc_deviceptr_clause (gfc_symbol *sym, locus loc, const char *name) |
| { |
| if (sym->attr.pointer |
| || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) |
| && CLASS_DATA (sym)->attr.class_pointer)) |
| gfc_error ("POINTER object %qs in %s clause at %L", |
| sym->name, name, &loc); |
| if (sym->attr.cray_pointer |
| || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) |
| && CLASS_DATA (sym)->attr.cray_pointer)) |
| gfc_error ("Cray pointer object %qs in %s clause at %L", |
| sym->name, name, &loc); |
| if (sym->attr.cray_pointee |
| || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) |
| && CLASS_DATA (sym)->attr.cray_pointee)) |
| gfc_error ("Cray pointee object %qs in %s clause at %L", |
| sym->name, name, &loc); |
| if (sym->attr.allocatable |
| || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) |
| && CLASS_DATA (sym)->attr.allocatable)) |
| gfc_error ("ALLOCATABLE object %qs in %s clause at %L", |
| sym->name, name, &loc); |
| if (sym->attr.value) |
| gfc_error ("VALUE object %qs in %s clause at %L", |
| sym->name, name, &loc); |
| check_array_not_assumed (sym, loc, name); |
| } |
| |
| |
| struct resolve_omp_udr_callback_data |
| { |
| gfc_symbol *sym1, *sym2; |
| }; |
| |
| |
| static int |
| resolve_omp_udr_callback (gfc_expr **e, int *, void *data) |
| { |
| struct resolve_omp_udr_callback_data *rcd |
| = (struct resolve_omp_udr_callback_data *) data; |
| if ((*e)->expr_type == EXPR_VARIABLE |
| && ((*e)->symtree->n.sym == rcd->sym1 |
| || (*e)->symtree->n.sym == rcd->sym2)) |
| { |
| gfc_ref *ref = gfc_get_ref (); |
| ref->type = REF_ARRAY; |
| ref->u.ar.where = (*e)->where; |
| ref->u.ar.as = (*e)->symtree->n.sym->as; |
| ref->u.ar.type = AR_FULL; |
| ref->u.ar.dimen = 0; |
| ref->next = (*e)->ref; |
| (*e)->ref = ref; |
| } |
| return 0; |
| } |
| |
| |
| static int |
| resolve_omp_udr_callback2 (gfc_expr **e, int *, void *) |
| { |
| if ((*e)->expr_type == EXPR_FUNCTION |
| && (*e)->value.function.isym == NULL) |
| { |
| gfc_symbol *sym = (*e)->symtree->n.sym; |
| if (!sym->attr.intrinsic |
| && sym->attr.if_source == IFSRC_UNKNOWN) |
| gfc_error ("Implicitly declared function %s used in " |
| "!$OMP DECLARE REDUCTION at %L", sym->name, &(*e)->where); |
| } |
| return 0; |
| } |
| |
| |
| static gfc_code * |
| resolve_omp_udr_clause (gfc_omp_namelist *n, gfc_namespace *ns, |
| gfc_symbol *sym1, gfc_symbol *sym2) |
| { |
| gfc_code *copy; |
| gfc_symbol sym1_copy, sym2_copy; |
| |
| if (ns->code->op == EXEC_ASSIGN) |
| { |
| copy = gfc_get_code (EXEC_ASSIGN); |
| copy->expr1 = gfc_copy_expr (ns->code->expr1); |
| copy->expr2 = gfc_copy_expr (ns->code->expr2); |
| } |
| else |
| { |
| copy = gfc_get_code (EXEC_CALL); |
| copy->symtree = ns->code->symtree; |
| copy->ext.actual = gfc_copy_actual_arglist (ns->code->ext.actual); |
| } |
| copy->loc = ns->code->loc; |
| sym1_copy = *sym1; |
| sym2_copy = *sym2; |
| *sym1 = *n->sym; |
| *sym2 = *n->sym; |
| sym1->name = sym1_copy.name; |
| sym2->name = sym2_copy.name; |
| ns->proc_name = ns->parent->proc_name; |
| if (n->sym->attr.dimension) |
| { |
| struct resolve_omp_udr_callback_data rcd; |
| rcd.sym1 = sym1; |
| rcd.sym2 = sym2; |
| gfc_code_walker (©, gfc_dummy_code_callback, |
| resolve_omp_udr_callback, &rcd); |
| } |
| gfc_resolve_code (copy, gfc_current_ns); |
| if (copy->op == EXEC_CALL && copy->resolved_isym == NULL) |
| { |
| gfc_symbol *sym = copy->resolved_sym; |
| if (sym |
| && !sym->attr.intrinsic |
| && sym->attr.if_source == IFSRC_UNKNOWN) |
| gfc_error ("Implicitly declared subroutine %s used in " |
| "!$OMP DECLARE REDUCTION at %L", sym->name, |
| ©->loc); |
| } |
| gfc_code_walker (©, gfc_dummy_code_callback, |
| resolve_omp_udr_callback2, NULL); |
| *sym1 = sym1_copy; |
| *sym2 = sym2_copy; |
| return copy; |
| } |
| |
| /* OpenMP directive resolving routines. */ |
| |
| static void |
| resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, |
| gfc_namespace *ns, bool openacc = false) |
| { |
| gfc_omp_namelist *n; |
| gfc_expr_list *el; |
| int list; |
| int ifc; |
| bool if_without_mod = false; |
| 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", |
| "TO", "FROM", "REDUCTION", "DEVICE_RESIDENT", "LINK", "USE_DEVICE", |
| "CACHE", "IS_DEVICE_PTR", "USE_DEVICE_PTR" }; |
| |
| if (omp_clauses == NULL) |
| return; |
| |
| if (omp_clauses->orderedc && omp_clauses->orderedc < omp_clauses->collapse) |
| gfc_error ("ORDERED clause parameter is less than COLLAPSE at %L", |
| &code->loc); |
| |
| if (omp_clauses->if_expr) |
| { |
| gfc_expr *expr = omp_clauses->if_expr; |
| if (!gfc_resolve_expr (expr) |
| || expr->ts.type != BT_LOGICAL || expr->rank != 0) |
| gfc_error ("IF clause at %L requires a scalar LOGICAL expression", |
| &expr->where); |
| if_without_mod = true; |
| } |
| for (ifc = 0; ifc < OMP_IF_LAST; ifc++) |
| if (omp_clauses->if_exprs[ifc]) |
| { |
| gfc_expr *expr = omp_clauses->if_exprs[ifc]; |
| bool ok = true; |
| if (!gfc_resolve_expr (expr) |
| || expr->ts.type != BT_LOGICAL || expr->rank != 0) |
| gfc_error ("IF clause at %L requires a scalar LOGICAL expression", |
| &expr->where); |
| else if (if_without_mod) |
| { |
| gfc_error ("IF clause without modifier at %L used together with " |
| "IF clauses with modifiers", |
| &omp_clauses->if_expr->where); |
| if_without_mod = false; |
| } |
| else |
| switch (code->op) |
| { |
| case EXEC_OMP_PARALLEL: |
| case EXEC_OMP_PARALLEL_DO: |
| case EXEC_OMP_PARALLEL_SECTIONS: |
| case EXEC_OMP_PARALLEL_WORKSHARE: |
| case EXEC_OMP_PARALLEL_DO_SIMD: |
| case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: |
| case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: |
| case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: |
| case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: |
| ok = ifc == OMP_IF_PARALLEL; |
| break; |
| |
| case EXEC_OMP_TASK: |
| ok = ifc == OMP_IF_TASK; |
| break; |
| |
| case EXEC_OMP_TASKLOOP: |
| case EXEC_OMP_TASKLOOP_SIMD: |
| ok = ifc == OMP_IF_TASKLOOP; |
| break; |
| |
| case EXEC_OMP_TARGET: |
| case EXEC_OMP_TARGET_TEAMS: |
| case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: |
| case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: |
| case EXEC_OMP_TARGET_SIMD: |
| ok = ifc == OMP_IF_TARGET; |
| break; |
| |
| case EXEC_OMP_TARGET_DATA: |
| ok = ifc == OMP_IF_TARGET_DATA; |
| break; |
| |
| case EXEC_OMP_TARGET_UPDATE: |
| ok = ifc == OMP_IF_TARGET_UPDATE; |
| break; |
| |
| case EXEC_OMP_TARGET_ENTER_DATA: |
| ok = ifc == OMP_IF_TARGET_ENTER_DATA; |
| break; |
| |
| case EXEC_OMP_TARGET_EXIT_DATA: |
| ok = ifc == OMP_IF_TARGET_EXIT_DATA; |
| break; |
| |
| case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: |
| case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: |
| case EXEC_OMP_TARGET_PARALLEL: |
| case EXEC_OMP_TARGET_PARALLEL_DO: |
| case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: |
| ok = ifc == OMP_IF_TARGET || ifc == OMP_IF_PARALLEL; |
| break; |
| |
| default: |
| ok = false; |
| break; |
| } |
| if (!ok) |
| { |
| static const char *ifs[] = { |
| "PARALLEL", |
| "TASK", |
| "TASKLOOP", |
| "TARGET", |
| "TARGET DATA", |
| "TARGET UPDATE", |
| "TARGET ENTER DATA", |
| "TARGET EXIT DATA" |
| }; |
| gfc_error ("IF clause modifier %s at %L not appropriate for " |
| "the current OpenMP construct", ifs[ifc], &expr->where); |
| } |
| } |
| |
| if (omp_clauses->final_expr) |
| { |
| gfc_expr *expr = omp_clauses->final_expr; |
| if (!gfc_resolve_expr (expr) |
| || expr->ts.type != BT_LOGICAL || expr->rank != 0) |
| gfc_error ("FINAL clause at %L requires a scalar LOGICAL expression", |
| &expr->where); |
| } |
| if (omp_clauses->num_threads) |
| resolve_positive_int_expr (omp_clauses->num_threads, "NUM_THREADS"); |
| if (omp_clauses->chunk_size) |
| { |
| gfc_expr *expr = omp_clauses->chunk_size; |
| if (!gfc_resolve_expr (expr) |
| || expr->ts.type != BT_INTEGER || expr->rank != 0) |
| gfc_error ("SCHEDULE clause's chunk_size at %L requires " |
| "a scalar INTEGER expression", &expr->where); |
| else if (expr->expr_type == EXPR_CONSTANT |
| && expr->ts.type == BT_INTEGER |
| && mpz_sgn (expr->value.integer) <= 0) |
| gfc_warning (0, "INTEGER expression of SCHEDULE clause's chunk_size " |
| "at %L must be positive", &expr->where); |
| } |
| if (omp_clauses->sched_kind != OMP_SCHED_NONE |
| && omp_clauses->sched_nonmonotonic) |
| { |
| if (omp_clauses->sched_kind != OMP_SCHED_DYNAMIC |
| && omp_clauses->sched_kind != OMP_SCHED_GUIDED) |
| { |
| const char *p; |
| switch (omp_clauses->sched_kind) |
| { |
| case OMP_SCHED_STATIC: p = "STATIC"; break; |
| case OMP_SCHED_RUNTIME: p = "RUNTIME"; break; |
| case OMP_SCHED_AUTO: p = "AUTO"; break; |
| default: gcc_unreachable (); |
| } |
| gfc_error ("NONMONOTONIC modifier specified for %s schedule kind " |
| "at %L", p, &code->loc); |
| } |
| else if (omp_clauses->sched_monotonic) |
| gfc_error ("Both MONOTONIC and NONMONOTONIC schedule modifiers " |
| "specified at %L", &code->loc); |
| else if (omp_clauses->ordered) |
| gfc_error ("NONMONOTONIC schedule modifier specified with ORDERED " |
| "clause at %L", &code->loc); |
| } |
| |
| /* Check that no symbol appears on multiple clauses, except that |
| a symbol can appear on both firstprivate and lastprivate. */ |
| for (list = 0; list < OMP_LIST_NUM; list++) |
| for (n = omp_clauses->lists[list]; n; n = n->next) |
| { |
| n->sym->mark = 0; |
| if (n->sym->attr.flavor == FL_VARIABLE |
| || n->sym->attr.proc_pointer |
| || (!code && (!n->sym->attr.dummy || n->sym->ns != ns))) |
| { |
| if (!code && (!n->sym->attr.dummy || n->sym->ns != ns)) |
| gfc_error ("Variable %qs is not a dummy argument at %L", |
| n->sym->name, &n->where); |
| continue; |
| } |
| if (n->sym->attr.flavor == FL_PROCEDURE |
| && n->sym->result == n->sym |
| && n->sym->attr.function) |
| { |
| if (gfc_current_ns->proc_name == n->sym |
| || (gfc_current_ns->parent |
| && gfc_current_ns->parent->proc_name == n->sym)) |
| continue; |
| if (gfc_current_ns->proc_name->attr.entry_master) |
| { |
| gfc_entry_list *el = gfc_current_ns->entries; |
| for (; el; el = el->next) |
| if (el->sym == n->sym) |
| break; |
| if (el) |
| continue; |
| } |
| if (gfc_current_ns->parent |
| && gfc_current_ns->parent->proc_name->attr.entry_master) |
| { |
| gfc_entry_list *el = gfc_current_ns->parent->entries; |
| for (; el; el = el->next) |
| if (el->sym == n->sym) |
| break; |
| if (el) |
| continue; |
| } |
| } |
| gfc_error ("Object %qs is not a variable at %L", n->sym->name, |
| &n->where); |
| } |
| |
| for (list = 0; list < OMP_LIST_NUM; list++) |
| if (list != OMP_LIST_FIRSTPRIVATE |
| && list != OMP_LIST_LASTPRIVATE |
| && list != OMP_LIST_ALIGNED |
| && list != OMP_LIST_DEPEND |
| && (list != OMP_LIST_MAP || openacc) |
| && list != OMP_LIST_FROM |
| && list != OMP_LIST_TO |
| && (list != OMP_LIST_REDUCTION || !openacc)) |
| for (n = omp_clauses->lists[list]; n; n = n->next) |
| { |
| if (n->sym->mark) |
| gfc_error ("Symbol %qs present on multiple clauses at %L", |
| n->sym->name, &n->where); |
| else |
| n->sym->mark = 1; |
| } |
| |
| gcc_assert (OMP_LIST_LASTPRIVATE == OMP_LIST_FIRSTPRIVATE + 1); |
| for (list = OMP_LIST_FIRSTPRIVATE; list <= OMP_LIST_LASTPRIVATE; list++) |
| for (n = omp_clauses->lists[list]; n; n = n->next) |
| if (n->sym->mark) |
| { |
| gfc_error ("Symbol %qs present on multiple clauses at %L", |
| n->sym->name, &n->where); |
| n->sym->mark = 0; |
| } |
| |
| for (n = omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; n; n = n->next) |
| { |
| if (n->sym->mark) |
| gfc_error ("Symbol %qs present on multiple clauses at %L", |
| n->sym->name, &n->where); |
| else |
| n->sym->mark = 1; |
| } |
| for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next) |
| n->sym->mark = 0; |
| |
| for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next) |
| { |
| if (n->sym->mark) |
| gfc_error ("Symbol %qs present on multiple clauses at %L", |
| n->sym->name, &n->where); |
| else |
| n->sym->mark = 1; |
| } |
| |
| for (n = omp_clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next) |
| n->sym->mark = 0; |
| |
| for (n = omp_clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next) |
| { |
| if (n->sym->mark) |
| gfc_error ("Symbol %qs present on multiple clauses at %L", |
| n->sym->name, &n->where); |
| else |
| n->sym->mark = 1; |
| } |
| |
| /* OpenACC reductions. */ |
| if (openacc) |
| { |
| for (n = omp_clauses->lists[OMP_LIST_REDUCTION]; n; n = n->next) |
| n->sym->mark = 0; |
| |
| for (n = omp_clauses->lists[OMP_LIST_REDUCTION]; n; n = n->next) |
| { |
| if (n->sym->mark) |
| gfc_error ("Symbol %qs present on multiple clauses at %L", |
| n->sym->name, &n->where); |
| else |
| n->sym->mark = 1; |
| |
| /* OpenACC does not support reductions on arrays. */ |
| if (n->sym->as) |
| gfc_error ("Array %qs is not permitted in reduction at %L", |
| n->sym->name, &n->where); |
| } |
| } |
| |
| for (n = omp_clauses->lists[OMP_LIST_TO]; n; n = n->next) |
| n->sym->mark = 0; |
| for (n = omp_clauses->lists[OMP_LIST_FROM]; n; n = n->next) |
| if (n->expr == NULL) |
| n->sym->mark = 1; |
| for (n = omp_clauses->lists[OMP_LIST_TO]; n; n = n->next) |
| { |
| if (n->expr == NULL && n->sym->mark) |
| gfc_error ("Symbol %qs present on both FROM and TO clauses at %L", |
| n->sym->name, &n->where); |
| else |
| n->sym->mark = 1; |
| } |
| |
| for (list = 0; list < OMP_LIST_NUM; list++) |
| if ((n = omp_clauses->lists[list]) != NULL) |
| { |
| const char *name; |
| |
| if (list < OMP_LIST_NUM) |
| name = clause_names[list]; |
| else |
| gcc_unreachable (); |
| |
| switch (list) |
| { |
| case OMP_LIST_COPYIN: |
| for (; n != NULL; n = n->next) |
| { |
| if (!n->sym->attr.threadprivate) |
| gfc_error ("Non-THREADPRIVATE object %qs in COPYIN clause" |
| " at %L", n->sym->name, &n->where); |
| } |
| break; |
| case OMP_LIST_COPYPRIVATE: |
| for (; n != NULL; n = n->next) |
| { |
| if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE) |
| gfc_error ("Assumed size array %qs in COPYPRIVATE clause " |
| "at %L", n->sym->name, &n->where); |
| if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN) |
| gfc_error ("INTENT(IN) POINTER %qs in COPYPRIVATE clause " |
| "at %L", n->sym->name, &n->where); |
| } |
| break; |
| case OMP_LIST_SHARED: |
| for (; n != NULL; n = n->next) |
| { |
| if (n->sym->attr.threadprivate) |
| gfc_error ("THREADPRIVATE object %qs in SHARED clause at " |
| "%L", n->sym->name, &n->where); |
| if (n->sym->attr.cray_pointee) |
| gfc_error ("Cray pointee %qs in SHARED clause at %L", |
| n->sym->name, &n->where); |
| if (n->sym->attr.associate_var) |
| gfc_error ("ASSOCIATE name %qs in SHARED clause at %L", |
| n->sym->name, &n->where); |
| } |
| break; |
| case OMP_LIST_ALIGNED: |
| for (; n != NULL; n = n->next) |
| { |
| if (!n->sym->attr.pointer |
| && !n->sym->attr.allocatable |
| && !n->sym->attr.cray_pointer |
| && (n->sym->ts.type != BT_DERIVED |
| || (n->sym->ts.u.derived->from_intmod |
| != INTMOD_ISO_C_BINDING) |
| || (n->sym->ts.u.derived->intmod_sym_id |
| != ISOCBINDING_PTR))) |
| gfc_error ("%qs in ALIGNED clause must be POINTER, " |
| "ALLOCATABLE, Cray pointer or C_PTR at %L", |
| n->sym->name, &n->where); |
| else if (n->expr) |
| { |
| gfc_expr *expr = n->expr; |
| int alignment = 0; |
| if (!gfc_resolve_expr (expr) |
| || expr->ts.type != BT_INTEGER |
| || expr->rank != 0 |
| || gfc_extract_int (expr, &alignment) |
| || alignment <= 0) |
| gfc_error ("%qs in ALIGNED clause at %L requires a scalar " |
| "positive constant integer alignment " |
| "expression", n->sym->name, &n->where); |
| } |
| } |
| break; |
| case OMP_LIST_DEPEND: |
| case OMP_LIST_MAP: |
| case OMP_LIST_TO: |
| case OMP_LIST_FROM: |
| case OMP_LIST_CACHE: |
| for (; n != NULL; n = n->next) |
| { |
| if (list == OMP_LIST_DEPEND) |
| { |
| if (n->u.depend_op == OMP_DEPEND_SINK_FIRST |
| || n->u.depend_op == OMP_DEPEND_SINK) |
| { |
| if (code->op != EXEC_OMP_ORDERED) |
| gfc_error ("SINK dependence type only allowed " |
| "on ORDERED directive at %L", &n->where); |
| else if (omp_clauses->depend_source) |
| { |
| gfc_error ("DEPEND SINK used together with " |
| "DEPEND SOURCE on the same construct " |
| "at %L", &n->where); |
| omp_clauses->depend_source = false; |
| } |
| else if (n->expr) |
| { |
| if (!gfc_resolve_expr (n->expr) |
| || n->expr->ts.type != BT_INTEGER |
| || n->expr->rank != 0) |
| gfc_error ("SINK addend not a constant integer " |
| "at %L", &n->where); |
| } |
| continue; |
| } |
| else if (code->op == EXEC_OMP_ORDERED) |
| gfc_error ("Only SOURCE or SINK dependence types " |
| "are allowed on ORDERED directive at %L", |
| &n->where); |
| } |
| if (n->expr) |
| { |
| if (!gfc_resolve_expr (n->expr) |
| || n->expr->expr_type != EXPR_VARIABLE |
| || n->expr->ref == NULL |
| || n->expr->ref->next |
| || n->expr->ref->type != REF_ARRAY) |
| gfc_error ("%qs in %s clause at %L is not a proper " |
| "array section", n->sym->name, name, |
| &n->where); |
| else if (n->expr->ref->u.ar.codimen) |
| gfc_error ("Coarrays not supported in %s clause at %L", |
| name, &n->where); |
| else |
| { |
| int i; |
| gfc_array_ref *ar = &n->expr->ref->u.ar; |
| for (i = 0; i < ar->dimen; i++) |
| if (ar->stride[i]) |
| { |
| gfc_error ("Stride should not be specified for " |
| "array section in %s clause at %L", |
| name, &n->where); |
| break; |
| } |
| else if (ar->dimen_type[i] != DIMEN_ELEMENT |
| && ar->dimen_type[i] != DIMEN_RANGE) |
| { |
| gfc_error ("%qs in %s clause at %L is not a " |
| "proper array section", |
| n->sym->name, name, &n->where); |
| break; |
| } |
| else if (list == OMP_LIST_DEPEND |
| && ar->start[i] |
| && ar->start[i]->expr_type == EXPR_CONSTANT |
| && ar->end[i] |
| && ar->end[i]->expr_type == EXPR_CONSTANT |
| && mpz_cmp (ar->start[i]->value.integer, |
| ar->end[i]->value.integer) > 0) |
| { |
| gfc_error ("%qs in DEPEND clause at %L is a " |
| "zero size array section", |
| n->sym->name, &n->where); |
| break; |
| } |
| } |
| } |
| else if (openacc) |
| { |
| if (list == OMP_LIST_MAP |
| && n->u.map_op == OMP_MAP_FORCE_DEVICEPTR) |
| resolve_oacc_deviceptr_clause (n->sym, n->where, name); |
| else |
| resolve_oacc_data_clauses (n->sym, n->where, name); |
| } |
| else if (list != OMP_LIST_DEPEND |
| && n->sym->as |
| && n->sym->as->type == AS_ASSUMED_SIZE) |
| gfc_error ("Assumed size array %qs in %s clause at %L", |
| n->sym->name, name, &n->where); |
| if (list == OMP_LIST_MAP && !openacc) |
| switch (code->op) |
| { |
| case EXEC_OMP_TARGET: |
| case EXEC_OMP_TARGET_DATA: |
| switch (n->u.map_op) |
| { |
| case OMP_MAP_TO: |
| case OMP_MAP_ALWAYS_TO: |
| case OMP_MAP_FROM: |
| case OMP_MAP_ALWAYS_FROM: |
| case OMP_MAP_TOFROM: |
| case OMP_MAP_ALWAYS_TOFROM: |
| case OMP_MAP_ALLOC: |
| break; |
| default: |
| gfc_error ("TARGET%s with map-type other than TO, " |
| "FROM, TOFROM, or ALLOC on MAP clause " |
| "at %L", |
| code->op == EXEC_OMP_TARGET |
| ? "" : " DATA", &n->where); |
| break; |
| } |
| break; |
| case EXEC_OMP_TARGET_ENTER_DATA: |
| switch (n->u.map_op) |
| { |
| case OMP_MAP_TO: |
| case OMP_MAP_ALWAYS_TO: |
| case OMP_MAP_ALLOC: |
| break; |
| default: |
| gfc_error ("TARGET ENTER DATA with map-type other " |
| "than TO, or ALLOC on MAP clause at %L", |
| &n->where); |
| break; |
| } |
| break; |
| case EXEC_OMP_TARGET_EXIT_DATA: |
| switch (n->u.map_op) |
| { |
| case OMP_MAP_FROM: |
| case OMP_MAP_ALWAYS_FROM: |
| case OMP_MAP_RELEASE: |
| case OMP_MAP_DELETE: |
| break; |
| default: |
| gfc_error ("TARGET EXIT DATA with map-type other " |
| "than FROM, RELEASE, or DELETE on MAP " |
| "clause at %L", &n->where); |
| break; |
| } |
| break; |
| default: |
| break; |
| } |
| } |
| |
| if (list != OMP_LIST_DEPEND) |
| for (n = omp_clauses->lists[list]; n != NULL; n = n->next) |
| { |
| n->sym->attr.referenced = 1; |
| if (n->sym->attr.threadprivate) |
| gfc_error ("THREADPRIVATE object %qs in %s clause at %L", |
| n->sym->name, name, &n->where); |
| if (n->sym->attr.cray_pointee) |
| gfc_error ("Cray pointee %qs in %s clause at %L", |
| n->sym->name, name, &n->where); |
| } |
| break; |
| case OMP_LIST_IS_DEVICE_PTR: |
| case OMP_LIST_USE_DEVICE_PTR: |
| /* FIXME: Handle these. */ |
| break; |
| default: |
| for (; n != NULL; n = n->next) |
| { |
| bool bad = false; |
| if (n->sym->attr.threadprivate) |
| gfc_error ("THREADPRIVATE object %qs in %s clause at %L", |
| n->sym->name, name, &n->where); |
| if (n->sym->attr.cray_pointee) |
| gfc_error ("Cray pointee %qs in %s clause at %L", |
| n->sym->name, name, &n->where); |
| if (n->sym->attr.associate_var) |
| gfc_error ("ASSOCIATE name %qs in %s clause at %L", |
| n->sym->name, name, &n->where); |
| if (list != OMP_LIST_PRIVATE) |
| { |
| if (n->sym->attr.proc_pointer && list == OMP_LIST_REDUCTION) |
| gfc_error ("Procedure pointer %qs in %s clause at %L", |
| n->sym->name, name, &n->where); |
| if (n->sym->attr.pointer && list == OMP_LIST_REDUCTION) |
| gfc_error ("POINTER object %qs in %s clause at %L", |
| n->sym->name, name, &n->where); |
| if (n->sym->attr.cray_pointer && list == OMP_LIST_REDUCTION) |
| gfc_error ("Cray pointer %qs in %s clause at %L", |
| n->sym->name, name, &n->where); |
| } |
| if (code |
| && (oacc_is_loop (code) || code->op == EXEC_OACC_PARALLEL)) |
| check_array_not_assumed (n->sym, n->where, name); |
| else if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE) |
| gfc_error ("Assumed size array %qs in %s clause at %L", |
| n->sym->name, name, &n->where); |
| if (n->sym->attr.in_namelist && list != OMP_LIST_REDUCTION) |
| gfc_error ("Variable %qs in %s clause is used in " |
| "NAMELIST statement at %L", |
| n->sym->name, name, &n->where); |
| if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN) |
| switch (list) |
| { |
| case OMP_LIST_PRIVATE: |
| case OMP_LIST_LASTPRIVATE: |
| case OMP_LIST_LINEAR: |
| /* case OMP_LIST_REDUCTION: */ |
| gfc_error ("INTENT(IN) POINTER %qs in %s clause at %L", |
| n->sym->name, name, &n->where); |
| break; |
| default: |
| break; |
| } |
| |
| switch (list) |
| { |
| case OMP_LIST_REDUCTION: |
| switch (n->u.reduction_op) |
| { |
| case OMP_REDUCTION_PLUS: |
| case OMP_REDUCTION_TIMES: |
| case OMP_REDUCTION_MINUS: |
| if (!gfc_numeric_ts (&n->sym->ts)) |
| bad = true; |
| break; |
| case OMP_REDUCTION_AND: |
| case OMP_REDUCTION_OR: |
| case OMP_REDUCTION_EQV: |
| case OMP_REDUCTION_NEQV: |
| if (n->sym->ts.type != BT_LOGICAL) |
| bad = true; |
| break; |
| case OMP_REDUCTION_MAX: |
| case OMP_REDUCTION_MIN: |
| if (n->sym->ts.type != BT_INTEGER |
| && n->sym->ts.type != BT_REAL) |
| bad = true; |
| break; |
| case OMP_REDUCTION_IAND: |
| case OMP_REDUCTION_IOR: |
| case OMP_REDUCTION_IEOR: |
| if (n->sym->ts.type != BT_INTEGER) |
| bad = true; |
| break; |
| case OMP_REDUCTION_USER: |
| bad = true; |
| break; |
| default: |
| break; |
| } |
| if (!bad) |
| n->udr = NULL; |
| else |
| { |
| const char *udr_name = NULL; |
| if (n->udr) |
| { |
| udr_name = n->udr->udr->name; |
| n->udr->udr |
| = gfc_find_omp_udr (NULL, udr_name, |
| &n->sym->ts); |
| if (n->udr->udr == NULL) |
| { |
| free (n->udr); |
| n->udr = NULL; |
| } |
| } |
| if (n->udr == NULL) |
| { |
| if (udr_name == NULL) |
| switch (n->u.reduction_op) |
| { |
| case OMP_REDUCTION_PLUS: |
| case OMP_REDUCTION_TIMES: |
| case OMP_REDUCTION_MINUS: |
| case OMP_REDUCTION_AND: |
| case OMP_REDUCTION_OR: |
| case OMP_REDUCTION_EQV: |
| case OMP_REDUCTION_NEQV: |
| udr_name = gfc_op2string ((gfc_intrinsic_op) |
| n->u.reduction_op); |
| break; |
| case OMP_REDUCTION_MAX: |
| udr_name = "max"; |
| break; |
| case OMP_REDUCTION_MIN: |
| udr_name = "min"; |
| break; |
| case OMP_REDUCTION_IAND: |
| udr_name = "iand"; |
| break; |
| case OMP_REDUCTION_IOR: |
| udr_name = "ior"; |
| break; |
| case OMP_REDUCTION_IEOR: |
| udr_name = "ieor"; |
| break; |
| default: |
| gcc_unreachable (); |
| } |
| gfc_error ("!$OMP DECLARE REDUCTION %s not found " |
| "for type %s at %L", udr_name, |
| gfc_typename (&n->sym->ts), &n->where); |
| } |
| else |
| { |
| gfc_omp_udr *udr = n->udr->udr; |
| n->u.reduction_op = OMP_REDUCTION_USER; |
| n->udr->combiner |
| = resolve_omp_udr_clause (n, udr->combiner_ns, |
| udr->omp_out, |
| udr->omp_in); |
| if (udr->initializer_ns) |
| n->udr->initializer |
| = resolve_omp_udr_clause (n, |
| udr->initializer_ns, |
| udr->omp_priv, |
| udr->omp_orig); |
| } |
| } |
| break; |
| case OMP_LIST_LINEAR: |
| if (code |
| && n->u.linear_op != OMP_LINEAR_DEFAULT |
| && n->u.linear_op != linear_op) |
| { |
| gfc_error ("LINEAR clause modifier used on DO or SIMD" |
| " construct at %L", &n->where); |
| linear_op = n->u.linear_op; |
| } |
| else if (omp_clauses->orderedc) |
| gfc_error ("LINEAR clause specified together with " |
| "ORDERED clause with argument at %L", |
| &n->where); |
| else if (n->u.linear_op != OMP_LINEAR_REF |
| && n->sym->ts.type != BT_INTEGER) |
| gfc_error ("LINEAR variable %qs must be INTEGER " |
| "at %L", n->sym->name, &n->where); |
| else if ((n->u.linear_op == OMP_LINEAR_REF |
| || n->u.linear_op == OMP_LINEAR_UVAL) |
| && n->sym->attr.value) |
| gfc_error ("LINEAR dummy argument %qs with VALUE " |
| "attribute with %s modifier at %L", |
| n->sym->name, |
| n->u.linear_op == OMP_LINEAR_REF |
| ? "REF" : "UVAL", &n->where); |
| else if (n->expr) |
| { |
| gfc_expr *expr = n->expr; |
| if (!gfc_resolve_expr (expr) |
| || expr->ts.type != BT_INTEGER |
| || expr->rank != 0) |
| gfc_error ("%qs in LINEAR clause at %L requires " |
| "a scalar integer linear-step expression", |
| n->sym->name, &n->where); |
| else if (!code && expr->expr_type != EXPR_CONSTANT) |
| { |
| if (expr->expr_type == EXPR_VARIABLE |
| && expr->symtree->n.sym->attr.dummy |
| && expr->symtree->n.sym->ns == ns) |
| { |
| gfc_omp_namelist *n2; |
| for (n2 = omp_clauses->lists[OMP_LIST_UNIFORM]; |
| n2; n2 = n2->next) |
| if (n2->sym == expr->symtree->n.sym) |
| break; |
| if (n2) |
| break; |
| } |
| gfc_error ("%qs in LINEAR clause at %L requires " |
| "a constant integer linear-step " |
| "expression or dummy argument " |
| "specified in UNIFORM clause", |
| n->sym->name, &n->where); |
| } |
| } |
| break; |
| /* Workaround for PR middle-end/26316, nothing really needs |
| to be done here for OMP_LIST_PRIVATE. */ |
| case OMP_LIST_PRIVATE: |
| gcc_assert (code && code->op != EXEC_NOP); |
| break; |
| case OMP_LIST_USE_DEVICE: |
| if (n->sym->attr.allocatable |
| || (n->sym->ts.type == BT_CLASS && CLASS_DATA (n->sym) |
| && CLASS_DATA (n->sym)->attr.allocatable)) |
| gfc_error ("ALLOCATABLE object %qs in %s clause at %L", |
| n->sym->name, name, &n->where); |
| if (n->sym->ts.type == BT_CLASS |
| && CLASS_DATA (n->sym) |
| && CLASS_DATA (n->sym)->attr.class_pointer) |
| gfc_error ("POINTER object %qs of polymorphic type in " |
| "%s clause at %L", n->sym->name, name, |
| &n->where); |
| if (n->sym->attr.cray_pointer) |
| gfc_error ("Cray pointer object %qs in %s clause at %L", |
| n->sym->name, name, &n->where); |
| else if (n->sym->attr.cray_pointee) |
| gfc_error ("Cray pointee object %qs in %s clause at %L", |
| n->sym->name, name, &n->where); |
| else if (n->sym->attr.flavor == FL_VARIABLE |
| && !n->sym->as |
| && !n->sym->attr.pointer) |
| gfc_error ("%s clause variable %qs at %L is neither " |
| "a POINTER nor an array", name, |
| n->sym->name, &n->where); |
| /* FALLTHRU */ |
| case OMP_LIST_DEVICE_RESIDENT: |
| check_symbol_not_pointer (n->sym, n->where, name); |
| check_array_not_assumed (n->sym, n->where, name); |
| break; |
| default: |
| break; |
| } |
| } |
| break; |
| } |
| } |
| if (omp_clauses->safelen_expr) |
| resolve_positive_int_expr (omp_clauses->safelen_expr, "SAFELEN"); |
| if (omp_clauses->simdlen_expr) |
| resolve_positive_int_expr (omp_clauses->simdlen_expr, "SIMDLEN"); |
| if (omp_clauses->num_teams) |
| resolve_positive_int_expr (omp_clauses->num_teams, "NUM_TEAMS"); |
| if (omp_clauses->device) |
| resolve_nonnegative_int_expr (omp_clauses->device, "DEVICE"); |
| if (omp_clauses->hint) |
| resolve_scalar_int_expr (omp_clauses->hint, "HINT"); |
| if (omp_clauses->priority) |
| resolve_nonnegative_int_expr (omp_clauses->priority, "PRIORITY"); |
| if (omp_clauses->dist_chunk_size) |
| { |
| gfc_expr *expr = omp_clauses->dist_chunk_size; |
| if (!gfc_resolve_expr (expr) |
| || expr->ts.type != BT_INTEGER || expr->rank != 0) |
| gfc_error ("DIST_SCHEDULE clause's chunk_size at %L requires " |
| "a scalar INTEGER expression", &expr->where); |
| } |
| if (omp_clauses->thread_limit) |
| resolve_positive_int_expr (omp_clauses->thread_limit, "THREAD_LIMIT"); |
| if (omp_clauses->grainsize) |
| resolve_positive_int_expr (omp_clauses->grainsize, "GRAINSIZE"); |
| if (omp_clauses->num_tasks) |
| resolve_positive_int_expr (omp_clauses->num_tasks, "NUM_TASKS"); |
| if (omp_clauses->async) |
| if (omp_clauses->async_expr) |
| resolve_scalar_int_expr (omp_clauses->async_expr, "ASYNC"); |
| if (omp_clauses->num_gangs_expr) |
| resolve_positive_int_expr (omp_clauses->num_gangs_expr, "NUM_GANGS"); |
| if (omp_clauses->num_workers_expr) |
| resolve_positive_int_expr (omp_clauses->num_workers_expr, "NUM_WORKERS"); |
| if (omp_clauses->vector_length_expr) |
| resolve_positive_int_expr (omp_clauses->vector_length_expr, |
| "VECTOR_LENGTH"); |
| if (omp_clauses->gang_num_expr) |
| resolve_positive_int_expr (omp_clauses->gang_num_expr, "GANG"); |
| if (omp_clauses->gang_static_expr) |
| resolve_positive_int_expr (omp_clauses->gang_static_expr, "GANG"); |
| if (omp_clauses->worker_expr) |
| resolve_positive_int_expr (omp_clauses->worker_expr, "WORKER"); |
| if (omp_clauses->vector_expr) |
| resolve_positive_int_expr (omp_clauses->vector_expr, "VECTOR"); |
| for (el = omp_clauses->wait_list; el; el = el->next) |
| resolve_scalar_int_expr (el->expr, "WAIT"); |
| if (omp_clauses->collapse && omp_clauses->tile_list) |
| gfc_error ("Incompatible use of TILE and COLLAPSE at %L", &code->loc); |
| if (omp_clauses->depend_source && code->op != EXEC_OMP_ORDERED) |
| gfc_error ("SOURCE dependence type only allowed " |
| "on ORDERED directive at %L", &code->loc); |
| if (!openacc && code && omp_clauses->lists[OMP_LIST_MAP] == NULL) |
| { |
| const char *p = NULL; |
| switch (code->op) |
| { |
| case EXEC_OMP_TARGET_DATA: p = "TARGET DATA"; break; |
| case EXEC_OMP_TARGET_ENTER_DATA: p = "TARGET ENTER DATA"; break; |
| case EXEC_OMP_TARGET_EXIT_DATA: p = "TARGET EXIT DATA"; break; |
| default: break; |
| } |
| if (p) |
| gfc_error ("%s must contain at least one MAP clause at %L", |
| p, &code->loc); |
| } |
| } |
| |
| |
| /* Return true if SYM is ever referenced in EXPR except in the SE node. */ |
| |
| static bool |
| expr_references_sym (gfc_expr *e, gfc_symbol *s, gfc_expr *se) |
| { |
| gfc_actual_arglist *arg; |
| if (e == NULL || e == se) |
| return false; |
| switch (e->expr_type) |
| { |
| case EXPR_CONSTANT: |
| case EXPR_NULL: |
| case EXPR_VARIABLE: |
| case EXPR_STRUCTURE: |
| case EXPR_ARRAY: |
| if (e->symtree != NULL |
| && e->symtree->n.sym == s) |
| return true; |
| return false; |
| case EXPR_SUBSTRING: |
| if (e->ref != NULL |
| && (expr_references_sym (e->ref->u.ss.start, s, se) |
| || expr_references_sym (e->ref->u.ss.end, s, se))) |
| return true; |
| return false; |
| case EXPR_OP: |
| if (expr_references_sym (e->value.op.op2, s, se)) |
| return true; |
| return expr_references_sym (e->value.op.op1, s, se); |
| case EXPR_FUNCTION: |
| for (arg = e->value.function.actual; arg; arg = arg->next) |
| if (expr_references_sym (arg->expr, s, se)) |
| return true; |
| return false; |
| default: |
| gcc_unreachable (); |
| } |
| } |
| |
| |
| /* If EXPR is a conversion function that widens the type |
| if WIDENING is true or narrows the type if WIDENING is false, |
| return the inner expression, otherwise return NULL. */ |
| |
| static gfc_expr * |
| is_conversion (gfc_expr *expr, bool widening) |
| { |
| gfc_typespec *ts1, *ts2; |
| |
| if (expr->expr_type != EXPR_FUNCTION |
| || expr->value.function.isym == NULL |
| || expr->value.function.esym != NULL |
| || expr->value.function.isym->id != GFC_ISYM_CONVERSION) |
| return NULL; |
| |
| if (widening) |
| { |
| ts1 = &expr->ts; |
| ts2 = &expr->value.function.actual->expr->ts; |
| } |
| else |
| { |
| ts1 = &expr->value.function.actual->expr->ts; |
| ts2 = &expr->ts; |
| } |
| |
| if (ts1->type > ts2->type |
| || (ts1->type == ts2->type && ts1->kind > ts2->kind)) |
| return expr->value.function.actual->expr; |
| |
| return NULL; |
| } |
| |
| |
| static void |
| resolve_omp_atomic (gfc_code *code) |
| { |
| gfc_code *atomic_code = code; |
| gfc_symbol *var; |
| gfc_expr *expr2, *expr2_tmp; |
| gfc_omp_atomic_op aop |
| = (gfc_omp_atomic_op) (atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_MASK); |
| |
| code = code->block->next; |
| /* resolve_blocks asserts this is initially EXEC_ASSIGN. |
| If it changed to EXEC_NOP, assume an error has been emitted already. */ |
| if (code->op == EXEC_NOP) |
| return; |
| if (code->op != EXEC_ASSIGN) |
| { |
| unexpected: |
| gfc_error ("unexpected !$OMP ATOMIC expression at %L", &code->loc); |
| return; |
| } |
| if (aop != GFC_OMP_ATOMIC_CAPTURE) |
| { |
| if (code->next != NULL) |
| goto unexpected; |
| } |
| else |
| { |
| if (code->next == NULL) |
| goto unexpected; |
| if (code->next->op == EXEC_NOP) |
| return; |
| if (code->next->op != EXEC_ASSIGN || code->next->next) |
| { |
| code = code->next; |
| goto unexpected; |
| } |
| } |
| |
| if (code->expr1->expr_type != EXPR_VARIABLE |
| || code->expr1->symtree == NULL |
| || code->expr1->rank != 0 |
| || (code->expr1->ts.type != BT_INTEGER |
| && code->expr1->ts.type != BT_REAL |
| && code->expr1->ts.type != BT_COMPLEX |
| && code->expr1->ts.type != BT_LOGICAL)) |
| { |
| gfc_error ("!$OMP ATOMIC statement must set a scalar variable of " |
| "intrinsic type at %L", &code->loc); |
| return; |
| } |
| |
| var = code->expr1->symtree->n.sym; |
| expr2 = is_conversion (code->expr2, false); |
| if (expr2 == NULL) |
| { |
| if (aop == GFC_OMP_ATOMIC_READ || aop == GFC_OMP_ATOMIC_WRITE) |
| expr2 = is_conversion (code->expr2, true); |
| if (expr2 == NULL) |
| expr2 = code->expr2; |
| } |
| |
| switch (aop) |
| { |
| case GFC_OMP_ATOMIC_READ: |
| if (expr2->expr_type != EXPR_VARIABLE |
| || expr2->symtree == NULL |
| || expr2->rank != 0 |
| || (expr2->ts.type != BT_INTEGER |
| && expr2->ts.type != BT_REAL |
| && expr2->ts.type != BT_COMPLEX |
| && expr2->ts.type != BT_LOGICAL)) |
| gfc_error ("!$OMP ATOMIC READ statement must read from a scalar " |
| "variable of intrinsic type at %L", &expr2->where); |
| return; |
| case GFC_OMP_ATOMIC_WRITE: |
| if (expr2->rank != 0 || expr_references_sym (code->expr2, var, NULL)) |
| gfc_error ("expr in !$OMP ATOMIC WRITE assignment var = expr " |
| "must be scalar and cannot reference var at %L", |
| &expr2->where); |
| return; |
| case GFC_OMP_ATOMIC_CAPTURE: |
| expr2_tmp = expr2; |
| if (expr2 == code->expr2) |
| { |
| expr2_tmp = is_conversion (code->expr2, true); |
| if (expr2_tmp == NULL) |
| expr2_tmp = expr2; |
| } |
| if (expr2_tmp->expr_type == EXPR_VARIABLE) |
| { |
| if (expr2_tmp->symtree == NULL |
| || expr2_tmp->rank != 0 |
| || (expr2_tmp->ts.type != BT_INTEGER |
| && expr2_tmp->ts.type != BT_REAL |
| && expr2_tmp->ts.type != BT_COMPLEX |
| && expr2_tmp->ts.type != BT_LOGICAL) |
| || expr2_tmp->symtree->n.sym == var) |
| { |
| gfc_error ("!$OMP ATOMIC CAPTURE capture statement must read from " |
| "a scalar variable of intrinsic type at %L", |
| &expr2_tmp->where); |
| return; |
| } |
| var = expr2_tmp->symtree->n.sym; |
| code = code->next; |
| if (code->expr1->expr_type != EXPR_VARIABLE |
| || code->expr1->symtree == NULL |
| || code->expr1->rank != 0 |
| || (code->expr1->ts.type != BT_INTEGER |
| && code->expr1->ts.type != BT_REAL |
| && code->expr1->ts.type != BT_COMPLEX |
| && code->expr1->ts.type != BT_LOGICAL)) |
| { |
| gfc_error ("!$OMP ATOMIC CAPTURE update statement must set " |
| "a scalar variable of intrinsic type at %L", |
| &code->expr1->where); |
| return; |
| } |
| if (code->expr1->symtree->n.sym != var) |
| { |
| gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from " |
| "different variable than update statement writes " |
| "into at %L", &code->expr1->where); |
| return; |
| } |
| expr2 = is_conversion (code->expr2, false); |
| if (expr2 == NULL) |
| expr2 = code->expr2; |
| } |
| break; |
| default: |
| break; |
| } |
| |
| if (gfc_expr_attr (code->expr1).allocatable) |
| { |
| gfc_error ("!$OMP ATOMIC with ALLOCATABLE variable at %L", |
| &code->loc); |
| return; |
| } |
| |
| if (aop == GFC_OMP_ATOMIC_CAPTURE |
| && code->next == NULL |
| && code->expr2->rank == 0 |
| && !expr_references_sym (code->expr2, var, NULL)) |
| atomic_code->ext.omp_atomic |
| = (gfc_omp_atomic_op) (atomic_code->ext.omp_atomic |
| | GFC_OMP_ATOMIC_SWAP); |
| else if (expr2->expr_type == EXPR_OP) |
| { |
| gfc_expr *v = NULL, *e, *c; |
| gfc_intrinsic_op op = expr2->value.op.op; |
| gfc_intrinsic_op alt_op = INTRINSIC_NONE; |
| |
| switch (op) |
| { |
| case INTRINSIC_PLUS: |
| alt_op = INTRINSIC_MINUS; |
| break; |
| case INTRINSIC_TIMES: |
| alt_op = INTRINSIC_DIVIDE; |
| break; |
| case INTRINSIC_MINUS: |
| alt_op = INTRINSIC_PLUS; |
| break; |
| case INTRINSIC_DIVIDE: |
| alt_op = INTRINSIC_TIMES; |
| break; |
| case INTRINSIC_AND: |
| case INTRINSIC_OR: |
| break; |
| case INTRINSIC_EQV: |
| alt_op = INTRINSIC_NEQV; |
| break; |
| case INTRINSIC_NEQV: |
| alt_op = INTRINSIC_EQV; |
| break; |
| default: |
| gfc_error ("!$OMP ATOMIC assignment operator must be binary " |
| "+, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L", |
| &expr2->where); |
| return; |
| } |
| |
| /* Check for var = var op expr resp. var = expr op var where |
| expr doesn't reference var and var op expr is mathematically |
| equivalent to var op (expr) resp. expr op var equivalent to |
| (expr) op var. We rely here on the fact that the matcher |
| for x op1 y op2 z where op1 and op2 have equal precedence |
| returns (x op1 y) op2 z. */ |
| e = expr2->value.op.op2; |
| if (e->expr_type == EXPR_VARIABLE |
| && e->symtree != NULL |
| && e->symtree->n.sym == var) |
| v = e; |
| else if ((c = is_conversion (e, true)) != NULL |
| && c->expr_type == EXPR_VARIABLE |
| && c->symtree != NULL |
| && c->symtree->n.sym == var) |
| v = c; |
| else |
| { |
| gfc_expr **p = NULL, **q; |
| for (q = &expr2->value.op.op1; (e = *q) != NULL; ) |
| if (e->expr_type == EXPR_VARIABLE |
| && e->symtree != NULL |
| && e->symtree->n.sym == var) |
| { |
| v = e; |
| break; |
| } |
| else if ((c = is_conversion (e, true)) != NULL) |
| q = &e->value.function.actual->expr; |
| else if (e->expr_type != EXPR_OP |
| || (e->value.op.op != op |
| && e->value.op.op != alt_op) |
| || e->rank != 0) |
| break; |
| else |
| { |
| p = q; |
| q = &e->value.op.op1; |
| } |
| |
| if (v == NULL) |
| { |
| gfc_error ("!$OMP ATOMIC assignment must be var = var op expr " |
| "or var = expr op var at %L", &expr2->where); |
| return; |
| } |
| |
| if (p != NULL) |
| { |
| e = *p; |
| switch (e->value.op.op) |
| { |
| case INTRINSIC_MINUS: |
| case INTRINSIC_DIVIDE: |
| case INTRINSIC_EQV: |
| case INTRINSIC_NEQV: |
| gfc_error ("!$OMP ATOMIC var = var op expr not " |
| "mathematically equivalent to var = var op " |
| "(expr) at %L", &expr2->where); |
| break; |
| default: |
| break; |
| } |
| |
| /* Canonicalize into var = var op (expr). */ |
| *p = e->value.op.op2; |
| e->value.op.op2 = expr2; |
| e->ts = expr2->ts; |
| if (code->expr2 == expr2) |
| code->expr2 = expr2 = e; |
| else |
| code->expr2->value.function.actual->expr = expr2 = e; |
| |
| if (!gfc_compare_types (&expr2->value.op.op1->ts, &expr2->ts)) |
| { |
| for (p = &expr2->value.op.op1; *p != v; |
| p = &(*p)->value.function.actual->expr) |
| ; |
| *p = NULL; |
| gfc_free_expr (expr2->value.op.op1); |
| expr2->value.op.op1 = v; |
| gfc_convert_type (v, &expr2->ts, 2); |
| } |
| } |
| } |
| |
| if (e->rank != 0 || expr_references_sym (code->expr2, var, v)) |
| { |
| gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr " |
| "must be scalar and cannot reference var at %L", |
| &expr2->where); |
| return; |
| } |
| } |
| else if (expr2->expr_type == EXPR_FUNCTION |
| && expr2->value.function.isym != NULL |
| && expr2->value.function.esym == NULL |
| && expr2->value.function.actual != NULL |
| && expr2->value.function.actual->next != NULL) |
| { |
| gfc_actual_arglist *arg, *var_arg; |
| |
| switch (expr2->value.function.isym->id) |
| { |
| case GFC_ISYM_MIN: |
| case GFC_ISYM_MAX: |
| break; |
| case GFC_ISYM_IAND: |
| case GFC_ISYM_IOR: |
| case GFC_ISYM_IEOR: |
| if (expr2->value.function.actual->next->next != NULL) |
| { |
| gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR " |
| "or IEOR must have two arguments at %L", |
| &expr2->where); |
| return; |
| } |
| break; |
| default: |
| gfc_error ("!$OMP ATOMIC assignment intrinsic must be " |
| "MIN, MAX, IAND, IOR or IEOR at %L", |
| &expr2->where); |
| return; |
| } |
| |
| var_arg = NULL; |
| for (arg = expr2->value.function.actual; arg; arg = arg->next) |
| { |
| if ((arg == expr2->value.function.actual |
| || (var_arg == NULL && arg->next == NULL)) |
| && arg->expr->expr_type == EXPR_VARIABLE |
| && arg->expr->symtree != NULL |
| && arg->expr->symtree->n.sym == var) |
| var_arg = arg; |
| else if (expr_references_sym (arg->expr, var, NULL)) |
| { |
| gfc_error ("!$OMP ATOMIC intrinsic arguments except one must " |
| "not reference %qs at %L", |
| var->name, &arg->expr->where); |
| return; |
| } |
| if (arg->expr->rank != 0) |
| { |
| gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar " |
| "at %L", &arg->expr->where); |
| return; |
| } |
| } |
| |
| if (var_arg == NULL) |
| { |
| gfc_error ("First or last !$OMP ATOMIC intrinsic argument must " |
| "be %qs at %L", var->name, &expr2->where); |
| return; |
| } |
| |
| if (var_arg != expr2->value.function.actual) |
| { |
| /* Canonicalize, so that var comes first. */ |
| gcc_assert (var_arg->next == NULL); |
| for (arg = expr2->value.function.actual; |
| arg->next != var_arg; arg = arg->next) |
| ; |
| var_arg->next = expr2->value.function.actual; |
| expr2->value.function.actual = var_arg; |
| arg->next = NULL; |
| } |
| } |
| else |
| gfc_error ("!$OMP ATOMIC assignment must have an operator or " |
| "intrinsic on right hand side at %L", &expr2->where); |
| |
| if (aop == GFC_OMP_ATOMIC_CAPTURE && code->next) |
| { |
| code = code->next; |
| if (code->expr1->expr_type != EXPR_VARIABLE |
| || code->expr1->symtree == NULL |
| || code->expr1->rank != 0 |
| || (code->expr1->ts.type != BT_INTEGER |
| && code->expr1->ts.type != BT_REAL |
| && code->expr1->ts.type != BT_COMPLEX |
| && code->expr1->ts.type != BT_LOGICAL)) |
| { |
| gfc_error ("!$OMP ATOMIC CAPTURE capture statement must set " |
| "a scalar variable of intrinsic type at %L", |
| &code->expr1->where); |
| return; |
| } |
| |
| expr2 = is_conversion (code->expr2, false); |
| if (expr2 == NULL) |
| { |
| expr2 = is_conversion (code->expr2, true); |
| if (expr2 == NULL) |
| expr2 = code->expr2; |
| } |
| |
| if (expr2->expr_type != EXPR_VARIABLE |
| || expr2->symtree == NULL |
| || expr2->rank != 0 |
| || (expr2->ts.type != BT_INTEGER |
| && expr2->ts.type != BT_REAL |
| && expr2->ts.type != BT_COMPLEX |
| && expr2->ts.type != BT_LOGICAL)) |
| { |
| gfc_error ("!$OMP ATOMIC CAPTURE capture statement must read " |
| "from a scalar variable of intrinsic type at %L", |
| &expr2->where); |
| return; |
| } |
| if (expr2->symtree->n.sym != var) |
| { |
| gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from " |
| "different variable than update statement writes " |
| "into at %L", &expr2->where); |
| return; |
| } |
| } |
| } |
| |
| |
| static struct fortran_omp_context |
| { |
| gfc_code *code; |
| hash_set<gfc_symbol *> *sharing_clauses; |
| hash_set<gfc_symbol *> *private_iterators; |
| struct fortran_omp_context *previous; |
| bool is_openmp; |
| } *omp_current_ctx; |
| static gfc_code *omp_current_do_code; |
| static int omp_current_do_collapse; |
| |
| void |
| gfc_resolve_omp_do_blocks (gfc_code *code, gfc_namespace *ns) |
| { |
| if (code->block->next && code->block->next->op == EXEC_DO) |
| { |
| int i; |
| gfc_code *c; |
| |
| omp_current_do_code = code->block->next; |
| if (code->ext.omp_clauses->orderedc) |
| omp_current_do_collapse = code->ext.omp_clauses->orderedc; |
| else |
| omp_current_do_collapse = code->ext.omp_clauses->collapse; |
| for (i = 1, c = omp_current_do_code; i < omp_current_do_collapse; i++) |
| { |
| c = c->block; |
| if (c->op != EXEC_DO || c->next == NULL) |
| break; |
| c = c->next; |
| if (c->op != EXEC_DO) |
| break; |
| } |
| if (i < omp_current_do_collapse || omp_current_do_collapse <= 0) |
| omp_current_do_collapse = 1; |
| } |
| gfc_resolve_blocks (code->block, ns); |
| omp_current_do_collapse = 0; |
| omp_current_do_code = NULL; |
| } |
| |
| |
| void |
| gfc_resolve_omp_parallel_blocks (gfc_code *code, gfc_namespace *ns) |
| { |
| struct fortran_omp_context ctx; |
| gfc_omp_clauses *omp_clauses = code->ext.omp_clauses; |
| gfc_omp_namelist *n; |
| int list; |
| |
| ctx.code = code; |
| ctx.sharing_clauses = new hash_set<gfc_symbol *>; |
| ctx.private_iterators = new hash_set<gfc_symbol *>; |
| ctx.previous = omp_current_ctx; |
| ctx.is_openmp = true; |
| omp_current_ctx = &ctx; |
| |
| for (list = 0; list < OMP_LIST_NUM; list++) |
| switch (list) |
| { |
| case OMP_LIST_SHARED: |
| case OMP_LIST_PRIVATE: |
| case OMP_LIST_FIRSTPRIVATE: |
| case OMP_LIST_LASTPRIVATE: |
| case OMP_LIST_REDUCTION: |
| case OMP_LIST_LINEAR: |
| for (n = omp_clauses->lists[list]; n; n = n->next) |
| ctx.sharing_clauses->add (n->sym); |
| break; |
| default: |
| break; |
| } |
| |
| switch (code->op) |
| { |
| case EXEC_OMP_PARALLEL_DO: |
| case EXEC_OMP_PARALLEL_DO_SIMD: |
| case EXEC_OMP_TARGET_PARALLEL_DO: |
| case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: |
| case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: |
| case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: |
| case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: |
| case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: |
| case EXEC_OMP_TASKLOOP: |
| case EXEC_OMP_TASKLOOP_SIMD: |
| case EXEC_OMP_TEAMS_DISTRIBUTE: |
| case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: |
| case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: |
| case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: |
| gfc_resolve_omp_do_blocks (code, ns); |
| break; |
| default: |
| gfc_resolve_blocks (code->block, ns); |
| } |
| |
| omp_current_ctx = ctx.previous; |
| delete ctx.sharing_clauses; |
| delete ctx.private_iterators; |
| } |
| |
| |
| /* Save and clear openmp.c private state. */ |
| |
| void |
| gfc_omp_save_and_clear_state (struct gfc_omp_saved_state *state) |
| { |
| state->ptrs[0] = omp_current_ctx; |
| state->ptrs[1] = omp_current_do_code; |
| state->ints[0] = omp_current_do_collapse; |
| omp_current_ctx = NULL; |
| omp_current_do_code = NULL; |
| omp_current_do_collapse = 0; |
| } |
| |
| |
| /* Restore openmp.c private state from the saved state. */ |
| |
| void |
| gfc_omp_restore_state (struct gfc_omp_saved_state *state) |
| { |
| omp_current_ctx = (struct fortran_omp_context *) state->ptrs[0]; |
| omp_current_do_code = (gfc_code *) state->ptrs[1]; |
| omp_current_do_collapse = state->ints[0]; |
| } |
| |
| |
| /* Note a DO iterator variable. This is special in !$omp parallel |
| construct, where they are predetermined private. */ |
| |
| void |
| gfc_resolve_do_iterator (gfc_code *code, gfc_symbol *sym, bool add_clause) |
| { |
| if (omp_current_ctx == NULL) |
| return; |
| |
| int i = omp_current_do_collapse; |
| gfc_code *c = omp_current_do_code; |
| |
| if (sym->attr.threadprivate) |
| return; |
| |
| /* !$omp do and !$omp parallel do iteration variable is predetermined |
| private just in the !$omp do resp. !$omp parallel do construct, |
| with no implications for the outer parallel constructs. */ |
| |
| while (i-- >= 1) |
| { |
| if (code == c) |
| return; |
| |
| c = c->block->next; |
| } |
| |
| /* An openacc context may represent a data clause. Abort if so. */ |
| if (!omp_current_ctx->is_openmp && !oacc_is_loop (omp_current_ctx->code)) |
| return; |
| |
| if (omp_current_ctx->sharing_clauses->contains (sym)) |
| return; |
| |
| if (! omp_current_ctx->private_iterators->add (sym) && add_clause) |
| { |
| gfc_omp_clauses *omp_clauses = omp_current_ctx->code->ext.omp_clauses; |
| gfc_omp_namelist *p; |
| |
| p = gfc_get_omp_namelist (); |
| p->sym = sym; |
| p->next = omp_clauses->lists[OMP_LIST_PRIVATE]; |
| omp_clauses->lists[OMP_LIST_PRIVATE] = p; |
| } |
| } |
| |
| static void |
| handle_local_var (gfc_symbol *sym) |
| { |
| if (sym->attr.flavor != FL_VARIABLE |
| || sym->as != NULL |
| || (sym->ts.type != BT_INTEGER && sym->ts.type != BT_REAL)) |
| return; |
| gfc_resolve_do_iterator (sym->ns->code, sym, false); |
| } |
| |
| void |
| gfc_resolve_omp_local_vars (gfc_namespace *ns) |
| { |
| if (omp_current_ctx) |
| gfc_traverse_ns (ns, handle_local_var); |
| } |
| |
| static void |
| resolve_omp_do (gfc_code *code) |
| { |
| gfc_code *do_code, *c; |
| int list, i, collapse; |
| gfc_omp_namelist *n; |
| gfc_symbol *dovar; |
| const char *name; |
| bool is_simd = false; |
| |
| switch (code->op) |
| { |
| case EXEC_OMP_DISTRIBUTE: name = "!$OMP DISTRIBUTE"; break; |
| case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: |
| name = "!$OMP DISTRIBUTE PARALLEL DO"; |
| break; |
| case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: |
| name = "!$OMP DISTRIBUTE PARALLEL DO SIMD"; |
| is_simd = true; |
| break; |
| case EXEC_OMP_DISTRIBUTE_SIMD: |
| name = "!$OMP DISTRIBUTE SIMD"; |
| is_simd = true; |
| break; |
| case EXEC_OMP_DO: name = "!$OMP DO"; break; |
| case EXEC_OMP_DO_SIMD: name = "!$OMP DO SIMD"; is_simd = true; break; |
| case EXEC_OMP_PARALLEL_DO: name = "!$OMP PARALLEL DO"; break; |
| case EXEC_OMP_PARALLEL_DO_SIMD: |
| name = "!$OMP PARALLEL DO SIMD"; |
| is_simd = true; |
| break; |
| case EXEC_OMP_SIMD: name = "!$OMP SIMD"; is_simd = true; break; |
| case EXEC_OMP_TARGET_PARALLEL_DO: name = "!$OMP TARGET PARALLEL DO"; break; |
| case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: |
| name = "!$OMP TARGET PARALLEL DO SIMD"; |
| is_simd = true; |
| break; |
| case EXEC_OMP_TARGET_SIMD: |
| name = "!$OMP TARGET SIMD"; |
| is_simd = true; |
| break; |
| case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: |
| name = "!$OMP TARGET TEAMS DISTRIBUTE"; |
| break; |
| case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: |
| name = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO"; |
| break; |
| case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: |
| name = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD"; |
| is_simd = true; |
| break; |
| case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: |
| name = "!$OMP TARGET TEAMS DISTRIBUTE SIMD"; |
| is_simd = true; |
| break; |
| case EXEC_OMP_TASKLOOP: name = "!$OMP TASKLOOP"; break; |
| case EXEC_OMP_TASKLOOP_SIMD: |
| name = "!$OMP TASKLOOP SIMD"; |
| is_simd = true; |
| break; |
| case EXEC_OMP_TEAMS_DISTRIBUTE: name = "!$OMP TEAMS DISTRIBUTE"; break; |
| case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: |
| name = "!$OMP TEAMS DISTRIBUTE PARALLEL DO"; |
| break; |
| case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: |
| name = "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD"; |
| is_simd = true; |
| break; |
| case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: |
| name = "!$OMP TEAMS DISTRIBUTE SIMD"; |
| is_simd = true; |
| break; |
| default: gcc_unreachable (); |
| } |
| |
| if (code->ext.omp_clauses) |
| resolve_omp_clauses (code, code->ext.omp_clauses, NULL); |
| |
| do_code = code->block->next; |
| if (code->ext.omp_clauses->orderedc) |
| collapse = code->ext.omp_clauses->orderedc; |
| else |
| { |
| collapse = code->ext.omp_clauses->collapse; |
| if (collapse <= 0) |
| collapse = 1; |
| } |
| for (i = 1; i <= collapse; i++) |
| { |
| if (do_code->op == EXEC_DO_WHILE) |
| { |
| gfc_error ("%s cannot be a DO WHILE or DO without loop control " |
| "at %L", name, &do_code->loc); |
| break; |
| } |
| if (do_code->op == EXEC_DO_CONCURRENT) |
| { |
| gfc_error ("%s cannot be a DO CONCURRENT loop at %L", name, |
| &do_code->loc); |
| break; |
| } |
| gcc_assert (do_code->op == EXEC_DO); |
| if (do_code->ext.iterator->var->ts.type != BT_INTEGER) |
| gfc_error ("%s iteration variable must be of type integer at %L", |
| name, &do_code->loc); |
| dovar = do_code->ext.iterator->var->symtree->n.sym; |
| if (dovar->attr.threadprivate) |
| gfc_error ("%s iteration variable must not be THREADPRIVATE " |
| "at %L", name, &do_code->loc); |
| if (code->ext.omp_clauses) |
| for (list = 0; list < OMP_LIST_NUM; list++) |
| if (!is_simd |
| ? (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE) |
| : code->ext.omp_clauses->collapse > 1 |
| ? (list != OMP_LIST_LASTPRIVATE) |
| : (list != OMP_LIST_LINEAR)) |
| for (n = code->ext.omp_clauses->lists[list]; n; n = n->next) |
| if (dovar == n->sym) |
| { |
| if (!is_simd) |
| gfc_error ("%s iteration variable present on clause " |
| "other than PRIVATE or LASTPRIVATE at %L", |
| name, &do_code->loc); |
| else if (code->ext.omp_clauses->collapse > 1) |
| gfc_error ("%s iteration variable present on clause " |
| "other than LASTPRIVATE at %L", |
| name, &do_code->loc); |
| else |
| gfc_error ("%s iteration variable present on clause " |
| "other than LINEAR at %L", |
| name, &do_code->loc); |
| break; |
| } |
| if (i > 1) |
| { |
| gfc_code *do_code2 = code->block->next; |
| int j; |
| |
| for (j = 1; j < i; j++) |
| { |
| gfc_symbol *ivar = do_code2->ext.iterator->var->symtree->n.sym; |
| if (dovar == ivar |
| || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->start) |
| || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->end) |
| || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->step)) |
| { |
| gfc_error ("%s collapsed loops don't form rectangular " |
| "iteration space at %L", name, &do_code->loc); |
| break; |
| } |
| do_code2 = do_code2->block->next; |
| } |
| } |
| if (i == collapse) |
| break; |
| for (c = do_code->next; c; c = c->next) |
| if (c->op != EXEC_NOP && c->op != EXEC_CONTINUE) |
| { |
| gfc_error ("collapsed %s loops not perfectly nested at %L", |
| name, &c->loc); |
| break; |
| } |
| if (c) |
| break; |
| do_code = do_code->block; |
| if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE) |
| { |
| gfc_error ("not enough DO loops for collapsed %s at %L", |
| name, &code->loc); |
| break; |
| } |
| do_code = do_code->next; |
| if (do_code == NULL |
| || (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE)) |
| { |
| gfc_error ("not enough DO loops for collapsed %s at %L", |
| name, &code->loc); |
| break; |
| } |
| } |
| } |
| |
| static bool |
| oacc_is_parallel (gfc_code *code) |
| { |
| return code->op == EXEC_OACC_PARALLEL || code->op == EXEC_OACC_PARALLEL_LOOP; |
| } |
| |
| static gfc_statement |
| omp_code_to_statement (gfc_code *code) |
| { |
| switch (code->op) |
| { |
| case EXEC_OMP_PARALLEL: |
| return ST_OMP_PARALLEL; |
| case EXEC_OMP_PARALLEL_SECTIONS: |
| return ST_OMP_PARALLEL_SECTIONS; |
| case EXEC_OMP_SECTIONS: |
| return ST_OMP_SECTIONS; |
| case EXEC_OMP_ORDERED: |
| return ST_OMP_ORDERED; |
| case EXEC_OMP_CRITICAL: |
| return ST_OMP_CRITICAL; |
| case EXEC_OMP_MASTER: |
| return ST_OMP_MASTER; |
| case EXEC_OMP_SINGLE: |
| return ST_OMP_SINGLE; |
| case EXEC_OMP_TASK: |
| return ST_OMP_TASK; |
| case EXEC_OMP_WORKSHARE: |
| return ST_OMP_WORKSHARE; |
| case EXEC_OMP_PARALLEL_WORKSHARE: |
| return ST_OMP_PARALLEL_WORKSHARE; |
| case EXEC_OMP_DO: |
| return ST_OMP_DO; |
| default: |
| gcc_unreachable (); |
| } |
| } |
| |
| static gfc_statement |
| oacc_code_to_statement (gfc_code *code) |
| { |
| switch (code->op) |
| { |
| case EXEC_OACC_PARALLEL: |
| return ST_OACC_PARALLEL; |
| case EXEC_OACC_KERNELS: |
| return ST_OACC_KERNELS; |
| case EXEC_OACC_DATA: |
| return ST_OACC_DATA; |
| case EXEC_OACC_HOST_DATA: |
| return ST_OACC_HOST_DATA; |
| case EXEC_OACC_PARALLEL_LOOP: |
| return ST_OACC_PARALLEL_LOOP; |
| case EXEC_OACC_KERNELS_LOOP: |
| return ST_OACC_KERNELS_LOOP; |
| case EXEC_OACC_LOOP: |
| return ST_OACC_LOOP; |
| case EXEC_OACC_ATOMIC: |
| return ST_OACC_ATOMIC; |
| default: |
| gcc_unreachable (); |
| } |
| } |
| |
| static void |
| resolve_oacc_directive_inside_omp_region (gfc_code *code) |
| { |
| if (omp_current_ctx != NULL && omp_current_ctx->is_openmp) |
| { |
| gfc_statement st = omp_code_to_statement (omp_current_ctx->code); |
| gfc_statement oacc_st = oacc_code_to_statement (code); |
| gfc_error ("The %s directive cannot be specified within " |
| "a %s region at %L", gfc_ascii_statement (oacc_st), |
| gfc_ascii_statement (st), &code->loc); |
| } |
| } |
| |
| static void |
| resolve_omp_directive_inside_oacc_region (gfc_code *code) |
| { |
| if (omp_current_ctx != NULL && !omp_current_ctx->is_openmp) |
| { |
| gfc_statement st = oacc_code_to_statement (omp_current_ctx->code); |
| gfc_statement omp_st = omp_code_to_statement (code); |
| gfc_error ("The %s directive cannot be specified within " |
| "a %s region at %L", gfc_ascii_statement (omp_st), |
| gfc_ascii_statement (st), &code->loc); |
| } |
| } |
| |
| |
| static void |
| resolve_oacc_nested_loops (gfc_code *code, gfc_code* do_code, int collapse, |
| const char *clause) |
| { |
| gfc_symbol *dovar; |
| gfc_code *c; |
| int i; |
| |
| for (i = 1; i <= collapse; i++) |
| { |
| if (do_code->op == EXEC_DO_WHILE) |
| { |
| gfc_error ("!$ACC LOOP cannot be a DO WHILE or DO without loop control " |
| "at %L", &do_code->loc); |
| break; |
| } |
| if (do_code->op == EXEC_DO_CONCURRENT) |
| { |
| gfc_error ("!$ACC LOOP cannot be a DO CONCURRENT loop at %L", |
| &do_code->loc); |
| break; |
| } |
| gcc_assert (do_code->op == EXEC_DO); |
| if (do_code->ext.iterator->var->ts.type != BT_INTEGER) |
| gfc_error ("!$ACC LOOP iteration variable must be of type integer at %L", |
| &do_code->loc); |
| dovar = do_code->ext.iterator->var->symtree->n.sym; |
| if (i > 1) |
| { |
| gfc_code *do_code2 = code->block->next; |
| int j; |
| |
| for (j = 1; j < i; j++) |
| { |
| gfc_symbol *ivar = do_code2->ext.iterator->var->symtree->n.sym; |
| if (dovar == ivar |
| || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->start) |
| || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->end) |
| || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->step)) |
| { |
| gfc_error ("!$ACC LOOP %s loops don't form rectangular " |
| "iteration space at %L", clause, &do_code->loc); |
| break; |
| } |
| do_code2 = do_code2->block->next; |
| } |
| } |
| if (i == collapse) |
| break; |
| for (c = do_code->next; c; c = c->next) |
| if (c->op != EXEC_NOP && c->op != EXEC_CONTINUE) |
| { |
| gfc_error ("%s !$ACC LOOP loops not perfectly nested at %L", |
| clause, &c->loc); |
| break; |
| } |
| if (c) |
| break; |
| do_code = do_code->block; |
| if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE |
| && do_code->op != EXEC_DO_CONCURRENT) |
| { |
| gfc_error ("not enough DO loops for %s !$ACC LOOP at %L", |
| clause, &code->loc); |
| break; |
| } |
| do_code = do_code->next; |
| if (do_code == NULL |
| || (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE |
| && do_code->op != EXEC_DO_CONCURRENT)) |
| { |
| gfc_error ("not enough DO loops for %s !$ACC LOOP at %L", |
| clause, &code->loc); |
| break; |
| } |
| } |
| } |
| |
| |
| static void |
| resolve_oacc_params_in_parallel (gfc_code *code, const char *clause, |
| const char *arg) |
| { |
| fortran_omp_context *c; |
| |
| if (oacc_is_parallel (code)) |
| gfc_error ("!$ACC LOOP %s in PARALLEL region doesn't allow " |
| "%s arguments at %L", clause, arg, &code->loc); |
| for (c = omp_current_ctx; c; c = c->previous) |
| { |
| if (oacc_is_loop (c->code)) |
| break; |
| if (oacc_is_parallel (c->code)) |
| gfc_error ("!$ACC LOOP %s in PARALLEL region doesn't allow " |
| "%s arguments at %L", clause, arg, &code->loc); |
| } |
| } |
| |
| |
| static void |
| resolve_oacc_loop_blocks (gfc_code *code) |
| { |
| if (!oacc_is_loop (code)) |
| return; |
| |
| if (code->ext.omp_clauses->tile_list && code->ext.omp_clauses->gang |
| && code->ext.omp_clauses->worker && code->ext.omp_clauses->vector) |
| gfc_error ("Tiled loop cannot be parallelized across gangs, workers and " |
| "vectors at the same time at %L", &code->loc); |
| |
| if (code->ext.omp_clauses->gang |
| && code->ext.omp_clauses->gang_num_expr) |
| resolve_oacc_params_in_parallel (code, "GANG", "num"); |
| |
| if (code->ext.omp_clauses->worker |
| && code->ext.omp_clauses->worker_expr) |
| resolve_oacc_params_in_parallel (code, "WORKER", "num"); |
| |
| if (code->ext.omp_clauses->vector |
| && code->ext.omp_clauses->vector_expr) |
| resolve_oacc_params_in_parallel (code, "VECTOR", "length"); |
| |
| if (code->ext.omp_clauses->tile_list) |
| { |
| gfc_expr_list *el; |
| int num = 0; |
| for (el = code->ext.omp_clauses->tile_list; el; el = el->next) |
| { |
| num++; |
| if (el->expr == NULL) |
| { |
| /* NULL expressions are used to represent '*' arguments. |
| Convert those to a 0 expressions. */ |
| el->expr = gfc_get_constant_expr (BT_INTEGER, |
| gfc_default_integer_kind, |
| &code->loc); |
| mpz_set_si (el->expr->value.integer, 0); |
| } |
| else |
| { |
| resolve_positive_int_expr (el->expr, "TILE"); |
| if (el->expr->expr_type != EXPR_CONSTANT) |
| gfc_error ("TILE requires constant expression at %L", |
| &code->loc); |
| } |
| } |
| resolve_oacc_nested_loops (code, code->block->next, num, "tiled"); |
| } |
| } |
| |
| |
| void |
| gfc_resolve_oacc_blocks (gfc_code *code, gfc_namespace *ns) |
| { |
| fortran_omp_context ctx; |
| gfc_omp_clauses *omp_clauses = code->ext.omp_clauses; |
| gfc_omp_namelist *n; |
| int list; |
| |
| resolve_oacc_loop_blocks (code); |
| |
| ctx.code = code; |
| ctx.sharing_clauses = new hash_set<gfc_symbol *>; |
| ctx.private_iterators = new hash_set<gfc_symbol *>; |
| ctx.previous = omp_current_ctx; |
| ctx.is_openmp = false; |
| omp_current_ctx = &ctx; |
| |
| for (list = 0; list < OMP_LIST_NUM; list++) |
| switch (list) |
| { |
| case OMP_LIST_PRIVATE: |
| for (n = omp_clauses->lists[list]; n; n = n->next) |
| ctx.sharing_clauses->add (n->sym); |
| break; |
| default: |
| break; |
| } |
| |
| gfc_resolve_blocks (code->block, ns); |
| |
| omp_current_ctx = ctx.previous; |
| delete ctx.sharing_clauses; |
| delete ctx.private_iterators; |
| } |
| |
| |
| static void |
| resolve_oacc_loop (gfc_code *code) |
| { |
| gfc_code *do_code; |
| int collapse; |
| |
| if (code->ext.omp_clauses) |
| resolve_omp_clauses (code, code->ext.omp_clauses, NULL, true); |
| |
| do_code = code->block->next; |
| collapse = code->ext.omp_clauses->collapse; |
| |
| if (collapse <= 0) |
| collapse = 1; |
| resolve_oacc_nested_loops (code, do_code, collapse, "collapsed"); |
| } |
| |
| void |
| gfc_resolve_oacc_declare (gfc_namespace *ns) |
| { |
| int list; |
| gfc_omp_namelist *n; |
| gfc_oacc_declare *oc; |
| |
| if (ns->oacc_declare == NULL) |
| return; |
| |
| 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.function || n->sym->attr.subroutine) |
| { |
| gfc_error ("Object %qs is not a variable at %L", |
| n->sym->name, &oc->loc); |
| continue; |
| } |
| if (n->sym->attr.flavor == FL_PARAMETER) |
| { |
| gfc_error ("PARAMETER object %qs is not allowed at %L", |
| n->sym->name, &oc->loc); |
| continue; |
| } |
| |
| 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 (n = oc->clauses->lists[OMP_LIST_DEVICE_RESIDENT]; n; n = n->next) |
| check_array_not_assumed (n->sym, oc->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_routines (gfc_namespace *ns) |
| { |
| for (gfc_oacc_routine_name *orn = ns->oacc_routine_names; |
| orn; |
| orn = orn->next) |
| { |
| gfc_symbol *sym = orn->sym; |
| if (!sym->attr.external |
| && !sym->attr.function |
| && !sym->attr.subroutine) |
| { |
| gfc_error ("NAME %qs does not refer to a subroutine or function" |
| " in !$ACC ROUTINE ( NAME ) at %L", sym->name, &orn->loc); |
| continue; |
| } |
| if (!gfc_add_omp_declare_target (&sym->attr, sym->name, &orn->loc)) |
| { |
| gfc_error ("NAME %qs invalid" |
| " in !$ACC ROUTINE ( NAME ) at %L", sym->name, &orn->loc); |
| continue; |
| } |
| } |
| } |
| |
| |
| void |
| gfc_resolve_oacc_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED) |
| { |
| resolve_oacc_directive_inside_omp_region (code); |
| |
| switch (code->op) |
| { |
| case EXEC_OACC_PARALLEL: |
| case EXEC_OACC_KERNELS: |
| case EXEC_OACC_DATA: |
| case EXEC_OACC_HOST_DATA: |
| case EXEC_OACC_UPDATE: |
| case EXEC_OACC_ENTER_DATA: |
| case EXEC_OACC_EXIT_DATA: |
| case EXEC_OACC_WAIT: |
| case EXEC_OACC_CACHE: |
| resolve_omp_clauses (code, code->ext.omp_clauses, NULL, true); |
| break; |
| case EXEC_OACC_PARALLEL_LOOP: |
| case EXEC_OACC_KERNELS_LOOP: |
| case EXEC_OACC_LOOP: |
| resolve_oacc_loop (code); |
| break; |
| case EXEC_OACC_ATOMIC: |
| resolve_omp_atomic (code); |
| break; |
| default: |
| break; |
| } |
| } |
| |
| |
| /* Resolve OpenMP directive clauses and check various requirements |
| of each directive. */ |
| |
| void |
| gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED) |
| { |
| resolve_omp_directive_inside_oacc_region (code); |
| |
| if (code->op != EXEC_OMP_ATOMIC) |
| gfc_maybe_initialize_eh (); |
| |
| switch (code->op) |
| { |
| case EXEC_OMP_DISTRIBUTE: |
| case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: |
| case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: |
| case EXEC_OMP_DISTRIBUTE_SIMD: |
| case EXEC_OMP_DO: |
| case EXEC_OMP_DO_SIMD: |
| case EXEC_OMP_PARALLEL_DO: |
| case EXEC_OMP_PARALLEL_DO_SIMD: |
| case EXEC_OMP_SIMD: |
| case EXEC_OMP_TARGET_PARALLEL_DO: |
| case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: |
| case EXEC_OMP_TARGET_SIMD: |
| case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: |
| case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: |
| case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: |
| case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: |
| case EXEC_OMP_TASKLOOP: |
| case EXEC_OMP_TASKLOOP_SIMD: |
| case EXEC_OMP_TEAMS_DISTRIBUTE: |
| case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: |
| case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: |
| case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: |
| resolve_omp_do (code); |
| break; |
| case EXEC_OMP_CANCEL: |
| case EXEC_OMP_PARALLEL_WORKSHARE: |
| case EXEC_OMP_PARALLEL: |
| case EXEC_OMP_PARALLEL_SECTIONS: |
| case EXEC_OMP_SECTIONS: |
| case EXEC_OMP_SINGLE: |
| case EXEC_OMP_TARGET: |
| case EXEC_OMP_TARGET_DATA: |
| case EXEC_OMP_TARGET_ENTER_DATA: |
| case EXEC_OMP_TARGET_EXIT_DATA: |
| case EXEC_OMP_TARGET_PARALLEL: |
| case EXEC_OMP_TARGET_TEAMS: |
| case EXEC_OMP_TASK: |
| case EXEC_OMP_TEAMS: |
| case EXEC_OMP_WORKSHARE: |
| if (code->ext.omp_clauses) |
| resolve_omp_clauses (code, code->ext.omp_clauses, NULL); |
| break; |
| case EXEC_OMP_TARGET_UPDATE: |
| if (code->ext.omp_clauses) |
| resolve_omp_clauses (code, code->ext.omp_clauses, NULL); |
| if (code->ext.omp_clauses == NULL |
| || (code->ext.omp_clauses->lists[OMP_LIST_TO] == NULL |
| && code->ext.omp_clauses->lists[OMP_LIST_FROM] == NULL)) |
| gfc_error ("OMP TARGET UPDATE at %L requires at least one TO or " |
| "FROM clause", &code->loc); |
| break; |
| case EXEC_OMP_ATOMIC: |
| resolve_omp_atomic (code); |
| break; |
| default: |
| break; |
| } |
| } |
| |
| /* Resolve !$omp declare simd constructs in NS. */ |
| |
| void |
| gfc_resolve_omp_declare_simd (gfc_namespace *ns) |
| { |
| gfc_omp_declare_simd *ods; |
| |
| for (ods = ns->omp_declare_simd; ods; ods = ods->next) |
| { |
| if (ods->proc_name != NULL |
| && ods->proc_name != ns->proc_name) |
| gfc_error ("!$OMP DECLARE SIMD should refer to containing procedure " |
| "%qs at %L", ns->proc_name->name, &ods->where); |
| if (ods->clauses) |
| resolve_omp_clauses (NULL, ods->clauses, ns); |
| } |
| } |
| |
| struct omp_udr_callback_data |
| { |
| gfc_omp_udr *omp_udr; |
| bool is_initializer; |
| }; |
| |
| static int |
| omp_udr_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, |
| void *data) |
| { |
| struct omp_udr_callback_data *cd = (struct omp_udr_callback_data *) data; |
| if ((*e)->expr_type == EXPR_VARIABLE) |
| { |
| if (cd->is_initializer) |
| { |
| if ((*e)->symtree->n.sym != cd->omp_udr->omp_priv |
| && (*e)->symtree->n.sym != cd->omp_udr->omp_orig) |
| gfc_error ("Variable other than OMP_PRIV or OMP_ORIG used in " |
| "INITIALIZER clause of !$OMP DECLARE REDUCTION at %L", |
| &(*e)->where); |
| } |
| else |
| { |
| if ((*e)->symtree->n.sym != cd->omp_udr->omp_out |
| && (*e)->symtree->n.sym != cd->omp_udr->omp_in) |
| gfc_error ("Variable other than OMP_OUT or OMP_IN used in " |
| "combiner of !$OMP DECLARE REDUCTION at %L", |
| &(*e)->where); |
| } |
| } |
| return 0; |
| } |
| |
| /* Resolve !$omp declare reduction constructs. */ |
| |
| static void |
| gfc_resolve_omp_udr (gfc_omp_udr *omp_udr) |
| { |
| gfc_actual_arglist *a; |
| const char *predef_name = NULL; |
| |
| switch (omp_udr->rop) |
| { |
| case OMP_REDUCTION_PLUS: |
| case OMP_REDUCTION_TIMES: |
| case OMP_REDUCTION_MINUS: |
| case OMP_REDUCTION_AND: |
| case OMP_REDUCTION_OR: |
| case OMP_REDUCTION_EQV: |
| case OMP_REDUCTION_NEQV: |
| case OMP_REDUCTION_MAX: |
| case OMP_REDUCTION_USER: |
| break; |
| default: |
| gfc_error ("Invalid operator for !$OMP DECLARE REDUCTION %s at %L", |
| omp_udr->name, &omp_udr->where); |
| return; |
| } |
| |
| if (gfc_omp_udr_predef (omp_udr->rop, omp_udr->name, |
| &omp_udr->ts, &predef_name)) |
| { |
| if (predef_name) |
| gfc_error_now ("Redefinition of predefined %s " |
| "!$OMP DECLARE REDUCTION at %L", |
| predef_name, &omp_udr->where); |
| else |
| gfc_error_now ("Redefinition of predefined " |
| "!$OMP DECLARE REDUCTION at %L", &omp_udr->where); |
| return; |
| } |
| |
| if (omp_udr->ts.type == BT_CHARACTER |
| && omp_udr->ts.u.cl->length |
| && omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT) |
| { |
| gfc_error ("CHARACTER length in !$OMP DECLARE REDUCTION %s not " |
| "constant at %L", omp_udr->name, &omp_udr->where); |
| return; |
| } |
| |
| struct omp_udr_callback_data cd; |
| cd.omp_udr = omp_udr; |
| cd.is_initializer = false; |
| gfc_code_walker (&omp_udr->combiner_ns->code, gfc_dummy_code_callback, |
| omp_udr_callback, &cd); |
| if (omp_udr->combiner_ns->code->op == EXEC_CALL) |
| { |
| for (a = omp_udr->combiner_ns->code->ext.actual; a; a = a->next) |
| if (a->expr == NULL) |
| break; |
| if (a) |
| gfc_error ("Subroutine call with alternate returns in combiner " |
| "of !$OMP DECLARE REDUCTION at %L", |
| &omp_udr->combiner_ns->code->loc); |
| } |
| if (omp_udr->initializer_ns) |
| { |
| cd.is_initializer = true; |
| gfc_code_walker (&omp_udr->initializer_ns->code, gfc_dummy_code_callback, |
| omp_udr_callback, &cd); |
| if (omp_udr->initializer_ns->code->op == EXEC_CALL) |
| { |
| for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next) |
| if (a->expr == NULL) |
| break; |
| if (a) |
| gfc_error ("Subroutine call with alternate returns in " |
| "INITIALIZER clause of !$OMP DECLARE REDUCTION " |
| "at %L", &omp_udr->initializer_ns->code->loc); |
| for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next) |
| if (a->expr |
| && a->expr->expr_type == EXPR_VARIABLE |
| && a->expr->symtree->n.sym == omp_udr->omp_priv |
| && a->expr->ref == NULL) |
| break; |
| if (a == NULL) |
| gfc_error ("One of actual subroutine arguments in INITIALIZER " |
| "clause of !$OMP DECLARE REDUCTION must be OMP_PRIV " |
| "at %L", &omp_udr->initializer_ns->code->loc); |
| } |
| } |
| else if (omp_udr->ts.type == BT_DERIVED |
| && !gfc_has_default_initializer (omp_udr->ts.u.derived)) |
| { |
| gfc_error ("Missing INITIALIZER clause for !$OMP DECLARE REDUCTION " |
| "of derived type without default initializer at %L", |
| &omp_udr->where); |
| return; |
| } |
| } |
| |
| void |
| gfc_resolve_omp_udrs (gfc_symtree *st) |
| { |
| gfc_omp_udr *omp_udr; |
| |
| if (st == NULL) |
| return; |
| gfc_resolve_omp_udrs (st->left); |
| gfc_resolve_omp_udrs (st->right); |
| for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next) |
| gfc_resolve_omp_udr (omp_udr); |
| } |