From 59175e6f0889ba3be79b04622ce614f0ceb6284a Mon Sep 17 00:00:00 2001 From: Tobias Burnus Date: Thu, 26 Oct 2023 11:52:15 +0200 Subject: [PATCH] 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 misleading 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 (OpenMP Impl. Status): Mention that Fortran now supports the allocate directive for stack variables. * testsuite/libgomp.fortran/allocate-5a.f90: Renamed from testsuite/libgomp.fortran/allocate-5.f90. * 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. (cherry picked from commit 969f5c3eaa7f073f532206ced0f177b4eb58aee2) --- gcc/ChangeLog.omp | 8 + gcc/fortran/ChangeLog.omp | 27 ++ 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 | 126 +++++++ gcc/fortran/trans-openmp.cc | 89 +++-- gcc/gimplify.cc | 166 +++++++-- gcc/testsuite/ChangeLog.omp | 19 + 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 +- .../gfortran.dg/gomp/allocate-10.f90 | 75 ++++ .../gfortran.dg/gomp/allocate-11.f90 | 33 ++ .../gfortran.dg/gomp/allocate-12.f90 | 24 ++ .../gfortran.dg/gomp/allocate-13.f90 | 25 ++ .../gfortran.dg/gomp/allocate-14.f90 | 95 +++++ .../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/ChangeLog.omp | 14 + libgomp/libgomp.texi | 4 +- .../testsuite/libgomp.fortran/allocate-5.f90 | 196 +++++----- .../testsuite/libgomp.fortran/allocate-5a.f90 | 119 ++++++ .../testsuite/libgomp.fortran/allocate-6.f90 | 123 +++++++ .../testsuite/libgomp.fortran/allocate-7.f90 | 342 ++++++++++++++++++ .../testsuite/libgomp.fortran/allocate-8.f90 | 99 +++++ 31 files changed, 1671 insertions(+), 220 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/gomp/allocate-10.f90 create mode 100644 gcc/testsuite/gfortran.dg/gomp/allocate-11.f90 create mode 100644 gcc/testsuite/gfortran.dg/gomp/allocate-12.f90 create mode 100644 gcc/testsuite/gfortran.dg/gomp/allocate-13.f90 create mode 100644 gcc/testsuite/gfortran.dg/gomp/allocate-14.f90 create mode 100644 gcc/testsuite/gfortran.dg/gomp/allocate-15.f90 create mode 100644 gcc/testsuite/gfortran.dg/gomp/allocate-8.f90 create mode 100644 gcc/testsuite/gfortran.dg/gomp/allocate-9.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/allocate-5a.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/allocate-6.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/allocate-7.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/allocate-8.f90 diff --git a/gcc/ChangeLog.omp b/gcc/ChangeLog.omp index e8b23b90de12..cdaabb97356c 100644 --- a/gcc/ChangeLog.omp +++ b/gcc/ChangeLog.omp @@ -1,3 +1,11 @@ +2023-10-26 Tobias Burnus + + Backported from master: + 2023-10-14 Tobias Burnus + + * gimplify.cc (gimplify_bind_expr): Handle Fortran's + 'omp allocate' for stack variables. + 2023-10-26 Tobias Burnus Chung-Lin Tang diff --git a/gcc/fortran/ChangeLog.omp b/gcc/fortran/ChangeLog.omp index 2181e2b86edc..2b81cada3263 100644 --- a/gcc/fortran/ChangeLog.omp +++ b/gcc/fortran/ChangeLog.omp @@ -1,3 +1,30 @@ +2023-10-26 Tobias Burnus + + Backported from master: + 2023-10-14 Tobias Burnus + + * 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 misleading 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. + 2023-10-26 Tobias Burnus Backported from master: diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index b93e17e98fff..2f4ad709e6f4 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -1008,6 +1008,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 465036b77405..0a493b47d411 100644 --- a/gcc/fortran/match.cc +++ b/gcc/fortran/match.cc @@ -5544,6 +5544,7 @@ gfc_free_omp_namelist (gfc_omp_namelist *name, int list) || list == OMP_LIST_FROM); bool free_align = (list == OMP_LIST_ALLOCATE); gfc_omp_namelist *n; + gfc_expr *last_allocator = NULL; for (; name; name = n) { @@ -5555,7 +5556,13 @@ gfc_free_omp_namelist (gfc_omp_namelist *name, int list) else if (free_mapper && name->u2.udm) free (name->u2.udm); else if (free_align) - 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_mapper && name->u2.udr) { if (name->u2.udr->combiner) diff --git a/gcc/fortran/openmp.cc b/gcc/fortran/openmp.cc index 4707d1d5a1aa..0e2f9d64edfe 100644 --- a/gcc/fortran/openmp.cc +++ b/gcc/fortran/openmp.cc @@ -2652,11 +2652,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; } @@ -5236,9 +5234,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; @@ -8231,7 +8228,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) @@ -8249,10 +8246,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 " @@ -8260,8 +8267,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", @@ -8274,7 +8280,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) { @@ -8289,7 +8301,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)) @@ -8347,8 +8380,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 @@ -8745,6 +8776,9 @@ verify_omp_clauses_symbol_dups (gfc_code *code, gfc_omp_clauses *omp_clauses, n_null = n; 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 feff05aa8680..9c9aee5860ea 100644 --- a/gcc/fortran/parse.cc +++ b/gcc/fortran/parse.cc @@ -788,18 +788,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 e13bbc71c3fc..211e2b5731dd 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" @@ -6846,6 +6849,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) @@ -6874,8 +6886,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 a12639529554..b53873ce38bf 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 @@ -4674,6 +4675,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) @@ -5107,6 +5138,101 @@ 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) + { + location_t loc = input_location; + gfc_init_se (&se, NULL); + if (n->u2.allocator) + { + input_location = gfc_get_location (&n->u2.allocator->where); + 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; + input_location = loc; + } + + /* '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 c2e036e4a1e6..30e43cea56cb 100644 --- a/gcc/fortran/trans-openmp.cc +++ b/gcc/fortran/trans-openmp.cc @@ -4710,48 +4710,60 @@ 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, + { + 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) - { - tree allocator_; - if (n->u2.allocator->expr_type == EXPR_VARIABLE) - { - allocator_ - = gfc_trans_omp_variable (n->u2.allocator->symtree->n.sym, - false); + OMP_CLAUSE_DECL (node) = t; + if (n->u2.allocator) + { + if (alloc_expr != n->u2.allocator + && n->u2.allocator->expr_type == EXPR_VARIABLE) + { + allocator_ + = gfc_trans_omp_variable (n->u2.allocator->symtree->n.sym, + false); if (POINTER_TYPE_P (TREE_TYPE (allocator_))) { allocator_ = build_fold_indirect_ref (allocator_); allocator_ = gfc_evaluate_now (allocator_, block); } - } - else - { - 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); + } + else 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); - } - } + } + omp_clauses = gfc_trans_add_clause (node, omp_clauses); + } + } + else + alloc_expr = n->u2.allocator; + } break; case OMP_LIST_LINEAR: { @@ -9861,11 +9873,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 594c5bef5c8b..f2fbd8554ac9 100644 --- a/gcc/gimplify.cc +++ b/gcc/gimplify.cc @@ -1463,18 +1463,45 @@ gimplify_bind_expr (tree *expr_p, gimple_seq *pre_p) || alloc == NULL_TREE || !integer_onep (alloc))) { - 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; + DECL_ATTRIBUTES (v) + = tree_cons (get_identifier ("omp allocate var"), + build_tree_list (NULL_TREE, t), + DECL_ATTRIBUTES (t)); + 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) @@ -1483,28 +1510,93 @@ 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); + /* Ensure that either TREE_CHAIN (TREE_VALUE (attr) is set + and GOMP_FREE added here or that DECL_HAS_VALUE_EXPR_P (t) + is set, using in a condition much further below. */ + gcc_assert (DECL_HAS_VALUE_EXPR_P (t) + || TREE_CHAIN (TREE_VALUE (attr))); + 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); + } } } @@ -1597,16 +1689,26 @@ 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, TREE_CHAIN (TREE_VALUE (attr)) is set, which + causes that the GOMP_free call is already added above. */ + tree v = TREE_OPERAND (DECL_VALUE_EXPR (t), 0); 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/ChangeLog.omp b/gcc/testsuite/ChangeLog.omp index 2d862b92797f..88428f2ef147 100644 --- a/gcc/testsuite/ChangeLog.omp +++ b/gcc/testsuite/ChangeLog.omp @@ -1,3 +1,22 @@ +2023-10-26 Tobias Burnus + + Backported from master: + 2023-10-14 Tobias Burnus + + * 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. + 2023-10-26 Tobias Burnus Chung-Lin Tang diff --git a/gcc/testsuite/c-c++-common/gomp/allocate-14.c b/gcc/testsuite/c-c++-common/gomp/allocate-14.c index b25da5497c5d..894921a76d5a 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 15105b9102e9..52cb7686b7b6 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 3c11080dd167..31382748be61 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 000000000000..e50db53c1a86 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/allocate-10.f90 @@ -0,0 +1,75 @@ +! { 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) + !$omp allocate(B1) allocator(my_handle) ! { dg-warning "31:'my_handle' is used uninitialized" } + B1(1) = 5 + ! { dg-final { scan-tree-dump-times "b1.\[0-9\]+ = __builtin_GOMP_alloc \\(4, 12, D\.\[0-9\]+\\);" 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) + !$omp allocate(B2) allocator(my_handle) ! { dg-warning "33:'my_handle' is used uninitialized" } + ! Similar above; B2 is unused - but in gfortran, the match in 'allocate(B2)' already + ! causes TREE_USED = 1 + ! { dg-final { scan-tree-dump-times "b2.\[0-9\]+ = __builtin_GOMP_alloc \\(4, 12, D\.\[0-9\]+\\);" 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 000000000000..8a8d93930b0a --- /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 000000000000..183c2941819a --- /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 000000000000..bf8a5a2bee27 --- /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 000000000000..8ff9c252e49b --- /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 000000000000..a0690a56394a --- /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 a2dcf105ee17..b93a37c780ca 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 b856204d48ae..ab85e327795a 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 000000000000..bb4d07d0c737 --- /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 000000000000..4d9553686c41 --- /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/ChangeLog.omp b/libgomp/ChangeLog.omp index 6df01bedf2e4..2e18098b4bce 100644 --- a/libgomp/ChangeLog.omp +++ b/libgomp/ChangeLog.omp @@ -1,3 +1,17 @@ +2023-10-26 Tobias Burnus + + Backported from master: + 2023-10-14 Tobias Burnus + + * libgomp.texi (OpenMP Impl. Status): Mention that Fortran now + supports the allocate directive for stack variables. + * testsuite/libgomp.fortran/allocate-5a.f90: Renamed from + testsuite/libgomp.fortran/allocate-5.f90. + * 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. + 2023-10-26 Tobias Burnus Chung-Lin Tang diff --git a/libgomp/libgomp.texi b/libgomp/libgomp.texi index c71c94c2ce7c..23a057568a1c 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 Some are only stubs @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 index f85a7cab123f..de9cd5a302e7 100644 --- a/libgomp/testsuite/libgomp.fortran/allocate-5.f90 +++ b/libgomp/testsuite/libgomp.fortran/allocate-5.f90 @@ -1,119 +1,87 @@ -! { dg-do compile } +! { dg-additional-options "-fdump-tree-gimple" } -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(:) - - x = 1 ! executable statement before '!$omp allocate' - - ! Don't use a hard-coded value (..., but it does pass the checks). - !$omp allocate (var1) allocator(10_omp_allocator_handle_kind) ! { dg-bogus "Expected integer expression of the 'omp_allocator_handle_kind' kind" } - allocate (var1(x)) - - ! Assumption is that 'omp_allocator_handle_kind' ('c_intptr_t') isn't 1. - !$omp allocate (var1) allocator(10_1) ! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind at .1." } - allocate (var1(x)) - - !$omp allocate (var2) ! { dg-error "'var2' specified in 'allocate' at .1. but not in the associated ALLOCATE statement" } - allocate (var3(x)) ! { dg-error "'var3' listed in 'allocate' statement at .1. but it is neither explicitly in listed in the '!.OMP ALLOCATE' directive nor exists a directive without argument list" } - - !$omp allocate (x) - x = 2 ! { dg-error "Unexpected assignment at .1.; expected ALLOCATE or !.OMP ALLOCATE statement" } - - !$omp allocate (var4) - y = 2 ! { dg-error "Unexpected assignment at .1.; expected ALLOCATE or !.OMP ALLOCATE statement" } - - !$omp allocate (var5) - !$omp allocate - allocate (var5(x)) - - !$omp allocate (var6) - !$omp allocate (var7) ! { dg-error "'var7' specified in 'allocate' at .1. but not in the associated ALLOCATE statement" } - !$omp allocate (var8) ! { dg-error "'var8' specified in 'allocate' at .1. but not in the associated ALLOCATE statement" } - allocate (var6(x)) - - !$omp allocate (var9) - !$omp allocate (var9) ! { dg-warning "var9' appears more than once in 'allocate'" } - allocate (var9(x)) - -end subroutine - -function outer(a) - IMPLICIT NONE - - integer :: outer, a - integer, allocatable :: var1 +! { dg-final { scan-tree-dump-times "__builtin_GOMP_alloc \\(" 5 "gimple" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(" 5 "gimple" } } - outer = inner(a) + 5 - return - contains - - integer function inner(x) - integer :: x - integer, allocatable :: var2 - - x = 1 ! executable statement before '!$omp allocate' - - !$omp allocate (var1, var2) ! { dg-error "Sorry, allocation of allocatable 'var1' with '!.omp allocators' or '!.omp allocate' at .1. is only suppored in the scope where it has been declared, unless it has the SAVE attribute" } - allocate (var1, var2) - - inner = x + 10 - return - end function inner - -end function outer - -subroutine bar(s) +module m 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) - allocate (mvar1) - - !$omp allocate (mvar2) - allocate (mvar2) - - !$omp allocate (mvar3) allocator(omp_low_lat_mem_alloc) - allocate (mvar3) - - !$omp allocate (svar1) allocator(a) - allocate (svar1) - - !$omp allocate (svar2) - allocate (svar2) + 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 - !$omp allocate (svar3) allocator(omp_low_lat_mem_alloc) - allocate (svar3) -end subroutine +use m +if (one () /= 1225) & + stop 1 +end diff --git a/libgomp/testsuite/libgomp.fortran/allocate-5a.f90 b/libgomp/testsuite/libgomp.fortran/allocate-5a.f90 new file mode 100644 index 000000000000..f85a7cab123f --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/allocate-5a.f90 @@ -0,0 +1,119 @@ +! { 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(:) + + x = 1 ! executable statement before '!$omp allocate' + + ! Don't use a hard-coded value (..., but it does pass the checks). + !$omp allocate (var1) allocator(10_omp_allocator_handle_kind) ! { dg-bogus "Expected integer expression of the 'omp_allocator_handle_kind' kind" } + allocate (var1(x)) + + ! Assumption is that 'omp_allocator_handle_kind' ('c_intptr_t') isn't 1. + !$omp allocate (var1) allocator(10_1) ! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind at .1." } + allocate (var1(x)) + + !$omp allocate (var2) ! { dg-error "'var2' specified in 'allocate' at .1. but not in the associated ALLOCATE statement" } + allocate (var3(x)) ! { dg-error "'var3' listed in 'allocate' statement at .1. but it is neither explicitly in listed in the '!.OMP ALLOCATE' directive nor exists a directive without argument list" } + + !$omp allocate (x) + x = 2 ! { dg-error "Unexpected assignment at .1.; expected ALLOCATE or !.OMP ALLOCATE statement" } + + !$omp allocate (var4) + y = 2 ! { dg-error "Unexpected assignment at .1.; expected ALLOCATE or !.OMP ALLOCATE statement" } + + !$omp allocate (var5) + !$omp allocate + allocate (var5(x)) + + !$omp allocate (var6) + !$omp allocate (var7) ! { dg-error "'var7' specified in 'allocate' at .1. but not in the associated ALLOCATE statement" } + !$omp allocate (var8) ! { dg-error "'var8' specified in 'allocate' at .1. but not in the associated ALLOCATE statement" } + allocate (var6(x)) + + !$omp allocate (var9) + !$omp allocate (var9) ! { dg-warning "var9' appears more than once in 'allocate'" } + 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 + + x = 1 ! executable statement before '!$omp allocate' + + !$omp allocate (var1, var2) ! { dg-error "Sorry, allocation of allocatable 'var1' with '!.omp allocators' or '!.omp allocate' at .1. is only suppored in the scope where it has been declared, unless it has the SAVE attribute" } + 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) + allocate (mvar1) + + !$omp allocate (mvar2) + allocate (mvar2) + + !$omp allocate (mvar3) allocator(omp_low_lat_mem_alloc) + allocate (mvar3) + + !$omp allocate (svar1) allocator(a) + allocate (svar1) + + !$omp allocate (svar2) + allocate (svar2) + + !$omp allocate (svar3) allocator(omp_low_lat_mem_alloc) + allocate (svar3) +end subroutine diff --git a/libgomp/testsuite/libgomp.fortran/allocate-6.f90 b/libgomp/testsuite/libgomp.fortran/allocate-6.f90 new file mode 100644 index 000000000000..5c32652f2a67 --- /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 000000000000..83f3eabfc3e1 --- /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 2 in no_alloc2_func. +! { dg-final { scan-tree-dump-times "__builtin_GOMP_alloc \\(" 10 "omplower" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(" 10 "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 000000000000..b9dea6c5148a --- /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 -- 2.47.3