From patchwork Tue Oct 10 16:46:35 2023 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 1845977 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=2620:52:3:1:0:246e:9693:128c; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.sourceware.org (server2.sourceware.org [IPv6:2620:52:3:1:0:246e:9693:128c]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4S4hdb5v2qz1ypX for ; Wed, 11 Oct 2023 03:47:14 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 836CD38582A1 for ; Tue, 10 Oct 2023 16:47:07 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from esa4.mentor.iphmx.com (esa4.mentor.iphmx.com [68.232.137.252]) by sourceware.org (Postfix) with ESMTPS id 0BD3D3858D28; Tue, 10 Oct 2023 16:46:43 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 0BD3D3858D28 Authentication-Results: sourceware.org; dmarc=none (p=none dis=none) header.from=codesourcery.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=mentor.com X-CSE-ConnectionGUID: R5XTLGVNQ8WH9uuh6Zs/1w== X-CSE-MsgGUID: S8Fy4VVYQXuH1lGm5IYzfQ== X-IronPort-AV: E=Sophos;i="6.03,213,1694764800"; d="diff'?scan'208";a="19042986" Received: from orw-gwy-01-in.mentorg.com ([192.94.38.165]) by esa4.mentor.iphmx.com with ESMTP; 10 Oct 2023 08:46:41 -0800 IronPort-SDR: DSeH/ayu+U5C5K9Shpcy9bCuJdcqUcVq91DWGmHLgWm7rj0deG7k1MkN2/8nWkFhRIZ4l8NjSt HeJ5ItCH6JuHLmsVnOtOu+Ii8M70geMvcm1AWAwJnPwT6uNr4dvqkB8fKKaLM7aPw7916s7c6v orX/OC+M4Maz7CXqtXB16DVdGwl7auyIxPN8KQJmBjSIs6ui1tvbLDSnayj1OxsZp5NBkeA+oW 4Zn/ftrd08bnfpoxc1qvyrx9KlivjwAuAdNRGHezSk+ubCVl9CQ/t2BpozeTuaofcfzTc789z2 OKA= Message-ID: <457ea120-5cca-48e0-89d6-c3eab4234b61@codesourcery.com> Date: Tue, 10 Oct 2023 18:46:35 +0200 MIME-Version: 1.0 User-Agent: Mozilla Thunderbird Content-Language: en-US To: gcc-patches , fortran , Jakub Jelinek From: Tobias Burnus Subject: [Patch] Fortran: Support OpenMP's 'allocate' directive for stack vars X-Originating-IP: [137.202.0.90] X-ClientProxiedBy: svr-ies-mbx-10.mgc.mentorg.com (139.181.222.10) To svr-ies-mbx-12.mgc.mentorg.com (139.181.222.12) X-Spam-Status: No, score=-10.1 required=5.0 tests=BAYES_00, GIT_PATCH_0, HEADER_FROM_DIFFERENT_DOMAINS, KAM_DMARC_STATUS, SCC_5_SHORT_WORD_LINES, SPF_HELO_PASS, SPF_PASS, TXREP, URIBL_BLACK autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.30 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org The attached patch adds 'omp allocate' support for stack/automatic variables variables for Fortran. I had originally a pure FE version for Fortran, which failed with 'defaultmap'/'default'; I then thought I could simply piggyback on the existing C/C++ support. But it turns out that Fortran is completely different, e.g. there is often no BIND_EXPR but just some (scoped / try-final-expr) code inside of it, i.e. the scope of the BIND_EXPR has no relation to where GOMP_alloc has to be added. (GOMP_free is less critical, except that a longer lifetime might cause memory constraints.) Thus, RFC: - Is the current scheme okay or should me move moved to the FE there is not that much happening at the ME? - Should for the one 'if (lang_GNU_Fortran () ...' condition a lang hook be introduced? Any other suggestions? ALSO: I decided that the wording permits 'type(c_ptr)', 'type(c_funptr)' as they are rather normal variables (of opaque type) in the Fortran sense. I decided that we do not want to support EQUIVALENCE, Cray pointers, COMMON blocks ever (even though the first to surely could be made to work, the latter - maybe.) I also reject coarrays as it is really incompatible for allocate/allocators; for the 'allocate' clause, that's different and permitted (just used for privatization). Thoughts, suggestions? Tobias ----------------- Siemens Electronic Design Automation GmbH; Anschrift: Arnulfstraße 201, 80634 München; Gesellschaft mit beschränkter Haftung; Geschäftsführer: Thomas Heurung, Frank Thürauf; Sitz der Gesellschaft: München; Registergericht München, HRB 106955 Fortran: Support OpenMP's 'allocate' directive for stack vars gcc/fortran/ChangeLog: * gfortran.h (ext_attr_t): Add omp_allocate flag. * match.cc (gfc_free_omp_namelist): Void deleting same u2.allocator multiple times now that a sequence can use the same one. * openmp.cc (gfc_match_omp_clauses, gfc_match_omp_allocate): Use same allocator expr multiple times. (is_predefined_allocator): Make static. (gfc_resolve_omp_allocate): Update/extend restriction checks; remove sorry message. (resolve_omp_clauses): Reject corarrays in allocate/allocators directive. * parse.cc (check_omp_allocate_stmt): Permit procedure pointers here (rejected later) for less mislreading diagnostic. * trans-array.cc (gfc_trans_auto_array_allocation): Propagate size for GOMP_alloc and location to which it should be added to. * trans-decl.cc (gfc_trans_deferred_vars): Handle 'omp allocate' for stack variables; sorry for static variables/common blocks. * trans-openmp.cc (gfc_trans_omp_clauses): Evaluate 'allocate' clause's allocator only once; fix adding expressions to the block. (gfc_trans_omp_single): Pass a block to gfc_trans_omp_clauses. gcc/ChangeLog: * gimplify.cc (gimplify_bind_expr): Handle Fortran's 'omp allocate' for stack variables. libgomp/ChangeLog: * libgomp.texi: * testsuite/libgomp.fortran/allocate-5.f90: New test. * testsuite/libgomp.fortran/allocate-6.f90: New test. * testsuite/libgomp.fortran/allocate-7.f90: New test. * testsuite/libgomp.fortran/allocate-8.f90: New test. gcc/testsuite/ChangeLog: * c-c++-common/gomp/allocate-14.c: Fix directive name. * c-c++-common/gomp/allocate-15.c: Likewise. * c-c++-common/gomp/allocate-9.c: Fix comment typo. * gfortran.dg/gomp/allocate-4.f90: Remove sorry dg-error. * gfortran.dg/gomp/allocate-7.f90: Likewise. * gfortran.dg/gomp/allocate-10.f90: New test. * gfortran.dg/gomp/allocate-11.f90: New test. * gfortran.dg/gomp/allocate-12.f90: New test. * gfortran.dg/gomp/allocate-13.f90: New test. * gfortran.dg/gomp/allocate-14.f90: New test. * gfortran.dg/gomp/allocate-15.f90: New test. * gfortran.dg/gomp/allocate-8.f90: New test. * gfortran.dg/gomp/allocate-9.f90: New test. gcc/fortran/gfortran.h | 1 + gcc/fortran/match.cc | 9 +- gcc/fortran/openmp.cc | 62 +++- gcc/fortran/parse.cc | 8 +- gcc/fortran/trans-array.cc | 28 +- gcc/fortran/trans-decl.cc | 121 ++++++++ gcc/fortran/trans-openmp.cc | 77 +++-- gcc/gimplify.cc | 173 +++++++++--- gcc/testsuite/c-c++-common/gomp/allocate-14.c | 2 +- gcc/testsuite/c-c++-common/gomp/allocate-15.c | 2 +- gcc/testsuite/c-c++-common/gomp/allocate-9.c | 2 +- gcc/testsuite/gfortran.dg/gomp/allocate-10.f90 | 74 +++++ gcc/testsuite/gfortran.dg/gomp/allocate-11.f90 | 33 +++ gcc/testsuite/gfortran.dg/gomp/allocate-12.f90 | 24 ++ gcc/testsuite/gfortran.dg/gomp/allocate-13.f90 | 25 ++ gcc/testsuite/gfortran.dg/gomp/allocate-14.f90 | 95 +++++++ gcc/testsuite/gfortran.dg/gomp/allocate-15.f90 | 38 +++ gcc/testsuite/gfortran.dg/gomp/allocate-4.f90 | 4 +- gcc/testsuite/gfortran.dg/gomp/allocate-7.f90 | 10 - gcc/testsuite/gfortran.dg/gomp/allocate-8.f90 | 29 ++ gcc/testsuite/gfortran.dg/gomp/allocate-9.f90 | 112 ++++++++ libgomp/libgomp.texi | 4 +- libgomp/testsuite/libgomp.fortran/allocate-5.f90 | 87 ++++++ libgomp/testsuite/libgomp.fortran/allocate-6.f90 | 123 ++++++++ libgomp/testsuite/libgomp.fortran/allocate-7.f90 | 342 +++++++++++++++++++++++ libgomp/testsuite/libgomp.fortran/allocate-8.f90 | 99 +++++++ 26 files changed, 1480 insertions(+), 104 deletions(-) diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 6caf7765ac6..88f33b0957e 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -1000,6 +1000,7 @@ typedef struct unsigned omp_declare_target:1; unsigned omp_declare_target_link:1; ENUM_BITFIELD (gfc_omp_device_type) omp_device_type:2; + unsigned omp_allocate:1; /* Mentioned in OACC DECLARE. */ unsigned oacc_declare_create:1; diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc index c926f38058f..148a86bb436 100644 --- a/gcc/fortran/match.cc +++ b/gcc/fortran/match.cc @@ -5541,6 +5541,7 @@ gfc_free_omp_namelist (gfc_omp_namelist *name, bool free_ns, bool free_mem_traits_space) { gfc_omp_namelist *n; + gfc_expr *last_allocator = NULL; for (; name; name = n) { @@ -5552,7 +5553,13 @@ gfc_free_omp_namelist (gfc_omp_namelist *name, bool free_ns, if (free_ns) gfc_free_namespace (name->u2.ns); else if (free_align_allocator) - gfc_free_expr (name->u2.allocator); + { + if (last_allocator != name->u2.allocator) + { + last_allocator = name->u2.allocator; + gfc_free_expr (name->u2.allocator); + } + } else if (free_mem_traits_space) { } /* name->u2.traits_sym: shall not call gfc_free_symbol here. */ else if (name->u2.udr) diff --git a/gcc/fortran/openmp.cc b/gcc/fortran/openmp.cc index 79b5ae0e4bd..ca6dce91f65 100644 --- a/gcc/fortran/openmp.cc +++ b/gcc/fortran/openmp.cc @@ -2032,11 +2032,9 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, for (gfc_omp_namelist *n = *head; n; n = n->next) { - n->u2.allocator = ((allocator) - ? gfc_copy_expr (allocator) : NULL); + n->u2.allocator = allocator; n->u.align = (align) ? gfc_copy_expr (align) : NULL; } - gfc_free_expr (allocator); gfc_free_expr (align); continue; } @@ -4547,9 +4545,8 @@ gfc_match_omp_allocate (void) for (; vars; vars = vars->next) { vars->u.align = (align) ? gfc_copy_expr (align) : NULL; - vars->u2.allocator = ((allocator) ? gfc_copy_expr (allocator) : NULL); + vars->u2.allocator = allocator; } - gfc_free_expr (allocator); gfc_free_expr (align); } return MATCH_YES; @@ -7191,7 +7188,7 @@ resolve_omp_udr_clause (gfc_omp_namelist *n, gfc_namespace *ns, /* Assume that a constant expression in the range 1 (omp_default_mem_alloc) to 8 (omp_thread_mem_alloc) range is fine. The original symbol name is already lost during matching via gfc_match_expr. */ -bool +static bool is_predefined_allocator (gfc_expr *expr) { return (gfc_resolve_expr (expr) @@ -7209,10 +7206,20 @@ is_predefined_allocator (gfc_expr *expr) void gfc_resolve_omp_allocate (gfc_namespace *ns, gfc_omp_namelist *list) { - for (gfc_omp_namelist *n = list; n; n = n->next) - n->sym->mark = 0; for (gfc_omp_namelist *n = list; n; n = n->next) { + if (n->sym->attr.result || n->sym->result == n->sym) + { + gfc_error ("Unexpected function-result variable %qs at %L in " + "declarative !$OMP ALLOCATE", n->sym->name, &n->where); + continue; + } + if (ns->omp_allocate->sym->attr.proc_pointer) + { + gfc_error ("Procedure pointer %qs not supported with !$OMP " + "ALLOCATE at %L", n->sym->name, &n->where); + continue; + } if (n->sym->attr.flavor != FL_VARIABLE) { gfc_error ("Argument %qs at %L to declarative !$OMP ALLOCATE " @@ -7220,8 +7227,7 @@ gfc_resolve_omp_allocate (gfc_namespace *ns, gfc_omp_namelist *list) &n->where); continue; } - if (ns != n->sym->ns || n->sym->attr.use_assoc - || n->sym->attr.host_assoc || n->sym->attr.imported) + if (ns != n->sym->ns || n->sym->attr.use_assoc || n->sym->attr.imported) { gfc_error ("Argument %qs at %L to declarative !$OMP ALLOCATE shall be" " in the same scope as the variable declaration", @@ -7234,7 +7240,13 @@ gfc_resolve_omp_allocate (gfc_namespace *ns, gfc_omp_namelist *list) "declarative !$OMP ALLOCATE", n->sym->name, &n->where); continue; } - if (n->sym->mark) + if (n->sym->attr.codimension) + { + gfc_error ("Unexpected coarray argument %qs as argument at %L to " + "declarative !$OMP ALLOCATE", n->sym->name, &n->where); + continue; + } + if (n->sym->attr.omp_allocate) { if (n->sym->attr.in_common) { @@ -7249,7 +7261,28 @@ gfc_resolve_omp_allocate (gfc_namespace *ns, gfc_omp_namelist *list) n->sym->name, &n->where); continue; } - n->sym->mark = 1; + /* For 'equivalence(a,b)', a 'union_type { a,b} equiv.0' is created + with a value expression for 'a' as 'equiv.0.a' (likewise for b); while + this can be handled, EQUIVALENCE is marked as obsolescent since Fortran + 2018 and also not widely used. However, it could be supported, + if needed. */ + if (n->sym->attr.in_equivalence) + { + gfc_error ("Sorry, EQUIVALENCE object %qs not supported with !$OMP " + "ALLOCATE at %L", n->sym->name, &n->where); + continue; + } + /* Similar for Cray pointer/pointee - they could be implemented but as + common vendor extension but nowadays rarely used and requiring + -fcray-pointer, there is no need to support them. */ + if (n->sym->attr.cray_pointer || n->sym->attr.cray_pointee) + { + gfc_error ("Sorry, Cray pointers and pointees such as %qs are not " + "supported with !$OMP ALLOCATE at %L", + n->sym->name, &n->where); + continue; + } + n->sym->attr.omp_allocate = 1; if ((n->sym->ts.type == BT_CLASS && n->sym->attr.class_ok && CLASS_DATA (n->sym)->attr.allocatable) || (n->sym->ts.type != BT_CLASS && n->sym->attr.allocatable)) @@ -7307,8 +7340,6 @@ gfc_resolve_omp_allocate (gfc_namespace *ns, gfc_omp_namelist *list) "% kind at %L", &n->u2.allocator->where); } - gfc_error ("Sorry, declarative !$OMP ALLOCATE at %L not yet supported", - &list->where); } /* Resolve ASSUME's and ASSUMES' assumption clauses. Note that absent/contains @@ -7897,6 +7928,9 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, { if (n->sym == NULL) continue; + if (n->sym->attr.codimension) + gfc_error ("Unexpected coarray %qs in % at %L", + n->sym->name, &n->where); for (a = code->block->next->ext.alloc.list; a; a = a->next) if (a->expr->expr_type == EXPR_VARIABLE && a->expr->symtree->n.sym == n->sym) diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc index 444baf42cbd..e103ebee557 100644 --- a/gcc/fortran/parse.cc +++ b/gcc/fortran/parse.cc @@ -833,18 +833,18 @@ check_omp_allocate_stmt (locus *loc) &n->expr->where, gfc_ascii_statement (ST_OMP_ALLOCATE)); return false; } + /* Procedure pointers are not allocatable; hence, we do not regard them as + pointers here - and reject them later in gfc_resolve_omp_allocate. */ bool alloc_ptr; if (n->sym->ts.type == BT_CLASS && n->sym->attr.class_ok) alloc_ptr = (CLASS_DATA (n->sym)->attr.allocatable || CLASS_DATA (n->sym)->attr.class_pointer); else - alloc_ptr = (n->sym->attr.allocatable || n->sym->attr.pointer - || n->sym->attr.proc_pointer); + alloc_ptr = n->sym->attr.allocatable || n->sym->attr.pointer; if (alloc_ptr || (n->sym->ns && n->sym->ns->proc_name && (n->sym->ns->proc_name->attr.allocatable - || n->sym->ns->proc_name->attr.pointer - || n->sym->ns->proc_name->attr.proc_pointer))) + || n->sym->ns->proc_name->attr.pointer))) has_allocatable = true; else has_non_allocatable = true; diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index 8e94a9a469f..bbb81f40aa9 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -82,6 +82,9 @@ along with GCC; see the file COPYING3. If not see #include "tree.h" #include "gfortran.h" #include "gimple-expr.h" +#include "tree-iterator.h" +#include "stringpool.h" /* Required by "attribs.h". */ +#include "attribs.h" /* For lookup_attribute. */ #include "trans.h" #include "fold-const.h" #include "constructor.h" @@ -6770,6 +6773,15 @@ gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, gimplifier to allocate storage, and all that good stuff. */ tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl); gfc_add_expr_to_block (&init, tmp); + if (sym->attr.omp_allocate) + { + /* Save location of size calculation to ensure GOMP_alloc is placed + after it. */ + tree omp_alloc = lookup_attribute ("omp allocate", + DECL_ATTRIBUTES (decl)); + TREE_CHAIN (TREE_CHAIN (TREE_VALUE (omp_alloc))) + = build_tree_list (NULL_TREE, tsi_stmt (tsi_last (init.head))); + } } if (onstack) @@ -6798,8 +6810,22 @@ gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); return; } + if (sym->attr.omp_allocate) + { + /* The size is the number of elements in the array, so multiply by the + size of an element to get the total size. */ + tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type)); + size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + size, fold_convert (gfc_array_index_type, tmp)); + size = gfc_evaluate_now (size, &init); - if (flag_stack_arrays) + tree omp_alloc = lookup_attribute ("omp allocate", + DECL_ATTRIBUTES (decl)); + TREE_CHAIN (TREE_CHAIN (TREE_VALUE (omp_alloc))) + = build_tree_list (size, NULL_TREE); + space = NULL_TREE; + } + else if (flag_stack_arrays) { gcc_assert (TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE); space = build_decl (gfc_get_location (&sym->declared_at), diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc index b0fd25e92a3..dfd58bf60a5 100644 --- a/gcc/fortran/trans-decl.cc +++ b/gcc/fortran/trans-decl.cc @@ -48,6 +48,7 @@ along with GCC; see the file COPYING3. If not see #include "gimplify.h" #include "omp-general.h" #include "attr-fnspec.h" +#include "tree-iterator.h" #define MAX_LABEL_VALUE 99999 @@ -4652,6 +4653,36 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) init_intent_out_dt (proc_sym, block); gfc_restore_backend_locus (&loc); + /* For some reasons, internal procedures point to the parent's + namespace. Top-level procedure and variables inside BLOCK are fine. */ + gfc_namespace *omp_ns = proc_sym->ns; + if (proc_sym->ns->proc_name != proc_sym) + for (omp_ns = proc_sym->ns->contained; omp_ns; + omp_ns = omp_ns->sibling) + if (omp_ns->proc_name == proc_sym) + break; + + /* Add 'omp allocate' attribute for gfc_trans_auto_array_allocation and + unset attr.omp_allocate for 'omp allocate allocator(omp_default_mem_alloc), + which has the normal codepath except for an invalid-use check in the ME. + The main processing happens later in this function. */ + for (struct gfc_omp_namelist *n = omp_ns ? omp_ns->omp_allocate : NULL; + n; n = n->next) + if (!TREE_STATIC (n->sym->backend_decl)) + { + /* Add empty entries - described and to be filled below. */ + tree tmp = build_tree_list (NULL_TREE, NULL_TREE); + TREE_CHAIN (tmp) = build_tree_list (NULL_TREE, NULL_TREE); + DECL_ATTRIBUTES (n->sym->backend_decl) + = tree_cons (get_identifier ("omp allocate"), tmp, + DECL_ATTRIBUTES (n->sym->backend_decl)); + if (n->u.align == NULL + && n->u2.allocator != NULL + && n->u2.allocator->expr_type == EXPR_CONSTANT + && mpz_cmp_si (n->u2.allocator->value.integer, 1) == 0) + n->sym->attr.omp_allocate = 0; + } + for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink) { bool alloc_comp_or_fini = (sym->ts.type == BT_DERIVED) @@ -5105,6 +5136,96 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) gcc_unreachable (); } + /* Handle 'omp allocate'. This has to be after the block above as + gfc_add_init_cleanup (..., init, ...) puts 'init' of later calls + before earlier calls. The code is a bit more complex as gfortran does + not really work with bind expressions / BIND_EXPR_VARS properly, i.e. + gimplify_bind_expr needs some help for placing the GOMP_alloc. Thus, + we pass on the location of the allocate-assignment expression and, + if the size is not constant, the size variable if Fortran computes this + differently. We also might add an expression location after which the + code has to be added, e.g. for character len expressions, which affect + the UNIT_SIZE. */ + gfc_expr *last_allocator = NULL; + if (omp_ns && omp_ns->omp_allocate) + { + if (!block->init || TREE_CODE (block->init) != STATEMENT_LIST) + { + tree tmp = build1_v (LABEL_EXPR, gfc_build_label_decl (NULL_TREE)); + append_to_statement_list (tmp, &block->init); + } + if (!block->cleanup || TREE_CODE (block->cleanup) != STATEMENT_LIST) + { + tree tmp = build1_v (LABEL_EXPR, gfc_build_label_decl (NULL_TREE)); + append_to_statement_list (tmp, &block->cleanup); + } + } + tree init_stmtlist = block->init; + tree cleanup_stmtlist = block->cleanup; + se.expr = NULL_TREE; + for (struct gfc_omp_namelist *n = omp_ns ? omp_ns->omp_allocate : NULL; + n; n = n->next) + if (!TREE_STATIC (n->sym->backend_decl)) + { + tree align = (n->u.align ? gfc_conv_constant_to_tree (n->u.align) + : NULL_TREE); + if (last_allocator != n->u2.allocator) + { + gfc_init_se (&se, NULL); + if (n->u2.allocator) + gfc_conv_expr (&se, n->u2.allocator); + /* We need to evalulate non-constants - also to find the location + after which the GOMP_alloc has to be added to - also as BLOCK + does not yield a new BIND_EXPR_BODY. */ + if (n->u2.allocator + && (!(CONSTANT_CLASS_P (se.expr) && DECL_P (se.expr)) + || se.pre.head || se.post.head)) + { + stmtblock_t tmpblock; + gfc_init_block (&tmpblock); + se.expr = gfc_evaluate_now (se.expr, &tmpblock); + /* First post then pre because the new code is inserted + at the top. */ + gfc_add_init_cleanup (block, gfc_finish_block (&se.post), NULL); + gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), + NULL); + gfc_add_init_cleanup (block, gfc_finish_block (&se.pre), NULL); + } + last_allocator = n->u2.allocator; + } + + /* 'omp allocate( {purpose: allocator, value: align}, + {purpose: init-stmtlist, value: cleanup-stmtlist}, + {purpose: size-var, value: last-size-expr}} + where init-stmt/cleanup-stmt is the STATEMENT list to find the + try-final block; last-size-expr is to find the location after + which to add the code and 'size-var' is for the proper size, cf. + gfc_trans_auto_array_allocation - either or both of the latter + can be NULL. */ + tree tmp = lookup_attribute ("omp allocate", + DECL_ATTRIBUTES (n->sym->backend_decl)); + tmp = TREE_VALUE (tmp); + TREE_PURPOSE (tmp) = se.expr; + TREE_VALUE (tmp) = align; + TREE_PURPOSE (TREE_CHAIN (tmp)) = init_stmtlist; + TREE_VALUE (TREE_CHAIN (tmp)) = cleanup_stmtlist; + } + else if (n->sym->attr.in_common) + { + gfc_error ("Sorry, !$OMP allocate for COMMON block variable %qs at %L " + "not supported", n->sym->common_block->name, + &n->sym->common_block->where); + break; + } + else + { + gfc_error ("Sorry, !$OMP allocate for variable %qs at %L with SAVE " + "attribute not yet implemented", n->sym->name, + &n->sym->declared_at); + /* FIXME: Remember to handle last_allocator. */ + break; + } + gfc_init_block (&tmpblock); for (f = gfc_sym_get_dummy_args (proc_sym); f; f = f->next) diff --git a/gcc/fortran/trans-openmp.cc b/gcc/fortran/trans-openmp.cc index 2f116fd6738..7930f2fd5d1 100644 --- a/gcc/fortran/trans-openmp.cc +++ b/gcc/fortran/trans-openmp.cc @@ -2739,34 +2739,48 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, } break; case OMP_LIST_ALLOCATE: - for (; n != NULL; n = n->next) - if (n->sym->attr.referenced) - { - tree t = gfc_trans_omp_variable (n->sym, false); - if (t != error_mark_node) - { - tree node = build_omp_clause (input_location, - OMP_CLAUSE_ALLOCATE); - OMP_CLAUSE_DECL (node) = t; - if (n->u2.allocator) - { - tree allocator_; - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, n->u2.allocator); - allocator_ = gfc_evaluate_now (se.expr, block); - OMP_CLAUSE_ALLOCATE_ALLOCATOR (node) = allocator_; - } - if (n->u.align) - { - tree align_; - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, n->u.align); - align_ = gfc_evaluate_now (se.expr, block); - OMP_CLAUSE_ALLOCATE_ALIGN (node) = align_; - } - omp_clauses = gfc_trans_add_clause (node, omp_clauses); - } - } + { + tree allocator_ = NULL_TREE; + gfc_expr *alloc_expr = NULL; + for (; n != NULL; n = n->next) + if (n->sym->attr.referenced) + { + tree t = gfc_trans_omp_variable (n->sym, false); + if (t != error_mark_node) + { + tree node = build_omp_clause (input_location, + OMP_CLAUSE_ALLOCATE); + OMP_CLAUSE_DECL (node) = t; + if (n->u2.allocator) + { + if (alloc_expr != n->u2.allocator) + { + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, n->u2.allocator); + gfc_add_block_to_block (block, &se.pre); + allocator_ = gfc_evaluate_now (se.expr, block); + gfc_add_block_to_block (block, &se.post); + } + OMP_CLAUSE_ALLOCATE_ALLOCATOR (node) = allocator_; + } + alloc_expr = n->u2.allocator; + if (n->u.align) + { + tree align_; + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, n->u.align); + gcc_assert (CONSTANT_CLASS_P (se.expr) + && se.pre.head == NULL + && se.post.head == NULL); + align_ = se.expr; + OMP_CLAUSE_ALLOCATE_ALIGN (node) = align_; + } + omp_clauses = gfc_trans_add_clause (node, omp_clauses); + } + } + else + alloc_expr = n->u2.allocator; + } break; case OMP_LIST_LINEAR: { @@ -7184,11 +7198,14 @@ gfc_trans_omp_sections (gfc_code *code, gfc_omp_clauses *clauses) static tree gfc_trans_omp_single (gfc_code *code, gfc_omp_clauses *clauses) { - tree omp_clauses = gfc_trans_omp_clauses (NULL, clauses, code->loc); + stmtblock_t block; + gfc_start_block (&block); + tree omp_clauses = gfc_trans_omp_clauses (&block, clauses, code->loc); tree stmt = gfc_trans_omp_code (code->block->next, true); stmt = build2_loc (gfc_get_location (&code->loc), OMP_SINGLE, void_type_node, stmt, omp_clauses); - return stmt; + gfc_add_expr_to_block (&block, stmt); + return gfc_finish_block (&block); } static tree diff --git a/gcc/gimplify.cc b/gcc/gimplify.cc index 9f4722f7458..402d9feaf9b 100644 --- a/gcc/gimplify.cc +++ b/gcc/gimplify.cc @@ -1400,23 +1400,53 @@ gimplify_bind_expr (tree *expr_p, gimple_seq *pre_p) "region must specify an % clause", t); /* Skip for omp_default_mem_alloc (= 1), unless align is present. */ - else if (!errorcount - && (align != NULL_TREE - || alloc == NULL_TREE - || !integer_onep (alloc))) + else if (errorcount + || (align == NULL_TREE + && alloc != NULL_TREE + && integer_onep (alloc))) + DECL_ATTRIBUTES (t) = remove_attribute ("omp allocate", + DECL_ATTRIBUTES (t)); + else { - tree tmp = build_pointer_type (TREE_TYPE (t)); - tree v = create_tmp_var (tmp, get_name (t)); - DECL_IGNORED_P (v) = 0; - tmp = remove_attribute ("omp allocate", DECL_ATTRIBUTES (t)); - DECL_ATTRIBUTES (v) - = tree_cons (get_identifier ("omp allocate var"), - build_tree_list (NULL_TREE, t), tmp); - tmp = build_fold_indirect_ref (v); - TREE_THIS_NOTRAP (tmp) = 1; - SET_DECL_VALUE_EXPR (t, tmp); - DECL_HAS_VALUE_EXPR_P (t) = 1; - tree sz = TYPE_SIZE_UNIT (TREE_TYPE (t)); + /* Fortran might already use a pointer type internally; + use that pointer except for type(C_ptr) and type(C_funptr); + note that normal proc pointers are rejected. */ + tree type = TREE_TYPE (t); + tree tmp, v; + if (lang_GNU_Fortran () + && POINTER_TYPE_P (type) + && TREE_TYPE (type) != void_type_node + && TREE_CODE (TREE_TYPE (type)) != FUNCTION_TYPE) + { + type = TREE_TYPE (type); + v = t; + } + else + { + tmp = build_pointer_type (type); + v = create_tmp_var (tmp, get_name (t)); + DECL_IGNORED_P (v) = 0; + tmp = remove_attribute ("omp allocate", DECL_ATTRIBUTES (t)); + DECL_ATTRIBUTES (v) + = tree_cons (get_identifier ("omp allocate var"), + build_tree_list (NULL_TREE, t), tmp); + tmp = build_fold_indirect_ref (v); + TREE_THIS_NOTRAP (tmp) = 1; + SET_DECL_VALUE_EXPR (t, tmp); + DECL_HAS_VALUE_EXPR_P (t) = 1; + } + tree sz = TYPE_SIZE_UNIT (type); + /* The size to use in Fortran might not match TYPE_SIZE_UNIT; + hence, for some decls, a size variable is saved in the + attributes; use it, if available. */ + if (TREE_CHAIN (TREE_VALUE (attr)) + && TREE_CHAIN (TREE_CHAIN (TREE_VALUE (attr))) + && TREE_PURPOSE ( + TREE_CHAIN (TREE_CHAIN (TREE_VALUE (attr))))) + { + sz = TREE_CHAIN (TREE_CHAIN (TREE_VALUE (attr))); + sz = TREE_PURPOSE (sz); + } if (alloc == NULL_TREE) alloc = build_zero_cst (ptr_type_node); if (align == NULL_TREE) @@ -1425,28 +1455,88 @@ gimplify_bind_expr (tree *expr_p, gimple_seq *pre_p) align = build_int_cst (size_type_node, MAX (tree_to_uhwi (align), DECL_ALIGN_UNIT (t))); + location_t loc = DECL_SOURCE_LOCATION (t); tmp = builtin_decl_explicit (BUILT_IN_GOMP_ALLOC); - tmp = build_call_expr_loc (DECL_SOURCE_LOCATION (t), tmp, - 3, align, sz, alloc); - tmp = fold_build2_loc (DECL_SOURCE_LOCATION (t), MODIFY_EXPR, - TREE_TYPE (v), v, + tmp = build_call_expr_loc (loc, tmp, 3, align, sz, alloc); + tmp = fold_build2_loc (loc, MODIFY_EXPR, TREE_TYPE (v), v, fold_convert (TREE_TYPE (v), tmp)); - gcc_assert (BIND_EXPR_BODY (bind_expr) != NULL_TREE - && (TREE_CODE (BIND_EXPR_BODY (bind_expr)) - == STATEMENT_LIST)); - tree_stmt_iterator e = tsi_start (BIND_EXPR_BODY (bind_expr)); - while (!tsi_end_p (e)) + gcc_assert (BIND_EXPR_BODY (bind_expr) != NULL_TREE); + if (TREE_CHAIN (TREE_VALUE (attr))) { - if ((TREE_CODE (*e) == DECL_EXPR - && TREE_OPERAND (*e, 0) == t) - || (TREE_CODE (*e) == CLEANUP_POINT_EXPR - && TREE_CODE (TREE_OPERAND (*e, 0)) == DECL_EXPR - && TREE_OPERAND (TREE_OPERAND (*e, 0), 0) == t)) - break; + /* Fortran is special as it does not have properly nest + declarations in blocks. And as there is no + initializer, there is also no expression to look for. + Hence, the FE makes the statement list of the + try-finally block available. We can put the GOMP_alloc + at the top, unless an allocator or size expression + requires to put it afterward; note that the size is + always later in generated code; for strings, no + size expr but still an expr might be available. */ + tree sl = TREE_PURPOSE (TREE_CHAIN (TREE_VALUE (attr))); + tree_stmt_iterator e = tsi_start (sl); + tree needle = NULL_TREE; + if (TREE_CHAIN (TREE_CHAIN (TREE_VALUE (attr)))) + { + needle = TREE_CHAIN (TREE_CHAIN (TREE_VALUE (attr))); + needle = (TREE_VALUE (needle) ? TREE_VALUE (needle) + : sz); + } + else if (TREE_CHAIN (TREE_CHAIN (TREE_VALUE (attr)))) + needle = sz; + else if (DECL_P (alloc) && DECL_ARTIFICIAL (alloc)) + needle = alloc; + + if (needle != NULL_TREE) + { + while (!tsi_end_p (e)) + { + if (*e == needle + || (TREE_CODE (*e) == MODIFY_EXPR + && TREE_OPERAND (*e, 0) == needle)) + break; + ++e; + } + gcc_assert (!tsi_end_p (e)); + } + tsi_link_after (&e, tmp, TSI_SAME_STMT); + + /* As the cleanup is in BIND_EXPR_BODY, GOMP_free is added + here; for C/C++ it will be added in the 'cleanup' + section after gimplification. But Fortran already has + a try-finally block. */ + sl = TREE_VALUE (TREE_CHAIN (TREE_VALUE (attr))); + e = tsi_last (sl); + tmp = builtin_decl_explicit (BUILT_IN_GOMP_FREE); + tmp = build_call_expr_loc (EXPR_LOCATION (*e), tmp, 2, v, + build_zero_cst (ptr_type_node)); + tsi_link_after (&e, tmp, TSI_SAME_STMT); + tmp = build_clobber (TREE_TYPE (v), CLOBBER_EOL); + tmp = fold_build2_loc (loc, MODIFY_EXPR, TREE_TYPE (v), v, + fold_convert (TREE_TYPE (v), tmp)); ++e; + tsi_link_after (&e, tmp, TSI_SAME_STMT); } - gcc_assert (!tsi_end_p (e)); - tsi_link_before (&e, tmp, TSI_SAME_STMT); + else + { + gcc_assert (TREE_CODE (BIND_EXPR_BODY (bind_expr)) + == STATEMENT_LIST); + tree_stmt_iterator e; + e = tsi_start (BIND_EXPR_BODY (bind_expr)); + while (!tsi_end_p (e)) + { + if ((TREE_CODE (*e) == DECL_EXPR + && TREE_OPERAND (*e, 0) == t) + || (TREE_CODE (*e) == CLEANUP_POINT_EXPR + && (TREE_CODE (TREE_OPERAND (*e, 0)) + == DECL_EXPR) + && (TREE_OPERAND (TREE_OPERAND (*e, 0), 0) + == t))) + break; + ++e; + } + gcc_assert (!tsi_end_p (e)); + tsi_link_before (&e, tmp, TSI_SAME_STMT); + } } } @@ -1539,16 +1629,25 @@ gimplify_bind_expr (tree *expr_p, gimple_seq *pre_p) && !is_global_var (t) && DECL_CONTEXT (t) == current_function_decl) { + tree attr; if (flag_openmp - && DECL_HAS_VALUE_EXPR_P (t) && TREE_USED (t) - && lookup_attribute ("omp allocate", DECL_ATTRIBUTES (t))) + && ((attr = lookup_attribute ("omp allocate", + DECL_ATTRIBUTES (t))) != NULL_TREE) + && TREE_CHAIN (TREE_VALUE (attr)) == NULL_TREE) { + /* For Fortran, the GOMP_free has already been added above. */ + tree v = (DECL_HAS_VALUE_EXPR_P (t) + ? TREE_OPERAND (DECL_VALUE_EXPR (t), 0) : t); tree tmp = builtin_decl_explicit (BUILT_IN_GOMP_FREE); - tmp = build_call_expr_loc (end_locus, tmp, 2, - TREE_OPERAND (DECL_VALUE_EXPR (t), 0), + tmp = build_call_expr_loc (end_locus, tmp, 2, v, build_zero_cst (ptr_type_node)); gimplify_and_add (tmp, &cleanup); + gimple *clobber_stmt; + tmp = build_clobber (TREE_TYPE (v), CLOBBER_EOL); + clobber_stmt = gimple_build_assign (v, tmp); + gimple_set_location (clobber_stmt, end_locus); + gimplify_seq_add_stmt (&cleanup, clobber_stmt); } if (!DECL_HARD_REGISTER (t) && !TREE_THIS_VOLATILE (t) diff --git a/gcc/testsuite/c-c++-common/gomp/allocate-14.c b/gcc/testsuite/c-c++-common/gomp/allocate-14.c index b25da5497c5..894921a76d5 100644 --- a/gcc/testsuite/c-c++-common/gomp/allocate-14.c +++ b/gcc/testsuite/c-c++-common/gomp/allocate-14.c @@ -17,7 +17,7 @@ h () { #pragma omp target #pragma omp parallel - #pragma omp serial + #pragma omp single { int var2[5]; /* { dg-error "'allocate' directive for 'var2' inside a target region must specify an 'allocator' clause" } */ #pragma omp allocate(var2) diff --git a/gcc/testsuite/c-c++-common/gomp/allocate-15.c b/gcc/testsuite/c-c++-common/gomp/allocate-15.c index 15105b9102e..52cb7686b7b 100644 --- a/gcc/testsuite/c-c++-common/gomp/allocate-15.c +++ b/gcc/testsuite/c-c++-common/gomp/allocate-15.c @@ -19,7 +19,7 @@ h () { #pragma omp target #pragma omp parallel - #pragma omp serial + #pragma omp single { int var2[5]; #pragma omp allocate(var2) diff --git a/gcc/testsuite/c-c++-common/gomp/allocate-9.c b/gcc/testsuite/c-c++-common/gomp/allocate-9.c index 3c11080dd16..31382748be6 100644 --- a/gcc/testsuite/c-c++-common/gomp/allocate-9.c +++ b/gcc/testsuite/c-c++-common/gomp/allocate-9.c @@ -20,7 +20,7 @@ typedef enum omp_allocator_handle_t static int A[5] = {1,2,3,4,5}; int B, C, D; -/* If the following fails bacause of added predefined allocators, please update +/* If the following fails because of added predefined allocators, please update - c/c-parser.c's c_parser_omp_allocate - fortran/openmp.cc's is_predefined_allocator - libgomp/env.c's parse_allocator diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-10.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-10.f90 new file mode 100644 index 00000000000..339aa3a97fb --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/allocate-10.f90 @@ -0,0 +1,74 @@ +! { dg-additional-options "-Wall -fdump-tree-gimple" } + +module m +use iso_c_binding +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 + + +! { dg-final { scan-tree-dump-times "__builtin_GOMP_alloc" 3 "gimple" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_free" 3 "gimple" } } + +subroutine f + use m + implicit none + integer :: n + block + integer :: A(n) ! { dg-warning "Unused variable 'a' declared" } + end block +end + +subroutine f2 + use m + implicit none + integer :: n ! { dg-note "'n' was declared here" } + block + integer :: A(n) ! { dg-warning "'n' is used uninitialized" } + !$omp allocate(A) + ! by matching 'A' above, TREE_USE is set. Hence: + ! { dg-final { scan-tree-dump-times "a = __builtin_GOMP_alloc \\(., D\.\[0-9\]+, 0B\\);" 1 "gimple" } } + ! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(a, 0B\\);" 1 "gimple" } } + end block +end + +subroutine h1() + use m + implicit none + integer(omp_allocator_handle_kind) my_handle ! { dg-note "'my_handle' was declared here" } + integer :: B1(3) ! { dg-warning "'my_handle' is used uninitialized" } + !$omp allocate(B1) allocator(my_handle) + B1(1) = 5 + ! { dg-final { scan-tree-dump-times "b1.\[0-9\]+ = __builtin_GOMP_alloc \\(4, 12, my_handle\\);" 1 "gimple" } } + ! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(b1.\[0-9\]+, 0B\\);" 1 "gimple" } } +end + +subroutine h2() + use m + implicit none + integer(omp_allocator_handle_kind) my_handle ! { dg-note "'my_handle' was declared here" } + block + integer :: B2(3) ! { dg-warning "'my_handle' is used uninitialized" } + !$omp allocate(B2) allocator(my_handle) ! No dump as 'B2' is unused + ! by matching 'B2' above, TREE_USE is set. Hence: + ! { dg-final { scan-tree-dump-times "b2.\[0-9\]+ = __builtin_GOMP_alloc \\(4, 12, my_handle\\);" 1 "gimple" } } + ! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(b2.\[0-9\]+, 0B\\);" 1 "gimple" } } + end block +end diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-11.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-11.f90 new file mode 100644 index 00000000000..8a8d93930b0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/allocate-11.f90 @@ -0,0 +1,33 @@ +module m +use iso_c_binding +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 + +subroutine f () + use m + implicit none + integer :: i + !$omp parallel firstprivate(i) allocate(allocator(omp_low_latency_mem_alloc): i) + ! { dg-error "Symbol 'omp_low_latency_mem_alloc' at .1. has no IMPLICIT type; did you mean 'omp_low_lat_mem_alloc'\\\?" "" { target *-*-* } .-1 } + ! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind at .1." "" { target *-*-* } .-2 } + i = 4 + !$omp end parallel +end diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-12.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-12.f90 new file mode 100644 index 00000000000..183c2941819 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/allocate-12.f90 @@ -0,0 +1,24 @@ +module m + implicit none +contains +subroutine f () + !$omp declare target + integer :: var ! { dg-error "'allocate' directive for 'var' inside a target region must specify an 'allocator' clause" } + !$omp allocate(var) + var = 5 +end + +subroutine h () + !$omp target + !$omp parallel + !$omp single + block + integer :: var2(5) ! { dg-error "'allocate' directive for 'var2' inside a target region must specify an 'allocator' clause" } + !$omp allocate(var2) + var2(1) = 7 + end block + !$omp end single + !$omp end parallel + !$omp end target +end +end module diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-13.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-13.f90 new file mode 100644 index 00000000000..bf8a5a2bee2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/allocate-13.f90 @@ -0,0 +1,25 @@ +module m + implicit none + !$omp requires dynamic_allocators +contains +subroutine f () + !$omp declare target + integer :: var + !$omp allocate(var) + var = 5 +end + +subroutine h () + !$omp target + !$omp parallel + !$omp single + block + integer :: var2(5) + !$omp allocate(var2) + var2(1) = 7 + end block + !$omp end single + !$omp end parallel + !$omp end target +end +end module diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-14.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-14.f90 new file mode 100644 index 00000000000..8ff9c252e49 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/allocate-14.f90 @@ -0,0 +1,95 @@ +! { dg-additional-options "-fcoarray=single -fcray-pointer" } + +module m +use iso_c_binding +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 + +subroutine coarrays(x) + use m + implicit none + + integer :: x[*] + integer, allocatable :: y[:], z(:)[:] + + !$omp allocate(x) ! { dg-error "Unexpected dummy argument 'x' as argument at .1. to declarative !.OMP ALLOCATE" } + + !$omp allocators allocate(y) ! { dg-error "28:Unexpected coarray 'y' in 'allocate' at .1." } + allocate(y[*]) + + !$omp allocate(z) ! { dg-error "17:Unexpected coarray 'z' in 'allocate' at .1." } + allocate(z(5)[*]) + x = 5 +end + + +integer function f() result(res) + !$omp allocate(f) ! { dg-error "Argument 'f' at .1. to declarative !.OMP ALLOCATE directive must be a variable" } + !$omp allocate(res) ! { dg-error "Unexpected function-result variable 'res' at .1. in declarative !.OMP ALLOCATE" } + res = 5 +end + +integer function g() result(res) + allocatable :: res + !$omp allocators allocate(g) ! { dg-error "Expected variable list at .1." } + + !$omp allocators allocate (res) + allocate(res, source=5) + deallocate(res) + + !$omp allocate (res) + allocate(res, source=5) +end + + +subroutine cray_ptr() + real pointee(10) + pointer (ipt, pointee) + !$omp allocate(pointee) ! { dg-error "Sorry, Cray pointers and pointees such as 'pointee' are not supported with !.OMP ALLOCATE at .1." } + !$omp allocate(ipt) ! { dg-error "Sorry, Cray pointers and pointees such as 'ipt' are not supported with !.OMP ALLOCATE at .1." } +end + +subroutine equiv + integer :: A + real :: B(2) + equivalence(A,B) + !$omp allocate (A) ! { dg-error "Sorry, EQUIVALENCE object 'a' not supported with !.OMP ALLOCATE at .1." } + !$omp allocate (B) ! { dg-error "Sorry, EQUIVALENCE object 'b' not supported with !.OMP ALLOCATE at .1." } +end + +subroutine common + use m + integer :: a,b,c(5) + common /my/ a,b,c + !$omp allocate(b) allocator(omp_cgroup_mem_alloc) ! { dg-error "'b' at .1. is part of the common block '/my/' and may only be specificed implicitly via the named common block" } +end + +subroutine c_and_func_ptrs + use iso_c_binding + implicit none + procedure(), pointer :: p + type(c_ptr) :: cptr + type(c_ptr) :: cfunptr + + !$omp allocate(cptr) ! OK + !$omp allocate(cfunptr) ! OK? A normal derived-type var? + !$omp allocate(p) ! { dg-error "Argument 'p' at .1. to declarative !.OMP ALLOCATE directive must be a variable" } +end diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-15.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-15.f90 new file mode 100644 index 00000000000..a0690a56394 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/allocate-15.f90 @@ -0,0 +1,38 @@ +module m +use iso_c_binding +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 + +subroutine common + use m + integer :: a,b,c(5) + common /my/ a,b,c ! { dg-error "Sorry, !.OMP allocate for COMMON block variable 'my' at .1. not supported" } + !$omp allocate(/my/) allocator(omp_cgroup_mem_alloc) +end + +integer function allocators() result(res) + use m + integer, save :: a(5) = [1,2,3,4,5] ! { dg-error "Sorry, !.OMP allocate for variable 'a' at .1. with SAVE attribute not yet implemented" } + !$omp allocate(a) allocator(omp_high_bw_mem_alloc) + res = a(4) +end + + diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-4.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-4.f90 index a2dcf105ee1..b93a37c780c 100644 --- a/gcc/testsuite/gfortran.dg/gomp/allocate-4.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/allocate-4.f90 @@ -33,13 +33,13 @@ integer(kind=omp_allocator_handle_kind), intent(in) :: my_alloc !stack variables: integer :: a,b,c(n),d(5),e(2) -!$omp allocate(a) ! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" } +!$omp allocate(a) !$omp allocate ( b , c ) align ( 32) allocator (my_alloc) !$omp allocate (d) align( 128 ) !$omp allocate( e ) allocator( omp_high_bw_mem_alloc ) !saved vars -integer, save :: k,l,m(5),r(2) +integer, save :: k,l,m(5),r(2) ! { dg-error "Sorry, !.OMP allocate for variable 'k' at .1. with SAVE attribute not yet implemented" } !$omp allocate(k) align(16) , allocator (omp_large_cap_mem_alloc) !$omp allocate ( l ) allocator (omp_large_cap_mem_alloc) , align ( 32) !$omp allocate (m) align( 128 ),allocator( omp_high_bw_mem_alloc ) diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-7.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-7.f90 index b856204d48a..ab85e327795 100644 --- a/gcc/testsuite/gfortran.dg/gomp/allocate-7.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/allocate-7.f90 @@ -47,7 +47,6 @@ integer, pointer :: ptr integer, parameter :: prm=5 !$omp allocate(prm) align(64) ! { dg-error "Argument 'prm' at .1. to declarative !.OMP ALLOCATE directive must be a variable" } -! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 } !$omp allocate(used) allocator(omp_pteam_mem_alloc) ! { dg-error "Argument 'used' at .1. to declarative !.OMP ALLOCATE shall be in the same scope as the variable declaration" } !$omp allocate(n) allocator(omp_pteam_mem_alloc) ! { dg-error "Unexpected dummy argument 'n' as argument at .1. to declarative !.OMP ALLOCATE" } @@ -59,7 +58,6 @@ contains subroutine inner !$omp allocate(a) allocator(omp_pteam_mem_alloc) ! { dg-error "Argument 'a' at .1. to declarative !.OMP ALLOCATE shall be in the same scope as the variable declaration" } -! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 } end end @@ -74,7 +72,6 @@ common /com4/ y,z allocatable :: q pointer :: b !$omp allocate (c, d) allocator (omp_pteam_mem_alloc) -! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 } !$omp allocate (/com4/) allocator (omp_pteam_mem_alloc) !$omp allocate (c) allocator (omp_pteam_mem_alloc) ! { dg-error "Duplicated variable 'c' in !.OMP ALLOCATE" } !$omp allocate (/com4/) allocator (omp_pteam_mem_alloc) ! { dg-error "Duplicated common block '/com4/' in !.OMP ALLOCATE" } @@ -86,7 +83,6 @@ end subroutine four(n) integer :: qq, rr, ss, tt, uu, vv,n !$omp allocate (qq) align(3+n) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1. that is a power of two" } -! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 } !$omp allocate (rr) align([4]) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1. that is a power of two" } !$omp allocate (ss) align([4]) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1. that is a power of two" } !$omp allocate (tt) align(32.0) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1. that is a power of two" } @@ -99,7 +95,6 @@ subroutine five(n,my_alloc) integer :: qq, rr, ss, tt, uu, vv,n integer(omp_allocator_handle_kind) :: my_alloc !$omp allocate (qq) allocator(3.0) ! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind" } -! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 } !$omp allocate (rr) allocator(3_2) ! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind" } !$omp allocate (ss) allocator([omp_pteam_mem_alloc]) ! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind" } !$omp allocate (tt) allocator(my_alloc) ! OK @@ -113,7 +108,6 @@ subroutine five_SaveAll(n,my_alloc) integer :: qq, rr, ss, tt, uu, vv,n integer(omp_allocator_handle_kind) :: my_alloc !$omp allocate (qq) allocator(3.0) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'qq' at .2. has the SAVE attribute" } -! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 } !$omp allocate (rr) allocator(3_2) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'rr' at .2. has the SAVE attribute" } !$omp allocate (ss) allocator([omp_pteam_mem_alloc]) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'ss' at .2. has the SAVE attribute" } !$omp allocate (tt) allocator(my_alloc) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'tt' at .2. has the SAVE attribute" } @@ -127,7 +121,6 @@ subroutine five_Save(n,my_alloc) integer, save :: qq, rr, ss, tt, uu, vv integer(omp_allocator_handle_kind) :: my_alloc !$omp allocate (qq) allocator(3.0) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'qq' at .2. has the SAVE attribute" } -! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 } !$omp allocate (rr) allocator(3_2) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'rr' at .2. has the SAVE attribute" } !$omp allocate (ss) allocator([omp_pteam_mem_alloc]) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'ss' at .2. has the SAVE attribute" } !$omp allocate (tt) allocator(my_alloc) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'tt' at .2. has the SAVE attribute" } @@ -139,7 +132,6 @@ module five_Module integer, save :: qq, rr, ss, tt, uu, vv,n integer(omp_allocator_handle_kind) :: my_alloc !$omp allocate (qq) allocator(3.0) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'qq' at .2. has the SAVE attribute" } -! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 } !$omp allocate (rr) allocator(3_2) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'rr' at .2. has the SAVE attribute" } !$omp allocate (ss) allocator([omp_pteam_mem_alloc]) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'ss' at .2. has the SAVE attribute" } !$omp allocate (tt) allocator(my_alloc) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'tt' at .2. has the SAVE attribute" } @@ -151,7 +143,6 @@ program five_program integer, save :: qq, rr, ss, tt, uu, vv,n integer(omp_allocator_handle_kind) :: my_alloc !$omp allocate (qq) allocator(3.0) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'qq' at .2. has the SAVE attribute" } -! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 } !$omp allocate (rr) allocator(3_2) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'rr' at .2. has the SAVE attribute" } !$omp allocate (ss) allocator([omp_pteam_mem_alloc]) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'ss' at .2. has the SAVE attribute" } !$omp allocate (tt) allocator(my_alloc) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'tt' at .2. has the SAVE attribute" } @@ -170,7 +161,6 @@ subroutine six(n,my_alloc) integer(omp_allocator_handle_kind) :: my_alloc !$omp allocate (/com6qq/) allocator(3.0) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item '/com6qq/' at .2. has the SAVE attribute" } -! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 } !$omp allocate (/com6rr/) allocator(3_2) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item '/com6rr/' at .2. has the SAVE attribute" } !$omp allocate (/com6ss/) allocator([omp_pteam_mem_alloc]) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item '/com6ss/' at .2. has the SAVE attribute" } !$omp allocate (/com6tt/) allocator(my_alloc) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item '/com6tt/' at .2. has the SAVE attribute" } diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-8.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-8.f90 new file mode 100644 index 00000000000..bb4d07d0c73 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/allocate-8.f90 @@ -0,0 +1,29 @@ +! { dg-additional-options "-fdump-tree-original" } + +module m + use iso_c_binding + !use omp_lib, only: omp_allocator_handle_kind + implicit none + integer, parameter :: omp_allocator_handle_kind = c_intptr_t + integer :: a = 0, b = 42, c = 0 + +contains + integer(omp_allocator_handle_kind) function get_alloc() + allocatable :: get_alloc + get_alloc = 2_omp_allocator_handle_kind + end + subroutine foo () + !$omp scope private (a) firstprivate (b) reduction (+: c) allocate ( get_alloc() : a , b , c) + if (b /= 42) & + error stop + a = 36 + b = 15 + c = c + 1 + !$omp end scope + end +end + +! { dg-final { scan-tree-dump "omp scope private\\(a\\) firstprivate\\(b\\) reduction\\(\\+:c\\) allocate\\(allocator\\(D\\.\[0-9\]+\\):a\\) allocate\\(allocator\\(D\\.\[0-9\]+\\):b\\) allocate\\(allocator\\(D\\.\[0-9\]+\\):c\\)" "original" } } + +! { dg-final { scan-tree-dump-times "D\\.\[0-9\]+ = get_alloc \\(\\);\[\n\r\]+ *D\\.\[0-9\]+ = \\*D\\.\[0-9\]+;\[\n\r\]+ *__builtin_free \\(\\(void \\*\\) D\\.\[0-9\]+\\);" 1 "original" } } + diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-9.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-9.f90 new file mode 100644 index 00000000000..4d9553686c4 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/allocate-9.f90 @@ -0,0 +1,112 @@ +module m +use iso_c_binding +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 m2 + use m + implicit none + integer :: A(5) = [1,2,3,4,5], A2, A3, A4, A5 + integer :: B, C, D + +! If the following fails because of added predefined allocators, please update +! - c/c-parser.c's c_parser_omp_allocate +! - fortran/openmp.cc's is_predefined_allocator +! - libgomp/env.c's parse_allocator +! - libgomp/libgomp.texi (document the new values - multiple locations) +! + ensure that the memory-spaces are also up to date. + +!$omp allocate(A) align(32) allocator(9_omp_allocator_handle_kind) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'a' at .2. has the SAVE attribute" } + +! typo in allocator name: +!$omp allocate(A2) allocator(omp_low_latency_mem_alloc) ! { dg-error "Symbol 'omp_low_latency_mem_alloc' at .1. has no IMPLICIT type; did you mean 'omp_low_lat_mem_alloc'\\?" } +! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'a2' at .2. has the SAVE attribute" "" { target *-*-* } .-1 } + +! align be const multiple of 2 +!$omp allocate(A3) align(31) allocator(omp_default_mem_alloc) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1. that is a power of two" } + +! allocator missing (required as A is static) +!$omp allocate(A4) align(32) ! { dg-error "An ALLOCATOR clause is required as the list item 'a4' at .1. has the SAVE attribute" } + +! "expression in the clause must be a constant expression that evaluates to one of the +! predefined memory allocator values -> omp_low_lat_mem_alloc" +!$omp allocate(B) allocator(omp_high_bw_mem_alloc+1_omp_allocator_handle_kind) align(32) ! OK: omp_low_lat_mem_alloc + +!$omp allocate(C) allocator(2_omp_allocator_handle_kind) ! OK: omp_large_cap_mem_alloc + +!$omp allocate(A5) align(32) allocator(omp_null_allocator) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'a5' at .2. has the SAVE attribute" } + +!$omp allocate(C) align(32) allocator(omp_large_cap_mem_alloc) ! { dg-error "Duplicated variable 'c' in !.OMP ALLOCATE at .1." } + +contains + +integer function f() + !$omp allocate(D) align(32) allocator(omp_large_cap_mem_alloc) ! { dg-error "Argument 'd' at .1. to declarative !.OMP ALLOCATE shall be in the same scope as the variable declaration" } + f = A(1) +end + +integer function g() + integer :: a2, b2 + !$omp allocate(a2) + !$omp allocate(a2) ! { dg-error "Duplicated variable 'a2' in !.OMP ALLOCATE at .1." } + a2=1; b2=2 + block + integer :: c2 + !$omp allocate(c2, b2) ! { dg-error "Argument 'b2' at .1. to declarative !.OMP ALLOCATE shall be in the same scope as the variable declaration" } + c2 = 3 + g = c2+a2+b2 + end block +end + +integer function h(q) + integer :: q + !$omp allocate(q) ! { dg-error "Unexpected dummy argument 'q' as argument at .1. to declarative !.OMP ALLOCATE" } + h = q +end + +integer function k () + integer, save :: var3 = 8 + !$omp allocate(var3) allocator(-1_omp_allocator_handle_kind) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'var3' at .2. has the SAVE attribute" } + k = var3 +end +end module + + +subroutine foo + integer :: a, b + integer :: c, d,h + !$omp allocate(a,b) + b = 1; d = 5 +contains +subroutine internal + integer :: e,f + !$omp allocate(c,d) + ! { dg-error "Argument 'c' at .1. to declarative !.OMP ALLOCATE shall be in the same scope as the variable declaration" "" { target *-*-* } .-1 } + ! { dg-error "Argument 'd' at .1. to declarative !.OMP ALLOCATE shall be in the same scope as the variable declaration" "" { target *-*-* } .-2 } + !$omp allocate(e) + a = 1; c = 2; e = 4 + block + !$omp allocate(f) ! { dg-error "Argument 'f' at .1. to declarative !.OMP ALLOCATE shall be in the same scope as the variable declaration" } + !$omp allocate(h) ! { dg-error "Argument 'h' at .1. to declarative !.OMP ALLOCATE shall be in the same scope as the variable declaration" } + end block +end +end diff --git a/libgomp/libgomp.texi b/libgomp/libgomp.texi index ba8e9013814..0d965f96d48 100644 --- a/libgomp/libgomp.texi +++ b/libgomp/libgomp.texi @@ -225,7 +225,7 @@ The OpenMP 4.5 specification is fully supported. @item Predefined memory spaces, memory allocators, allocator traits @tab Y @tab See also @ref{Memory allocation} @item Memory management routines @tab Y @tab -@item @code{allocate} directive @tab P @tab Only C, only stack variables +@item @code{allocate} directive @tab P @tab Only C and Fortran, only stack variables @item @code{allocate} clause @tab P @tab Initial support @item @code{use_device_addr} clause on @code{target data} @tab Y @tab @item @code{ancestor} modifier on @code{device} clause @tab Y @tab @@ -297,7 +297,7 @@ The OpenMP 4.5 specification is fully supported. @item @code{strict} modifier in the @code{grainsize} and @code{num_tasks} clauses of the @code{taskloop} construct @tab Y @tab @item @code{align} clause in @code{allocate} directive @tab P - @tab Only C (and only stack variables) + @tab Only C and Fortran (and only stack variables) @item @code{align} modifier in @code{allocate} clause @tab Y @tab @item @code{thread_limit} clause to @code{target} construct @tab Y @tab @item @code{has_device_addr} clause to @code{target} construct @tab Y @tab diff --git a/libgomp/testsuite/libgomp.fortran/allocate-5.f90 b/libgomp/testsuite/libgomp.fortran/allocate-5.f90 new file mode 100644 index 00000000000..de9cd5a302e --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/allocate-5.f90 @@ -0,0 +1,87 @@ +! { dg-additional-options "-fdump-tree-gimple" } + +! { dg-final { scan-tree-dump-times "__builtin_GOMP_alloc \\(" 5 "gimple" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(" 5 "gimple" } } + + +module m + use omp_lib + use iso_c_binding + implicit none (type, external) + integer(c_intptr_t) :: intptr +contains + +integer function one () + integer :: sum, i + !$omp allocate(sum) + ! { dg-final { scan-tree-dump-times "sum\\.\[0-9\]+ = __builtin_GOMP_alloc \\(4, 4, 0B\\);" 1 "gimple" } } + ! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(sum\\.\[0-9\]+, 0B\\);" 1 "gimple" } } + + ! NOTE: Initializer cannot be omp_init_allocator - as 'A' is + ! in the same scope and the auto-omp_free comes later than + ! any omp_destroy_allocator. + integer(omp_allocator_handle_kind) :: my_allocator = omp_low_lat_mem_alloc + integer :: n = 25 + sum = 0 + block + type(omp_alloctrait) :: traits(1) = [ omp_alloctrait(omp_atk_alignment, 64) ] + integer :: A(n) + !$omp allocate(A) align(128) allocator(my_allocator) + ! { dg-final { scan-tree-dump-times "a = __builtin_GOMP_alloc \\(128, D\\.\[0-9\]+, D\\.\[0-9\]+\\);" 1 "gimple" } } + ! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(a, 0B\\);" 1 "gimple" } } + + if (mod (transfer(loc(A), intptr), 128_c_intptr_t) /= 0) & + stop 2 + do i = 1, n + A(i) = i + end do + + my_allocator = omp_init_allocator(omp_low_lat_mem_space,1,traits) + block + integer B(n) + integer C(5) + !$omp allocate(B,C) allocator(my_allocator) + ! { dg-final { scan-tree-dump-times "b = __builtin_GOMP_alloc \\(\[0-9\]+, D\\.\[0-9\]+, D\\.\[0-9\]+\\);" 1 "gimple" } } + ! { dg-final { scan-tree-dump-times "c\\.\[0-9\]+ = __builtin_GOMP_alloc \\(\[0-9\]+, 20, D\\.\[0-9\]+\\);" 1 "gimple" } } + ! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(b, 0B\\);" 1 "gimple" } } + ! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(c\\.\[0-9\]+, 0B\\);" 1 "gimple" } } + + integer :: D(5) + !$omp allocate(D) align(256) + ! { dg-final { scan-tree-dump-times "d\\.\[0-9\]+ = __builtin_GOMP_alloc \\(256, 20, 0B\\);" 1 "gimple" } } + ! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(d\\.\[0-9\]+, 0B\\);" 1 "gimple" } } + + B = 0 + C = [1,2,3,4,5] + D = [11,22,33,44,55] + + if (mod (transfer(loc(B), intptr), 64_c_intptr_t) /= 0) & + stop 3 + if (mod (transfer(loc(C), intptr), 64_c_intptr_t) /= 0) & + stop 4 + if (mod (transfer(loc(D), intptr), 256_c_intptr_t) /= 0) & + stop 5 + + do i = 1, 5 + if (C(i) /= i) & + stop 6 + if (D(i) /= i + 10*i) & + stop 7 + end do + + do i = 1, n + if (B(i) /= 0) & + stop 9 + sum = sum + A(i)+B(i)+C(mod(i,5)+1)+D(mod(i,5)+1) + end do + end block + call omp_destroy_allocator (my_allocator) + end block + one = sum +end +end module + +use m +if (one () /= 1225) & + stop 1 +end diff --git a/libgomp/testsuite/libgomp.fortran/allocate-6.f90 b/libgomp/testsuite/libgomp.fortran/allocate-6.f90 new file mode 100644 index 00000000000..5c32652f2a6 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/allocate-6.f90 @@ -0,0 +1,123 @@ +module m + use iso_c_binding + use omp_lib + implicit none (type, external) + integer(c_intptr_t) :: intptr + +! { dg-final { scan-tree-dump-not "__builtin_stack_save" "gimple" } } +! { dg-final { scan-tree-dump-not "__builtin_alloca" "gimple" } } +! { dg-final { scan-tree-dump-not "__builtin_stack_restore" "gimple" } } + +! { dg-final { scan-tree-dump-times "__builtin_GOMP_alloc \\(" 5 "gimple" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(" 5 "gimple" } } + +contains + +subroutine one () + integer :: result, n, i + result = 0 + n = 3 + !$omp target map(tofrom: result) firstprivate(n) + block + integer :: var, var2(n) + !$omp allocate(var,var2) align(128) allocator(omp_low_lat_mem_alloc) + var = 5 +! { dg-final { scan-tree-dump-times "var\\.\[0-9\]+ = __builtin_GOMP_alloc \\(128, 4, 5\\);" 1 "gimple" } } */ +! { dg-final { scan-tree-dump-times "var2\\.\[0-9\]+ = __builtin_GOMP_alloc \\(128, D\\.\[0-9\]+, 5\\);" 1 "gimple" } } */ + +! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(var\\.\[0-9\]+, 0B\\);" 1 "gimple" } } */ +! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(var2\\.\[0-9\]+, 0B\\);" 1 "gimple" } } */ + + if (mod(transfer(loc(var), intptr), 128_c_intptr_t) /= 0) & + stop 1 + if (mod(transfer(loc(var2), intptr), 128_c_intptr_t) /= 0) & + stop 2 + if (var /= 5) & + stop 3 + + !$omp parallel do + do i = 1, n + var2(i) = (i+32); + end do + + !$omp parallel loop reduction(+:result) + do i = 1, n + result = result + var + var2(i) + end do + end block + if (result /= (3*5 + 33 + 34 + 35)) & + stop 4 +end + +subroutine two () + type st + integer :: a, b + end type + integer :: scalar, array(5), i + type(st) s + !$omp allocate(scalar, array, s) +! { dg-final { scan-tree-dump-times "scalar\\.\[0-9\]+ = __builtin_GOMP_alloc \\(4, 4, 0B\\);" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "array\\.\[0-9\]+ = __builtin_GOMP_alloc \\(4, 20, 0B\\);" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "s\\.\[0-9\]+ = __builtin_GOMP_alloc \\(4, 8, 0B\\);" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(scalar\\.\[0-9\]+, 0B\\);" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(array\\.\[0-9\]+, 0B\\);" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(s\\.\[0-9\]+, 0B\\);" 1 "gimple" } } + + scalar = 44 + array = [1,2,3,4,5] + s = st(a=11, b=56) + + !$omp parallel firstprivate(scalar) firstprivate(array) firstprivate(s) + if (scalar /= 44) & + stop 5 + scalar = 33; + if (any (array /= [1,2,3,4,5])) & + stop 6 + array = [10,20,30,40,50] + if (s%a /= 11 .or. s%b /= 56) & + stop 7 + s%a = 74 + s%b = 674 + !$omp end parallel + + if (scalar /= 44) & + stop 8 + if (any (array /= [1,2,3,4,5])) & + stop 9 + if (s%a /= 11 .or. s%b /= 56) & + stop 10 + + !$omp target defaultmap(firstprivate : scalar) defaultmap(none : aggregate) defaultmap(none : pointer) + if (scalar /= 44) & + stop 11 + scalar = 33; + !$omp end target + + if (scalar /= 44) & + stop 12 + + !$omp target defaultmap(none : scalar) defaultmap(firstprivate : aggregate) defaultmap(none : pointer) private(i) + if (any (array /= [1,2,3,4,5])) & + stop 13 + do i = 1, 5 + array(i) = 10*i + end do + !$omp end target + + if (any(array /= [1,2,3,4,5])) & + stop 13 + !$omp target defaultmap(none : scalar) defaultmap(firstprivate : aggregate) defaultmap(none : pointer) + if (s%a /= 11 .or. s%b /= 56) & + stop 14 + s%a = 74 + s%b = 674 + !$omp end target + if (s%a /= 11 .or. s%b /= 56) & + stop 15 +end +end module + +use m + call one () + call two () +end diff --git a/libgomp/testsuite/libgomp.fortran/allocate-7.f90 b/libgomp/testsuite/libgomp.fortran/allocate-7.f90 new file mode 100644 index 00000000000..4a0f6b6df32 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/allocate-7.f90 @@ -0,0 +1,342 @@ +! { dg-additional-options "-fdump-tree-omplower" } + +! For the 4 vars in omp_parallel, 4 in omp_target and 1 of 2 in no_alloc2_func. +! { dg-final { scan-tree-dump-times "__builtin_GOMP_alloc \\(" 9 "omplower" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(" 9 "omplower" } } + +module m + use iso_c_binding + use omp_lib + implicit none (type, external) + integer(c_intptr_t) :: intptr + +contains + +subroutine check_int (x, y) + integer :: x, y + value :: y + if (x /= y) & + stop 1 +end + +subroutine check_ptr (x, y) + type(c_ptr) :: x + integer(c_intptr_t), value :: y + if (transfer(x,intptr) /= y) & + stop 2 +end + +integer function no_alloc_func () result(res) + ! There is no __builtin_GOMP_alloc / __builtin_GOMP_free as + ! allocator == omp_default_mem_alloc (known at compile time. + integer :: no_alloc + !$omp allocate(no_alloc) allocator(omp_default_mem_alloc) + no_alloc = 7 + res = no_alloc +end + +integer function no_alloc2_func() result(res) + ! If no_alloc2 were TREE_UNUSED, there would be no + ! __builtin_GOMP_alloc / __builtin_GOMP_free + ! However, as the parser already marks no_alloc2 + ! and is_alloc2 as used, the tree is generated for both vars. + integer :: no_alloc2, is_alloc2 + !$omp allocate(no_alloc2, is_alloc2) + is_alloc2 = 7 + res = is_alloc2 +end + + +subroutine omp_parallel () + integer :: i, n, iii, jjj(5) + type(c_ptr) :: ptr + !$omp allocate(iii, jjj, ptr) + n = 6 + iii = 5 + ptr = transfer (int(z'1234', c_intptr_t), ptr) + block + integer :: kkk(n) + !$omp allocate(kkk) + + do i = 1, 5 + jjj(i) = 3*i + end do + do i = 1, 6 + kkk(i) = 7*i + end do + + !$omp parallel default(none) firstprivate(iii, jjj, kkk, ptr) if(.false.) + if (iii /= 5) & + stop 3 + iii = 7 + call check_int (iii, 7) + do i = 1, 5 + if (jjj(i) /= 3*i) & + stop 4 + end do + do i = 1, 6 + if (kkk(i) /= 7*i) & + stop 5 + end do + do i = 1, 5 + jjj(i) = 4*i + end do + do i = 1, 6 + kkk(i) = 8*i + end do + do i = 1, 5 + call check_int (jjj(i), 4*i) + end do + do i = 1, 6 + call check_int (kkk(i), 8*i) + end do + if (transfer (ptr, intptr) /= int(z'1234', c_intptr_t)) & + stop 6 + ptr = transfer (int(z'abcd', c_intptr_t), ptr) + if (transfer (ptr, intptr) /= int(z'abcd', c_intptr_t)) & + stop 7 + call check_ptr (ptr, int(z'abcd', c_intptr_t)) + !$omp end parallel + + if (iii /= 5) & + stop 8 + call check_int (iii, 5) + do i = 1, 5 + if (jjj(i) /= 3*i) & + stop 9 + call check_int (jjj(i), 3*i) + end do + do i = 1, 6 + if (kkk(i) /= 7*i) & + stop 10 + call check_int (kkk(i), 7*i) + end do + if (transfer (ptr, intptr) /= int(z'1234', c_intptr_t)) & + stop 11 + call check_ptr (ptr, int(z'1234', c_intptr_t)) + + !$omp parallel default(firstprivate) if(.false.) + if (iii /= 5) & + stop 12 + iii = 7 + call check_int (iii, 7) + do i = 1, 5 + if (jjj(i) /= 3*i) & + stop 13 + end do + do i = 1, 6 + if (kkk(i) /= 7*i) & + stop 14 + end do + do i = 1, 5 + jjj(i) = 4*i + end do + do i = 1, 6 + kkk(i) = 8*i + end do + do i = 1, 5 + call check_int (jjj(i), 4*i) + end do + do i = 1, 6 + call check_int (kkk(i), 8*i) + end do + if (transfer (ptr, intptr) /= int(z'1234', c_intptr_t)) & + stop 15 + ptr = transfer (int (z'abcd', c_intptr_t), ptr) + if (transfer (ptr, intptr) /= int(z'abcd', c_intptr_t)) & + stop 16 + call check_ptr (ptr, int (z'abcd', c_intptr_t)) + !$omp end parallel + if (iii /= 5) & + stop 17 + call check_int (iii, 5) + do i = 1, 5 + if (jjj(i) /= 3*i) & + stop 18 + call check_int (jjj(i), 3*i) + end do + do i = 1, 6 + if (kkk(i) /= 7*i) & + stop 19 + call check_int (kkk(i), 7*i) + end do + if (transfer (ptr, intptr) /= int(z'1234', c_intptr_t)) & + stop 20 + call check_ptr (ptr, int (z'1234', c_intptr_t)) + end block +end + +subroutine omp_target () + integer :: i, n, iii, jjj(5) + type(c_ptr) :: ptr + !$omp allocate(iii, jjj, ptr) + n = 6 + iii = 5 + ptr = transfer (int (z'1234', c_intptr_t), ptr) + block + integer :: kkk(n) + !$omp allocate(kkk) + do i = 1, 5 + jjj(i) = 3*i + end do + do i = 1, 6 + kkk(i) = 7*i + end do + + !$omp target defaultmap(none) firstprivate(iii, jjj, kkk, ptr) private(i) + if (iii /= 5) & + stop 21 + iii = 7 + call check_int (iii, 7) + do i = 1, 5 + if (jjj(i) /= 3*i) & + stop 22 + end do + do i = 1, 6 + if (kkk(i) /= 7*i) & + stop 23 + end do + do i = 1, 5 + jjj(i) = 4*i + end do + do i = 1, 6 + kkk(i) = 8*i + end do + do i = 1, 5 + call check_int (jjj(i), 4*i) + end do + do i = 1, 6 + call check_int (kkk(i), 8*i) + end do + if (transfer (ptr, intptr) /= int(z'1234', c_intptr_t)) & + stop 24 + ptr = transfer (int (z'abcd', c_intptr_t), ptr) + if (transfer (ptr, intptr) /= int(z'abcd', c_intptr_t)) & + stop 25 + call check_ptr (ptr, int (z'abcd', c_intptr_t)) + !$omp end target + + if (iii /= 5) & + stop 26 + call check_int (iii, 5) + do i = 1, 5 + if (jjj(i) /= 3*i) & + stop 27 + call check_int (jjj(i), 3*i) + end do + do i = 1, 6 + if (kkk(i) /= 7*i) & + stop 28 + call check_int (kkk(i), 7*i) + end do + if (transfer (ptr, intptr) /= int(z'1234', c_intptr_t)) & + stop 29 + call check_ptr (ptr, int (z'1234', c_intptr_t)) + + !$omp target defaultmap(firstprivate) + if (iii /= 5) & + stop 30 + iii = 7 + call check_int (iii, 7) + do i = 1, 5 + if (jjj(i) /= 3*i) & + stop 31 + end do + do i = 1, 6 + if (kkk(i) /= 7*i) & + stop 32 + end do + do i = 1, 5 + jjj(i) = 4*i + end do + do i = 1, 6 + kkk(i) = 8*i + end do + do i = 1, 5 + call check_int (jjj(i), 4*i) + end do + do i = 1, 6 + call check_int (kkk(i), 8*i) + end do + if (transfer (ptr, intptr) /= int(z'1234', c_intptr_t)) & + stop 33 + ptr = transfer (int (z'abcd', c_intptr_t), ptr) + if (transfer (ptr, intptr) /= int(z'abcd', c_intptr_t)) & + stop 34 + call check_ptr (ptr, int (z'abcd', c_intptr_t)) + !$omp end target + if (iii /= 5) & + stop 35 + call check_int (iii, 5) + do i = 1, 5 + if (jjj(i) /= 3*i) & + stop 36 + call check_int (jjj(i), 3*i) + end do + do i = 1, 6 + if (kkk(i) /= 7*i) & + stop 37 + call check_int (kkk(i), 7*i) + end do + if (transfer (ptr, intptr) /= int(z'1234', c_intptr_t)) & + stop 38 + call check_ptr (ptr, int (z'1234', c_intptr_t)) + + !$omp target defaultmap(tofrom) + if (iii /= 5) & + stop 39 + iii = 7 + call check_int (iii, 7) + do i = 1, 5 + if (jjj(i) /= 3*i) & + stop 40 + end do + do i = 1, 6 + if (kkk(i) /= 7*i) & + stop 41 + end do + do i = 1, 5 + jjj(i) = 4*i + end do + do i = 1, 6 + kkk(i) = 8*i + end do + do i = 1, 5 + call check_int (jjj(i), 4*i) + end do + do i = 1, 6 + call check_int (kkk(i), 8*i) + end do + if (transfer (ptr, intptr) /= int(z'1234', c_intptr_t)) & + stop 42 + ptr = transfer (int(z'abcd',c_intptr_t), ptr) + if (transfer (ptr, intptr) /= int(z'abcd', c_intptr_t)) & + stop 43 + call check_ptr (ptr, int (z'abcd', c_intptr_t)) + !$omp end target + + if (iii /= 7) & + stop 44 + call check_int (iii, 7) + do i = 1, 5 + if (jjj(i) /= 4*i) & + stop 45 + call check_int (jjj(i), 4*i) + end do + do i = 1, 6 + if (kkk(i) /= 8*i) & + stop 46 + call check_int (kkk(i), 8*i) + end do + if (transfer (ptr, intptr) /= int(z'abcd', c_intptr_t)) & + stop 47 + call check_ptr (ptr, int (z'abcd', c_intptr_t)) + end block +end +end module + + +use m + call omp_parallel () + call omp_target () +end diff --git a/libgomp/testsuite/libgomp.fortran/allocate-8.f90 b/libgomp/testsuite/libgomp.fortran/allocate-8.f90 new file mode 100644 index 00000000000..b9dea6c5148 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/allocate-8.f90 @@ -0,0 +1,99 @@ +module m +use omp_lib +implicit none +!!$omp requires dynamic_allocators + +integer :: final_count + +type t + integer :: i = 0 + integer, allocatable :: A(:,:) +contains + final :: count_finalization +end type t + +contains + +elemental impure subroutine count_finalization(self) + type(t), intent(in) :: self + final_count = final_count + 1 +end + +subroutine test(allocator) +integer(omp_allocator_handle_kind), optional, value :: allocator +call zero_size(allocator) +call finalization_test(allocator) +end subroutine test + +subroutine finalization_test(allocator) +integer(omp_allocator_handle_kind), optional, value :: allocator +integer :: n = 5 + +final_count = 0; +block + type(t) :: A +! !$omp allocate(A) allocator(allocator) + A%i = 1 +end block +if (final_count /= 1) & + stop 10 + +final_count = 0; +block + type(t) :: B(7) + !$omp allocate(B) allocator(allocator) + B(1)%i = 1 +end block +if (final_count /= 7) stop 10 + +final_count = 0; +block + type(t) :: C(n) +! !$omp allocate(C) allocator(allocator) + C(1)%i = 1 +end block +if (final_count /= 5) stop 10 + +final_count = 0; +block + type(t) :: D(0) +! !$omp allocate(D) allocator(allocator) + D(1:0)%i = 1 +end block +if (final_count /= 0) stop 10 +end subroutine + +subroutine zero_size(allocator) +integer(omp_allocator_handle_kind), optional, value :: allocator +integer :: n +n = -3 + +block + integer :: A(n) + character(len=n) :: B +! !$omp allocate(A,b) allocator(allocator) + if (size(A) /= 0 .or. len(b) /= 0) & + stop 1 + B(1:len(b)) ='A' +end block + +!!$omp target +block + integer :: A(n) + character(len=n) :: B +! !$omp allocate(A,b) allocator(allocator) + if (size(A) /= 0 .or. len(b) /= 0) & + stop 2 + B(1:len(b)) ='A' +end block +end +end module + +use m +call test() +call test(omp_default_mem_alloc) +call test(omp_large_cap_mem_alloc) +call test(omp_high_bw_mem_alloc) +call test(omp_low_lat_mem_alloc) +call test(omp_cgroup_mem_alloc) +end