[gomp] Fix privatization of function result variable (both implicit and explicit)
Jakub Jelinek
jakub@redhat.com
Mon Nov 7 17:00:00 GMT 2005
Hi!
There have been a bunch of places that need changing, so that function
result variables can be privatized:
1) ensure in presence of ENTRY statements there are distinct variables,
so that they can be privatized individually
2) make sure FUNCTION_DECL that are stored in sym->backend_decl of those
symbols don't make it into GIMPLE, instead we need to put there the
fake result variables
3) ensure they have complete types
Ok for gomp?
2005-11-07 Jakub Jelinek <jakub@redhat.com>
* gimplify.c (omp_notice_variable): Call omp_predetermined_sharing
langhook even for DECL_ARTIFICIAL.
* langhooks.c (lhd_omp_predetermined_sharing): Return
OMP_CLAUSE_DEFAULT_SHARED for DECL_ARTIFICIAL decls.
fortran/
* trans-decl.c (saved_function_decls, saved_parent_function_decls):
Remove unnecessary initialization.
(create_function_arglist): Make sure __result has complete type.
(gfc_get_fake_result_decl): Change current_fake_result_decl into
a tree chain. For entry master, create a separate variable
for each result name. For BT_CHARACTER results, call
gfc_finish_var_decl on length even if it has been already created,
but not pushdecl'ed.
(gfc_trans_vla_type_sizes): For function/entry result, adjust
result value type, not the FUNCTION_TYPE.
(gfc_generate_function_code): Adjust for current_fake_result_decl
changes.
(gfc_trans_deferred_vars): Likewise. Call gfc_trans_vla_type_sizes
even on result if it is assumed-length character.
* trans-openmp.c (gfc_omp_privatize_by_reference): Make
DECL_ARTIFICIAL vars predetermined shared except GFC_DECL_RESULT.
(gfc_omp_disregard_value_expr): Handle GFC_DECL_RESULT.
(gfc_trans_omp_variable): New function.
(gfc_trans_omp_variable_list, gfc_trans_omp_reduction_list): Use it.
* trans.h (GFC_DECL_RESULT): Define.
libgomp/
* testsuite/libgomp.fortran/retval1.f90: New test.
* testsuite/libgomp.fortran/vla7.f90: New test.
--- gcc/gimplify.c.jj 2005-11-07 09:59:40.000000000 +0100
+++ gcc/gimplify.c 2005-11-07 14:22:08.000000000 +0100
@@ -4337,14 +4337,9 @@ omp_notice_variable (struct gimplify_omp
remapped firstprivate instead of shared. To some extent this is
addressed in omp_firstprivatize_type_sizes, but not effectively. */
default_kind = ctx->default_kind;
- if (DECL_ARTIFICIAL (decl))
- default_kind = OMP_CLAUSE_DEFAULT_SHARED;
- else
- {
- kind = lang_hooks.decls.omp_predetermined_sharing (decl);
- if (kind != OMP_CLAUSE_DEFAULT_UNSPECIFIED)
- default_kind = kind;
- }
+ kind = lang_hooks.decls.omp_predetermined_sharing (decl);
+ if (kind != OMP_CLAUSE_DEFAULT_UNSPECIFIED)
+ default_kind = kind;
switch (default_kind)
{
--- gcc/langhooks.c.jj 2005-11-07 10:04:22.000000000 +0100
+++ gcc/langhooks.c 2005-11-07 14:21:15.000000000 +0100
@@ -557,6 +557,8 @@ lhd_expr_to_decl (tree expr, bool *tc AT
enum omp_clause_default_kind
lhd_omp_predetermined_sharing (tree decl ATTRIBUTE_UNUSED)
{
+ if (DECL_ARTIFICIAL (decl))
+ return OMP_CLAUSE_DEFAULT_SHARED;
return OMP_CLAUSE_DEFAULT_UNSPECIFIED;
}
--- gcc/fortran/trans-decl.c.jj 2005-11-06 00:31:31.000000000 +0100
+++ gcc/fortran/trans-decl.c 2005-11-07 16:14:15.000000000 +0100
@@ -55,8 +55,8 @@ static GTY(()) tree current_function_ret
/* Holds the variable DECLs for the current function. */
-static GTY(()) tree saved_function_decls = NULL_TREE;
-static GTY(()) tree saved_parent_function_decls = NULL_TREE;
+static GTY(()) tree saved_function_decls;
+static GTY(()) tree saved_parent_function_decls;
/* The namespace of the module we're currently generating. Only used while
@@ -1282,43 +1282,72 @@ create_function_arglist (gfc_symbol * sy
if (gfc_return_by_reference (sym))
{
- type = TREE_VALUE (typelist);
- parm = build_decl (PARM_DECL, get_identifier ("__result"), type);
-
- DECL_CONTEXT (parm) = fndecl;
- DECL_ARG_TYPE (parm) = type;
- TREE_READONLY (parm) = 1;
- DECL_ARTIFICIAL (parm) = 1;
- gfc_finish_decl (parm, NULL_TREE);
-
- arglist = chainon (arglist, parm);
- typelist = TREE_CHAIN (typelist);
+ tree type = TREE_VALUE (typelist), length = NULL;
if (sym->ts.type == BT_CHARACTER)
{
- tree length;
- gfc_allocate_lang_decl (parm);
-
/* Length of character result. */
- type = TREE_VALUE (typelist);
- gcc_assert (type == gfc_charlen_type_node);
+ tree len_type = TREE_VALUE (TREE_CHAIN (typelist));
+ gcc_assert (len_type == gfc_charlen_type_node);
length = build_decl (PARM_DECL,
get_identifier (".__result"),
- type);
+ len_type);
if (!sym->ts.cl->length)
{
sym->ts.cl->backend_decl = length;
TREE_USED (length) = 1;
}
gcc_assert (TREE_CODE (length) == PARM_DECL);
- arglist = chainon (arglist, length);
- typelist = TREE_CHAIN (typelist);
DECL_CONTEXT (length) = fndecl;
- DECL_ARG_TYPE (length) = type;
+ DECL_ARG_TYPE (length) = len_type;
TREE_READONLY (length) = 1;
DECL_ARTIFICIAL (length) = 1;
gfc_finish_decl (length, NULL_TREE);
+ if (sym->ts.cl->backend_decl == NULL
+ || sym->ts.cl->backend_decl == length)
+ {
+ gfc_symbol *arg;
+ tree backend_decl;
+
+ if (sym->ts.cl->backend_decl == NULL)
+ {
+ tree len = build_decl (VAR_DECL,
+ get_identifier ("..__result"),
+ gfc_charlen_type_node);
+ DECL_ARTIFICIAL (len) = 1;
+ TREE_USED (len) = 1;
+ sym->ts.cl->backend_decl = len;
+ }
+
+ /* Make sure PARM_DECL type doesn't point to incomplete type. */
+ arg = sym->result ? sym->result : sym;
+ backend_decl = arg->backend_decl;
+ /* Temporary clear it, so that gfc_sym_type creates complete
+ type. */
+ arg->backend_decl = NULL;
+ type = gfc_sym_type (arg);
+ arg->backend_decl = backend_decl;
+ type = build_reference_type (type);
+ }
+ }
+
+ parm = build_decl (PARM_DECL, get_identifier ("__result"), type);
+
+ DECL_CONTEXT (parm) = fndecl;
+ DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
+ TREE_READONLY (parm) = 1;
+ DECL_ARTIFICIAL (parm) = 1;
+ gfc_finish_decl (parm, NULL_TREE);
+
+ arglist = chainon (arglist, parm);
+ typelist = TREE_CHAIN (typelist);
+
+ if (sym->ts.type == BT_CHARACTER)
+ {
+ gfc_allocate_lang_decl (parm);
+ arglist = chainon (arglist, length);
+ typelist = TREE_CHAIN (typelist);
}
}
@@ -1693,18 +1722,24 @@ gfc_create_function_decl (gfc_namespace
tree
gfc_get_fake_result_decl (gfc_symbol * sym)
{
- tree decl;
- tree length;
+ tree decl, length;
char name[GFC_MAX_SYMBOL_LEN + 10];
if (sym
&& sym->ns->proc_name->backend_decl == current_function_decl
- && sym->ns->proc_name->attr.mixed_entry_master
+ && sym->ns->proc_name->attr.entry_master
&& sym != sym->ns->proc_name)
{
+ tree t = NULL, var;
+ if (current_fake_result_decl != NULL)
+ for (t = TREE_CHAIN (current_fake_result_decl); t; t = TREE_CHAIN (t))
+ if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0)
+ break;
+ if (t)
+ return TREE_VALUE (t);
decl = gfc_get_fake_result_decl (sym->ns->proc_name);
- if (decl)
+ if (decl && sym->ns->proc_name->attr.mixed_entry_master)
{
tree field;
@@ -1718,22 +1753,33 @@ gfc_get_fake_result_decl (gfc_symbol * s
decl = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field,
NULL_TREE);
}
- return decl;
+ var = gfc_create_var (TREE_TYPE (decl), sym->name);
+ GFC_DECL_RESULT (var) = 1;
+ SET_DECL_VALUE_EXPR (var, decl);
+ DECL_HAS_VALUE_EXPR_P (var) = 1;
+ TREE_CHAIN (current_fake_result_decl)
+ = tree_cons (get_identifier (sym->name), var,
+ TREE_CHAIN (current_fake_result_decl));
+ return var;
}
if (current_fake_result_decl != NULL_TREE)
- return current_fake_result_decl;
+ return TREE_VALUE (current_fake_result_decl);
/* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
sym is NULL. */
if (!sym)
return NULL_TREE;
- if (sym->ts.type == BT_CHARACTER
- && !sym->ts.cl->backend_decl)
+ if (sym->ts.type == BT_CHARACTER)
{
- length = gfc_create_string_length (sym);
- gfc_finish_var_decl (length, sym);
+ if (sym->ts.cl->backend_decl == NULL_TREE)
+ length = gfc_create_string_length (sym);
+ else
+ length = sym->ts.cl->backend_decl;
+ if (TREE_CODE (length) == VAR_DECL
+ && DECL_CONTEXT (length) == NULL_TREE)
+ gfc_finish_var_decl (length, sym);
}
if (gfc_return_by_reference (sym))
@@ -1760,13 +1806,14 @@ gfc_get_fake_result_decl (gfc_symbol * s
DECL_EXTERNAL (decl) = 0;
TREE_PUBLIC (decl) = 0;
TREE_USED (decl) = 1;
+ GFC_DECL_RESULT (decl) = 1;
layout_decl (decl, 0);
gfc_add_decl_to_function (decl);
}
- current_fake_result_decl = decl;
+ current_fake_result_decl = build_tree_list (NULL, decl);
return decl;
}
@@ -2333,6 +2380,15 @@ gfc_trans_vla_type_sizes (gfc_symbol *sy
{
tree type = TREE_TYPE (sym->backend_decl);
+ if (TREE_CODE (type) == FUNCTION_TYPE
+ && (sym->attr.function || sym->attr.result || sym->attr.entry))
+ {
+ if (! current_fake_result_decl)
+ return;
+
+ type = TREE_TYPE (TREE_VALUE (current_fake_result_decl));
+ }
+
while (POINTER_TYPE_P (type))
type = TREE_TYPE (type);
@@ -2373,9 +2429,8 @@ gfc_trans_deferred_vars (gfc_symbol * pr
}
else if (proc_sym->as)
{
- fnbody = gfc_trans_dummy_array_bias (proc_sym,
- current_fake_result_decl,
- fnbody);
+ tree result = TREE_VALUE (current_fake_result_decl);
+ fnbody = gfc_trans_dummy_array_bias (proc_sym, result, fnbody);
}
else if (proc_sym->ts.type == BT_CHARACTER)
{
@@ -2470,6 +2525,14 @@ gfc_trans_deferred_vars (gfc_symbol * pr
gfc_trans_vla_type_sizes (f->sym, &body);
}
+ if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
+ && current_fake_result_decl != NULL)
+ {
+ gcc_assert (proc_sym->ts.cl->backend_decl != NULL);
+ if (TREE_CODE (proc_sym->ts.cl->backend_decl) == PARM_DECL)
+ gfc_trans_vla_type_sizes (proc_sym, &body);
+ }
+
gfc_add_expr_to_block (&body, fnbody);
return gfc_finish_block (&body);
}
@@ -2784,7 +2847,10 @@ gfc_generate_function_code (gfc_namespac
{
if (sym->attr.subroutine || sym == sym->result)
{
- result = current_fake_result_decl;
+ if (current_fake_result_decl != NULL)
+ result = TREE_VALUE (current_fake_result_decl);
+ else
+ result = NULL_TREE;
current_fake_result_decl = NULL_TREE;
}
else
--- gcc/fortran/trans-openmp.c.jj 2005-11-07 10:18:45.000000000 +0100
+++ gcc/fortran/trans-openmp.c 2005-11-07 14:40:13.000000000 +0100
@@ -71,6 +71,9 @@ gfc_omp_privatize_by_reference (tree dec
enum omp_clause_default_kind
gfc_omp_predetermined_sharing (tree decl)
{
+ if (DECL_ARTIFICIAL (decl) && ! GFC_DECL_RESULT (decl))
+ return OMP_CLAUSE_DEFAULT_SHARED;
+
/* Cray pointees shouldn't be listed in any clauses and should be
gimplified to dereference of the corresponding Cray pointer.
Make them all private, so that they are emitted in the debug
@@ -85,6 +88,9 @@ gfc_omp_predetermined_sharing (tree decl
if (GFC_DECL_COMMON_OR_EQUIV (decl) && ! DECL_HAS_VALUE_EXPR_P (decl))
return OMP_CLAUSE_DEFAULT_SHARED;
+ if (GFC_DECL_RESULT (decl) && ! DECL_HAS_VALUE_EXPR_P (decl))
+ return OMP_CLAUSE_DEFAULT_SHARED;
+
return OMP_CLAUSE_DEFAULT_UNSPECIFIED;
}
@@ -115,6 +121,10 @@ gfc_omp_disregard_value_expr (tree decl,
return ! shared;
}
}
+
+ if (GFC_DECL_RESULT (decl) && DECL_HAS_VALUE_EXPR_P (decl))
+ return ! shared;
+
return false;
}
@@ -173,13 +183,48 @@ gfc_trans_add_clause (tree node, tree ta
}
static tree
+gfc_trans_omp_variable (gfc_symbol *sym)
+{
+ tree t = gfc_get_symbol_decl (sym);
+
+ /* Special case for assigning the return value of a function.
+ Self recursive functions must have an explicit return value. */
+ if (t == current_function_decl && sym->attr.function
+ && (sym->result == sym))
+ t = gfc_get_fake_result_decl (sym);
+
+ /* Similarly for alternate entry points. */
+ else if (sym->attr.function && sym->attr.entry
+ && (sym->result == sym)
+ && sym->ns->proc_name->backend_decl == current_function_decl)
+ {
+ gfc_entry_list *el = NULL;
+
+ for (el = sym->ns->entries; el; el = el->next)
+ if (sym == el->sym)
+ {
+ t = gfc_get_fake_result_decl (sym);
+ break;
+ }
+ }
+
+ else if (sym->attr.result
+ && sym->ns->proc_name->backend_decl == current_function_decl
+ && sym->ns->proc_name->attr.entry_master
+ && !gfc_return_by_reference (sym->ns->proc_name))
+ t = gfc_get_fake_result_decl (sym);
+
+ return t;
+}
+
+static tree
gfc_trans_omp_variable_list (enum tree_code code, gfc_namelist *namelist,
tree list)
{
for (; namelist != NULL; namelist = namelist->next)
if (namelist->sym->attr.referenced)
{
- tree t = gfc_get_symbol_decl (namelist->sym);
+ tree t = gfc_trans_omp_variable (namelist->sym);
if (t != error_mark_node)
{
tree node = make_node (code);
@@ -368,7 +413,7 @@ gfc_trans_omp_reduction_list (enum tree_
for (; namelist != NULL; namelist = namelist->next)
if (namelist->sym->attr.referenced)
{
- tree t = gfc_get_symbol_decl (namelist->sym);
+ tree t = gfc_trans_omp_variable (namelist->sym);
if (t != error_mark_node)
{
tree node = make_node (code);
--- gcc/fortran/trans.h.jj 2005-11-07 10:31:26.000000000 +0100
+++ gcc/fortran/trans.h 2005-11-07 14:20:23.000000000 +0100
@@ -558,6 +558,7 @@ struct lang_decl GTY(())
#define GFC_DECL_ASSIGN(node) DECL_LANG_FLAG_2(node)
#define GFC_DECL_COMMON_OR_EQUIV(node) DECL_LANG_FLAG_3(node)
#define GFC_DECL_CRAY_POINTEE(node) DECL_LANG_FLAG_4(node)
+#define GFC_DECL_RESULT(node) DECL_LANG_FLAG_5(node)
/* An array descriptor. */
#define GFC_DESCRIPTOR_TYPE_P(node) TYPE_LANG_FLAG_1(node)
--- libgomp/testsuite/libgomp.fortran/retval1.f90.jj 2005-11-07 12:03:26.000000000 +0100
+++ libgomp/testsuite/libgomp.fortran/retval1.f90 2005-11-07 15:01:17.000000000 +0100
@@ -0,0 +1,120 @@
+! { dg-do run }
+
+function f1 ()
+ use omp_lib
+ real :: f1
+ logical :: l
+ f1 = 6.5
+ l = .false.
+!$omp parallel firstprivate (f1) num_threads (2) reduction (.or.:l)
+ l = f1 .ne. 6.5
+ if (omp_get_thread_num () .eq. 0) f1 = 8.5
+ if (omp_get_thread_num () .eq. 1) f1 = 14.5
+!$omp barrier
+ l = l .or. (omp_get_thread_num () .eq. 0 .and. f1 .ne. 8.5)
+ l = l .or. (omp_get_thread_num () .eq. 1 .and. f1 .ne. 14.5)
+!$omp end parallel
+ if (l) call abort
+ f1 = -2.5
+end function f1
+function f2 ()
+ use omp_lib
+ real :: f2, e2
+ logical :: l
+entry e2 ()
+ f2 = 6.5
+ l = .false.
+!$omp parallel firstprivate (e2) num_threads (2) reduction (.or.:l)
+ l = e2 .ne. 6.5
+ if (omp_get_thread_num () .eq. 0) e2 = 8.5
+ if (omp_get_thread_num () .eq. 1) e2 = 14.5
+!$omp barrier
+ l = l .or. (omp_get_thread_num () .eq. 0 .and. e2 .ne. 8.5)
+ l = l .or. (omp_get_thread_num () .eq. 1 .and. e2 .ne. 14.5)
+!$omp end parallel
+ if (l) call abort
+ e2 = 7.5
+end function f2
+function f3 ()
+ use omp_lib
+ real :: f3, e3
+ logical :: l
+entry e3 ()
+ f3 = 6.5
+ l = .false.
+!$omp parallel firstprivate (f3, e3) num_threads (2) reduction (.or.:l)
+ l = e3 .ne. 6.5
+ l = l .or. f3 .ne. 6.5
+ if (omp_get_thread_num () .eq. 0) e3 = 8.5
+ if (omp_get_thread_num () .eq. 1) e3 = 14.5
+ f3 = e3 - 4.5
+!$omp barrier
+ l = l .or. (omp_get_thread_num () .eq. 0 .and. e3 .ne. 8.5)
+ l = l .or. (omp_get_thread_num () .eq. 1 .and. e3 .ne. 14.5)
+ l = l .or. f3 .ne. e3 - 4.5
+!$omp end parallel
+ if (l) call abort
+ e3 = 0.5
+end function f3
+function f4 () result (r4)
+ use omp_lib
+ real :: r4, s4
+ logical :: l
+entry e4 () result (s4)
+ r4 = 6.5
+ l = .false.
+!$omp parallel firstprivate (r4, s4) num_threads (2) reduction (.or.:l)
+ l = s4 .ne. 6.5
+ l = l .or. r4 .ne. 6.5
+ if (omp_get_thread_num () .eq. 0) s4 = 8.5
+ if (omp_get_thread_num () .eq. 1) s4 = 14.5
+ r4 = s4 - 4.5
+!$omp barrier
+ l = l .or. (omp_get_thread_num () .eq. 0 .and. s4 .ne. 8.5)
+ l = l .or. (omp_get_thread_num () .eq. 1 .and. s4 .ne. 14.5)
+ l = l .or. r4 .ne. s4 - 4.5
+!$omp end parallel
+ if (l) call abort
+ s4 = -0.5
+end function f4
+function f5 (is_f5)
+ use omp_lib
+ real :: f5
+ integer :: e5
+ logical :: l, is_f5
+entry e5 (is_f5)
+ if (is_f5) then
+ f5 = 6.5
+ else
+ e5 = 8
+ end if
+ l = .false.
+!$omp parallel firstprivate (f5, e5) shared (is_f5) num_threads (2) &
+!$omp reduction (.or.:l)
+ l = .not. is_f5 .and. e5 .ne. 8
+ l = l .or. (is_f5 .and. f5 .ne. 6.5)
+ if (omp_get_thread_num () .eq. 0) e5 = 8
+ if (omp_get_thread_num () .eq. 1) e5 = 14
+ f5 = e5 - 4.5
+!$omp barrier
+ l = l .or. (omp_get_thread_num () .eq. 0 .and. e5 .ne. 8)
+ l = l .or. (omp_get_thread_num () .eq. 1 .and. e5 .ne. 14)
+ l = l .or. f5 .ne. e5 - 4.5
+!$omp end parallel
+ if (l) call abort
+ if (is_f5) f5 = -2.5
+ if (.not. is_f5) e5 = 8
+end function f5
+
+ real :: f1, f2, e2, f3, e3, f4, e4, f5
+ integer :: e5
+ if (f1 () .ne. -2.5) call abort
+ if (f2 () .ne. 7.5) call abort
+ if (e2 () .ne. 7.5) call abort
+ if (f3 () .ne. 0.5) call abort
+ if (e3 () .ne. 0.5) call abort
+ if (f4 () .ne. -0.5) call abort
+ if (e4 () .ne. -0.5) call abort
+ if (f5 (.true.) .ne. -2.5) call abort
+ if (e5 (.false.) .ne. 8) call abort
+end
--- libgomp/testsuite/libgomp.fortran/vla7.f90.jj 2005-11-07 15:03:03.000000000 +0100
+++ libgomp/testsuite/libgomp.fortran/vla7.f90 2005-11-07 17:03:51.000000000 +0100
@@ -0,0 +1,227 @@
+! { dg-do run }
+
+ character (6) :: c, f2
+ character (6) :: d(2)
+ interface
+ function f4 (n)
+ integer :: n
+ character (n), dimension (2) :: f4
+ end function f4
+ function f6 (n)
+ integer :: n
+ character (n), dimension (n - 4) :: f6
+ end function f6
+ end interface
+ c = f1 (6)
+ if (c .ne. 'opqrst') call abort
+ c = f2 (6)
+ if (c .ne. '_/!!/_') call abort
+ d = f3 (6)
+ if (d(1) .ne. 'opqrst' .or. d(2) .ne. 'a') call abort
+ d = f4 (6)
+ if (d(1) .ne. '_/!!/_' .or. d(2) .ne. '-') call abort
+ d = f5 (6)
+ if (d(1) .ne. 'Opqrst' .or. d(2) .ne. 'A') call abort
+ d = f6 (6)
+ if (d(1) .ne. '-/!!/_' .or. d(2) .ne. '?') call abort
+contains
+ function f1 (n)
+ use omp_lib
+ character (n) :: f1
+ logical :: l
+ f1 = 'abcdef'
+ l = .false.
+!$omp parallel firstprivate (f1) reduction (.or.:l) num_threads (2)
+ l = f1 .ne. 'abcdef'
+ if (omp_get_thread_num () .eq. 0) f1 = 'ijklmn'
+ if (omp_get_thread_num () .eq. 1) f1 = 'IJKLMN'
+!$omp barrier
+ l = l .or. (omp_get_thread_num () .eq. 0 .and. f1 .ne. 'ijklmn')
+ l = l .or. (omp_get_thread_num () .eq. 1 .and. f1 .ne. 'IJKLMN')
+!$omp end parallel
+ f1 = 'zZzz_z'
+!$omp parallel shared (f1) reduction (.or.:l) num_threads (2)
+ l = l .or. f1 .ne. 'zZzz_z'
+!$omp barrier
+!$omp master
+ f1 = 'abc'
+!$omp end master
+!$omp barrier
+ l = l .or. f1 .ne. 'abc'
+!$omp barrier
+ if (omp_get_thread_num () .eq. 1) f1 = 'def'
+!$omp barrier
+ l = l .or. f1 .ne. 'def'
+!$omp end parallel
+ if (l) call abort
+ f1 = 'opqrst'
+ end function f1
+ function f3 (n)
+ use omp_lib
+ character (n), dimension (2) :: f3
+ logical :: l
+ f3 = 'abcdef'
+ l = .false.
+!$omp parallel firstprivate (f3) reduction (.or.:l) num_threads (2)
+ l = any (f3 .ne. 'abcdef')
+ if (omp_get_thread_num () .eq. 0) f3 = 'ijklmn'
+ if (omp_get_thread_num () .eq. 1) f3 = 'IJKLMN'
+!$omp barrier
+ l = l .or. (omp_get_thread_num () .eq. 0 .and. any (f3 .ne. 'ijklmn'))
+ l = l .or. (omp_get_thread_num () .eq. 1 .and. any (f3 .ne. 'IJKLMN'))
+!$omp end parallel
+ f3 = 'zZzz_z'
+!$omp parallel shared (f3) reduction (.or.:l) num_threads (2)
+ l = l .or. any (f3 .ne. 'zZzz_z')
+!$omp barrier
+!$omp master
+ f3 = 'abc'
+!$omp end master
+!$omp barrier
+ l = l .or. any (f3 .ne. 'abc')
+!$omp barrier
+ if (omp_get_thread_num () .eq. 1) f3 = 'def'
+!$omp barrier
+ l = l .or. any (f3 .ne. 'def')
+!$omp end parallel
+ if (l) call abort
+ f3(1) = 'opqrst'
+ f3(2) = 'a'
+ end function f3
+ function f5 (n)
+ use omp_lib
+ character (n), dimension (n - 4) :: f5
+ logical :: l
+ f5 = 'abcdef'
+ l = .false.
+!$omp parallel firstprivate (f5) reduction (.or.:l) num_threads (2)
+ l = any (f5 .ne. 'abcdef')
+ if (omp_get_thread_num () .eq. 0) f5 = 'ijklmn'
+ if (omp_get_thread_num () .eq. 1) f5 = 'IJKLMN'
+!$omp barrier
+ l = l .or. (omp_get_thread_num () .eq. 0 .and. any (f5 .ne. 'ijklmn'))
+ l = l .or. (omp_get_thread_num () .eq. 1 .and. any (f5 .ne. 'IJKLMN'))
+ l = l .or. size (f5) .ne. 2
+!$omp end parallel
+ f5 = 'zZzz_z'
+!$omp parallel shared (f5) reduction (.or.:l) num_threads (2)
+ l = l .or. any (f5 .ne. 'zZzz_z')
+!$omp barrier
+!$omp master
+ f5 = 'abc'
+!$omp end master
+!$omp barrier
+ l = l .or. any (f5 .ne. 'abc')
+!$omp barrier
+ if (omp_get_thread_num () .eq. 1) f5 = 'def'
+!$omp barrier
+ l = l .or. any (f5 .ne. 'def')
+ l = l .or. size (f5) .ne. 2
+!$omp end parallel
+ if (l) call abort
+ f5(1) = 'Opqrst'
+ f5(2) = 'A'
+ end function f5
+end
+function f2 (n)
+ use omp_lib
+ character (*) :: f2
+ logical :: l
+ f2 = 'abcdef'
+ l = .false.
+!$omp parallel firstprivate (f2) reduction (.or.:l) num_threads (2)
+ l = f2 .ne. 'abcdef'
+ if (omp_get_thread_num () .eq. 0) f2 = 'ijklmn'
+ if (omp_get_thread_num () .eq. 1) f2 = 'IJKLMN'
+!$omp barrier
+ l = l .or. (omp_get_thread_num () .eq. 0 .and. f2 .ne. 'ijklmn')
+ l = l .or. (omp_get_thread_num () .eq. 1 .and. f2 .ne. 'IJKLMN')
+!$omp end parallel
+ f2 = 'zZzz_z'
+!$omp parallel shared (f2) reduction (.or.:l) num_threads (2)
+ l = l .or. f2 .ne. 'zZzz_z'
+!$omp barrier
+!$omp master
+ f2 = 'abc'
+!$omp end master
+!$omp barrier
+ l = l .or. f2 .ne. 'abc'
+!$omp barrier
+ if (omp_get_thread_num () .eq. 1) f2 = 'def'
+!$omp barrier
+ l = l .or. f2 .ne. 'def'
+!$omp end parallel
+ if (l) call abort
+ f2 = '_/!!/_'
+end function f2
+function f4 (n)
+ use omp_lib
+ character (*), dimension (2) :: f4
+ logical :: l
+ f4 = 'abcdef'
+ l = .false.
+!$omp parallel firstprivate (f4) reduction (.or.:l) num_threads (2)
+ l = any (f4 .ne. 'abcdef')
+ if (omp_get_thread_num () .eq. 0) f4 = 'ijklmn'
+ if (omp_get_thread_num () .eq. 1) f4 = 'IJKLMN'
+!$omp barrier
+ l = l .or. (omp_get_thread_num () .eq. 0 .and. f4(1) .ne. 'ijklmn')
+ l = l .or. (omp_get_thread_num () .eq. 0 .and. f4(2) .ne. 'ijklmn')
+ l = l .or. (omp_get_thread_num () .eq. 1 .and. f4(1) .ne. 'IJKLMN')
+ l = l .or. (omp_get_thread_num () .eq. 1 .and. f4(2) .ne. 'IJKLMN')
+!$omp end parallel
+ f4 = 'zZzz_z'
+!$omp parallel shared (f4) reduction (.or.:l) num_threads (2)
+ l = l .or. any (f4 .ne. 'zZzz_z')
+!$omp barrier
+!$omp master
+ f4 = 'abc'
+!$omp end master
+!$omp barrier
+ l = l .or. any (f4 .ne. 'abc')
+!$omp barrier
+ if (omp_get_thread_num () .eq. 1) f4 = 'def'
+!$omp barrier
+ l = l .or. any (f4 .ne. 'def')
+ l = l .or. size (f4) .ne. 2
+!$omp end parallel
+ if (l) call abort
+ f4(1) = '_/!!/_'
+ f4(2) = '-'
+end function f4
+function f6 (n)
+ use omp_lib
+ character (*), dimension (n - 4) :: f6
+ logical :: l
+ f6 = 'abcdef'
+ l = .false.
+!$omp parallel firstprivate (f6) reduction (.or.:l) num_threads (2)
+ l = any (f6 .ne. 'abcdef')
+ if (omp_get_thread_num () .eq. 0) f6 = 'ijklmn'
+ if (omp_get_thread_num () .eq. 1) f6 = 'IJKLMN'
+!$omp barrier
+ l = l .or. (omp_get_thread_num () .eq. 0 .and. f6(1) .ne. 'ijklmn')
+ l = l .or. (omp_get_thread_num () .eq. 0 .and. f6(2) .ne. 'ijklmn')
+ l = l .or. (omp_get_thread_num () .eq. 1 .and. f6(1) .ne. 'IJKLMN')
+ l = l .or. (omp_get_thread_num () .eq. 1 .and. f6(2) .ne. 'IJKLMN')
+ l = l .or. size (f6) .ne. 2
+!$omp end parallel
+ f6 = 'zZzz_z'
+!$omp parallel shared (f6) reduction (.or.:l) num_threads (2)
+ l = l .or. any (f6 .ne. 'zZzz_z')
+!$omp barrier
+!$omp master
+ f6 = 'abc'
+!$omp end master
+!$omp barrier
+ l = l .or. any (f6 .ne. 'abc')
+!$omp barrier
+ if (omp_get_thread_num () .eq. 1) f6 = 'def'
+!$omp barrier
+ l = l .or. any (f6 .ne. 'def')
+ l = l .or. size (f6) .ne. 2
+!$omp end parallel
+ if (l) call abort
+ f6(1) = '-/!!/_'
+ f6(2) = '?'
+end function f6
Jakub
More information about the Fortran
mailing list