From patchwork Thu Jan 23 18:03:42 2014 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Ilmir Usmanov X-Patchwork-Id: 313667 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id B25142C009B for ; Fri, 24 Jan 2014 05:04:03 +1100 (EST) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender :message-id:date:from:mime-version:to:cc:subject:references :in-reply-to:content-type; q=dns; s=default; b=ju0NEeovZc4bLFk/u yfyxRi/aCVeNCLG0/O3VL8eTD5BflWMniwFirtyQbHVl9iianikPddGSm6MHfhhI KQYEEez3J40cW0d1ATeOXIHVs/aQPC/ea9bUivldTa2HCv4qa6x+vQy1HQMTOlUR leVzVBPSPLGJPmfb6Ee84gqIGY= 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 :message-id:date:from:mime-version:to:cc:subject:references :in-reply-to:content-type; s=default; bh=kSA523gSTkAcB+wnhwhFcNk 6d70=; b=bmTKQ0clvtzBLizw4u8Eg0TLRjbY6QrYp/vwu0GttfCoD+E+DW2FLRc cVGEdU4MNKeq4PnsDgqFBVWQdGV095bYTgt1GhHM0fJ7dhGdL6mYKwB3bSHxukq+ E3heJ8QTSCrDXiYbGunWBPLcoIu6zvlGHBOl1K+r+DcS7HpaAPTY= Received: (qmail 13690 invoked by alias); 23 Jan 2014 18:03:55 -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 13669 invoked by uid 89); 23 Jan 2014 18:03:54 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-1.3 required=5.0 tests=AWL, BAYES_00, RP_MATCHES_RCVD, SPF_HELO_PASS autolearn=ham version=3.3.2 X-HELO: mailout4.w1.samsung.com Received: from mailout4.w1.samsung.com (HELO mailout4.w1.samsung.com) (210.118.77.14) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with (DES-CBC3-SHA encrypted) ESMTPS; Thu, 23 Jan 2014 18:03:48 +0000 Received: from eucpsbgm1.samsung.com (unknown [203.254.199.244]) by mailout4.w1.samsung.com (Oracle Communications Messaging Server 7u4-24.01(7.0.4.24.0) 64bit (built Nov 17 2011)) with ESMTP id <0MZV00FWC8U9L650@mailout4.w1.samsung.com> for gcc-patches@gcc.gnu.org; Thu, 23 Jan 2014 18:03:45 +0000 (GMT) Received: from eusync2.samsung.com ( [203.254.199.212]) by eucpsbgm1.samsung.com (EUCPMTA) with SMTP id 36.AB.23059.F7951E25; Thu, 23 Jan 2014 18:03:43 +0000 (GMT) Received: from [106.109.130.57] by eusync2.samsung.com (Oracle Communications Messaging Server 7u4-23.01(7.0.4.23.0) 64bit (built Aug 10 2011)) with ESMTPA id <0MZV00AP38U61T60@eusync2.samsung.com>; Thu, 23 Jan 2014 18:03:43 +0000 (GMT) Message-id: <52E1597E.8070809@samsung.com> Date: Thu, 23 Jan 2014 22:03:42 +0400 From: Ilmir Usmanov User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:24.0) Gecko/20100101 Thunderbird/24.0 MIME-version: 1.0 To: gcc-patches@gcc.gnu.org, Thomas Schwinge , jakub@redhat.com Cc: Evgeny Gavrin , GarbuzovViacheslav , Dmitri Botcharnikov Subject: [PATCH 2/6] [GOMP4] OpenACC 1.0+ support in fortran front-end References: <52E158EF.9050009@samsung.com> <52E1595D.9000007@samsung.com> In-reply-to: <52E1595D.9000007@samsung.com> Content-type: multipart/mixed; boundary=------------080008090307050609000505 From 69bf2531e4512b7cdb2feba8541de1eaf9c2aa56 Mon Sep 17 00:00:00 2001 From: Ilmir Usmanov Date: Thu, 23 Jan 2014 21:05:11 +0400 Subject: [PATCH 2/6] OpenACC fortran FE part 2 --- gcc/fortran/openmp.c | 1032 +++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 1019 insertions(+), 13 deletions(-) diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c index 6c4dccb..ce13e52 100644 --- a/gcc/fortran/openmp.c +++ b/gcc/fortran/openmp.c @@ -69,11 +69,36 @@ gfc_free_omp_clauses (gfc_omp_clauses *c) gfc_free_expr (c->final_expr); gfc_free_expr (c->num_threads); gfc_free_expr (c->chunk_size); - for (i = 0; i < OMP_LIST_NUM; i++) + gfc_free_expr (c->async_expr); + gfc_free_expr (c->gang_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); + gfc_free_expr (c->non_clause_wait_expr); + + for (i = 0; i < OACC_LIST_NUM; i++) gfc_free_namelist (c->lists[i]); + + gfc_free_exprlist (c->waitlist); + free (c); } +/* Free expression list. */ +void +gfc_free_exprlist (gfc_exprlist *list) +{ + gfc_exprlist *n; + + for (; list; list = n) + { + n = list->next; + free (list); + } +} + /* Match a variable/common block list and construct a namelist from it. */ static match @@ -169,6 +194,87 @@ cleanup: return MATCH_ERROR; } +static match +match_oacc_exprlist (const char *str, gfc_exprlist **list, bool allow_asterisk) +{ + gfc_exprlist *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_exprlist (); + 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_exprlist (head); + gfc_current_locus = old_loc; + return MATCH_ERROR; +} + +static match +match_oacc_clause_gang (gfc_oacc_clauses *cp) +{ + if (gfc_match_char ('(') != MATCH_YES) + return MATCH_NO; + if (gfc_match (" num :") == MATCH_YES) + { + cp->gang_static = false; + return gfc_match (" %e )", &cp->gang_expr); + } + if (gfc_match (" static :") == MATCH_YES) + { + cp->gang_static = true; + if (gfc_match (" * )") != MATCH_YES) + return gfc_match (" %e )", &cp->gang_expr); + return MATCH_YES; + } + return gfc_match (" %e )", &cp->gang_expr); +} + #define OMP_CLAUSE_PRIVATE (1 << 0) #define OMP_CLAUSE_FIRSTPRIVATE (1 << 1) #define OMP_CLAUSE_LASTPRIVATE (1 << 2) @@ -186,15 +292,51 @@ cleanup: #define OMP_CLAUSE_FINAL (1 << 14) #define OMP_CLAUSE_MERGEABLE (1 << 15) +/* OpenACC 2.0 clauses. */ +#define OACC_CLAUSE_IF OMP_CLAUSE_IF +#define OACC_CLAUSE_ASYNC (1 << 16) +#define OACC_CLAUSE_NUM_GANGS (1 << 17) +#define OACC_CLAUSE_NUM_WORKERS (1 << 18) +#define OACC_CLAUSE_VECTOR_LENGTH (1 << 19) +#define OACC_CLAUSE_REDUCTION OMP_CLAUSE_REDUCTION +#define OACC_CLAUSE_COPY (1 << 20) +#define OACC_CLAUSE_COPYIN OMP_CLAUSE_COPYIN +#define OACC_CLAUSE_COPYOUT (1 << 21) +#define OACC_CLAUSE_CREATE (1 << 22) +#define OACC_CLAUSE_PRESENT (1 << 23) +#define OACC_CLAUSE_PRESENT_OR_COPY (1 << 24) +#define OACC_CLAUSE_PRESENT_OR_COPYIN (1 << 25) +#define OACC_CLAUSE_PRESENT_OR_COPYOUT (1 << 26) +#define OACC_CLAUSE_PRESENT_OR_CREATE (1 << 27) +#define OACC_CLAUSE_DEVICEPTR (1 << 28) +#define OACC_CLAUSE_PRIVATE OMP_CLAUSE_PRIVATE +#define OACC_CLAUSE_FIRSTPRIVATE OMP_CLAUSE_FIRSTPRIVATE +#define OACC_CLAUSE_COLLAPSE OMP_CLAUSE_COLLAPSE +#define OACC_CLAUSE_GANG (1 << 29) +#define OACC_CLAUSE_WORKER (1 << 30) +#define OACC_CLAUSE_VECTOR (1 << 31) +#define OACC_CLAUSE_SEQ (1ll << 32) +#define OACC_CLAUSE_INDEPENDENT (1ll << 33) +#define OACC_CLAUSE_USE_DEVICE (1ll << 34) +#define OACC_CLAUSE_DEVICE_RESIDENT (1ll << 35) +#define OACC_CLAUSE_HOST (1ll << 36) +#define OACC_CLAUSE_DEVICE (1ll << 37) +#define OACC_CLAUSE_DEFAULT (1ll << 38) +#define OACC_CLAUSE_WAIT (1ll << 39) +#define OACC_CLAUSE_DELETE (1ll << 40) +#define OACC_CLAUSE_AUTO (1ll << 41) +#define OACC_CLAUSE_TILE (1ll << 42) + /* Match OpenMP 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, int mask) +gfc_match_omp_clauses (gfc_omp_clauses **cp, long long mask, bool is_acc) { gfc_omp_clauses *c = gfc_get_omp_clauses (); locus old_loc; bool needs_space = true, first = true; + c->is_acc = is_acc; *cp = NULL; while (1) @@ -205,6 +347,52 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, int mask) needs_space = false; first = false; gfc_gobble_whitespace (); + if ((mask & OACC_CLAUSE_ASYNC) && !c->async) + if (gfc_match ("async") == MATCH_YES) + { + c->async = true; + if (gfc_match (" ( %e )", &c->async_expr) == MATCH_YES) + needs_space = false; + else + needs_space = true; + continue; + } + if ((mask & OACC_CLAUSE_GANG) && !c->gang) + if (gfc_match ("gang") == MATCH_YES) + { + c->gang = true; + if (match_oacc_clause_gang(c) == MATCH_YES) + needs_space = false; + else + needs_space = true; + continue; + } + if ((mask & OACC_CLAUSE_WORKER) && !c->worker) + if (gfc_match ("worker") == MATCH_YES) + { + c->worker = true; + if (gfc_match (" ( num : %e )", &c->worker_expr) == MATCH_YES + || gfc_match (" ( %e )", &c->worker_expr) == MATCH_YES) + needs_space = false; + else + needs_space = true; + continue; + } + if ((mask & OACC_CLAUSE_VECTOR_LENGTH) && c->vector_length_expr == NULL + && gfc_match ("vector_length ( %e )", &c->vector_length_expr) + == MATCH_YES) + continue; + if ((mask & OACC_CLAUSE_VECTOR) && !c->vector) + if (gfc_match ("vector") == MATCH_YES) + { + c->vector = true; + if (gfc_match (" ( length : %e )", &c->vector_expr) == MATCH_YES + || gfc_match (" ( %e )", &c->vector_expr) == MATCH_YES) + needs_space = false; + else + needs_space = true; + continue; + } if ((mask & OMP_CLAUSE_IF) && c->if_expr == NULL && gfc_match ("if ( %e )", &c->if_expr) == MATCH_YES) continue; @@ -242,11 +430,157 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, int mask) &c->lists[OMP_LIST_SHARED], true) == MATCH_YES) continue; - if ((mask & OMP_CLAUSE_COPYIN) + if (!c->is_acc && (mask & OMP_CLAUSE_COPYIN) && gfc_match_omp_variable_list ("copyin (", &c->lists[OMP_LIST_COPYIN], true) == MATCH_YES) continue; + if (c->is_acc && (mask & OACC_CLAUSE_COPYIN) + && gfc_match_omp_variable_list ("copyin (", + &c->lists[OACC_LIST_COPYIN], true) + == MATCH_YES) + continue; + if ((mask & OACC_CLAUSE_NUM_GANGS) && c->num_gangs_expr == NULL + && gfc_match ("num_gangs ( %e )", &c->num_gangs_expr) == MATCH_YES) + continue; + if ((mask & OACC_CLAUSE_NUM_WORKERS) && c->num_workers_expr == NULL + && gfc_match ("num_workers ( %e )", &c->num_workers_expr) + == MATCH_YES) + continue; + if ((mask & OACC_CLAUSE_COPY) + && gfc_match_omp_variable_list ("copy (", + &c->lists[OACC_LIST_COPY], true) + == MATCH_YES) + continue; + if ((mask & OACC_CLAUSE_COPYOUT) + && gfc_match_omp_variable_list ("copyout (", + &c->lists[OACC_LIST_COPYOUT], true) + == MATCH_YES) + continue; + if ((mask & OACC_CLAUSE_CREATE) + && gfc_match_omp_variable_list ("create (", + &c->lists[OACC_LIST_CREATE], true) + == MATCH_YES) + continue; + if ((mask & OACC_CLAUSE_DELETE) + && gfc_match_omp_variable_list ("delete (", + &c->lists[OACC_LIST_DELETE], true) + == MATCH_YES) + continue; + if ((mask & OACC_CLAUSE_PRESENT) + && gfc_match_omp_variable_list ("present (", + &c->lists[OACC_LIST_PRESENT], true) + == MATCH_YES) + continue; + if ((mask & OACC_CLAUSE_PRESENT_OR_COPY) + && gfc_match_omp_variable_list ("present_or_copy (", + &c->lists[OACC_LIST_PRESENT_OR_COPY], true) + == MATCH_YES) + continue; + if ((mask & OACC_CLAUSE_PRESENT_OR_COPY) + && gfc_match_omp_variable_list ("pcopy (", + &c->lists[OACC_LIST_PRESENT_OR_COPY], true) + == MATCH_YES) + continue; + if ((mask & OACC_CLAUSE_PRESENT_OR_COPYIN) + && gfc_match_omp_variable_list ("present_or_copyin (", + &c->lists[OACC_LIST_PRESENT_OR_COPYIN], + true) + == MATCH_YES) + continue; + if ((mask & OACC_CLAUSE_PRESENT_OR_COPYIN) + && gfc_match_omp_variable_list ("pcopyin (", + &c->lists[OACC_LIST_PRESENT_OR_COPYIN], + true) + == MATCH_YES) + continue; + if ((mask & OACC_CLAUSE_PRESENT_OR_COPYOUT) + && gfc_match_omp_variable_list ("present_or_copyout (", + &c->lists[OACC_LIST_PRESENT_OR_COPYOUT], + true) + == MATCH_YES) + continue; + if ((mask & OACC_CLAUSE_PRESENT_OR_COPYOUT) + && gfc_match_omp_variable_list ("pcopyout (", + &c->lists[OACC_LIST_PRESENT_OR_COPYOUT], + true) + == MATCH_YES) + continue; + if ((mask & OACC_CLAUSE_PRESENT_OR_CREATE) + && gfc_match_omp_variable_list ("present_or_create (", + &c->lists[OACC_LIST_PRESENT_OR_CREATE], + true) + == MATCH_YES) + continue; + if ((mask & OACC_CLAUSE_PRESENT_OR_CREATE) + && gfc_match_omp_variable_list ("pcreate (", + &c->lists[OACC_LIST_PRESENT_OR_CREATE], + true) + == MATCH_YES) + continue; + if ((mask & OACC_CLAUSE_DEVICEPTR) + && gfc_match_omp_variable_list ("deviceptr (", + &c->lists[OACC_LIST_DEVICEPTR], true) + == MATCH_YES) + continue; + if ((mask & OACC_CLAUSE_USE_DEVICE) + && gfc_match_omp_variable_list ("use_device (", + &c->lists[OACC_LIST_USE_DEVICE], true) + == MATCH_YES) + continue; + if ((mask & OACC_CLAUSE_DEVICE_RESIDENT) + && gfc_match_omp_variable_list ("device_resident (", + &c->lists[OACC_LIST_DEVICE_RESIDENT], true) + == MATCH_YES) + continue; + if ((mask & OACC_CLAUSE_HOST) + && gfc_match_omp_variable_list ("host (", + &c->lists[OACC_LIST_HOST], true) + == MATCH_YES) + continue; + if ((mask & OACC_CLAUSE_DEVICE) + && gfc_match_omp_variable_list ("device (", + &c->lists[OACC_LIST_DEVICE], true) + == MATCH_YES) + continue; + if ((mask & OACC_CLAUSE_TILE) + && match_oacc_exprlist ("tile (", &c->tilelist, true) == MATCH_YES) + continue; + if ((mask & OACC_CLAUSE_SEQ) && !c->seq + && gfc_match ("seq") == MATCH_YES) + { + c->seq = true; + needs_space = true; + continue; + } + if ((mask & OACC_CLAUSE_INDEPENDENT) && !c->independent + && gfc_match ("independent") == MATCH_YES) + { + c->independent = true; + needs_space = true; + continue; + } + if ((mask & OACC_CLAUSE_DEFAULT) && !c->default_none + && gfc_match ("default ( none )") == MATCH_YES) + { + c->default_none = true; + needs_space = true; + continue; + } + if ((mask & OACC_CLAUSE_AUTO) && !c->par_auto + && gfc_match ("auto") == MATCH_YES) + { + c->par_auto = true; + needs_space = true; + continue; + } + if ((mask & OACC_CLAUSE_WAIT) && !c->wait + && gfc_match ("wait") == MATCH_YES) + { + c->wait = true; + match_oacc_exprlist (" (", &c->waitlist, false); + continue; + } old_loc = gfc_current_locus; if ((mask & OMP_CLAUSE_REDUCTION) && gfc_match ("reduction ( ") == MATCH_YES) @@ -433,6 +767,51 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, int mask) return MATCH_YES; } +#define OACC_PARALLEL_CLAUSES \ + (OACC_CLAUSE_IF | OACC_CLAUSE_ASYNC | OACC_CLAUSE_NUM_GANGS \ + | OACC_CLAUSE_NUM_WORKERS | OACC_CLAUSE_VECTOR_LENGTH | OACC_CLAUSE_REDUCTION \ + | OACC_CLAUSE_COPY | OACC_CLAUSE_COPYIN | OACC_CLAUSE_COPYOUT \ + | OACC_CLAUSE_CREATE | OACC_CLAUSE_PRESENT | OACC_CLAUSE_PRESENT_OR_COPY \ + | OACC_CLAUSE_PRESENT_OR_COPYIN | OACC_CLAUSE_PRESENT_OR_COPYOUT \ + | OACC_CLAUSE_PRESENT_OR_CREATE | OACC_CLAUSE_DEVICEPTR | OACC_CLAUSE_PRIVATE \ + | OACC_CLAUSE_FIRSTPRIVATE | OACC_CLAUSE_DEFAULT | OACC_CLAUSE_WAIT) +#define OACC_KERNELS_CLAUSES \ + (OACC_CLAUSE_IF | OACC_CLAUSE_ASYNC | OACC_CLAUSE_DEVICEPTR \ + | OACC_CLAUSE_COPY | OACC_CLAUSE_COPYIN | OACC_CLAUSE_COPYOUT \ + | OACC_CLAUSE_CREATE | OACC_CLAUSE_PRESENT | OACC_CLAUSE_PRESENT_OR_COPY \ + | OACC_CLAUSE_PRESENT_OR_COPYIN | OACC_CLAUSE_PRESENT_OR_COPYOUT \ + | OACC_CLAUSE_PRESENT_OR_CREATE | OACC_CLAUSE_DEFAULT | OACC_CLAUSE_WAIT) +#define OACC_DATA_CLAUSES \ + (OACC_CLAUSE_IF | OACC_CLAUSE_DEVICEPTR | OACC_CLAUSE_COPY | OACC_CLAUSE_COPYIN \ + | OACC_CLAUSE_COPYOUT | OACC_CLAUSE_CREATE | OACC_CLAUSE_PRESENT \ + | OACC_CLAUSE_PRESENT_OR_COPY | OACC_CLAUSE_PRESENT_OR_COPYIN \ + | OACC_CLAUSE_PRESENT_OR_COPYOUT | OACC_CLAUSE_PRESENT_OR_CREATE) +#define OACC_LOOP_CLAUSES \ + (OACC_CLAUSE_COLLAPSE | OACC_CLAUSE_GANG | OACC_CLAUSE_WORKER \ + | OACC_CLAUSE_VECTOR | OACC_CLAUSE_SEQ | OACC_CLAUSE_INDEPENDENT \ + | OACC_CLAUSE_PRIVATE | OACC_CLAUSE_REDUCTION | OACC_CLAUSE_AUTO \ + | OACC_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 OACC_CLAUSE_USE_DEVICE +#define OACC_DECLARE_CLAUSES \ + (OACC_CLAUSE_COPY | OACC_CLAUSE_COPYIN | OACC_CLAUSE_COPYOUT \ + | OACC_CLAUSE_CREATE | OACC_CLAUSE_DEVICEPTR | OACC_CLAUSE_DEVICE_RESIDENT \ + | OACC_CLAUSE_PRESENT | OACC_CLAUSE_PRESENT_OR_COPY \ + | OACC_CLAUSE_PRESENT_OR_COPYIN | OACC_CLAUSE_PRESENT_OR_COPYOUT \ + | OACC_CLAUSE_PRESENT_OR_CREATE) +#define OACC_UPDATE_CLAUSES \ + (OACC_CLAUSE_IF | OACC_CLAUSE_ASYNC | OACC_CLAUSE_HOST | OACC_CLAUSE_DEVICE) +#define OACC_ENTER_DATA_CLAUSES \ + (OACC_CLAUSE_IF | OACC_CLAUSE_ASYNC | OACC_CLAUSE_WAIT | OACC_CLAUSE_COPYIN \ + | OACC_CLAUSE_CREATE | OACC_CLAUSE_PRESENT_OR_COPYIN \ + | OACC_CLAUSE_PRESENT_OR_CREATE) +#define OACC_EXIT_DATA_CLAUSES \ + (OACC_CLAUSE_IF | OACC_CLAUSE_ASYNC | OACC_CLAUSE_WAIT | OACC_CLAUSE_COPYOUT \ + | OACC_CLAUSE_DELETE) + #define OMP_PARALLEL_CLAUSES \ (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_SHARED \ | OMP_CLAUSE_COPYIN | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_IF \ @@ -449,11 +828,190 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, int mask) | OMP_CLAUSE_IF | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_UNTIED \ | OMP_CLAUSE_FINAL | OMP_CLAUSE_MERGEABLE) + +match +gfc_match_oacc_parallel_loop (void) +{ + gfc_oacc_clauses *c; + if (gfc_match_omp_clauses (&c, OACC_PARALLEL_LOOP_CLAUSES, true) != MATCH_YES) + return MATCH_ERROR; + + new_st.op = EXEC_OACC_PARALLEL_LOOP; + new_st.ext.omp_clauses = c; + return MATCH_YES; +} + + +match +gfc_match_oacc_parallel (void) +{ + gfc_oacc_clauses *c; + if (gfc_match_omp_clauses (&c, OACC_PARALLEL_CLAUSES, true) != MATCH_YES) + return MATCH_ERROR; + + new_st.op = EXEC_OACC_PARALLEL; + new_st.ext.omp_clauses = c; + return MATCH_YES; +} + + +match +gfc_match_oacc_kernels_loop (void) +{ + gfc_oacc_clauses *c; + if (gfc_match_omp_clauses (&c, OACC_KERNELS_LOOP_CLAUSES, true) != MATCH_YES) + return MATCH_ERROR; + + new_st.op = EXEC_OACC_KERNELS_LOOP; + new_st.ext.omp_clauses = c; + return MATCH_YES; +} + + +match +gfc_match_oacc_kernels (void) +{ + gfc_oacc_clauses *c; + if (gfc_match_omp_clauses (&c, OACC_KERNELS_CLAUSES, true) != MATCH_YES) + return MATCH_ERROR; + + new_st.op = EXEC_OACC_KERNELS; + new_st.ext.omp_clauses = c; + return MATCH_YES; +} + + +match +gfc_match_oacc_data (void) +{ + gfc_oacc_clauses *c; + if (gfc_match_omp_clauses (&c, OACC_DATA_CLAUSES, true) != MATCH_YES) + return MATCH_ERROR; + + new_st.op = EXEC_OACC_DATA; + new_st.ext.omp_clauses = c; + return MATCH_YES; +} + + +match +gfc_match_oacc_host_data (void) +{ + gfc_oacc_clauses *c; + if (gfc_match_omp_clauses (&c, OACC_HOST_DATA_CLAUSES, true) != MATCH_YES) + return MATCH_ERROR; + + new_st.op = EXEC_OACC_HOST_DATA; + new_st.ext.omp_clauses = c; + return MATCH_YES; +} + + +match +gfc_match_oacc_loop (void) +{ + gfc_oacc_clauses *c; + if (gfc_match_omp_clauses (&c, OACC_LOOP_CLAUSES, true) != MATCH_YES) + return MATCH_ERROR; + + new_st.op = EXEC_OACC_LOOP; + new_st.ext.omp_clauses = c; + return MATCH_YES; +} + + +match +gfc_match_oacc_declare (void) +{ + gfc_oacc_clauses *c; + if (gfc_match_omp_clauses (&c, OACC_DECLARE_CLAUSES, true) != MATCH_YES) + return MATCH_ERROR; + + new_st.ext.omp_clauses = c; + return MATCH_YES; +} + + +match +gfc_match_oacc_update (void) +{ + gfc_oacc_clauses *c; + if (gfc_match_omp_clauses (&c, OACC_UPDATE_CLAUSES, true) != MATCH_YES) + 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) +{ + gfc_oacc_clauses *c; + if (gfc_match_omp_clauses (&c, OACC_ENTER_DATA_CLAUSES, true) != MATCH_YES) + return MATCH_ERROR; + + new_st.op = EXEC_OACC_ENTER_DATA; + new_st.ext.omp_clauses = c; + return MATCH_YES; +} + + +match +gfc_match_oacc_exit_data (void) +{ + gfc_oacc_clauses *c; + if (gfc_match_omp_clauses (&c, OACC_EXIT_DATA_CLAUSES, true) != MATCH_YES) + return MATCH_ERROR; + + new_st.op = EXEC_OACC_EXIT_DATA; + new_st.ext.omp_clauses = c; + return MATCH_YES; +} + + +match +gfc_match_oacc_wait (void) +{ + gfc_oacc_clauses *c = gfc_get_oacc_clauses (); + gfc_match (" ( %e )", &c->non_clause_wait_expr); + + new_st.op = EXEC_OACC_WAIT; + new_st.ext.omp_clauses = c; + return MATCH_YES; +} + + +match +gfc_match_oacc_cache (void) +{ + gfc_oacc_clauses *c = gfc_get_oacc_clauses (); + match m = gfc_match_omp_variable_list (" (",&c->lists[OACC_LIST_CACHE], true); + if (m != MATCH_YES) + { + gfc_free_omp_clauses(c); + return m; + } + + if (gfc_current_state() != COMP_DO) + { + 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; +} + + match gfc_match_omp_parallel (void) { gfc_omp_clauses *c; - if (gfc_match_omp_clauses (&c, OMP_PARALLEL_CLAUSES) != MATCH_YES) + if (gfc_match_omp_clauses (&c, OMP_PARALLEL_CLAUSES, false) != MATCH_YES) return MATCH_ERROR; new_st.op = EXEC_OMP_PARALLEL; new_st.ext.omp_clauses = c; @@ -465,7 +1023,7 @@ match gfc_match_omp_task (void) { gfc_omp_clauses *c; - if (gfc_match_omp_clauses (&c, OMP_TASK_CLAUSES) != MATCH_YES) + if (gfc_match_omp_clauses (&c, OMP_TASK_CLAUSES, false) != MATCH_YES) return MATCH_ERROR; new_st.op = EXEC_OMP_TASK; new_st.ext.omp_clauses = c; @@ -523,7 +1081,7 @@ match gfc_match_omp_do (void) { gfc_omp_clauses *c; - if (gfc_match_omp_clauses (&c, OMP_DO_CLAUSES) != MATCH_YES) + if (gfc_match_omp_clauses (&c, OMP_DO_CLAUSES, false) != MATCH_YES) return MATCH_ERROR; new_st.op = EXEC_OMP_DO; new_st.ext.omp_clauses = c; @@ -620,7 +1178,7 @@ match gfc_match_omp_parallel_do (void) { gfc_omp_clauses *c; - if (gfc_match_omp_clauses (&c, OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES) + if (gfc_match_omp_clauses (&c, OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES, false) != MATCH_YES) return MATCH_ERROR; new_st.op = EXEC_OMP_PARALLEL_DO; @@ -633,7 +1191,8 @@ match gfc_match_omp_parallel_sections (void) { gfc_omp_clauses *c; - if (gfc_match_omp_clauses (&c, OMP_PARALLEL_CLAUSES | OMP_SECTIONS_CLAUSES) + if (gfc_match_omp_clauses (&c, OMP_PARALLEL_CLAUSES | OMP_SECTIONS_CLAUSES, + false) != MATCH_YES) return MATCH_ERROR; new_st.op = EXEC_OMP_PARALLEL_SECTIONS; @@ -646,7 +1205,7 @@ match gfc_match_omp_parallel_workshare (void) { gfc_omp_clauses *c; - if (gfc_match_omp_clauses (&c, OMP_PARALLEL_CLAUSES) != MATCH_YES) + if (gfc_match_omp_clauses (&c, OMP_PARALLEL_CLAUSES, false) != MATCH_YES) return MATCH_ERROR; new_st.op = EXEC_OMP_PARALLEL_WORKSHARE; new_st.ext.omp_clauses = c; @@ -658,7 +1217,7 @@ match gfc_match_omp_sections (void) { gfc_omp_clauses *c; - if (gfc_match_omp_clauses (&c, OMP_SECTIONS_CLAUSES) != MATCH_YES) + if (gfc_match_omp_clauses (&c, OMP_SECTIONS_CLAUSES, false) != MATCH_YES) return MATCH_ERROR; new_st.op = EXEC_OMP_SECTIONS; new_st.ext.omp_clauses = c; @@ -670,7 +1229,8 @@ match gfc_match_omp_single (void) { gfc_omp_clauses *c; - if (gfc_match_omp_clauses (&c, OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE) + if (gfc_match_omp_clauses (&c, OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE, + false) != MATCH_YES) return MATCH_ERROR; new_st.op = EXEC_OMP_SINGLE; @@ -785,7 +1345,7 @@ gfc_match_omp_end_single (void) new_st.ext.omp_bool = true; return MATCH_YES; } - if (gfc_match_omp_clauses (&c, OMP_CLAUSE_COPYPRIVATE) != MATCH_YES) + if (gfc_match_omp_clauses (&c, OMP_CLAUSE_COPYPRIVATE, false) != MATCH_YES) return MATCH_ERROR; new_st.op = EXEC_OMP_END_SINGLE; new_st.ext.omp_clauses = c; @@ -793,6 +1353,27 @@ gfc_match_omp_end_single (void) } +static void +resolve_oacc_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_oacc_positive_int_expr (gfc_expr *expr, const char *clause) +{ + resolve_oacc_scalar_int_expr (expr, clause); + if (expr->expr_type == EXPR_CONSTANT && expr->ts.type == BT_INTEGER + && expr->value.integer->_mp_size <= 0) + gfc_warning ("INTEGER expression of %s clause at %L must be positive", + clause, &expr->where); +} + + /* OpenMP directive resolving routines. */ static void @@ -800,10 +1381,17 @@ resolve_omp_clauses (gfc_code *code) { gfc_omp_clauses *omp_clauses = code->ext.omp_clauses; gfc_namelist *n; + gfc_oacc_clauses *oacc_clauses = omp_clauses; + gfc_exprlist *el; int list; static const char *clause_names[] = { "PRIVATE", "FIRSTPRIVATE", "LASTPRIVATE", "COPYPRIVATE", "SHARED", "COPYIN", "REDUCTION" }; + static const char *oacc_clause_names[] + = { "COPY", "COPYIN", "COPYOUT", "CREATE", "DELETE", + "PRESENT", "PRESENT_OR_COPY", "PRESENT_OR_COPYIN", "PRESENT_OR_COPYOUT", + "PRESENT_OR_CREATE", "DEVICEPTR", "USE_DEVICE", "DEVICE_RESIDENT", + "HOST", "DEVICE", "CACHE"}; if (omp_clauses == NULL) return; @@ -843,7 +1431,7 @@ resolve_omp_clauses (gfc_code *code) /* 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 (list = 0; list < OACC_LIST_NUM; list++) for (n = omp_clauses->lists[list]; n; n = n->next) { n->sym->mark = 0; @@ -1005,6 +1593,12 @@ resolve_omp_clauses (gfc_code *code) gfc_error ("Variable '%s' in %s clause is used in " "NAMELIST statement at %L", n->sym->name, name, &code->loc); + if (omp_clauses->is_acc + && list >= OACC_LIST_REDUCTION_FIRST + && list <= OACC_LIST_REDUCTION_LAST + && n->sym->as && n->sym->as->rank != 0) + gfc_error ("OpenACC reduction requires SCALAR variable " + "at %L", &code->loc); switch (list) { case OMP_LIST_PLUS: @@ -1059,6 +1653,82 @@ resolve_omp_clauses (gfc_code *code) break; } } + if (!oacc_clauses->is_acc) + return; + + /* In OpenACC, single variable may appear in several clauses, + such as COPYIN and COPYOUT. However, it's better to replace these clause + with COPY. Hence, we use warning instead of error. */ + for (list = OACC_LIST_FIRST; list < OACC_LIST_NUM; list++) + for (n = oacc_clauses->lists[list]; n; n = n->next) + { + if (n->sym->mark) + gfc_warning ("Symbol '%s' present on multiple clauses at %L", + n->sym->name, &code->loc); + else + n->sym->mark = 1; + } + if (oacc_clauses->async) + if (oacc_clauses->async_expr) + resolve_oacc_scalar_int_expr (oacc_clauses->async_expr, "ASYNC"); + if (oacc_clauses->num_gangs_expr) + resolve_oacc_positive_int_expr (oacc_clauses->num_gangs_expr, "NUM_GANGS"); + if (oacc_clauses->num_workers_expr) + resolve_oacc_positive_int_expr (oacc_clauses->num_workers_expr, "NUM_WORKERS"); + if (oacc_clauses->vector_length_expr) + resolve_oacc_positive_int_expr (oacc_clauses->vector_length_expr, "VECTOR_LENGTH"); + if (oacc_clauses->gang_expr) + resolve_oacc_positive_int_expr (oacc_clauses->gang_expr, "GANG"); + if (oacc_clauses->worker_expr) + resolve_oacc_positive_int_expr (oacc_clauses->worker_expr, "WORKER"); + if (oacc_clauses->vector_expr) + resolve_oacc_positive_int_expr (oacc_clauses->vector_expr, "VECTOR"); + if (oacc_clauses->wait) + if (oacc_clauses->waitlist) + for (el = oacc_clauses->waitlist; el; el = el->next) + resolve_oacc_positive_int_expr (el->expr, "WAIT"); + + for (list = OACC_LIST_FIRST; list < OACC_LIST_NUM; list++) + if ((n = oacc_clauses->lists[list]) != NULL) + { + const char *name = oacc_clause_names[list - OACC_LIST_FIRST]; + + if (list > OACC_LIST_DATA_CLAUSE_LAST) + { + if (n->sym->attr.pointer) + gfc_error ("POINTER object '%s' in %s clause at %L", + n->sym->name, name, &code->loc); + if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE) + gfc_error ("Assumed size array '%s' in %s clause at %L", + n->sym->name, name, &code->loc); + } + + if (list == OACC_LIST_DEVICEPTR) + { + if (n->sym->attr.pointer) + gfc_error ("POINTER object '%s' in %s clause at %L", + n->sym->name, name, &code->loc); + if (n->sym->attr.allocatable) + gfc_error ("ALLOCATABLE object '%s' in %s clause at %L", + n->sym->name, name, &code->loc); + if (n->sym->attr.value) + gfc_error ("VALUE object '%s' in %s clause at %L", + n->sym->name, name, &code->loc); + } + + if (list >= OACC_LIST_DATA_CLAUSE_FIRST + && list <= OACC_LIST_DATA_CLAUSE_LAST) + { + if (n->sym->ts.type == BT_DERIVED + && n->sym->attr.allocatable) + gfc_error ("ALLOCATABLE object '%s' of DERIVED type in %s clause at %L", + n->sym->name, name, &code->loc); + if (n->sym->ts.type == BT_DERIVED + && n->sym->attr.pointer) + gfc_error ("POINTER object '%s' of DERIVED type in %s clause at %L", + n->sym->name, name, &code->loc); + } + } } @@ -1727,6 +2397,342 @@ resolve_omp_do (gfc_code *code) } } +typedef struct omp_context oacc_context; +oacc_context *oacc_current_ctx; + +static bool +oacc_is_parallel (gfc_code *code) +{ + return code->op == EXEC_OACC_PARALLEL || code->op == EXEC_OACC_PARALLEL_LOOP; +} + +static bool +oacc_is_kernels (gfc_code *code) +{ + return code->op == EXEC_OACC_KERNELS || code->op == EXEC_OACC_KERNELS_LOOP; +} + +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_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; + } + 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; + } + if (j < i) + 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) + { + 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)) + { + 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) +{ + oacc_context *c; + + if (oacc_is_parallel (code)) + gfc_error ("LOOP %s in PARALLEL section allows no argument or static at %L", + clause, &code->loc); + for (c = oacc_current_ctx; c; c = c->previous) + { + if (oacc_is_loop (c->code)) + break; + if (oacc_is_parallel (c->code)) + gfc_error ("LOOP %s in PARALLEL section allows no argument or static at %L", + clause, &code->loc); + } +} + + +static void +resolve_oacc_loop_blocks (gfc_code *code) +{ + oacc_context *c; + + if (!oacc_is_loop (code)) + return; + + if (code->op == EXEC_OACC_LOOP) + for (c = oacc_current_ctx; c; c = c->previous) + { + if (oacc_is_loop (c->code)) + { + if (code->ext.omp_clauses->gang) + { + if (c->code->ext.omp_clauses->gang) + gfc_error ("Loop parallelized across gangs is not allowed " + "inside another loop parallelized across gangs at %L", + &code->loc); + if (c->code->ext.omp_clauses->worker) + gfc_error ("Loop parallelized across gangs is not allowed " + "inside loop parallelized across workers at %L", + &code->loc); + if (c->code->ext.omp_clauses->vector) + gfc_error ("Loop parallelized across gangs is not allowed " + "inside loop parallelized across workers at %L", + &code->loc); + } + if (code->ext.omp_clauses->worker) + { + if (c->code->ext.omp_clauses->worker) + gfc_error ("Loop parallelized across workers is not allowed " + "inside another loop parallelized across workers at %L", + &code->loc); + if (c->code->ext.omp_clauses->vector) + gfc_error ("Loop parallelized across workers is not allowed " + "inside another loop parallelized across vectors at %L", + &code->loc); + } + if (code->ext.omp_clauses->vector) + if (c->code->ext.omp_clauses->vector) + gfc_error ("Loop parallelized across vectors is not allowed " + "inside another loop parallelized across vectors at %L", + &code->loc); + } + + if (oacc_is_parallel (c->code) || oacc_is_kernels (c->code)) + break; + } + + if (code->ext.omp_clauses->seq) + { + if (code->ext.omp_clauses->independent) + gfc_error ("Both SEQ and INDEPENDENT are not allowed in %L", &code->loc); + if (code->ext.omp_clauses->gang) + gfc_error ("Both SEQ and GANG are not allowed in %L", &code->loc); + if (code->ext.omp_clauses->worker) + gfc_error ("Both SEQ and WORKER are not allowed in %L", &code->loc); + if (code->ext.omp_clauses->vector) + gfc_error ("Both SEQ and VECTOR are not allowed in %L", &code->loc); + if (code->ext.omp_clauses->par_auto) + gfc_error ("Both SEQ and AUTO are not allowed in %L", &code->loc); + } + if (code->ext.omp_clauses->par_auto) + { + if (code->ext.omp_clauses->gang) + gfc_error ("Both AUTO and GANG are not allowed in %L", &code->loc); + if (code->ext.omp_clauses->worker) + gfc_error ("Both AUTO and WORKER are not allowed in %L", &code->loc); + if (code->ext.omp_clauses->vector) + gfc_error ("Both AUTO and VECTOR are not allowed in %L", &code->loc); + } + if (!code->ext.omp_clauses->tilelist) + { + if (code->ext.omp_clauses->gang) + { + if (code->ext.omp_clauses->worker) + gfc_error ("Both GANG and WORKER are not allowed in %L", &code->loc); + if (code->ext.omp_clauses->vector) + gfc_error ("Both GANG and VECTOR are not allowed in %L", &code->loc); + } + if (code->ext.omp_clauses->worker) + if (code->ext.omp_clauses->vector) + gfc_error ("Both WORKER and VECTOR are not allowed in %L", &code->loc); + } + else if (code->ext.omp_clauses->gang + && code->ext.omp_clauses->worker + && code->ext.omp_clauses->vector) + gfc_error ("All GANG, WORKER and VECTOR are not allowed in %L", &code->loc); + + if (code->ext.omp_clauses->gang + && code->ext.omp_clauses->gang_expr + && !code->ext.omp_clauses->gang_static) + resolve_oacc_params_in_parallel (code, "GANG"); + + if (code->ext.omp_clauses->worker + && code->ext.omp_clauses->worker_expr) + resolve_oacc_params_in_parallel (code, "WORKER"); + + if (code->ext.omp_clauses->tilelist) + { + gfc_exprlist *el; + int num = 0; + for (el = code->ext.omp_clauses->tilelist; el; el = el->next) + { + num++; + if (el->expr == NULL) + continue; + resolve_oacc_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) +{ + oacc_context ctx; + + resolve_oacc_loop_blocks (code); + + ctx.code = code; + ctx.previous = oacc_current_ctx; + oacc_current_ctx = &ctx; + + gfc_resolve_blocks (code->block, ns); + + oacc_current_ctx = ctx.previous; +} + + +static void +resolve_oacc_loop(gfc_code *code) +{ + gfc_code *do_code; + int collapse; + int list; + + if (code->ext.omp_clauses) + resolve_omp_clauses (code); + + for (list = OACC_LIST_REDUCTION_FIRST; list <= OACC_LIST_REDUCTION_LAST; list++) + if (code->ext.omp_clauses->lists[list]) + { + bool kernels_region = false; + oacc_context *c; + + if (code->op == EXEC_OACC_KERNELS_LOOP) + kernels_region = true; + if (!kernels_region) + for (c = oacc_current_ctx; c != NULL && !kernels_region; c = c->previous) + if (c->code->op == EXEC_OACC_KERNELS) + kernels_region = true; + + if (kernels_region) + { + gfc_error ("REDUCTION clause is not allowed in KERNELS region at %L", + &code->loc); + break; + } + } + + 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"); +} + + +static void +resolve_oacc_cache (gfc_code *) +{ + //TODO: resolve subarrays +} + + +static void +resolve_oacc_wait (gfc_code *code) +{ + gfc_exprlist* el; + + for (el = code->ext.omp_clauses->waitlist; el; el = el->next) + resolve_oacc_positive_int_expr (el->expr, "WAIT"); +} + + +void +gfc_resolve_oacc_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED) +{ + 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: + resolve_omp_clauses (code); + break; + case EXEC_OACC_PARALLEL_LOOP: + case EXEC_OACC_KERNELS_LOOP: + case EXEC_OACC_LOOP: + resolve_oacc_loop (code); + break; + case EXEC_OACC_CACHE: + resolve_oacc_cache (code); + break; + case EXEC_OACC_WAIT: + resolve_oacc_wait (code); + break; + default: + break; + } +} + /* Resolve OpenMP directive clauses and check various requirements of each directive. */ -- 1.8.3.2