From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from esa3.mentor.iphmx.com (esa3.mentor.iphmx.com [68.232.137.180]) by sourceware.org (Postfix) with ESMTPS id 248B039518B1; Thu, 13 Jan 2022 14:53:34 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org 248B039518B1 Authentication-Results: sourceware.org; dmarc=none (p=none dis=none) header.from=codesourcery.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=mentor.com IronPort-SDR: vPE3/sjiNS5YazNALR6PXOM23++h9y5MhnhuJPQGImcDvFacusYxgaVun7iWnTIElbermJol0L q14aJHAnGe4EiH9t9whtwnk9TFJilad0jw+Y1hg3QF4M1MHXqaYx+UtGvqGzHDuuEzqj0UWL9P pA1AYOsIJTOEttS49SkaFf8T48Ngvy3hl+K9USKyhukb8FNwcg9NHfVTtPePEkrKnDJGK/iIVL nAPprKa7oytTiFFYUMTAAh9CymX2D5vznmELuccNlNTQT+lxqa3mohn8rt48c9oySuNIWXWjF2 Fk+ZicrFWzhewO8WZT+RsLet X-IronPort-AV: E=Sophos;i="5.88,286,1635235200"; d="scan'208";a="70595074" Received: from orw-gwy-01-in.mentorg.com ([192.94.38.165]) by esa3.mentor.iphmx.com with ESMTP; 13 Jan 2022 06:53:33 -0800 IronPort-SDR: vRnE+pfV/kbs+un2VQ543P8bHIJfqIMBp/GO2NZVGr6AuaklB8hZVqF/CX+9xibf3R3gIfSXQD O++GbHFytjKKEoev7/9zukkpMaqhmcr1gIyzsGMvWuPtTW/McIAGeQDoX06zgrHTEUZBggESBC sifF52OLHbYHjNaf/bxefOPzRZBE3RPzFDuW8mulvAsCBfSkwTCGcesdJvZMjIMelgFEITLIOL mMk4AY5XaiQo+DnXtXS+bheuNSo0Vlv9A91uyeTlWyrCS74WMiiNLycg/z6kMacFAvYlR/3UaW kpU= From: Hafiz Abid Qadeer To: , CC: , Subject: [PATCH 1/5] [gfortran] Add parsing support for allocate directive (OpenMP 5.0). Date: Thu, 13 Jan 2022 14:53:16 +0000 Message-ID: <20220113145320.3153087-2-abidh@codesourcery.com> X-Mailer: git-send-email 2.25.1 In-Reply-To: <20220113145320.3153087-1-abidh@codesourcery.com> References: <20220113145320.3153087-1-abidh@codesourcery.com> MIME-Version: 1.0 Content-Transfer-Encoding: 8bit Content-Type: text/plain X-Originating-IP: [137.202.0.90] X-ClientProxiedBy: svr-ies-mbx-01.mgc.mentorg.com (139.181.222.1) To SVR-IES-MBX-03.mgc.mentorg.com (139.181.222.3) X-Spam-Status: No, score=-12.4 required=5.0 tests=BAYES_00, GIT_PATCH_0, HEADER_FROM_DIFFERENT_DOMAINS, KAM_DMARC_STATUS, SPF_HELO_PASS, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.4 X-Spam-Checker-Version: SpamAssassin 3.4.4 (2020-01-24) on server2.sourceware.org X-BeenThere: fortran@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Fortran mailing list List-Unsubscribe: , List-Archive: List-Help: List-Subscribe: , X-List-Received-Date: Thu, 13 Jan 2022 14:53:37 -0000 Currently we only make use of this directive when it is associated with an allocate statement. gcc/fortran/ChangeLog: * dump-parse-tree.c (show_omp_node): Handle EXEC_OMP_ALLOCATE. (show_code_node): Likewise. * gfortran.h (enum gfc_statement): Add ST_OMP_ALLOCATE. (OMP_LIST_ALLOCATOR): New enum value. (enum gfc_exec_op): Add EXEC_OMP_ALLOCATE. * match.h (gfc_match_omp_allocate): New function. * openmp.c (enum omp_mask1): Add OMP_CLAUSE_ALLOCATOR. (OMP_ALLOCATE_CLAUSES): New define. (gfc_match_omp_allocate): New function. (resolve_omp_clauses): Add ALLOCATOR in clause_names. (omp_code_to_statement): Handle EXEC_OMP_ALLOCATE. (EMPTY_VAR_LIST): New define. (check_allocate_directive_restrictions): New function. (gfc_resolve_omp_allocate): Likewise. (gfc_resolve_omp_directive): Handle EXEC_OMP_ALLOCATE. * parse.c (decode_omp_directive): Handle ST_OMP_ALLOCATE. (next_statement): Likewise. (gfc_ascii_statement): Likewise. * resolve.c (gfc_resolve_code): Handle EXEC_OMP_ALLOCATE. * st.c (gfc_free_statement): Likewise. * trans.c (trans_code): Likewise gcc/testsuite/ChangeLog: * gfortran.dg/gomp/allocate-4.f90: New test. * gfortran.dg/gomp/allocate-5.f90: New test. --- gcc/fortran/dump-parse-tree.c | 3 + gcc/fortran/gfortran.h | 4 +- gcc/fortran/match.h | 1 + gcc/fortran/openmp.c | 199 +++++++++++++++++- gcc/fortran/parse.c | 10 +- gcc/fortran/resolve.c | 1 + gcc/fortran/st.c | 1 + gcc/fortran/trans.c | 1 + gcc/testsuite/gfortran.dg/gomp/allocate-4.f90 | 112 ++++++++++ gcc/testsuite/gfortran.dg/gomp/allocate-5.f90 | 73 +++++++ 10 files changed, 400 insertions(+), 5 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/gomp/allocate-4.f90 create mode 100644 gcc/testsuite/gfortran.dg/gomp/allocate-5.f90 diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c index 7459f4b89a9..38fef42150a 100644 --- a/gcc/fortran/dump-parse-tree.c +++ b/gcc/fortran/dump-parse-tree.c @@ -1993,6 +1993,7 @@ show_omp_node (int level, gfc_code *c) case EXEC_OACC_CACHE: name = "CACHE"; is_oacc = true; break; case EXEC_OACC_ENTER_DATA: name = "ENTER DATA"; is_oacc = true; break; case EXEC_OACC_EXIT_DATA: name = "EXIT DATA"; is_oacc = true; break; + case EXEC_OMP_ALLOCATE: name = "ALLOCATE"; break; case EXEC_OMP_ATOMIC: name = "ATOMIC"; break; case EXEC_OMP_BARRIER: name = "BARRIER"; break; case EXEC_OMP_CANCEL: name = "CANCEL"; break; @@ -2194,6 +2195,7 @@ show_omp_node (int level, gfc_code *c) || c->op == EXEC_OMP_TARGET_UPDATE || c->op == EXEC_OMP_TARGET_ENTER_DATA || c->op == EXEC_OMP_TARGET_EXIT_DATA || c->op == EXEC_OMP_SCAN || c->op == EXEC_OMP_DEPOBJ || c->op == EXEC_OMP_ERROR + || c->op == EXEC_OMP_ALLOCATE || (c->op == EXEC_OMP_ORDERED && c->block == NULL)) return; if (c->op == EXEC_OMP_SECTIONS || c->op == EXEC_OMP_PARALLEL_SECTIONS) @@ -3314,6 +3316,7 @@ show_code_node (int level, gfc_code *c) case EXEC_OACC_CACHE: case EXEC_OACC_ENTER_DATA: case EXEC_OACC_EXIT_DATA: + case EXEC_OMP_ALLOCATE: case EXEC_OMP_ATOMIC: case EXEC_OMP_CANCEL: case EXEC_OMP_CANCELLATION_POINT: diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 3b791a4f6be..79a43a2fdf0 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -259,7 +259,7 @@ enum gfc_statement ST_OACC_CACHE, ST_OACC_KERNELS_LOOP, ST_OACC_END_KERNELS_LOOP, ST_OACC_SERIAL_LOOP, ST_OACC_END_SERIAL_LOOP, ST_OACC_SERIAL, ST_OACC_END_SERIAL, ST_OACC_ENTER_DATA, ST_OACC_EXIT_DATA, ST_OACC_ROUTINE, - ST_OACC_ATOMIC, ST_OACC_END_ATOMIC, + ST_OACC_ATOMIC, ST_OACC_END_ATOMIC, ST_OMP_ALLOCATE, ST_OMP_ATOMIC, ST_OMP_BARRIER, ST_OMP_CRITICAL, ST_OMP_END_ATOMIC, ST_OMP_END_CRITICAL, ST_OMP_END_DO, ST_OMP_END_MASTER, ST_OMP_END_ORDERED, ST_OMP_END_PARALLEL, ST_OMP_END_PARALLEL_DO, ST_OMP_END_PARALLEL_SECTIONS, @@ -1392,6 +1392,7 @@ enum OMP_LIST_USE_DEVICE_PTR, OMP_LIST_USE_DEVICE_ADDR, OMP_LIST_NONTEMPORAL, + OMP_LIST_ALLOCATOR, OMP_LIST_NUM }; @@ -2893,6 +2894,7 @@ enum gfc_exec_op EXEC_OACC_DATA, EXEC_OACC_HOST_DATA, EXEC_OACC_LOOP, EXEC_OACC_UPDATE, EXEC_OACC_WAIT, EXEC_OACC_CACHE, EXEC_OACC_ENTER_DATA, EXEC_OACC_EXIT_DATA, EXEC_OACC_ATOMIC, EXEC_OACC_DECLARE, + EXEC_OMP_ALLOCATE, EXEC_OMP_CRITICAL, EXEC_OMP_DO, EXEC_OMP_FLUSH, EXEC_OMP_MASTER, EXEC_OMP_ORDERED, EXEC_OMP_PARALLEL, EXEC_OMP_PARALLEL_DO, EXEC_OMP_PARALLEL_SECTIONS, EXEC_OMP_PARALLEL_WORKSHARE, diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h index 65ee3b6cb41..9f0449eda0e 100644 --- a/gcc/fortran/match.h +++ b/gcc/fortran/match.h @@ -149,6 +149,7 @@ match gfc_match_oacc_routine (void); /* OpenMP directive matchers. */ match gfc_match_omp_eos_error (void); +match gfc_match_omp_allocate (void); match gfc_match_omp_atomic (void); match gfc_match_omp_barrier (void); match gfc_match_omp_cancel (void); diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c index 86c412a4334..ee7c39980bb 100644 --- a/gcc/fortran/openmp.c +++ b/gcc/fortran/openmp.c @@ -921,6 +921,7 @@ enum omp_mask1 OMP_CLAUSE_FAIL, /* OpenMP 5.1. */ OMP_CLAUSE_WEAK, /* OpenMP 5.1. */ OMP_CLAUSE_NOWAIT, + OMP_CLAUSE_ALLOCATOR, /* This must come last. */ OMP_MASK1_LAST }; @@ -3568,6 +3569,7 @@ cleanup: } +#define OMP_ALLOCATE_CLAUSES (omp_mask (OMP_CLAUSE_ALLOCATOR)) #define OMP_PARALLEL_CLAUSES \ (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \ | OMP_CLAUSE_SHARED | OMP_CLAUSE_COPYIN | OMP_CLAUSE_REDUCTION \ @@ -5762,6 +5764,64 @@ gfc_match_omp_ordered_depend (void) return match_omp (EXEC_OMP_ORDERED, omp_mask (OMP_CLAUSE_DEPEND)); } +/* omp allocate (list) [clause-list] + - clause-list: allocator +*/ + +match +gfc_match_omp_allocate (void) +{ + gfc_omp_clauses *c = gfc_get_omp_clauses (); + gfc_expr *allocator = NULL; + match m; + + m = gfc_match (" ("); + if (m == MATCH_YES) + { + m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_ALLOCATOR], + true, NULL); + + if (m != MATCH_YES) + { + /* If the list was empty, we must find closing ')'. */ + m = gfc_match (")"); + if (m != MATCH_YES) + return m; + } + } + + if (gfc_match (" allocator ( ") == MATCH_YES) + { + m = gfc_match_expr (&allocator); + if (m != MATCH_YES) + { + gfc_error ("Expected allocator at %C"); + return MATCH_ERROR; + } + if (gfc_match (" ) ") != MATCH_YES) + { + gfc_error ("Expected ')' at %C"); + gfc_free_expr (allocator); + return MATCH_ERROR; + } + } + + if (gfc_match_omp_eos () != MATCH_YES) + { + gfc_free_expr (allocator); + gfc_error ("Unexpected junk after $OMP allocate at %C"); + return MATCH_ERROR; + } + gfc_omp_namelist *n; + for (n = c->lists[OMP_LIST_ALLOCATOR]; n; n = n->next) + n->expr = gfc_copy_expr (allocator); + + new_st.op = EXEC_OMP_ALLOCATE; + new_st.ext.omp_clauses = c; + gfc_free_expr (allocator); + return MATCH_YES; +} + /* omp atomic [clause-list] - atomic-clause: read | write | update @@ -6243,7 +6303,7 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, "IN_REDUCTION", "TASK_REDUCTION", "DEVICE_RESIDENT", "LINK", "USE_DEVICE", "CACHE", "IS_DEVICE_PTR", "USE_DEVICE_PTR", "USE_DEVICE_ADDR", - "NONTEMPORAL" }; + "NONTEMPORAL", "ALLOCATOR" }; STATIC_ASSERT (ARRAY_SIZE (clause_names) == OMP_LIST_NUM); if (omp_clauses == NULL) @@ -8507,6 +8567,8 @@ omp_code_to_statement (gfc_code *code) { switch (code->op) { + case EXEC_OMP_ALLOCATE: + return ST_OMP_ALLOCATE; case EXEC_OMP_PARALLEL: return ST_OMP_PARALLEL; case EXEC_OMP_PARALLEL_MASKED: @@ -8987,6 +9049,138 @@ gfc_resolve_oacc_routines (gfc_namespace *ns) } } +static void +check_allocate_directive_restrictions (gfc_symbol *sym, gfc_expr *omp_al, + gfc_namespace *ns, locus loc) +{ + if (sym->attr.save != SAVE_NONE || sym->attr.in_common == 1 + || sym->module != NULL) + { + int tmp; + /* Assumption here is that we can extract an integer then + it is a predefined thing. */ + if (!omp_al || gfc_extract_int (omp_al, &tmp)) + gfc_error ("%qs should use predefined allocator at %L", sym->name, + &loc); + } + if (ns != sym->ns) + gfc_error ("%qs is not in the same scope as %" + " directive at %L", sym->name, &loc); +} + +#define EMPTY_VAR_LIST(node) \ + (node->ext.omp_clauses->lists[OMP_LIST_ALLOCATOR] == NULL) + +static void +gfc_resolve_omp_allocate (gfc_code *code, gfc_namespace *ns) +{ + gfc_alloc *al; + gfc_omp_namelist *n = NULL; + gfc_omp_namelist *cn = NULL; + gfc_omp_namelist *p, *tail; + gfc_code *cur; + hash_set vars; + + gfc_omp_clauses *clauses = code->ext.omp_clauses; + gcc_assert (clauses); + cn = clauses->lists[OMP_LIST_ALLOCATOR]; + gfc_expr *omp_al = cn ? cn->expr : NULL; + + if (omp_al && (omp_al->ts.type != BT_INTEGER + || omp_al->ts.kind != gfc_c_intptr_kind)) + gfc_error ("Expected integer expression of the " + "% kind at %L", &omp_al->where); + + /* Check that variables in this allocate directive are not duplicated + in this directive or others coming directly after it. */ + for (cur = code; cur != NULL && cur->op == EXEC_OMP_ALLOCATE; + cur = cur->next) + { + gfc_omp_clauses *c = cur->ext.omp_clauses; + gcc_assert (c); + for (n = c->lists[OMP_LIST_ALLOCATOR]; n; n = n->next) + { + if (vars.contains (n->sym)) + gfc_error ("%qs is used in multiple % " + "directives at %L", n->sym->name, &cur->loc); + /* This helps us avoid duplicate error messages. */ + if (cur == code) + vars.add (n->sym); + } + } + + if (cur == NULL || cur->op != EXEC_ALLOCATE) + { + /* There is no allocate statement right after allocate directive. + We don't support this case at the moment. */ + for (n = cn; n != NULL; n = n->next) + { + gfc_symbol *sym = n->sym; + if (sym->attr.allocatable == 1) + gfc_error ("%qs with ALLOCATABLE attribute is not allowed in " + "% directive at %L as this directive is not" + " associated with an % statement.", + sym->name, &code->loc); + } + sorry_at (code->loc.lb->location, "% directive that is " + "not associated with an % statement is not " + "supported."); + return; + } + + /* If there is another allocate directive right after this one, check + that none of them is empty. Doing it this way, we can check this + thing even when multiple directives are together and generate + error at right location. */ + if (code->next && code->next->op == EXEC_OMP_ALLOCATE + && (EMPTY_VAR_LIST (code) || EMPTY_VAR_LIST (code->next))) + gfc_error ("Empty variable list is not allowed at %L when multiple " + "% directives are associated with an " + "% statement.", + EMPTY_VAR_LIST (code) ? &code->loc : &code->next->loc); + + if (EMPTY_VAR_LIST (code)) + { + /* Empty namelist means allocate directive applies to all + variables in allocate statement. 'cur' points to associated + allocate statement. */ + for (al = cur->ext.alloc.list; al != NULL; al = al->next) + if (al->expr && al->expr->symtree && al->expr->symtree->n.sym) + { + check_allocate_directive_restrictions (al->expr->symtree->n.sym, + omp_al, ns, code->loc); + p = gfc_get_omp_namelist (); + p->sym = al->expr->symtree->n.sym; + p->expr = omp_al; + p->where = code->loc; + if (cn == NULL) + cn = tail = p; + else + { + tail->next = p; + tail = tail->next; + } + } + clauses->lists[OMP_LIST_ALLOCATOR]= cn; + } + else + { + for (n = cn; n != NULL; n = n->next) + { + for (al = cur->ext.alloc.list; al != NULL; al = al->next) + if (al->expr && al->expr->symtree && al->expr->symtree->n.sym + && al->expr->symtree->n.sym == n->sym) + break; + if (al == NULL) + gfc_error ("%qs in % directive at %L is not present " + "in associated % statement.", + n->sym->name, &code->loc); + check_allocate_directive_restrictions (n->sym, omp_al, ns, + code->loc); + } + } +} + void gfc_resolve_oacc_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED) @@ -9128,6 +9322,9 @@ gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns) code->ext.omp_clauses->if_present = false; resolve_omp_clauses (code, code->ext.omp_clauses, ns); break; + case EXEC_OMP_ALLOCATE: + gfc_resolve_omp_allocate (code, ns); + break; default: break; } diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index c04ad774f25..fda36433129 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -886,6 +886,7 @@ decode_omp_directive (void) { case 'a': matcho ("atomic", gfc_match_omp_atomic, ST_OMP_ATOMIC); + matcho ("allocate", gfc_match_omp_allocate, ST_OMP_ALLOCATE); break; case 'b': matcho ("barrier", gfc_match_omp_barrier, ST_OMP_BARRIER); @@ -1672,9 +1673,9 @@ next_statement (void) case ST_OMP_CANCEL: case ST_OMP_CANCELLATION_POINT: case ST_OMP_DEPOBJ: \ case ST_OMP_TARGET_UPDATE: case ST_OMP_TARGET_ENTER_DATA: \ case ST_OMP_TARGET_EXIT_DATA: case ST_OMP_ORDERED_DEPEND: case ST_OMP_ERROR: \ - case ST_ERROR_STOP: case ST_OMP_SCAN: case ST_SYNC_ALL: \ - case ST_SYNC_IMAGES: case ST_SYNC_MEMORY: case ST_LOCK: case ST_UNLOCK: \ - case ST_FORM_TEAM: case ST_CHANGE_TEAM: \ + case ST_OMP_ALLOCATE: case ST_ERROR_STOP: case ST_OMP_SCAN: \ + case ST_SYNC_ALL: case ST_SYNC_IMAGES: case ST_SYNC_MEMORY: case ST_LOCK: \ + case ST_UNLOCK: case ST_FORM_TEAM: case ST_CHANGE_TEAM: \ case ST_END_TEAM: case ST_SYNC_TEAM: \ case ST_EVENT_POST: case ST_EVENT_WAIT: case ST_FAIL_IMAGE: \ case ST_OACC_UPDATE: case ST_OACC_WAIT: case ST_OACC_CACHE: \ @@ -2351,6 +2352,9 @@ gfc_ascii_statement (gfc_statement st) case ST_OACC_END_ATOMIC: p = "!$ACC END ATOMIC"; break; + case ST_OMP_ALLOCATE: + p = "!$OMP ALLOCATE"; + break; case ST_OMP_ATOMIC: p = "!$OMP ATOMIC"; break; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 43eeefee07f..991cd4fe874 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -12306,6 +12306,7 @@ start: gfc_resolve_oacc_directive (code, ns); break; + case EXEC_OMP_ALLOCATE: case EXEC_OMP_ATOMIC: case EXEC_OMP_BARRIER: case EXEC_OMP_CANCEL: diff --git a/gcc/fortran/st.c b/gcc/fortran/st.c index 73f30c2137f..7b282e96c3d 100644 --- a/gcc/fortran/st.c +++ b/gcc/fortran/st.c @@ -214,6 +214,7 @@ gfc_free_statement (gfc_code *p) case EXEC_OACC_ENTER_DATA: case EXEC_OACC_EXIT_DATA: case EXEC_OACC_ROUTINE: + case EXEC_OMP_ALLOCATE: case EXEC_OMP_ATOMIC: case EXEC_OMP_CANCEL: case EXEC_OMP_CANCELLATION_POINT: diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index 26f0815b5ea..a2248c83623 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -2140,6 +2140,7 @@ trans_code (gfc_code * code, tree cond) res = gfc_trans_dt_end (code); break; + case EXEC_OMP_ALLOCATE: case EXEC_OMP_ATOMIC: case EXEC_OMP_BARRIER: case EXEC_OMP_CANCEL: diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-4.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-4.f90 new file mode 100644 index 00000000000..3f512d66495 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/allocate-4.f90 @@ -0,0 +1,112 @@ +! { dg-do compile } + +module test + integer, allocatable :: mvar1 + integer, allocatable :: mvar2 + integer, allocatable :: mvar3 +end module + +subroutine foo(x, y) + use omp_lib + implicit none + integer :: x + integer :: y + + integer, allocatable :: var1(:) + integer, allocatable :: var2(:) + integer, allocatable :: var3(:) + integer, allocatable :: var4(:) + integer, allocatable :: var5(:) + integer, allocatable :: var6(:) + integer, allocatable :: var7(:) + integer, allocatable :: var8(:) + integer, allocatable :: var9(:) + + !$omp allocate (var1) allocator(10) ! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind at .1." } + allocate (var1(x)) + + !$omp allocate (var2) ! { dg-error "'var2' in 'allocate' directive at .1. is not present in associated 'allocate' statement." } + allocate (var3(x)) + + !$omp allocate (x) ! { dg-message "sorry, unimplemented: 'allocate' directive that is not associated with an 'allocate' statement is not supported." } + x = 2 + + !$omp allocate (var4) ! { dg-error "'var4' with ALLOCATABLE attribute is not allowed in 'allocate' directive at .1. as this directive is not associated with an 'allocate' statement." } + ! { dg-message "sorry, unimplemented: 'allocate' directive that is not associated with an 'allocate' statement is not supported." "" { target *-*-* } .-1 } + y = 2 + + !$omp allocate (var5) + !$omp allocate ! { dg-error "Empty variable list is not allowed at .1. when multiple 'allocate' directives are associated with an 'allocate' statement." } + allocate (var5(x)) + + !$omp allocate (var6) + !$omp allocate (var7) ! { dg-error "'var7' in 'allocate' directive at .1. is not present in associated 'allocate' statement." } + !$omp allocate (var8) ! { dg-error "'var8' in 'allocate' directive at .1. is not present in associated 'allocate' statement." } + allocate (var6(x)) + + !$omp allocate (var9) + !$omp allocate (var9) ! { dg-error "'var9' is used in multiple 'allocate' directives at .1." } + allocate (var9(x)) + +end subroutine + +function outer(a) + IMPLICIT NONE + + integer :: outer, a + integer, allocatable :: var1 + + outer = inner(a) + 5 + return + + contains + + integer function inner(x) + integer :: x + integer, allocatable :: var2 + + !$omp allocate (var1, var2) ! { dg-error "'var1' is not in the same scope as 'allocate' directive at .1." } + allocate (var1, var2) + + inner = x + 10 + return + end function inner + +end function outer + +subroutine bar(s) + use omp_lib + use test + integer :: s + integer, save, allocatable :: svar1 + integer, save, allocatable :: svar2 + integer, save, allocatable :: svar3 + + type (omp_alloctrait) :: traits(3) + integer (omp_allocator_handle_kind) :: a + + traits = [omp_alloctrait (omp_atk_alignment, 64), & + omp_alloctrait (omp_atk_fallback, omp_atv_null_fb), & + omp_alloctrait (omp_atk_pool_size, 8192)] + a = omp_init_allocator (omp_default_mem_space, 3, traits) + if (a == omp_null_allocator) stop 1 + + !$omp allocate (mvar1) allocator(a) ! { dg-error "'mvar1' should use predefined allocator at .1." } + allocate (mvar1) + + !$omp allocate (mvar2) ! { dg-error "'mvar2' should use predefined allocator at .1." } + allocate (mvar2) + + !$omp allocate (mvar3) allocator(omp_low_lat_mem_alloc) + allocate (mvar3) + + !$omp allocate (svar1) allocator(a) ! { dg-error "'svar1' should use predefined allocator at .1." } + allocate (svar1) + + !$omp allocate (svar2) ! { dg-error "'svar2' should use predefined allocator at .1." } + allocate (svar2) + + !$omp allocate (svar3) allocator(omp_low_lat_mem_alloc) + allocate (svar3) +end subroutine + diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-5.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-5.f90 new file mode 100644 index 00000000000..761b6dede28 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/allocate-5.f90 @@ -0,0 +1,73 @@ +! { dg-do compile } + +module omp_lib_kinds + use iso_c_binding, only: c_int, c_intptr_t + implicit none + private :: c_int, c_intptr_t + integer, parameter :: omp_allocator_handle_kind = c_intptr_t + + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_null_allocator = 0 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_default_mem_alloc = 1 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_large_cap_mem_alloc = 2 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_const_mem_alloc = 3 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_high_bw_mem_alloc = 4 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_low_lat_mem_alloc = 5 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_cgroup_mem_alloc = 6 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_pteam_mem_alloc = 7 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_thread_mem_alloc = 8 +end module + +subroutine foo(x, y) + use omp_lib_kinds + implicit none + integer :: x + integer :: y + + integer, allocatable :: var1(:) + integer, allocatable :: var2(:) + integer, allocatable :: var3(:) + integer, allocatable :: var4(:,:) + integer, allocatable :: var5(:) + integer, allocatable :: var6(:) + integer, allocatable :: var7(:) + integer, allocatable :: var8(:) + integer, allocatable :: var9(:) + integer, allocatable :: var10(:) + integer, allocatable :: var11(:) + integer, allocatable :: var12(:) + + !$omp allocate (var1) allocator(omp_default_mem_alloc) + allocate (var1(x)) + + !$omp allocate (var2) + allocate (var2(x)) + + !$omp allocate (var3, var4) allocator(omp_large_cap_mem_alloc) + allocate (var3(x),var4(x,y)) + + !$omp allocate() + allocate (var5(x)) + + !$omp allocate + allocate (var6(x)) + + !$omp allocate () allocator(omp_default_mem_alloc) + allocate (var7(x)) + + !$omp allocate allocator(omp_default_mem_alloc) + allocate (var8(x)) + + !$omp allocate (var9) allocator(omp_default_mem_alloc) + !$omp allocate (var10) allocator(omp_large_cap_mem_alloc) + allocate (var9(x), var10(x)) + +end subroutine -- 2.25.1