From patchwork Tue Nov 22 19:58:58 2016 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Cesar Philippidis X-Patchwork-Id: 83484 Delivered-To: patch@linaro.org Received: by 10.140.97.165 with SMTP id m34csp2287251qge; Tue, 22 Nov 2016 11:59:44 -0800 (PST) X-Received: by 10.84.218.7 with SMTP id q7mr2993293pli.18.1479844784442; Tue, 22 Nov 2016 11:59:44 -0800 (PST) Return-Path: Received: from sourceware.org (server1.sourceware.org. [209.132.180.131]) by mx.google.com with ESMTPS id z97si1292520plh.165.2016.11.22.11.59.44 for (version=TLS1_2 cipher=ECDHE-RSA-AES128-GCM-SHA256 bits=128/128); Tue, 22 Nov 2016 11:59:44 -0800 (PST) Received-SPF: pass (google.com: domain of gcc-patches-return-442282-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-442282-patch=linaro.org@gcc.gnu.org designates 209.132.180.131 as permitted sender) smtp.mailfrom=gcc-patches-return-442282-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 :subject:to:references:cc:from:message-id:date:mime-version :in-reply-to:content-type; q=dns; s=default; b=AcZra00AOyZDfNfwA ewP8QR6W4PbzJli4BCpVlsjjf3B9ZrK1fTLil8/nV4ise2wd1WKZN7e+/Nr8f7Y/ v6IwYvjHDAiRCRzRYWTYPPeOFTJHPU03UOk7UKgL12FBDQ1OZosAat7w3ikizZJP /782hKOsGB3Gg8ebNW4BjJQbQ4= 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 :subject:to:references:cc:from:message-id:date:mime-version :in-reply-to:content-type; s=default; bh=EUAxgkBT5CuSmrl9n9cBXYO 9TT8=; b=AQ1WSQTSD29WFpndv9DVCfBLZr8DuslFRFXnG8sDtVGl4MfPHZRoyY5 AHHacgOzCUE7rJKmYJmxXV5HSCcsE+ALlFCsVvq/A86XVp1kROk3ZJh0BsLc4mTs CE9J765JlxhmZcbLlFShSqPCBsot4YEJeBE3/5fFXI+3ia+KJteQ= Received: (qmail 114463 invoked by alias); 22 Nov 2016 19:59:16 -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 114433 invoked by uid 89); 22 Nov 2016 19:59:14 -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=imposed, sk:gomp-co, geometry, UD:gomp-constants.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; Tue, 22 Nov 2016 19:59:04 +0000 Received: from svr-orw-mbx-01.mgc.mentorg.com ([147.34.90.201]) by relay1.mentorg.com with esmtp id 1c9HDa-00038P-Dc from Cesar_Philippidis@mentor.com ; Tue, 22 Nov 2016 11:59:02 -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; Tue, 22 Nov 2016 11:58:59 -0800 Subject: Re: [PATCH] OpenACC routines -- fortran front end To: Jakub Jelinek References: <20161118122910.GZ3541@tucnak.redhat.com> CC: "gcc-patches@gcc.gnu.org" , Fortran List , Thomas Schwinge From: Cesar Philippidis Message-ID: Date: Tue, 22 Nov 2016 11:58:58 -0800 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:45.0) Gecko/20100101 Thunderbird/45.3.0 MIME-Version: 1.0 In-Reply-To: <20161118122910.GZ3541@tucnak.redhat.com> X-ClientProxiedBy: svr-orw-mbx-02.mgc.mentorg.com (147.34.90.202) To svr-orw-mbx-01.mgc.mentorg.com (147.34.90.201) On 11/18/2016 04:29 AM, Jakub Jelinek wrote: > On Fri, Nov 11, 2016 at 03:44:07PM -0800, Cesar Philippidis wrote: >> --- 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, > > Please add a newline after {. > >> 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; >> + } > > As you have {}s around, please use > level = GOMP_DIM_*; > mask |= GOMP_DIM_MASK (level); > ret = OACC_FUNCTION_*; > >> 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 > > Please add a newline before &&. > >> + && gfc_current_ns->parent) >> + st = gfc_find_symtree (gfc_current_ns->parent->sym_root, >> + buffer); >> + } > >> @@ -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; > > Shouldn't these be else if ? >> + >> + if (dims == OACC_FUNCTION_NONE && ctx.previous != NULL > > Again, as the whole condition doesn't fit on one line, please > put && on a new line. >> + && !ctx.previous->is_openmp) >> + dims = ctx.previous->dims; I've address those issues in this patch. Is it ok for trunk? Cesar 2016-11-22 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..5c1dbda 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -314,6 +314,16 @@ 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 +333,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 +893,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 +1322,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 +1704,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 +3081,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..135b44c 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); diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c index 11ffb5d..29d6fb8 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,58 @@ 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 +2317,53 @@ 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 +2372,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 +5364,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 +6028,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 +6037,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; + else if (code->ext.omp_clauses->worker) + dims = OACC_FUNCTION_WORKER; + else if (code->ext.omp_clauses->vector) + dims = OACC_FUNCTION_VECTOR; + else 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 +6403,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 9e628f1..b00c9fa 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -3159,6 +3159,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; } @@ -3502,6 +3507,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; } @@ -16022,6 +16032,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 ba71a21..c43f4c1 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); }