From patchwork Fri Nov 11 23:44:07 2016 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Cesar Philippidis X-Patchwork-Id: 81907 Delivered-To: patch@linaro.org Received: by 10.140.97.165 with SMTP id m34csp9739qge; Fri, 11 Nov 2016 15:44:37 -0800 (PST) X-Received: by 10.98.131.67 with SMTP id h64mr11698031pfe.86.1478907877570; Fri, 11 Nov 2016 15:44:37 -0800 (PST) Return-Path: Received: from sourceware.org (server1.sourceware.org. [209.132.180.131]) by mx.google.com with ESMTPS id 12si9374512pfi.251.2016.11.11.15.44.37 for (version=TLS1_2 cipher=ECDHE-RSA-AES128-GCM-SHA256 bits=128/128); Fri, 11 Nov 2016 15:44:37 -0800 (PST) Received-SPF: pass (google.com: domain of gcc-patches-return-441211-patch=linaro.org@gcc.gnu.org designates 209.132.180.131 as permitted sender) client-ip=209.132.180.131; Authentication-Results: mx.google.com; dkim=pass header.i=@gcc.gnu.org; spf=pass (google.com: domain of gcc-patches-return-441211-patch=linaro.org@gcc.gnu.org designates 209.132.180.131 as permitted sender) smtp.mailfrom=gcc-patches-return-441211-patch=linaro.org@gcc.gnu.org DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:from :subject:to:cc:message-id:date:mime-version:content-type; q=dns; s=default; b=ujdLnHfkL8XOiPX7niaaytWxHkxrZRURaGGsazozMmoqGwxNwN f66DK9LZvgLU8M7dZO52wPhbXVZiMiuurP11+Vhzhg6/6yfZ+3lBMkumbjg7iMVW +47D2Jz+KxncgcNcrUGZ3c9eO8k7OlUVl4YJZOJ4Xr/bibC/ML16fwUZw= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:from :subject:to:cc:message-id:date:mime-version:content-type; s= default; bh=nsFSul30ZLqknfDzkybNej9VN08=; b=m9xpj9TX8H90mCXqWt+x c2L4TjYb2uaEsIqyE3h3yNQST2UTsLvjNOXV4v8J8Ue8gNcfg+sis9epo1/x3t5u rbJy3gN+rzfuxNwK+lTR34rrIp6uZ+hil9Itocy2pbJdnKsvIOHS9oiXZkHwdhBn 4H+fzEWD5nnAa8/rbXC15qI= Received: (qmail 55651 invoked by alias); 11 Nov 2016 23:44:22 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Received: (qmail 55627 invoked by uid 89); 11 Nov 2016 23:44:22 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-1.9 required=5.0 tests=AWL, BAYES_00, RCVD_IN_DNSWL_NONE, SPF_PASS, URIBL_RED autolearn=ham version=3.3.2 spammy=8138, gimplifyh, 21198, UD:gimplify.h X-Spam-User: qpsmtpd, 2 recipients X-HELO: relay1.mentorg.com Received: from relay1.mentorg.com (HELO relay1.mentorg.com) (192.94.38.131) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Fri, 11 Nov 2016 23:44:11 +0000 Received: from svr-orw-mbx-01.mgc.mentorg.com ([147.34.90.201]) by relay1.mentorg.com with esmtp id 1c5LUQ-0002sl-9F from Cesar_Philippidis@mentor.com ; Fri, 11 Nov 2016 15:44:10 -0800 Received: from [127.0.0.1] (147.34.91.1) by svr-orw-mbx-01.mgc.mentorg.com (147.34.90.201) with Microsoft SMTP Server (TLS) id 15.0.1210.3; Fri, 11 Nov 2016 15:44:08 -0800 From: Cesar Philippidis Subject: [PATCH] OpenACC routines -- fortran front end To: "gcc-patches@gcc.gnu.org" , Fortran List , Jakub Jelinek CC: Thomas Schwinge Message-ID: Date: Fri, 11 Nov 2016 15:44:07 -0800 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:45.0) Gecko/20100101 Thunderbird/45.3.0 MIME-Version: 1.0 X-ClientProxiedBy: svr-orw-mbx-01.mgc.mentorg.com (147.34.90.201) To svr-orw-mbx-01.mgc.mentorg.com (147.34.90.201) This patch contains for following changes to the Fortran FE: * Update module support for acc routines. * Add support for the bind and nohost clauses. * Add more acc routine diagnostics. I probably should have split the module changes from the rest of the routine changes, but they are closely related. Last time I posted the module patch someone raised the concern that this change would break backwards compatibility. Considering this patch is for GCC 7, perhaps the module version number can be bumped to address that problem. Is this patch ok for trunk? Cesar 2016-11-11 Cesar Philippidis gcc/fortran/ * gfortran.h (enum oacc_function): Make OACC_FUNCTION_SEQ the last entry the enum. (oacc_function_types): Declare. (symbol_attribute): Add oacc_function, oacc_function_nohost members. (gfc_omp_clauses): Add routine_bind, nohost, bind members. (gfc_oacc_routine_name): Add loc. (gfc_resolve_oacc_routine_call): Declare. (gfc_resolve_oacc_routines): Declare. * module.c (oacc_function): New DECL_MIO_NAME. (mio_symbol_attribute): Set the oacc_function attribute. * openmp.c (enum omp_mask2): Add OMP_CLAUSE_BIND and OMP_CLAUSE_NOHOST. (gfc_match_omp_clauses): Likewise. (OACC_ROUTINE_CLAUSES): Add OMP_CLAUSE_BIND and OMP_CLAUSE_NOHOST. (gfc_oacc_routine_dims): Change the type of oacc_function from unsigned to an ENUM_BITFIELD.Move gfc_error to gfc_match_oacc_routine. Return OACC_FUNCTION_NONE on error. (gfc_match_oacc_routine): Make error reporting more precise. Defer rejection of non-function and subroutine symbols until gfc_resolve_oacc_routines. (struct fortran_omp_context): Add a dims member. (gfc_resolve_oacc_blocks): Update ctx->dims. (gfc_resolve_oacc_routine_call): New function. (gfc_resolve_oacc_routines): New function. * resolve.c (resolve_function): Call gfc_resolve_oacc_routine_call. (resolve_call): Likewise. (resolve_codes): Call gfc_resolve_oacc_routines. * symbol.c (oacc_function_types): Define. * trans-decl.c (add_attributes_to_decl): Update to handle the retyped oacc_function attribute. diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 7956630..9cfe40a 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -314,6 +314,15 @@ enum save_state { SAVE_NONE = 0, SAVE_EXPLICIT, SAVE_IMPLICIT }; +/* Flags to keep track of ACC routine states. */ +enum oacc_function +{ OACC_FUNCTION_NONE = 0, + OACC_FUNCTION_GANG, + OACC_FUNCTION_WORKER, + OACC_FUNCTION_VECTOR, + OACC_FUNCTION_SEQ +}; + /* Strings for all symbol attributes. We use these for dumping the parse tree, in error messages, and also when reading and writing modules. In symbol.c. */ @@ -323,6 +332,7 @@ extern const mstring intents[]; extern const mstring access_types[]; extern const mstring ifsrc_types[]; extern const mstring save_status[]; +extern const mstring oacc_function_types[]; /* Strings for DTIO procedure names. In symbol.c. */ extern const mstring dtio_procs[]; @@ -882,7 +892,8 @@ typedef struct unsigned oacc_declare_link:1; /* This is an OpenACC acclerator function at level N - 1 */ - unsigned oacc_function:3; + ENUM_BITFIELD (oacc_function) oacc_function:3; + unsigned oacc_function_nohost:1; /* Attributes set by compiler extensions (!GCC$ ATTRIBUTES). */ unsigned ext_attr:EXT_ATTR_NUM; @@ -1310,10 +1321,11 @@ typedef struct gfc_omp_clauses struct gfc_expr *num_gangs_expr; struct gfc_expr *num_workers_expr; struct gfc_expr *vector_length_expr; + struct gfc_symbol *routine_bind; gfc_expr_list *wait_list; gfc_expr_list *tile_list; unsigned async:1, gang:1, worker:1, vector:1, seq:1, independent:1; - unsigned wait:1, par_auto:1, gang_static:1; + unsigned wait:1, par_auto:1, gang_static:1, nohost:1, bind:1; locus loc; } @@ -1691,6 +1703,7 @@ typedef struct gfc_oacc_routine_name struct gfc_symbol *sym; struct gfc_omp_clauses *clauses; struct gfc_oacc_routine_name *next; + locus loc; } gfc_oacc_routine_name; @@ -3067,6 +3080,8 @@ void gfc_resolve_oacc_directive (gfc_code *, gfc_namespace *); void gfc_resolve_oacc_declare (gfc_namespace *); void gfc_resolve_oacc_parallel_loop_blocks (gfc_code *, gfc_namespace *); void gfc_resolve_oacc_blocks (gfc_code *, gfc_namespace *); +void gfc_resolve_oacc_routine_call (gfc_symbol *, locus *); +void gfc_resolve_oacc_routines (gfc_namespace *); /* expr.c */ void gfc_free_actual_arglist (gfc_actual_arglist *); diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index 4116db8..a36ba0c 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -2097,6 +2097,7 @@ DECL_MIO_NAME (procedure_type) DECL_MIO_NAME (ref_type) DECL_MIO_NAME (sym_flavor) DECL_MIO_NAME (sym_intent) +DECL_MIO_NAME (oacc_function) #undef DECL_MIO_NAME /* Symbol attributes are stored in list with the first three elements @@ -2118,6 +2119,8 @@ mio_symbol_attribute (symbol_attribute *attr) attr->proc = MIO_NAME (procedure_type) (attr->proc, procedures); attr->if_source = MIO_NAME (ifsrc) (attr->if_source, ifsrc_types); attr->save = MIO_NAME (save_state) (attr->save, save_status); + attr->oacc_function = MIO_NAME (oacc_function) (attr->oacc_function, + oacc_function_types); ext_attr = attr->ext_attr; mio_integer ((int *) &ext_attr); @@ -6166,11 +6169,9 @@ create_intrinsic_function (const char *name, int id, tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name); if (tmp_symtree) { - if (tmp_symtree->n.sym && tmp_symtree->n.sym->module - && strcmp (modname, tmp_symtree->n.sym->module) == 0) - return; - gfc_error ("Symbol %qs at %C already declared", name); - return; + if (strcmp (modname, tmp_symtree->n.sym->module) == 0) + return; + gfc_error ("Symbol %qs already declared", name); } gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false); diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c index 11ffb5d..88e8edb 100644 --- a/gcc/fortran/openmp.c +++ b/gcc/fortran/openmp.c @@ -813,6 +813,8 @@ enum omp_mask2 OMP_CLAUSE_DELETE, OMP_CLAUSE_AUTO, OMP_CLAUSE_TILE, + OMP_CLAUSE_BIND, + OMP_CLAUSE_NOHOST, /* This must come last. */ OMP_MASK2_LAST }; @@ -1015,6 +1017,14 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, continue; } break; + case 'b': + if ((mask & OMP_CLAUSE_BIND) && c->routine_bind == NULL + && gfc_match ("bind ( %s )", &c->routine_bind) == MATCH_YES) + { + c->bind = 1; + continue; + } + break; case 'c': if ((mask & OMP_CLAUSE_COLLAPSE) && !c->collapse) @@ -1434,6 +1444,12 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, c->nogroup = needs_space = true; continue; } + if ((mask & OMP_CLAUSE_NOHOST) && !c->nohost + && gfc_match ("nohost") == MATCH_YES) + { + c->nohost = true; + continue; + } if ((mask & OMP_CLAUSE_NOTINBRANCH) && !c->notinbranch && !c->inbranch @@ -1975,7 +1991,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, omp_mask (OMP_CLAUSE_ASYNC) #define OACC_ROUTINE_CLAUSES \ (omp_mask (OMP_CLAUSE_GANG) | OMP_CLAUSE_WORKER | OMP_CLAUSE_VECTOR \ - | OMP_CLAUSE_SEQ) + | OMP_CLAUSE_SEQ | OMP_CLAUSE_BIND | OMP_CLAUSE_NOHOST) static match @@ -2232,44 +2248,55 @@ gfc_match_oacc_cache (void) return MATCH_YES; } -/* Determine the loop level for a routine. */ +/* Determine the loop level for a routine. Returns OACC_FUNCTION_NONE + if any error is detected. */ -static int +static oacc_function gfc_oacc_routine_dims (gfc_omp_clauses *clauses) { int level = -1; + oacc_function ret = OACC_FUNCTION_SEQ; if (clauses) { unsigned mask = 0; if (clauses->gang) - level = GOMP_DIM_GANG, mask |= GOMP_DIM_MASK (level); + { + level = GOMP_DIM_GANG, mask |= GOMP_DIM_MASK (level); + ret = OACC_FUNCTION_GANG; + } if (clauses->worker) - level = GOMP_DIM_WORKER, mask |= GOMP_DIM_MASK (level); + { + level = GOMP_DIM_WORKER, mask |= GOMP_DIM_MASK (level); + ret = OACC_FUNCTION_WORKER; + } if (clauses->vector) - level = GOMP_DIM_VECTOR, mask |= GOMP_DIM_MASK (level); + { + level = GOMP_DIM_VECTOR, mask |= GOMP_DIM_MASK (level); + ret = OACC_FUNCTION_VECTOR; + } if (clauses->seq) level = GOMP_DIM_MAX, mask |= GOMP_DIM_MASK (level); if (mask != (mask & -mask)) - gfc_error ("Multiple loop axes specified for routine"); + ret = OACC_FUNCTION_NONE; } - if (level < 0) - level = GOMP_DIM_MAX; - - return level; + return ret; } match gfc_match_oacc_routine (void) { locus old_loc; - gfc_symbol *sym = NULL; match m; + gfc_intrinsic_sym *isym = NULL; + gfc_symbol *sym = NULL; gfc_omp_clauses *c = NULL; gfc_oacc_routine_name *n = NULL; + oacc_function dims = OACC_FUNCTION_NONE; + bool seen_error = false; old_loc = gfc_current_locus; @@ -2287,45 +2314,52 @@ gfc_match_oacc_routine (void) if (m == MATCH_YES) { char buffer[GFC_MAX_SYMBOL_LEN + 1]; - gfc_symtree *st; + gfc_symtree *st = NULL; m = gfc_match_name (buffer); if (m == MATCH_YES) { - st = gfc_find_symtree (gfc_current_ns->sym_root, buffer); + if ((isym = gfc_find_function (buffer)) == NULL + && (isym = gfc_find_subroutine (buffer)) == NULL) + { + st = gfc_find_symtree (gfc_current_ns->sym_root, buffer); + if (st == NULL && gfc_current_ns->proc_name->attr.contained + && gfc_current_ns->parent) + st = gfc_find_symtree (gfc_current_ns->parent->sym_root, + buffer); + } if (st) { sym = st->n.sym; if (strcmp (sym->name, gfc_current_ns->proc_name->name) == 0) sym = NULL; } - - if (st == NULL - || (sym - && !sym->attr.external - && !sym->attr.function - && !sym->attr.subroutine)) + else if (isym == NULL) { - gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, " - "invalid function name %s", - (sym) ? sym->name : buffer); - gfc_current_locus = old_loc; - return MATCH_ERROR; + gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %L, " + "invalid function name %qs", &old_loc, buffer);\ + goto cleanup; + } + + /* Set sym to NULL if it matches the current procedure's + name. This will simplify the check for duplicate ACC + ROUTINE attributes. */ + if (gfc_current_ns->proc_name + && !strcmp (buffer, gfc_current_ns->proc_name->name)) + sym = NULL; } else { - gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C"); - gfc_current_locus = old_loc; - return MATCH_ERROR; + gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %L", &old_loc); + goto cleanup; } 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; + gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %L, expecting" + " ')' after NAME", &old_loc); + goto cleanup; } } @@ -2334,26 +2368,89 @@ gfc_match_oacc_routine (void) != MATCH_YES)) return MATCH_ERROR; - if (sym != NULL) + /* Scan for invalid routine geometry. */ + dims = gfc_oacc_routine_dims (c); + if (dims == OACC_FUNCTION_NONE) + { + gfc_error ("Multiple loop axes specified in !$ACC ROUTINE at %L", + &old_loc); + + /* Don't abort early, because it's important to let the user + know of any potential duplicate routine directives. */ + seen_error = true; + } + + if (isym != NULL) { - n = gfc_get_oacc_routine_name (); - n->sym = sym; - n->clauses = NULL; - n->next = NULL; - if (gfc_current_ns->oacc_routine_names != NULL) - n->next = gfc_current_ns->oacc_routine_names; - - gfc_current_ns->oacc_routine_names = n; + if (c && (c->gang || c->worker || c->vector)) + { + gfc_error ("Intrinsic symbol specified in !$ACC ROUTINE ( NAME ) " + "at %L, with incompatible clauses specifying the level " + "of parallelism", &old_loc); + goto cleanup; + } + /* The intrinsic symbol has been marked with a SEQ, or with no clause at + all, which is OK. */ + } + else if (sym != NULL) + { + bool needs_entry = true; + + /* Scan for any repeated routine directives on 'sym' and report + an error if necessary. TODO: Extend this function to scan + for compatible DEVICE_TYPE dims. */ + for (n = gfc_current_ns->oacc_routine_names; n; n = n->next) + if (n->sym == sym) + { + needs_entry = false; + if (dims != gfc_oacc_routine_dims (n->clauses)) + { + gfc_error ("$!ACC ROUTINE already applied at %L", &old_loc); + goto cleanup; + } + } + + if (needs_entry) + { + n = gfc_get_oacc_routine_name (); + n->sym = sym; + n->clauses = c; + n->next = NULL; + n->loc = old_loc; + + if (gfc_current_ns->oacc_routine_names != NULL) + n->next = gfc_current_ns->oacc_routine_names; + + gfc_current_ns->oacc_routine_names = n; + } + + if (seen_error) + goto cleanup; } else if (gfc_current_ns->proc_name) { + if (gfc_current_ns->proc_name->attr.oacc_function != OACC_FUNCTION_NONE + && !seen_error) + { + gfc_error ("!$ACC ROUTINE already applied at %L", &old_loc); + 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_function - = gfc_oacc_routine_dims (c) + 1; + = seen_error ? OACC_FUNCTION_SEQ : dims; + gfc_current_ns->proc_name->attr.oacc_function_nohost + = c ? c->nohost : false; + + if (seen_error) + goto cleanup; } + else + gcc_unreachable (); if (n) n->clauses = c; @@ -5263,6 +5360,7 @@ struct fortran_omp_context hash_set *private_iterators; struct fortran_omp_context *previous; bool is_openmp; + oacc_function dims; } *omp_current_ctx; static gfc_code *omp_current_do_code; static int omp_current_do_collapse; @@ -5926,6 +6024,7 @@ void gfc_resolve_oacc_blocks (gfc_code *code, gfc_namespace *ns) { fortran_omp_context ctx; + oacc_function dims = OACC_FUNCTION_NONE; resolve_oacc_loop_blocks (code); @@ -5934,6 +6033,21 @@ gfc_resolve_oacc_blocks (gfc_code *code, gfc_namespace *ns) ctx.private_iterators = new hash_set; ctx.previous = omp_current_ctx; ctx.is_openmp = false; + + if (code->ext.omp_clauses->gang) + dims = OACC_FUNCTION_GANG; + if (code->ext.omp_clauses->worker) + dims = OACC_FUNCTION_WORKER; + if (code->ext.omp_clauses->vector) + dims = OACC_FUNCTION_VECTOR; + if (code->ext.omp_clauses->seq) + dims = OACC_FUNCTION_SEQ; + + if (dims == OACC_FUNCTION_NONE && ctx.previous != NULL + && !ctx.previous->is_openmp) + dims = ctx.previous->dims; + + ctx.dims = dims; omp_current_ctx = &ctx; gfc_resolve_blocks (code->block, ns); @@ -6285,3 +6399,54 @@ gfc_resolve_omp_udrs (gfc_symtree *st) for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next) gfc_resolve_omp_udr (omp_udr); } + +/* Ensure that any calls to OpenACC routines respects the current + level of parallelism of the innermost loop. */ + +void +gfc_resolve_oacc_routine_call (gfc_symbol *sym, locus *loc) +{ + gfc_oacc_routine_name *n = NULL; + oacc_function loop_dims = OACC_FUNCTION_NONE; + oacc_function routine_dims; + + if (!omp_current_ctx) + return; + + loop_dims = omp_current_ctx->dims; + + if (omp_current_ctx->is_openmp || loop_dims == OACC_FUNCTION_NONE) + return; + + for (n = gfc_current_ns->oacc_routine_names; n; n = n->next) + if (n->sym == sym) + break; + + if (n == NULL) + return; + + routine_dims = gfc_oacc_routine_dims (n->clauses); + + if (routine_dims == OACC_FUNCTION_SEQ) + return; + if (routine_dims <= loop_dims) + gfc_error ("Insufficient !$ACC LOOP parallelism available to call " + "%qs at %L", sym->name, loc); +} + +void +gfc_resolve_oacc_routines (gfc_namespace *ns) +{ + gfc_oacc_routine_name *routines = NULL; + + for (routines = ns->oacc_routine_names; routines; routines = routines->next) + { + gfc_symbol *sym = routines->sym; + + if (!sym->attr.external + && !sym->attr.function + && !sym->attr.subroutine) + gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %L, " + "invalid function name %qs", &routines->loc, sym->name); + } +} diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index faf7dde..cf8a789 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -3153,6 +3153,11 @@ resolve_function (gfc_expr *expr) /* typebound procedure: Assume the worst. */ gfc_current_ns->proc_name->attr.array_outer_dependency = 1; + /* Calls to OpenACC routines have imposed restrictions on gang, + worker and vector parallelism. */ + if (sym) + gfc_resolve_oacc_routine_call (sym, &expr->where); + return t; } @@ -3496,6 +3501,11 @@ resolve_call (gfc_code *c) /* Typebound procedure: Assume the worst. */ gfc_current_ns->proc_name->attr.array_outer_dependency = 1; + /* Calls to OpenACC routines have imposed restrictions on gang, + worker and vector parallelism. */ + if (csym) + gfc_resolve_oacc_routine_call (csym, &c->loc); + return t; } @@ -16024,6 +16034,7 @@ resolve_codes (gfc_namespace *ns) bitmap_obstack_initialize (&labels_obstack); gfc_resolve_oacc_declare (ns); + gfc_resolve_oacc_routines (ns); gfc_resolve_code (ns->code, ns); bitmap_obstack_release (&labels_obstack); diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 0b711ca..ab07f64 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -96,6 +96,15 @@ const mstring dtio_procs[] = minit ("_dtio_unformatted_write", DTIO_WUF), }; +const mstring oacc_function_types[] = +{ + minit ("NONE", OACC_FUNCTION_NONE), + minit ("OACC_FUNCTION_SEQ", OACC_FUNCTION_SEQ), + minit ("OACC_FUNCTION_GANG", OACC_FUNCTION_GANG), + minit ("OACC_FUNCTION_WORKER", OACC_FUNCTION_WORKER), + minit ("OACC_FUNCTION_VECTOR", OACC_FUNCTION_VECTOR) +}; + /* This is to make sure the backend generates setup code in the correct order. */ diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 7c9730c..84eff1a 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -46,6 +46,7 @@ along with GCC; see the file COPYING3. If not see #include "trans-stmt.h" #include "gomp-constants.h" #include "gimplify.h" +#include "omp-low.h" #define MAX_LABEL_VALUE 99999 @@ -1380,19 +1381,38 @@ add_attributes_to_decl (symbol_attribute sym_attr, tree list) list = tree_cons (get_identifier ("omp declare target link"), NULL_TREE, list); else if (sym_attr.omp_declare_target) - list = tree_cons (get_identifier ("omp declare target"), - NULL_TREE, list); - - if (sym_attr.oacc_function) { - tree dims = NULL_TREE; - int ix; - int level = sym_attr.oacc_function - 1; + tree c = NULL_TREE; + if (sym_attr.oacc_function_nohost) + c = build_omp_clause (/* TODO */ input_location, + OMP_CLAUSE_NOHOST); + list = tree_cons (get_identifier ("omp declare target"), c, list); + } + if (sym_attr.oacc_function) - for (ix = GOMP_DIM_MAX; ix--;) - dims = tree_cons (build_int_cst (boolean_type_node, ix >= level), - integer_zero_node, dims); + if (sym_attr.oacc_function != OACC_FUNCTION_NONE) + { + omp_clause_code code = OMP_CLAUSE_ERROR; + tree clause, dims; + + switch (sym_attr.oacc_function) + { + case OACC_FUNCTION_GANG: + code = OMP_CLAUSE_GANG; + break; + case OACC_FUNCTION_WORKER: + code = OMP_CLAUSE_WORKER; + break; + case OACC_FUNCTION_VECTOR: + code = OMP_CLAUSE_VECTOR; + break; + case OACC_FUNCTION_SEQ: + default: + code = OMP_CLAUSE_SEQ; + } + clause = build_omp_clause (UNKNOWN_LOCATION, code); + dims = build_oacc_routine_dims (clause); list = tree_cons (get_identifier ("oacc function"), dims, list); }