* [Patch] Fortran: Support OpenMP's 'allocate' directive for stack vars @ 2023-10-10 16:46 Tobias Burnus 2023-10-13 11:01 ` Jakub Jelinek 0 siblings, 1 reply; 7+ messages in thread From: Tobias Burnus @ 2023-10-10 16:46 UTC (permalink / raw) To: gcc-patches, fortran, Jakub Jelinek [-- Attachment #1: Type: text/plain, Size: 1635 bytes --] 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 [-- Attachment #2: omp-allocate-fortran.diff --] [-- Type: text/x-patch, Size: 79184 bytes --] 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 {<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) "%<omp_allocator_handle_kind%> 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 %<allocate%> 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 %<allocator%> 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 ^ permalink raw reply [flat|nested] 7+ messages in thread
* Re: [Patch] Fortran: Support OpenMP's 'allocate' directive for stack vars 2023-10-10 16:46 [Patch] Fortran: Support OpenMP's 'allocate' directive for stack vars Tobias Burnus @ 2023-10-13 11:01 ` Jakub Jelinek 2023-10-13 13:29 ` Tobias Burnus 0 siblings, 1 reply; 7+ messages in thread From: Jakub Jelinek @ 2023-10-13 11:01 UTC (permalink / raw) To: Tobias Burnus; +Cc: gcc-patches, fortran On Tue, Oct 10, 2023 at 06:46:35PM +0200, Tobias Burnus wrote: > * parse.cc (check_omp_allocate_stmt): Permit procedure pointers > here (rejected later) for less mislreading diagnostic. s/misl/mis/ > libgomp/ChangeLog: > > * libgomp.texi: Fill in something here. > @@ -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) s/ n/ n/ > --- 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 %<allocator%> 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)); Probably already preexisting, by I wonder how safe remove_attribute is. Aren't attributes shared in some cases (like __attribute__((attr1, attr2, attr3)) int a, b, c, d;)? Not really sure if something unshares them afterwards. If they are shared, adding new attributes is fine, that will make the new additions not shared and the tail shared, but remove_attribute could remove it from all of them at once. Perhaps I'm wrong, haven't verified. Otherwise LGTM (though, I didn't spot anything about allocatables in the patch, am I just looking wrong or are they still unsupported)? Jakub ^ permalink raw reply [flat|nested] 7+ messages in thread
* Re: [Patch] Fortran: Support OpenMP's 'allocate' directive for stack vars 2023-10-13 11:01 ` Jakub Jelinek @ 2023-10-13 13:29 ` Tobias Burnus 2023-10-18 9:12 ` Thomas Schwinge 0 siblings, 1 reply; 7+ messages in thread From: Tobias Burnus @ 2023-10-13 13:29 UTC (permalink / raw) To: Jakub Jelinek; +Cc: gcc-patches, fortran [-- Attachment #1: Type: text/plain, Size: 2845 bytes --] On 13.10.23 13:01, Jakub Jelinek wrote: > On Tue, Oct 10, 2023 at 06:46:35PM +0200, Tobias Burnus wrote: > +++ b/gcc/gimplify.cc >> @@ -1400,23 +1400,53 @@ gimplify_bind_expr (tree *expr_p, gimple_seq *pre_p) >> + else if (errorcount >> + || (align == NULL_TREE >> + && alloc != NULL_TREE >> + && integer_onep (alloc))) >> + DECL_ATTRIBUTES (t) = remove_attribute ("omp allocate", >> + DECL_ATTRIBUTES (t)); > Probably already preexisting, by I wonder how safe remove_attribute is. > Aren't attributes shared in some cases > (like __attribute__((attr1, attr2, attr3)) int a, b, c, d;)? I think there should be no problem – new attributes get added as: DECL_ATTRIBUTES (var) = tree_cons (get_identifier ("omp allocate"), t, DECL_ATTRIBUTES (var)); Thus, attr = DECL_ATTRIBUTES (var) is not shared, even if TREE_CHAIN (attr) might be shared. Thus, as long as new attributes get added at the head of the chain, there should be no issue. And "omp allocate" is added once per decl and is therefore not shared - removing might create again a shared tree, but any following 'tree_cons' will again unshare it. I think in your case, there would be indeed a problem when doing: 'tree attr = remove_attr (...("attr2") ...)' as this would remove "attr2" for 4 decls. * * * However, as 'omp allocate' is not used later on, I also do not need to remove it. => Updated patch attached + interdiff for gimplify.cc attached. Changes: * Condition now the same as previously * Keep 'omp allocate' also for DECL_VALUE_EXPR variable * Add assert that we either have Fortran's expression the GOMP_FREE location - or a DECL_VALUE_EXPR. * Make use of the assertion by keeping the HAS_DECL_VALUE expr below; this avoids adding an align/allocator == default check. => same code as old code, except for creating + using 'v' variable and adding a clobber. * * * > Otherwise LGTM (though, I didn't spot anything about allocatables in the > patch, am I just looking wrong or are they still unsupported)? It's unsupported – albeit Chung-Lin has some patch for it. The code path is completely different. It already starts by 'omp allocators' (+ legacy: 'omp allocate') being not declarative but executable and associated with a Fortran 'allocate' statement and ... Sorry for being slow - but I keep getting distracted by other tasks ... 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 [-- Attachment #2: interdiff.diff --] [-- Type: text/x-patch, Size: 2666 bytes --] diff -u b/gcc/gimplify.cc b/gcc/gimplify.cc --- b/gcc/gimplify.cc +++ b/gcc/gimplify.cc @@ -1400,13 +1400,10 @@ "region must specify an %<allocator%> 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))) - DECL_ATTRIBUTES (t) = remove_attribute ("omp allocate", - DECL_ATTRIBUTES (t)); - else + else if (!errorcount + && (align != NULL_TREE + || alloc == NULL_TREE + || !integer_onep (alloc))) { /* Fortran might already use a pointer type internally; use that pointer except for type(C_ptr) and type(C_funptr); @@ -1426,10 +1423,10 @@ 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); + 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); @@ -1461,6 +1458,11 @@ 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); + /* 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))) { /* Fortran is special as it does not have properly nest @@ -1631,14 +1633,15 @@ { tree attr; if (flag_openmp + && DECL_HAS_VALUE_EXPR_P (t) && TREE_USED (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); + /* 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, v, build_zero_cst (ptr_type_node)); [-- Attachment #3: omp-allocate-fortran-v3.diff --] [-- Type: text/x-patch, Size: 79304 bytes --] 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-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 | 126 +++++++++ gcc/fortran/trans-openmp.cc | 77 +++-- gcc/gimplify.cc | 166 ++++++++--- 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 | 75 +++++ 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, 1484 insertions(+), 99 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..1cc65d7fa49 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 {<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) "%<omp_allocator_handle_kind%> 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 %<allocate%> 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..a3f037bd07b 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,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 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..9c617c21381 100644 --- a/gcc/gimplify.cc +++ b/gcc/gimplify.cc @@ -1405,18 +1405,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) @@ -1425,28 +1452,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); + } } } @@ -1539,16 +1631,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/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..e50db53c1a8 --- /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 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 6a7770084d2..c163411c529 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..83f3eabfc3e --- /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 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 ^ permalink raw reply [flat|nested] 7+ messages in thread
* Re: [Patch] Fortran: Support OpenMP's 'allocate' directive for stack vars 2023-10-13 13:29 ` Tobias Burnus @ 2023-10-18 9:12 ` Thomas Schwinge 2023-10-18 9:36 ` Jakub Jelinek 0 siblings, 1 reply; 7+ messages in thread From: Thomas Schwinge @ 2023-10-18 9:12 UTC (permalink / raw) To: Tobias Burnus; +Cc: Jakub Jelinek, gcc-patches, fortran Hi Tobias! On 2023-10-13T15:29:52+0200, Tobias Burnus <tobias@codesourcery.com> wrote: > => Updated patch attached When cherry-picking this commit cccc2d3dbf0eff668bed5f5f168b3cafd8590c54 "Fortran: Support OpenMP's 'allocate' directive for stack vars" on top of slightly older GCC sources (mentioning that just in case that's relevant), in a configuration with offloading enabled (only), I see: +FAIL: gfortran.dg/gomp/allocate-13.f90 -O (internal compiler error: tree code 'statement_list' is not supported in LTO streams) +FAIL: gfortran.dg/gomp/allocate-13.f90 -O (test for excess errors) during IPA pass: modref [...]/gcc/testsuite/gfortran.dg/gomp/allocate-13.f90:10:3: internal compiler error: tree code 'statement_list' is not supported in LTO streams 0x13374fd lto_write_tree [...]/gcc/lto-streamer-out.cc:561 0x13374fd lto_output_tree_1 [...]/gcc/lto-streamer-out.cc:599 0x133f55b DFS::DFS(output_block*, tree_node*, bool, bool, bool) [...]/gcc/lto-streamer-out.cc:899 0x1340287 lto_output_tree(output_block*, tree_node*, bool, bool) [...]/gcc/lto-streamer-out.cc:1865 0x134197a output_function [...]/gcc/lto-streamer-out.cc:2436 0x134197a lto_output() [...]/gcc/lto-streamer-out.cc:2807 0x13d0551 write_lto [...]/gcc/passes.cc:2774 0x13d0551 ipa_write_summaries_1 [...]/gcc/passes.cc:2838 0x13d0551 ipa_write_summaries() [...]/gcc/passes.cc:2894 0x1002f2c ipa_passes [...]/gcc/cgraphunit.cc:2251 0x1002f2c symbol_table::compile() [...]/gcc/cgraphunit.cc:2331 0x10056b7 symbol_table::compile() [...]/gcc/cgraphunit.cc:2311 0x10056b7 symbol_table::finalize_compilation_unit() [...]/gcc/cgraphunit.cc:2583 Similarly: +FAIL: libgomp.fortran/allocate-6.f90 -O (internal compiler error: tree code 'statement_list' is not supported in LTO streams) +FAIL: libgomp.fortran/allocate-7.f90 -O (internal compiler error: tree code 'statement_list' is not supported in LTO streams) Grüße Thomas > 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-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 | 126 +++++++++ > gcc/fortran/trans-openmp.cc | 77 +++-- > gcc/gimplify.cc | 166 ++++++++--- > 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 | 75 +++++ > 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, 1484 insertions(+), 99 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..1cc65d7fa49 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 {<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) > "%<omp_allocator_handle_kind%> 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 %<allocate%> 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..a3f037bd07b 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,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 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..9c617c21381 100644 > --- a/gcc/gimplify.cc > +++ b/gcc/gimplify.cc > @@ -1405,18 +1405,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) > @@ -1425,28 +1452,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); > + } > } > } > > @@ -1539,16 +1631,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/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..e50db53c1a8 > --- /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 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 6a7770084d2..c163411c529 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..83f3eabfc3e > --- /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 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 ----------------- 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 ^ permalink raw reply [flat|nested] 7+ messages in thread
* Re: [Patch] Fortran: Support OpenMP's 'allocate' directive for stack vars 2023-10-18 9:12 ` Thomas Schwinge @ 2023-10-18 9:36 ` Jakub Jelinek 2023-10-18 10:56 ` [Patch] OpenMP: Avoid ICE with LTO and 'omp allocate (was: [Patch] Fortran: Support OpenMP's 'allocate' directive for stack vars) Tobias Burnus 0 siblings, 1 reply; 7+ messages in thread From: Jakub Jelinek @ 2023-10-18 9:36 UTC (permalink / raw) To: Thomas Schwinge; +Cc: Tobias Burnus, gcc-patches, fortran On Wed, Oct 18, 2023 at 11:12:44AM +0200, Thomas Schwinge wrote: > Hi Tobias! > > On 2023-10-13T15:29:52+0200, Tobias Burnus <tobias@codesourcery.com> wrote: > > => Updated patch attached > > When cherry-picking this commit cccc2d3dbf0eff668bed5f5f168b3cafd8590c54 > "Fortran: Support OpenMP's 'allocate' directive for stack vars" on top of > slightly older GCC sources (mentioning that just in case that's > relevant), in a configuration with offloading enabled (only), I see: > > +FAIL: gfortran.dg/gomp/allocate-13.f90 -O (internal compiler error: tree code 'statement_list' is not supported in LTO streams) > +FAIL: gfortran.dg/gomp/allocate-13.f90 -O (test for excess errors) Any references to GENERIC code in clauses etc. should have been gimplified or cleared during gimplification, we shouldn't support STATEMENT_LIST in LTO streaming. Jakub ^ permalink raw reply [flat|nested] 7+ messages in thread
* [Patch] OpenMP: Avoid ICE with LTO and 'omp allocate (was: [Patch] Fortran: Support OpenMP's 'allocate' directive for stack vars) 2023-10-18 9:36 ` Jakub Jelinek @ 2023-10-18 10:56 ` Tobias Burnus 2023-10-18 11:01 ` Jakub Jelinek 0 siblings, 1 reply; 7+ messages in thread From: Tobias Burnus @ 2023-10-18 10:56 UTC (permalink / raw) To: Jakub Jelinek, gcc-patches; +Cc: fortran, Thomas Schwinge [-- Attachment #1: Type: text/plain, Size: 1138 bytes --] On 18.10.23 11:36, Jakub Jelinek wrote: > On Wed, Oct 18, 2023 at 11:12:44AM +0200, Thomas Schwinge wrote: >> +FAIL: gfortran.dg/gomp/allocate-13.f90 -O (internal compiler error: tree code 'statement_list' is not supported in LTO streams) > Any references to GENERIC code in clauses etc. should have been gimplified > or cleared during gimplification, we shouldn't support STATEMENT_LIST > in LTO streaming. We only needed the statement list as aid during the gimplify.cc handling of GOMP_alloc/GOMP_free for Fortran. How about just remove_attribute it in that case? As discussed, as DECL_ATTRIBUTE gets added from the left to the DECL_CHAIN, there shouldn't be a problem of introducing shared trees; note that 'omp allocate' itself is added per DECL, i.e. it does not introduce sharing itself, either. Tested with x86-64-gnu-linux. 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 [-- Attachment #2: fix-lto.diff --] [-- Type: text/x-patch, Size: 3585 bytes --] OpenMP: Avoid ICE with LTO and 'omp allocate' gcc/ChangeLog: * gimplify.cc (gimplify_bind_expr): Remove "omp allocate" attribute to avoid that auxillary statement list reaches to LTO. gcc/testsuite/ChangeLog: * gfortran.dg/gomp/allocate-13a.f90: New test. gcc/gimplify.cc | 18 ++++++++----- gcc/testsuite/gfortran.dg/gomp/allocate-13a.f90 | 34 +++++++++++++++++++++++++ 2 files changed, 45 insertions(+), 7 deletions(-) diff --git a/gcc/gimplify.cc b/gcc/gimplify.cc index 9c617c21381..22ff1075abb 100644 --- a/gcc/gimplify.cc +++ b/gcc/gimplify.cc @@ -1426,7 +1426,8 @@ gimplify_bind_expr (tree *expr_p, gimple_seq *pre_p) DECL_ATTRIBUTES (v) = tree_cons (get_identifier ("omp allocate var"), build_tree_list (NULL_TREE, t), - DECL_ATTRIBUTES (t)); + remove_attribute ("omp allocate", + DECL_ATTRIBUTES (t))); tmp = build_fold_indirect_ref (v); TREE_THIS_NOTRAP (tmp) = 1; SET_DECL_VALUE_EXPR (t, tmp); @@ -1473,7 +1474,12 @@ gimplify_bind_expr (tree *expr_p, gimple_seq *pre_p) 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. */ + size expr but still an expr might be available. + As LTO does not handle a statement list, 'sl' has + to be removed; done so by removing the attribute. */ + DECL_ATTRIBUTES (t) + = remove_attribute ("omp allocate", + DECL_ATTRIBUTES (t)); tree sl = TREE_PURPOSE (TREE_CHAIN (TREE_VALUE (attr))); tree_stmt_iterator e = tsi_start (sl); tree needle = NULL_TREE; @@ -1631,16 +1637,14 @@ 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) - && ((attr = lookup_attribute ("omp allocate", - DECL_ATTRIBUTES (t))) != NULL_TREE) - && TREE_CHAIN (TREE_VALUE (attr)) == NULL_TREE) + && lookup_attribute ("omp allocate", DECL_ATTRIBUTES (t))) { /* For Fortran, TREE_CHAIN (TREE_VALUE (attr)) is set, which - causes that the GOMP_free call is already added above. */ + causes that the GOMP_free call is already added above; + and "omp allocate" is removed from DECL_ATTRIBUTES. */ 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, v, diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-13a.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-13a.f90 new file mode 100644 index 00000000000..4b297cdb4aa --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/allocate-13a.f90 @@ -0,0 +1,34 @@ +! { dg-do compile { target lto } } +! { dg-additional-options "-flto" } + +! Same as allocate-13.f90 but compiled with -flto. + +! This was failing before as the statement list, +! used for placing the GOMP_alloc/GOMP_free leaked +! through to LTO. + +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 ^ permalink raw reply [flat|nested] 7+ messages in thread
* Re: [Patch] OpenMP: Avoid ICE with LTO and 'omp allocate (was: [Patch] Fortran: Support OpenMP's 'allocate' directive for stack vars) 2023-10-18 10:56 ` [Patch] OpenMP: Avoid ICE with LTO and 'omp allocate (was: [Patch] Fortran: Support OpenMP's 'allocate' directive for stack vars) Tobias Burnus @ 2023-10-18 11:01 ` Jakub Jelinek 0 siblings, 0 replies; 7+ messages in thread From: Jakub Jelinek @ 2023-10-18 11:01 UTC (permalink / raw) To: Tobias Burnus; +Cc: gcc-patches, fortran, Thomas Schwinge On Wed, Oct 18, 2023 at 12:56:01PM +0200, Tobias Burnus wrote: > On 18.10.23 11:36, Jakub Jelinek wrote: > > On Wed, Oct 18, 2023 at 11:12:44AM +0200, Thomas Schwinge wrote: > > > +FAIL: gfortran.dg/gomp/allocate-13.f90 -O (internal compiler error: tree code 'statement_list' is not supported in LTO streams) > > Any references to GENERIC code in clauses etc. should have been gimplified > > or cleared during gimplification, we shouldn't support STATEMENT_LIST > > in LTO streaming. > > We only needed the statement list as aid during the gimplify.cc handling > of GOMP_alloc/GOMP_free for Fortran. How about just remove_attribute it > in that case? As discussed, as DECL_ATTRIBUTE gets added from the left > to the DECL_CHAIN, there shouldn't be a problem of introducing shared > trees; note that 'omp allocate' itself is added per DECL, i.e. it does > not introduce sharing itself, either. > > Tested with x86-64-gnu-linux. > > 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 > OpenMP: Avoid ICE with LTO and 'omp allocate' > > gcc/ChangeLog: > > * gimplify.cc (gimplify_bind_expr): Remove "omp allocate" attribute > to avoid that auxillary statement list reaches to LTO. > > gcc/testsuite/ChangeLog: > > * gfortran.dg/gomp/allocate-13a.f90: New test. LGTM. Jakub ^ permalink raw reply [flat|nested] 7+ messages in thread
end of thread, other threads:[~2023-10-18 11:01 UTC | newest] Thread overview: 7+ messages (download: mbox.gz / follow: Atom feed) -- links below jump to the message on this page -- 2023-10-10 16:46 [Patch] Fortran: Support OpenMP's 'allocate' directive for stack vars Tobias Burnus 2023-10-13 11:01 ` Jakub Jelinek 2023-10-13 13:29 ` Tobias Burnus 2023-10-18 9:12 ` Thomas Schwinge 2023-10-18 9:36 ` Jakub Jelinek 2023-10-18 10:56 ` [Patch] OpenMP: Avoid ICE with LTO and 'omp allocate (was: [Patch] Fortran: Support OpenMP's 'allocate' directive for stack vars) Tobias Burnus 2023-10-18 11:01 ` Jakub Jelinek
This is a public inbox, see mirroring instructions for how to clone and mirror all data and code used for this inbox; as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).