[gomp3] OpenMP 3.0 allocatable arrays support
Jakub Jelinek
jakub@redhat.com
Thu Feb 28 14:52:00 GMT 2008
Hi!
The upcoming OpenMP standard allows ALLOCATABLE arrays in many more places
than the older standard and for private clause which before allowed
allocatable arrays only if they were .not.allocated() before the parallel
now allows even if they are allocated. This has some minor consequences,
e.g. private allocatable arrays now need to look at the outer context's
variable to check if it is allocated or not.
Regtested on x86_64-linux, committed to gomp-3_0-branch.
2008-02-28 Jakub Jelinek <jakub@redhat.com>
* langhooks.h (lang_hooks_for_decls): Add omp_private_outer_ref
hook, add another argument to omp_clause_default_ctor hook.
* langhooks-def.h (LANG_HOOKS_OMP_PRIVATE_OUTER_REF): Define.
(LANG_HOOKS_OMP_CLAUSE_DEFAULT_CTOR): Change to
hook_tree_tree_tree_tree_null.
(LANG_HOOKS_DECLS): Add LANG_HOOKS_OMP_PRIVATE_OUTER_REF.
* hooks.c (hook_tree_tree_tree_tree_null): New function.
* hooks.h (hook_tree_tree_tree_tree_null): New prototype.
* gimplify.c (enum gimplify_omp_var_data): Add GOVD_PRIVATE_OUTER_REF.
(omp_notice_variable): Set GOVD_PRIVATE_OUTER_REF if needed,
if it is set, lookup var in outer contexts too.
(gimplify_scan_omp_clauses): Likewise, set
OMP_CLAUSE_PRIVATE_OUTER_REF if GOVD_PRIVATE_OUTER_REF is set.
(gimplify_adjust_omp_clauses_1): Set OMP_CLAUSE_PRIVATE_OUTER_REF if
GOVD_PRIVATE_OUTER_REF is set.
* tree-nested.c (convert_nonlocal_omp_clauses,
convert_local_omp_clauses): Set placeholder context before walking
OMP_CLAUSE_REDUCTION_INIT.
* tree.h (OMP_CLAUSE_PRIVATE_OUTER_REF): Define.
* omp-low.c (scan_sharing_clauses): Handle
OMP_CLAUSE_PRIVATE_OUTER_REF.
(lower_rec_input_clauses): Pass outer var ref to
omp_clause_default_ctor hook if OMP_CLAUSE_PRIVATE_OUTER_REF
or OMP_CLAUSE_LASTPRIVATE. Replace OMP_CLAUSE_REDUCTION_PLACEHOLDER
decls in OMP_CLAUSE_REDUCTION_INIT.
(lower_send_clauses): Handle OMP_CLAUSE_PRIVATE_OUTER_REF.
* cp-tree.h (cxx_omp_clause_default_ctor): Add outer argument.
* cp-gimplify.c (cxx_omp_clause_default_ctor): Likewise.
* openmp.c (resolve_omp_clauses): Allow allocatable arrays in
firstprivate, lastprivate, reduction, copyprivate and copyin
clauses.
* trans-openmp.c (gfc_omp_private_outer_ref): New function.
(gfc_omp_clause_default_ctor): Add outer argument. For allocatable
arrays allocate them with the bounds of the outer var if outer
var is allocated.
(gfc_omp_clause_copy_ctor, gfc_omp_clause_assign_op,
gfc_omp_clause_dtor): New functions.
(gfc_trans_omp_array_reduction): If decl is allocatable array,
allocate it with outer var's bounds in OMP_CLAUSE_REDUCTION_INIT
and deallocate it in OMP_CLAUSE_REDUCTION_MERGE.
* trans.h (gfc_omp_clause_default_ctor): Add another argument.
(gfc_omp_clause_copy_ctor, gfc_omp_clause_assign_op,
gfc_omp_clause_dtor, gfc_omp_private_outer_ref): New prototypes.
* f95-lang.c (LANG_HOOKS_OMP_CLAUSE_COPY_CTOR,
LANG_HOOKS_OMP_CLAUSE_ASSIGN_OP, LANG_HOOKS_OMP_CLAUSE_DTOR,
LANG_HOOKS_OMP_PRIVATE_OUTER_REF): Define.
* gfortran.dg/gomp/appendix-a/a.33.4.f90: Remove dg-error
about allocatable array.
* gfortran.dg/gomp/reduction1.f90: Likewise.
* testsuite/libgomp.fortran/allocatable1.f90: New test.
* testsuite/libgomp.fortran/allocatable2.f90: New test.
--- gcc/langhooks.h (revision 132481)
+++ gcc/langhooks.h (working copy)
@@ -1,5 +1,5 @@
/* The lang_hooks data structure.
- Copyright 2001, 2002, 2003, 2004, 2005, 2006, 2007
+ Copyright 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
Free Software Foundation, Inc.
This file is part of GCC.
@@ -216,9 +216,14 @@ struct lang_hooks_for_decls
be put into OMP_CLAUSE_PRIVATE_DEBUG. */
bool (*omp_private_debug_clause) (tree, bool);
+ /* Return true if DECL in private clause needs
+ OMP_CLAUSE_PRIVATE_OUTER_REF on the private clause. */
+ bool (*omp_private_outer_ref) (tree);
+
/* Build and return code for a default constructor for DECL in
- response to CLAUSE. Return NULL if nothing to be done. */
- tree (*omp_clause_default_ctor) (tree clause, tree decl);
+ response to CLAUSE. OUTER is corresponding outer region's
+ variable if needed. Return NULL if nothing to be done. */
+ tree (*omp_clause_default_ctor) (tree clause, tree decl, tree outer);
/* Build and return code for a copy constructor from SRC to DST. */
tree (*omp_clause_copy_ctor) (tree clause, tree dst, tree src);
--- gcc/gimplify.c (revision 132668)
+++ gcc/gimplify.c (working copy)
@@ -62,6 +62,7 @@ enum gimplify_omp_var_data
GOVD_REDUCTION = 64,
GOVD_LOCAL = 128,
GOVD_DEBUG_PRIVATE = 256,
+ GOVD_PRIVATE_OUTER_REF = 512,
GOVD_DATA_SHARE_CLASS = (GOVD_SHARED | GOVD_PRIVATE | GOVD_FIRSTPRIVATE
| GOVD_LASTPRIVATE | GOVD_REDUCTION | GOVD_LOCAL)
};
@@ -4952,6 +4953,10 @@ omp_notice_variable (struct gimplify_omp
gcc_unreachable ();
}
+ if ((flags & GOVD_PRIVATE)
+ && lang_hooks.decls.omp_private_outer_ref (decl))
+ flags |= GOVD_PRIVATE_OUTER_REF;
+
omp_add_variable (ctx, decl, flags);
shared = (flags & GOVD_SHARED) != 0;
@@ -4971,7 +4976,7 @@ omp_notice_variable (struct gimplify_omp
do_outer:
/* If the variable is private in the current context, then we don't
need to propagate anything to an outer context. */
- if (flags & GOVD_PRIVATE)
+ if ((flags & GOVD_PRIVATE) && !(flags & GOVD_PRIVATE_OUTER_REF))
return ret;
if (ctx->outer_context
&& omp_notice_variable (ctx->outer_context, decl, in_code))
@@ -5076,7 +5081,13 @@ gimplify_scan_omp_clauses (tree *list_p,
{
case OMP_CLAUSE_PRIVATE:
flags = GOVD_PRIVATE | GOVD_EXPLICIT;
- notice_outer = false;
+ if (lang_hooks.decls.omp_private_outer_ref (OMP_CLAUSE_DECL (c)))
+ {
+ flags |= GOVD_PRIVATE_OUTER_REF;
+ OMP_CLAUSE_PRIVATE_OUTER_REF (c) = 1;
+ }
+ else
+ notice_outer = false;
goto do_add;
case OMP_CLAUSE_SHARED:
flags = GOVD_SHARED | GOVD_EXPLICIT;
@@ -5253,6 +5264,8 @@ gimplify_adjust_omp_clauses_1 (splay_tre
OMP_CLAUSE_CHAIN (clause) = *list_p;
if (private_debug)
OMP_CLAUSE_PRIVATE_DEBUG (clause) = 1;
+ else if (code == OMP_CLAUSE_PRIVATE && (flags & GOVD_PRIVATE_OUTER_REF))
+ OMP_CLAUSE_PRIVATE_OUTER_REF (clause) = 1;
*list_p = clause;
return 0;
--- gcc/tree-nested.c (revision 132492)
+++ gcc/tree-nested.c (working copy)
@@ -1240,11 +1240,11 @@ convert_nonlocal_omp_clauses (tree *pcla
{
tree old_context
= DECL_CONTEXT (OMP_CLAUSE_REDUCTION_PLACEHOLDER (clause));
- walk_body (convert_nonlocal_reference, info,
- &OMP_CLAUSE_REDUCTION_INIT (clause));
DECL_CONTEXT (OMP_CLAUSE_REDUCTION_PLACEHOLDER (clause))
= info->context;
walk_body (convert_nonlocal_reference, info,
+ &OMP_CLAUSE_REDUCTION_INIT (clause));
+ walk_body (convert_nonlocal_reference, info,
&OMP_CLAUSE_REDUCTION_MERGE (clause));
DECL_CONTEXT (OMP_CLAUSE_REDUCTION_PLACEHOLDER (clause))
= old_context;
@@ -1581,11 +1581,11 @@ convert_local_omp_clauses (tree *pclause
{
tree old_context
= DECL_CONTEXT (OMP_CLAUSE_REDUCTION_PLACEHOLDER (clause));
- walk_body (convert_local_reference, info,
- &OMP_CLAUSE_REDUCTION_INIT (clause));
DECL_CONTEXT (OMP_CLAUSE_REDUCTION_PLACEHOLDER (clause))
= info->context;
walk_body (convert_local_reference, info,
+ &OMP_CLAUSE_REDUCTION_INIT (clause));
+ walk_body (convert_local_reference, info,
&OMP_CLAUSE_REDUCTION_MERGE (clause));
DECL_CONTEXT (OMP_CLAUSE_REDUCTION_PLACEHOLDER (clause))
= old_context;
--- gcc/langhooks-def.h (revision 132481)
+++ gcc/langhooks-def.h (working copy)
@@ -213,7 +213,8 @@ extern tree lhd_make_node (enum tree_cod
#define LANG_HOOKS_OMP_PREDETERMINED_SHARING lhd_omp_predetermined_sharing
#define LANG_HOOKS_OMP_DISREGARD_VALUE_EXPR hook_bool_tree_bool_false
#define LANG_HOOKS_OMP_PRIVATE_DEBUG_CLAUSE hook_bool_tree_bool_false
-#define LANG_HOOKS_OMP_CLAUSE_DEFAULT_CTOR hook_tree_tree_tree_null
+#define LANG_HOOKS_OMP_PRIVATE_OUTER_REF hook_bool_tree_false
+#define LANG_HOOKS_OMP_CLAUSE_DEFAULT_CTOR hook_tree_tree_tree_tree_null
#define LANG_HOOKS_OMP_CLAUSE_COPY_CTOR lhd_omp_assignment
#define LANG_HOOKS_OMP_CLAUSE_ASSIGN_OP lhd_omp_assignment
#define LANG_HOOKS_OMP_CLAUSE_DTOR hook_tree_tree_tree_null
@@ -231,6 +232,7 @@ extern tree lhd_make_node (enum tree_cod
LANG_HOOKS_OMP_PREDETERMINED_SHARING, \
LANG_HOOKS_OMP_DISREGARD_VALUE_EXPR, \
LANG_HOOKS_OMP_PRIVATE_DEBUG_CLAUSE, \
+ LANG_HOOKS_OMP_PRIVATE_OUTER_REF, \
LANG_HOOKS_OMP_CLAUSE_DEFAULT_CTOR, \
LANG_HOOKS_OMP_CLAUSE_COPY_CTOR, \
LANG_HOOKS_OMP_CLAUSE_ASSIGN_OP, \
--- gcc/hooks.c (revision 132481)
+++ gcc/hooks.c (working copy)
@@ -291,6 +291,14 @@ hook_tree_tree_tree_null (tree t0 ATTRIB
return NULL;
}
+tree
+hook_tree_tree_tree_tree_null (tree t0 ATTRIBUTE_UNUSED,
+ tree t1 ATTRIBUTE_UNUSED,
+ tree t2 ATTRIBUTE_UNUSED)
+{
+ return NULL;
+}
+
/* Generic hook that takes a rtx and returns a NULL string. */
const char *
hook_constcharptr_const_rtx_null (const_rtx r ATTRIBUTE_UNUSED)
--- gcc/hooks.h (revision 132481)
+++ gcc/hooks.h (working copy)
@@ -63,6 +63,7 @@ extern int hook_int_size_t_constcharptr_
extern int hook_int_void_no_regs (void);
extern tree hook_tree_tree_tree_null (tree, tree);
+extern tree hook_tree_tree_tree_tree_null (tree, tree, tree);
extern tree hook_tree_tree_tree_tree_3rd_identity (tree, tree, tree);
extern tree hook_tree_tree_tree_bool_null (tree, tree, bool);
--- gcc/tree.h (revision 132492)
+++ gcc/tree.h (working copy)
@@ -317,7 +317,7 @@ enum omp_clause_code
Operand 2: OMP_CLAUSE_REDUCTION_MERGE: Stmt-list to merge private var
into the shared one.
Operand 3: OMP_CLAUSE_REDUCTION_PLACEHOLDER: A dummy VAR_DECL
- placeholder used in OMP_CLAUSE_REDUCTION_MERGE. */
+ placeholder used in OMP_CLAUSE_REDUCTION_{INIT,MERGE}. */
OMP_CLAUSE_REDUCTION,
/* OpenMP clause: copyin (variable_list). */
@@ -501,6 +501,8 @@ struct gimple_stmt GTY(())
OMP_SECTION
OMP_PARALLEL_COMBINED in
OMP_PARALLEL
+ OMP_CLAUSE_PRIVATE_OUTER_REF in
+ OMP_CLAUSE_PRIVATE
protected_flag:
@@ -1813,6 +1815,11 @@ struct tree_constructor GTY(())
#define OMP_CLAUSE_PRIVATE_DEBUG(NODE) \
TREE_PUBLIC (OMP_CLAUSE_SUBCODE_CHECK (NODE, OMP_CLAUSE_PRIVATE))
+/* True on a PRIVATE clause if ctor needs access to outer region's
+ variable. */
+#define OMP_CLAUSE_PRIVATE_OUTER_REF(NODE) \
+ TREE_PRIVATE (OMP_CLAUSE_SUBCODE_CHECK (NODE, OMP_CLAUSE_PRIVATE))
+
/* True on a LASTPRIVATE clause if a FIRSTPRIVATE clause for the same
decl is present in the chain. */
#define OMP_CLAUSE_LASTPRIVATE_FIRSTPRIVATE(NODE) \
--- gcc/omp-low.c (revision 132492)
+++ gcc/omp-low.c (working copy)
@@ -1061,7 +1061,9 @@ scan_sharing_clauses (tree clauses, omp_
{
case OMP_CLAUSE_PRIVATE:
decl = OMP_CLAUSE_DECL (c);
- if (!is_variable_sized (decl))
+ if (OMP_CLAUSE_PRIVATE_OUTER_REF (c))
+ goto do_private;
+ else if (!is_variable_sized (decl))
install_var_local (decl, ctx);
break;
@@ -1933,7 +1935,12 @@ lower_rec_input_clauses (tree clauses, t
/* FALLTHRU */
case OMP_CLAUSE_PRIVATE:
- x = lang_hooks.decls.omp_clause_default_ctor (c, new_var);
+ if (OMP_CLAUSE_CODE (c) != OMP_CLAUSE_PRIVATE
+ || OMP_CLAUSE_PRIVATE_OUTER_REF (c))
+ x = build_outer_var_ref (var, ctx);
+ else
+ x = NULL;
+ x = lang_hooks.decls.omp_clause_default_ctor (c, new_var, x);
if (x)
gimplify_and_add (x, ilist);
/* FALLTHRU */
@@ -1966,8 +1973,16 @@ lower_rec_input_clauses (tree clauses, t
case OMP_CLAUSE_REDUCTION:
if (OMP_CLAUSE_REDUCTION_PLACEHOLDER (c))
{
+ tree placeholder = OMP_CLAUSE_REDUCTION_PLACEHOLDER (c);
+ x = build_outer_var_ref (var, ctx);
+
+ if (is_reference (var))
+ x = build_fold_addr_expr (x);
+ SET_DECL_VALUE_EXPR (placeholder, x);
+ DECL_HAS_VALUE_EXPR_P (placeholder) = 1;
gimplify_and_add (OMP_CLAUSE_REDUCTION_INIT (c), ilist);
OMP_CLAUSE_REDUCTION_INIT (c) = NULL;
+ DECL_HAS_VALUE_EXPR_P (placeholder) = 0;
}
else
{
@@ -2227,6 +2242,10 @@ lower_send_clauses (tree clauses, tree *
switch (OMP_CLAUSE_CODE (c))
{
+ case OMP_CLAUSE_PRIVATE:
+ if (OMP_CLAUSE_PRIVATE_OUTER_REF (c))
+ break;
+ continue;
case OMP_CLAUSE_FIRSTPRIVATE:
case OMP_CLAUSE_COPYIN:
case OMP_CLAUSE_LASTPRIVATE:
@@ -2248,6 +2267,7 @@ lower_send_clauses (tree clauses, tree *
switch (OMP_CLAUSE_CODE (c))
{
+ case OMP_CLAUSE_PRIVATE:
case OMP_CLAUSE_FIRSTPRIVATE:
case OMP_CLAUSE_COPYIN:
do_in = true;
@@ -2261,7 +2281,11 @@ lower_send_clauses (tree clauses, tree *
do_in = true;
}
else
- do_out = true;
+ {
+ do_out = true;
+ if (lang_hooks.decls.omp_private_outer_ref (val))
+ do_in = true;
+ }
break;
case OMP_CLAUSE_REDUCTION:
--- gcc/cp/cp-tree.h (revision 132668)
+++ gcc/cp/cp-tree.h (working copy)
@@ -4672,7 +4672,7 @@ extern void finish_omp_barrier (void);
extern void finish_omp_flush (void);
extern void finish_omp_taskwait (void);
extern enum omp_clause_default_kind cxx_omp_predetermined_sharing (tree);
-extern tree cxx_omp_clause_default_ctor (tree, tree);
+extern tree cxx_omp_clause_default_ctor (tree, tree, tree);
extern tree cxx_omp_clause_copy_ctor (tree, tree, tree);
extern tree cxx_omp_clause_assign_op (tree, tree, tree);
extern tree cxx_omp_clause_dtor (tree, tree);
--- gcc/cp/cp-gimplify.c (revision 132554)
+++ gcc/cp/cp-gimplify.c (working copy)
@@ -898,7 +898,8 @@ cxx_omp_clause_apply_fn (tree fn, tree a
NULL if there's nothing to do. */
tree
-cxx_omp_clause_default_ctor (tree clause, tree decl)
+cxx_omp_clause_default_ctor (tree clause, tree decl,
+ tree outer ATTRIBUTE_UNUSED)
{
tree info = CP_OMP_CLAUSE_INFO (clause);
tree ret = NULL;
--- gcc/fortran/openmp.c (revision 132481)
+++ gcc/fortran/openmp.c (working copy)
@@ -1,5 +1,5 @@
/* OpenMP directive matching and resolving.
- Copyright (C) 2005, 2006, 2007
+ Copyright (C) 2005, 2006, 2007, 2008
Free Software Foundation, Inc.
Contributed by Jakub Jelinek
@@ -838,9 +838,6 @@ resolve_omp_clauses (gfc_code *code)
if (!n->sym->attr.threadprivate)
gfc_error ("Non-THREADPRIVATE object '%s' in COPYIN clause"
" at %L", n->sym->name, &code->loc);
- if (n->sym->attr.allocatable)
- gfc_error ("COPYIN clause object '%s' is ALLOCATABLE at %L",
- n->sym->name, &code->loc);
if (n->sym->ts.type == BT_DERIVED && n->sym->ts.derived->attr.alloc_comp)
gfc_error ("COPYIN clause object '%s' at %L has ALLOCATABLE components",
n->sym->name, &code->loc);
@@ -852,9 +849,6 @@ resolve_omp_clauses (gfc_code *code)
if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
gfc_error ("Assumed size array '%s' in COPYPRIVATE clause "
"at %L", n->sym->name, &code->loc);
- if (n->sym->attr.allocatable)
- gfc_error ("COPYPRIVATE clause object '%s' is ALLOCATABLE "
- "at %L", n->sym->name, &code->loc);
if (n->sym->ts.type == BT_DERIVED && n->sym->ts.derived->attr.alloc_comp)
gfc_error ("COPYPRIVATE clause object '%s' at %L has ALLOCATABLE components",
n->sym->name, &code->loc);
@@ -885,9 +879,6 @@ resolve_omp_clauses (gfc_code *code)
if (n->sym->attr.pointer)
gfc_error ("POINTER object '%s' in %s clause at %L",
n->sym->name, name, &code->loc);
- if (n->sym->attr.allocatable)
- gfc_error ("%s clause object '%s' is ALLOCATABLE at %L",
- name, n->sym->name, &code->loc);
/* Variables in REDUCTION-clauses must be of intrinsic type (flagged below). */
if ((list < OMP_LIST_REDUCTION_FIRST || list > OMP_LIST_REDUCTION_LAST) &&
n->sym->ts.type == BT_DERIVED && n->sym->ts.derived->attr.alloc_comp)
--- gcc/fortran/trans-openmp.c (revision 132673)
+++ gcc/fortran/trans-openmp.c (working copy)
@@ -109,27 +109,178 @@ gfc_omp_predetermined_sharing (tree decl
}
+/* Return true if DECL in private clause needs
+ OMP_CLAUSE_PRIVATE_OUTER_REF on the private clause. */
+bool
+gfc_omp_private_outer_ref (tree decl)
+{
+ tree type = TREE_TYPE (decl);
+
+ if (GFC_DESCRIPTOR_TYPE_P (type)
+ && GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
+ return true;
+
+ return false;
+}
+
/* Return code to initialize DECL with its default constructor, or
NULL if there's nothing to do. */
tree
-gfc_omp_clause_default_ctor (tree clause ATTRIBUTE_UNUSED, tree decl)
+gfc_omp_clause_default_ctor (tree clause, tree decl, tree outer)
{
- tree type = TREE_TYPE (decl);
- stmtblock_t block;
+ tree type = TREE_TYPE (decl), rank, size, esize, ptr, cond, then_b, else_b;
+ stmtblock_t block, cond_block;
- if (! GFC_DESCRIPTOR_TYPE_P (type))
+ if (! GFC_DESCRIPTOR_TYPE_P (type)
+ || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
return NULL;
+ gcc_assert (outer != NULL);
+ gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_PRIVATE
+ || OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LASTPRIVATE);
+
/* Allocatable arrays in PRIVATE clauses need to be set to
- "not currently allocated" allocation status. */
- gfc_init_block (&block);
+ "not currently allocated" allocation status if outer
+ array is "not currently allocated", otherwise should be allocated. */
+ gfc_start_block (&block);
+
+ gfc_init_block (&cond_block);
+
+ gfc_add_modify_expr (&cond_block, decl, outer);
+ rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
+ size = gfc_conv_descriptor_ubound (decl, rank);
+ size = fold_build2 (MINUS_EXPR, gfc_array_index_type, size,
+ gfc_conv_descriptor_lbound (decl, rank));
+ size = fold_build2 (PLUS_EXPR, gfc_array_index_type, size,
+ gfc_index_one_node);
+ if (GFC_TYPE_ARRAY_RANK (type) > 1)
+ size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
+ gfc_conv_descriptor_stride (decl, rank));
+ esize = fold_convert (gfc_array_index_type,
+ TYPE_SIZE_UNIT (gfc_get_element_type (type)));
+ size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, esize);
+ size = gfc_evaluate_now (fold_convert (size_type_node, size), &cond_block);
+ ptr = gfc_allocate_array_with_status (&cond_block,
+ build_int_cst (pvoid_type_node, 0),
+ size, NULL);
+ gfc_conv_descriptor_data_set_tuples (&cond_block, decl, ptr);
+ then_b = gfc_finish_block (&cond_block);
+
+ gfc_init_block (&cond_block);
+ gfc_conv_descriptor_data_set_tuples (&cond_block, decl, null_pointer_node);
+ else_b = gfc_finish_block (&cond_block);
+
+ cond = fold_build2 (NE_EXPR, boolean_type_node,
+ fold_convert (pvoid_type_node,
+ gfc_conv_descriptor_data_get (outer)),
+ null_pointer_node);
+ gfc_add_expr_to_block (&block, build3_v (COND_EXPR, cond, then_b, else_b));
- gfc_conv_descriptor_data_set_tuples (&block, decl, null_pointer_node);
+ return gfc_finish_block (&block);
+}
+
+/* Build and return code for a copy constructor from SRC to DEST. */
+
+tree
+gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src)
+{
+ tree type = TREE_TYPE (dest), ptr, size, esize, rank, call;
+ stmtblock_t block;
+
+ if (! GFC_DESCRIPTOR_TYPE_P (type)
+ || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
+ return build_gimple_modify_stmt (dest, src);
+
+ gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_FIRSTPRIVATE);
+
+ /* Allocatable arrays in FIRSTPRIVATE clauses need to be allocated
+ and copied from SRC. */
+ gfc_start_block (&block);
+
+ gfc_add_modify_expr (&block, dest, src);
+ rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
+ size = gfc_conv_descriptor_ubound (dest, rank);
+ size = fold_build2 (MINUS_EXPR, gfc_array_index_type, size,
+ gfc_conv_descriptor_lbound (dest, rank));
+ size = fold_build2 (PLUS_EXPR, gfc_array_index_type, size,
+ gfc_index_one_node);
+ if (GFC_TYPE_ARRAY_RANK (type) > 1)
+ size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
+ gfc_conv_descriptor_stride (dest, rank));
+ esize = fold_convert (gfc_array_index_type,
+ TYPE_SIZE_UNIT (gfc_get_element_type (type)));
+ size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, esize);
+ size = gfc_evaluate_now (fold_convert (size_type_node, size), &block);
+ ptr = gfc_allocate_array_with_status (&block,
+ build_int_cst (pvoid_type_node, 0),
+ size, NULL);
+ gfc_conv_descriptor_data_set_tuples (&block, dest, ptr);
+ call = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3, ptr,
+ fold_convert (pvoid_type_node,
+ gfc_conv_descriptor_data_get (src)),
+ size);
+ gfc_add_expr_to_block (&block, fold_convert (void_type_node, call));
return gfc_finish_block (&block);
}
+/* Similarly, except use an assignment operator instead. */
+
+tree
+gfc_omp_clause_assign_op (tree clause ATTRIBUTE_UNUSED, tree dest, tree src)
+{
+ tree type = TREE_TYPE (dest), rank, size, esize, call;
+ stmtblock_t block;
+
+ if (! GFC_DESCRIPTOR_TYPE_P (type)
+ || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
+ return build_gimple_modify_stmt (dest, src);
+
+ /* Handle copying allocatable arrays. */
+ gfc_start_block (&block);
+
+ rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
+ size = gfc_conv_descriptor_ubound (dest, rank);
+ size = fold_build2 (MINUS_EXPR, gfc_array_index_type, size,
+ gfc_conv_descriptor_lbound (dest, rank));
+ size = fold_build2 (PLUS_EXPR, gfc_array_index_type, size,
+ gfc_index_one_node);
+ if (GFC_TYPE_ARRAY_RANK (type) > 1)
+ size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
+ gfc_conv_descriptor_stride (dest, rank));
+ esize = fold_convert (gfc_array_index_type,
+ TYPE_SIZE_UNIT (gfc_get_element_type (type)));
+ size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, esize);
+ size = gfc_evaluate_now (fold_convert (size_type_node, size), &block);
+ call = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
+ fold_convert (pvoid_type_node,
+ gfc_conv_descriptor_data_get (dest)),
+ fold_convert (pvoid_type_node,
+ gfc_conv_descriptor_data_get (src)),
+ size);
+ gfc_add_expr_to_block (&block, fold_convert (void_type_node, call));
+
+ return gfc_finish_block (&block);
+}
+
+/* Build and return code destructing DECL. Return NULL if nothing
+ to be done. */
+
+tree
+gfc_omp_clause_dtor (tree clause ATTRIBUTE_UNUSED, tree decl)
+{
+ tree type = TREE_TYPE (decl);
+
+ if (! GFC_DESCRIPTOR_TYPE_P (type)
+ || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
+ return NULL;
+
+ /* Allocatable arrays in FIRSTPRIVATE/LASTPRIVATE etc. clauses need
+ to be deallocated if they were allocated. */
+ return gfc_trans_dealloc_allocated (decl);
+}
+
/* Return true if DECL's DECL_VALUE_EXPR (if any) should be
disregarded in OpenMP construct, because it is going to be
@@ -440,7 +591,39 @@ gfc_trans_omp_array_reduction (tree c, g
/* Create the init statement list. */
pushlevel (0);
- stmt = gfc_trans_assignment (e1, e2, false);
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
+ && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl)) == GFC_ARRAY_ALLOCATABLE)
+ {
+ /* If decl is an allocatable array, it needs to be allocated
+ with the same bounds as the outer var. */
+ tree type = TREE_TYPE (decl), rank, size, esize, ptr;
+ stmtblock_t block;
+
+ gfc_start_block (&block);
+
+ gfc_add_modify_expr (&block, decl, outer_sym.backend_decl);
+ rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
+ size = gfc_conv_descriptor_ubound (decl, rank);
+ size = fold_build2 (MINUS_EXPR, gfc_array_index_type, size,
+ gfc_conv_descriptor_lbound (decl, rank));
+ size = fold_build2 (PLUS_EXPR, gfc_array_index_type, size,
+ gfc_index_one_node);
+ if (GFC_TYPE_ARRAY_RANK (type) > 1)
+ size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
+ gfc_conv_descriptor_stride (decl, rank));
+ esize = fold_convert (gfc_array_index_type,
+ TYPE_SIZE_UNIT (gfc_get_element_type (type)));
+ size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, esize);
+ size = gfc_evaluate_now (fold_convert (size_type_node, size), &block);
+ ptr = gfc_allocate_array_with_status (&block,
+ build_int_cst (pvoid_type_node, 0),
+ size, NULL);
+ gfc_conv_descriptor_data_set_tuples (&block, decl, ptr);
+ gfc_add_expr_to_block (&block, gfc_trans_assignment (e1, e2, false));
+ stmt = gfc_finish_block (&block);
+ }
+ else
+ stmt = gfc_trans_assignment (e1, e2, false);
if (TREE_CODE (stmt) != BIND_EXPR)
stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
else
@@ -449,7 +632,20 @@ gfc_trans_omp_array_reduction (tree c, g
/* Create the merge statement list. */
pushlevel (0);
- stmt = gfc_trans_assignment (e3, e4, false);
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
+ && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl)) == GFC_ARRAY_ALLOCATABLE)
+ {
+ /* If decl is an allocatable array, it needs to be deallocated
+ afterwards. */
+ stmtblock_t block;
+
+ gfc_start_block (&block);
+ gfc_add_expr_to_block (&block, gfc_trans_assignment (e3, e4, false));
+ gfc_add_expr_to_block (&block, gfc_trans_dealloc_allocated (decl));
+ stmt = gfc_finish_block (&block);
+ }
+ else
+ stmt = gfc_trans_assignment (e3, e4, false);
if (TREE_CODE (stmt) != BIND_EXPR)
stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
else
--- gcc/fortran/trans.h (revision 132481)
+++ gcc/fortran/trans.h (working copy)
@@ -489,9 +489,13 @@ bool gfc_get_array_descr_info (const_tre
/* In trans-openmp.c */
bool gfc_omp_privatize_by_reference (const_tree);
enum omp_clause_default_kind gfc_omp_predetermined_sharing (tree);
-tree gfc_omp_clause_default_ctor (tree, tree);
+tree gfc_omp_clause_default_ctor (tree, tree, tree);
+tree gfc_omp_clause_copy_ctor (tree, tree, tree);
+tree gfc_omp_clause_assign_op (tree, tree, tree);
+tree gfc_omp_clause_dtor (tree, tree);
bool gfc_omp_disregard_value_expr (tree, bool);
bool gfc_omp_private_debug_clause (tree, bool);
+bool gfc_omp_private_outer_ref (tree);
struct gimplify_omp_ctx;
void gfc_omp_firstprivatize_type_sizes (struct gimplify_omp_ctx *, tree);
--- gcc/fortran/f95-lang.c (revision 132481)
+++ gcc/fortran/f95-lang.c (working copy)
@@ -116,8 +116,12 @@ static alias_set_type gfc_get_alias_set
#undef LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE
#undef LANG_HOOKS_OMP_PREDETERMINED_SHARING
#undef LANG_HOOKS_OMP_CLAUSE_DEFAULT_CTOR
+#undef LANG_HOOKS_OMP_CLAUSE_COPY_CTOR
+#undef LANG_HOOKS_OMP_CLAUSE_ASSIGN_OP
+#undef LANG_HOOKS_OMP_CLAUSE_DTOR
#undef LANG_HOOKS_OMP_DISREGARD_VALUE_EXPR
#undef LANG_HOOKS_OMP_PRIVATE_DEBUG_CLAUSE
+#undef LANG_HOOKS_OMP_PRIVATE_OUTER_REF
#undef LANG_HOOKS_OMP_FIRSTPRIVATIZE_TYPE_SIZES
#undef LANG_HOOKS_BUILTIN_FUNCTION
#undef LANG_HOOKS_GET_ARRAY_DESCR_INFO
@@ -139,8 +143,12 @@ static alias_set_type gfc_get_alias_set
#define LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE gfc_omp_privatize_by_reference
#define LANG_HOOKS_OMP_PREDETERMINED_SHARING gfc_omp_predetermined_sharing
#define LANG_HOOKS_OMP_CLAUSE_DEFAULT_CTOR gfc_omp_clause_default_ctor
+#define LANG_HOOKS_OMP_CLAUSE_COPY_CTOR gfc_omp_clause_copy_ctor
+#define LANG_HOOKS_OMP_CLAUSE_ASSIGN_OP gfc_omp_clause_assign_op
+#define LANG_HOOKS_OMP_CLAUSE_DTOR gfc_omp_clause_dtor
#define LANG_HOOKS_OMP_DISREGARD_VALUE_EXPR gfc_omp_disregard_value_expr
#define LANG_HOOKS_OMP_PRIVATE_DEBUG_CLAUSE gfc_omp_private_debug_clause
+#define LANG_HOOKS_OMP_PRIVATE_OUTER_REF gfc_omp_private_outer_ref
#define LANG_HOOKS_OMP_FIRSTPRIVATIZE_TYPE_SIZES \
gfc_omp_firstprivatize_type_sizes
#define LANG_HOOKS_BUILTIN_FUNCTION gfc_builtin_function
--- gcc/testsuite/gfortran.dg/gomp/appendix-a/a.33.4.f90 (revision 132481)
+++ gcc/testsuite/gfortran.dg/gomp/appendix-a/a.33.4.f90 (working copy)
@@ -4,7 +4,7 @@
REAL, DIMENSION(:), ALLOCATABLE :: A
REAL, DIMENSION(:), POINTER :: B
ALLOCATE (A(N))
-!$OMP SINGLE ! { dg-error "COPYPRIVATE clause object 'a'" }
+!$OMP SINGLE
ALLOCATE (B(N))
READ (11) A,B
!$OMP END SINGLE COPYPRIVATE(A,B)
--- gcc/testsuite/gfortran.dg/gomp/reduction1.f90 (revision 132481)
+++ gcc/testsuite/gfortran.dg/gomp/reduction1.f90 (working copy)
@@ -56,7 +56,7 @@ common /blk/ i1
!$omp end parallel
!$omp parallel reduction (*:p1) ! { dg-error "POINTER object" }
!$omp end parallel
-!$omp parallel reduction (-:aa1) ! { dg-error "is ALLOCATABLE" }
+!$omp parallel reduction (-:aa1)
!$omp end parallel
!$omp parallel reduction (*:ia1) ! { dg-error "Assumed size" }
!$omp end parallel
--- libgomp/testsuite/libgomp.fortran/allocatable1.f90 (revision 0)
+++ libgomp/testsuite/libgomp.fortran/allocatable1.f90 (revision 0)
@@ -0,0 +1,81 @@
+! { dg-do run }
+!$ use omp_lib
+
+ integer, allocatable :: a(:, :)
+ integer :: b(6, 3)
+ integer :: i, j
+ logical :: k, l
+ b(:, :) = 16
+ l = .false.
+ if (allocated (a)) call abort
+!$omp parallel private (a, b) reduction (.or.:l)
+ l = l.or.allocated (a)
+ allocate (a(3, 6))
+ l = l.or..not.allocated (a)
+ l = l.or.size(a).ne.18.or.size(a,1).ne.3.or.size(a,2).ne.6
+ a(3, 2) = 1
+ b(3, 2) = 1
+ deallocate (a)
+ l = l.or.allocated (a)
+!$omp end parallel
+ if (allocated (a).or.l) call abort
+ allocate (a(6, 3))
+ a(:, :) = 3
+ if (.not.allocated (a)) call abort
+ l = l.or.size(a).ne.18.or.size(a,1).ne.6.or.size(a,2).ne.3
+ if (l) call abort
+!$omp parallel private (a, b) reduction (.or.:l)
+ l = l.or..not.allocated (a)
+ a(3, 2) = 1
+ b(3, 2) = 1
+!$omp end parallel
+ if (l.or..not.allocated (a)) call abort
+!$omp parallel firstprivate (a, b) reduction (.or.:l)
+ l = l.or..not.allocated (a)
+ l = l.or.size(a).ne.18.or.size(a,1).ne.6.or.size(a,2).ne.3
+ do i = 1, 6
+ l = l.or.(a(i, 1).ne.3).or.(a(i, 2).ne.3)
+ l = l.or.(a(i, 3).ne.3).or.(b(i, 1).ne.16)
+ l = l.or.(b(i, 2).ne.16).or.(b(i, 3).ne.16)
+ end do
+ a(:, :) = omp_get_thread_num ()
+ b(:, :) = omp_get_thread_num ()
+!$omp end parallel
+ if (any (a.ne.3).or.any (b.ne.16).or.l) call abort
+ k = .true.
+!$omp parallel do firstprivate (a, b, k) lastprivate (a, b) &
+!$omp & reduction (.or.:l)
+ do i = 1, 36
+ l = l.or..not.allocated (a)
+ l = l.or.size(a).ne.18.or.size(a,1).ne.6.or.size(a,2).ne.3
+ if (k) then
+ do j = 1, 6
+ l = l.or.(a(j, 1).ne.3).or.(a(j, 2).ne.3)
+ l = l.or.(a(j, 3).ne.3).or.(b(j, 1).ne.16)
+ l = l.or.(b(j, 2).ne.16).or.(b(j, 3).ne.16)
+ end do
+ k = .false.
+ end if
+ a(:, :) = i + 2
+ b(:, :) = i
+ end do
+ if (any (a.ne.38).or.any (b.ne.36).or.l) call abort
+ deallocate (a)
+ if (allocated (a)) call abort
+ allocate (a (0:1, 0:3))
+ a(:, :) = 0
+!$omp parallel do reduction (+:a) reduction (.or.:l) &
+!$omp & num_threads(3) schedule(static)
+ do i = 0, 7
+ l = l.or..not.allocated (a)
+ l = l.or.size(a).ne.8.or.size(a,1).ne.2.or.size(a,2).ne.4
+ a(modulo (i, 2), i / 2) = a(modulo (i, 2), i / 2) + i
+ a(i / 4, modulo (i, 4)) = a(i / 4, modulo (i, 4)) + i
+ end do
+ if (l) call abort
+ do i = 0, 1
+ do j = 0, 3
+ if (a(i, j) .ne. (5*i + 3*j)) call abort
+ end do
+ end do
+end
--- libgomp/testsuite/libgomp.fortran/allocatable2.f90 (revision 0)
+++ libgomp/testsuite/libgomp.fortran/allocatable2.f90 (revision 0)
@@ -0,0 +1,47 @@
+! { dg-do run }
+! { dg-require-effective-target tls_runtime }
+!$ use omp_lib
+
+ integer, save, allocatable :: a(:, :)
+ integer, allocatable :: b(:, :)
+ integer :: n
+ logical :: l
+!$omp threadprivate (a)
+ if (allocated (a)) call abort
+ call omp_set_dynamic (.false.)
+ l = .false.
+!$omp parallel num_threads (4) reduction(.or.:l)
+ allocate (a(-1:1, 7:10))
+ a(:, :) = omp_get_thread_num () + 6
+ l = l.or..not.allocated (a)
+ l = l.or.size(a).ne.12.or.size(a,1).ne.3.or.size(a,2).ne.4
+!$omp end parallel
+ if (l.or.any(a.ne.6)) call abort ()
+!$omp parallel num_threads (4) copyin (a) reduction(.or.:l) private (b)
+ l = l.or.allocated (b)
+ l = l.or..not.allocated (a)
+ l = l.or.size(a).ne.12.or.size(a,1).ne.3.or.size(a,2).ne.4
+ l = l.or.any(a.ne.6)
+ allocate (b(1, 3))
+ a(:, :) = omp_get_thread_num () + 36
+ b(:, :) = omp_get_thread_num () + 66
+ !$omp single
+ n = omp_get_thread_num ()
+ !$omp end single copyprivate (a, b)
+ l = l.or..not.allocated (a)
+ l = l.or.size(a).ne.12.or.size(a,1).ne.3.or.size(a,2).ne.4
+ l = l.or.any(a.ne.(n + 36))
+ l = l.or..not.allocated (b)
+ l = l.or.size(b).ne.3.or.size(b,1).ne.1.or.size(b,2).ne.3
+ l = l.or.any(b.ne.(n + 66))
+ deallocate (b)
+ l = l.or.allocated (b)
+!$omp end parallel
+ if (n.lt.0 .or. n.ge.4) call abort
+ if (l.or.any(a.ne.(n + 36))) call abort
+!$omp parallel num_threads (4) reduction(.or.:l)
+ deallocate (a)
+ l = l.or.allocated (a)
+!$omp end parallel
+ if (l.or.allocated (a)) call abort
+end
Jakub
More information about the Fortran
mailing list