[gomp] Handle array reductions plus various fortran reduction handling fixes
Jakub Jelinek
jakub@redhat.com
Fri Oct 14 15:57:00 GMT 2005
Hi!
Unlike C/C++, Fortran allows array reductions (where the reduction
initialization and merge operation are done on each entry of the array).
With this patch, openmpbench_F_v2.tar.gz finally builds (unless using -g),
but there are still runtime issues in it.
Ok for gomp? Or should I wait for the VLA changes, as there are likely
going to be small clashes in expand_rec_input_clauses?
2005-10-14 Jakub Jelinek <jakub@redhat.com>
* omp-low.c (build_reduction_init): Use array member type for arrays.
Handle NE_EXPR and EQ_EXPR. Handle floating point MAX_EXPR/MIN_EXPR
initialization.
(array_reduction_init): New function.
(expand_rec_input_clauses): Use it.
(array_reduction_op): New function.
(expand_reduction_clauses): Use it.
fortran/
* openmp.c (gfc_match_omp_variable_list): Add ALLOW_COMMON argument.
Disallow COMMON matching if it is set.
(gfc_match_omp_clauses, gfc_match_omp_flush): Adjust all callers.
(resolve_omp_clauses): Show locus in error messages. Check that
variable types in reduction clauses are appropriate for reduction
operators.
gcc/testsuite/
* gfortran.dg/gomp/reduction1.f90: New test.
libgomp/
* testsuite/libgomp.fortran/character2.f90: Remove explicit
declaration of omp_get_thread_num.
* testsuite/libgomp.fortran/threadprivate1.f90: Likewise. Add
use omp_lib.
* testsuite/libgomp.fortran/reduction1.f90: New test.
* testsuite/libgomp.fortran/reduction2.f90: New test.
* testsuite/libgomp.fortran/reduction3.f90: New test.
* testsuite/libgomp.fortran/reduction4.f90: New test.
--- gcc/omp-low.c.jj 2005-10-12 15:58:19.000000000 +0200
+++ gcc/omp-low.c 2005-10-14 16:21:03.000000000 +0200
@@ -800,6 +800,9 @@ maybe_lookup_ctx (tree stmt)
static tree
build_reduction_init (tree clause, tree type)
{
+ if (TREE_CODE (type) == ARRAY_TYPE)
+ type = TREE_TYPE (type);
+
switch (OMP_CLAUSE_REDUCTION_CODE (clause))
{
case PLUS_EXPR:
@@ -809,11 +812,13 @@ build_reduction_init (tree clause, tree
case TRUTH_OR_EXPR:
case TRUTH_ORIF_EXPR:
case TRUTH_XOR_EXPR:
+ case NE_EXPR:
return fold_convert (type, integer_zero_node);
case MULT_EXPR:
case TRUTH_AND_EXPR:
case TRUTH_ANDIF_EXPR:
+ case EQ_EXPR:
return fold_convert (type, integer_one_node);
case BIT_AND_EXPR:
@@ -821,7 +826,12 @@ build_reduction_init (tree clause, tree
case MAX_EXPR:
if (SCALAR_FLOAT_TYPE_P (type))
- gcc_unreachable (); /* FIXME */
+ {
+ REAL_VALUE_TYPE inf, min;
+ real_inf (&inf);
+ real_arithmetic (&min, NEGATE_EXPR, &inf, NULL);
+ return build_real (type, min);
+ }
else
{
gcc_assert (INTEGRAL_TYPE_P (type));
@@ -830,7 +840,11 @@ build_reduction_init (tree clause, tree
case MIN_EXPR:
if (SCALAR_FLOAT_TYPE_P (type))
- gcc_unreachable (); /* FIXME */
+ {
+ REAL_VALUE_TYPE inf;
+ real_inf (&inf);
+ return build_real (type, inf);
+ }
else
{
gcc_assert (INTEGRAL_TYPE_P (type));
@@ -842,6 +856,41 @@ build_reduction_init (tree clause, tree
}
}
+/* Initialize all entries of array VAR to value X. */
+
+static void
+array_reduction_init (tree var, tree x, tree *stmt_list)
+{
+ tree ptr_type = build_pointer_type (TREE_TYPE (TREE_TYPE (var)));
+ tree array = build_fold_addr_expr_with_type (var, ptr_type);
+ tree ptr = create_tmp_var (ptr_type, NULL);
+ tree test_label = NULL, loop_label, end_label = NULL;
+ tree stmt, end, cond;
+
+ stmt = build2 (MODIFY_EXPR, void_type_node, ptr, array);
+ gimplify_and_add (stmt, stmt_list);
+ append_to_statement_list (build_and_jump (&test_label), stmt_list);
+ loop_label = create_artificial_label ();
+ stmt = build1 (LABEL_EXPR, void_type_node, loop_label);
+ append_to_statement_list (stmt, stmt_list);
+ stmt = build2 (MODIFY_EXPR, void_type_node,
+ build_fold_indirect_ref (ptr), x);
+ gimplify_and_add (stmt, stmt_list);
+ stmt = build2 (POSTINCREMENT_EXPR, ptr_type, ptr,
+ fold_convert (ptr_type, TYPE_SIZE_UNIT (TREE_TYPE (x))));
+ gimplify_and_add (stmt, stmt_list);
+ stmt = build1 (LABEL_EXPR, void_type_node, test_label);
+ append_to_statement_list (stmt, stmt_list);
+ end = build2 (PLUS_EXPR, ptr_type, array,
+ fold_convert (ptr_type, TYPE_SIZE_UNIT (TREE_TYPE (var))));
+ cond = build2 (GT_EXPR, boolean_type_node, end, ptr);
+ stmt = build3 (COND_EXPR, void_type_node, cond,
+ build_and_jump (&loop_label), build_and_jump (&end_label));
+ gimplify_and_add (stmt, stmt_list);
+ stmt = build1 (LABEL_EXPR, void_type_node, end_label);
+ append_to_statement_list (stmt, stmt_list);
+}
+
/* Generate code to implement the input clauses, FIRSTPRIVATE and COPYIN,
from the receiver (aka child) side and initializers for REFERENCE_TYPE
private variables. */
@@ -849,7 +898,7 @@ build_reduction_init (tree clause, tree
static void
expand_rec_input_clauses (tree clauses, tree *stmt_list, omp_context *ctx)
{
- tree c;
+ tree c, type;
for (c = ctx->block_vars; c; c = TREE_CHAIN (c))
if (DECL_INITIAL (c))
@@ -888,13 +937,18 @@ expand_rec_input_clauses (tree clauses,
case OMP_CLAUSE_REDUCTION:
var = OMP_CLAUSE_DECL (c);
new_var = lookup_decl (var, ctx);
+ type = TREE_TYPE (var);
if (TREE_CODE (TREE_TYPE (var)) == REFERENCE_TYPE)
{
new_var = build_fold_indirect_ref (new_var);
- x = build_reduction_init (c, TREE_TYPE (TREE_TYPE (var)));
+ type = TREE_TYPE (type);
+ }
+ x = build_reduction_init (c, type);
+ if (TREE_CODE (type) == ARRAY_TYPE)
+ {
+ array_reduction_init (new_var, x, stmt_list);
+ continue;
}
- else
- x = build_reduction_init (c, TREE_TYPE (var));
break;
default:
@@ -959,6 +1013,49 @@ expand_lastprivate_clauses (tree clauses
gimplify_and_add (x, stmt_list);
}
+/* Perform DST[x] = DST[x] OP SRC[x] on all entries of the arrays. */
+
+static void
+array_reduction_op (enum tree_code op, tree dst, tree src, tree *stmt_list)
+{
+ tree ptr_type = build_pointer_type (TREE_TYPE (TREE_TYPE (src)));
+ tree dst_array = build_fold_addr_expr_with_type (dst, ptr_type);
+ tree src_array = build_fold_addr_expr_with_type (src, ptr_type);
+ tree dstp = create_tmp_var (ptr_type, NULL);
+ tree srcp = create_tmp_var (ptr_type, NULL);
+ tree test_label = NULL, loop_label, end_label = NULL;
+ tree stmt, end, cond, x, size;
+
+ stmt = build2 (MODIFY_EXPR, void_type_node, srcp, src_array);
+ gimplify_and_add (stmt, stmt_list);
+ stmt = build2 (MODIFY_EXPR, void_type_node, dstp, dst_array);
+ gimplify_and_add (stmt, stmt_list);
+ append_to_statement_list (build_and_jump (&test_label), stmt_list);
+ loop_label = create_artificial_label ();
+ stmt = build1 (LABEL_EXPR, void_type_node, loop_label);
+ append_to_statement_list (stmt, stmt_list);
+ x = build2 (op, TREE_TYPE (ptr_type), build_fold_indirect_ref (dstp),
+ build_fold_indirect_ref (srcp));
+ stmt = build2 (MODIFY_EXPR, void_type_node,
+ build_fold_indirect_ref (dstp), x);
+ gimplify_and_add (stmt, stmt_list);
+ size = fold_convert (ptr_type, TYPE_SIZE_UNIT (TREE_TYPE (ptr_type)));
+ stmt = build2 (POSTINCREMENT_EXPR, ptr_type, srcp, size);
+ gimplify_and_add (stmt, stmt_list);
+ stmt = build2 (POSTINCREMENT_EXPR, ptr_type, dstp, size);
+ gimplify_and_add (stmt, stmt_list);
+ stmt = build1 (LABEL_EXPR, void_type_node, test_label);
+ append_to_statement_list (stmt, stmt_list);
+ end = build2 (PLUS_EXPR, ptr_type, src_array,
+ fold_convert (ptr_type, TYPE_SIZE_UNIT (TREE_TYPE (src))));
+ cond = build2 (GT_EXPR, boolean_type_node, end, srcp);
+ stmt = build3 (COND_EXPR, void_type_node, cond,
+ build_and_jump (&loop_label), build_and_jump (&end_label));
+ gimplify_and_add (stmt, stmt_list);
+ stmt = build1 (LABEL_EXPR, void_type_node, end_label);
+ append_to_statement_list (stmt, stmt_list);
+}
+
/* Generate code to implement the REDUCTION clauses. */
static void
@@ -971,7 +1068,18 @@ expand_reduction_clauses (tree clauses,
update in that case, otherwise use a lock. */
for (c = clauses; c && count < 2; c = OMP_CLAUSE_CHAIN (c))
if (TREE_CODE (c) == OMP_CLAUSE_REDUCTION)
- count++;
+ {
+ tree type = TREE_TYPE (OMP_CLAUSE_DECL (c));
+ if (TREE_CODE (type) == REFERENCE_TYPE)
+ type = TREE_TYPE (type);
+ /* Never use OMP_ATOMIC for array reductions. */
+ if (TREE_CODE (type) == ARRAY_TYPE)
+ {
+ count = -1;
+ break;
+ }
+ count++;
+ }
if (count == 0)
return;
@@ -1006,13 +1114,19 @@ expand_reduction_clauses (tree clauses,
return;
}
- x = build2 (OMP_CLAUSE_REDUCTION_CODE (c),
- TREE_TYPE (ref), ref, new_var);
- ref = build_outer_var_ref (var, ctx);
- if (TREE_CODE (TREE_TYPE (var)) == REFERENCE_TYPE)
- ref = build_fold_indirect_ref (ref);
- x = build2 (MODIFY_EXPR, void_type_node, ref, x);
- append_to_statement_list (x, &sub_list);
+ if (TREE_CODE (TREE_TYPE (new_var)) == ARRAY_TYPE)
+ array_reduction_op (OMP_CLAUSE_REDUCTION_CODE (c),
+ ref, new_var, &sub_list);
+ else
+ {
+ x = build2 (OMP_CLAUSE_REDUCTION_CODE (c),
+ TREE_TYPE (ref), ref, new_var);
+ ref = build_outer_var_ref (var, ctx);
+ if (TREE_CODE (TREE_TYPE (var)) == REFERENCE_TYPE)
+ ref = build_fold_indirect_ref (ref);
+ x = build2 (MODIFY_EXPR, void_type_node, ref, x);
+ append_to_statement_list (x, &sub_list);
+ }
}
x = built_in_decls[BUILT_IN_GOMP_ATOMIC_START];
@@ -1810,7 +1924,7 @@ expand_omp_for_1 (tree *stmt_p, omp_cont
gcc_assert (fd.chunk_size == NULL);
else if (fd.chunk_size == NULL)
fd.chunk_size = (sched_kind == OMP_CLAUSE_SCHEDULE_STATIC)
- ? integer_zero_node : integer_one_node;
+ ? integer_zero_node : integer_one_node;
fn_index = sched_kind + have_ordered * 4;
--- gcc/fortran/openmp.c.jj 2005-10-11 19:05:32.000000000 +0200
+++ gcc/fortran/openmp.c 2005-10-13 23:33:15.000000000 +0200
@@ -76,7 +76,8 @@ gfc_free_omp_clauses (gfc_omp_clauses *c
/* Match a variable/common block list and construct a namelist from it. */
static match
-gfc_match_omp_variable_list (const char *str, gfc_namelist **list)
+gfc_match_omp_variable_list (const char *str, gfc_namelist **list,
+ bool allow_common)
{
gfc_namelist *head, *tail, *p;
locus old_loc;
@@ -115,6 +116,9 @@ gfc_match_omp_variable_list (const char
goto cleanup;
}
+ if (!allow_common)
+ goto syntax;
+
m = gfc_match (" / %n /", n);
if (m == MATCH_ERROR)
goto cleanup;
@@ -202,32 +206,35 @@ gfc_match_omp_clauses (gfc_omp_clauses *
continue;
if ((mask & OMP_CLAUSE_PRIVATE)
&& gfc_match_omp_variable_list ("private (",
- &c->lists[OMP_LIST_PRIVATE])
+ &c->lists[OMP_LIST_PRIVATE], true)
== MATCH_YES)
continue;
if ((mask & OMP_CLAUSE_FIRSTPRIVATE)
&& gfc_match_omp_variable_list ("firstprivate (",
- &c->lists[OMP_LIST_FIRSTPRIVATE])
+ &c->lists[OMP_LIST_FIRSTPRIVATE],
+ true)
== MATCH_YES)
continue;
if ((mask & OMP_CLAUSE_LASTPRIVATE)
&& gfc_match_omp_variable_list ("lastprivate (",
- &c->lists[OMP_LIST_LASTPRIVATE])
+ &c->lists[OMP_LIST_LASTPRIVATE],
+ true)
== MATCH_YES)
continue;
if ((mask & OMP_CLAUSE_COPYPRIVATE)
&& gfc_match_omp_variable_list ("copyprivate (",
- &c->lists[OMP_LIST_COPYPRIVATE])
+ &c->lists[OMP_LIST_COPYPRIVATE],
+ true)
== MATCH_YES)
continue;
if ((mask & OMP_CLAUSE_SHARED)
&& gfc_match_omp_variable_list ("shared (",
- &c->lists[OMP_LIST_SHARED])
+ &c->lists[OMP_LIST_SHARED], true)
== MATCH_YES)
continue;
if ((mask & OMP_CLAUSE_COPYIN)
&& gfc_match_omp_variable_list ("copyin (",
- &c->lists[OMP_LIST_COPYIN])
+ &c->lists[OMP_LIST_COPYIN], true)
== MATCH_YES)
continue;
old_loc = gfc_current_locus;
@@ -260,7 +267,8 @@ gfc_match_omp_clauses (gfc_omp_clauses *
else if (gfc_match ("ieor") == MATCH_YES)
reduction = OMP_LIST_IEOR;
if (reduction != OMP_LIST_NUM
- && gfc_match_omp_variable_list (" :", &c->lists[reduction])
+ && gfc_match_omp_variable_list (" :", &c->lists[reduction],
+ false)
== MATCH_YES)
continue;
else
@@ -378,7 +386,7 @@ match
gfc_match_omp_flush (void)
{
gfc_namelist *list = NULL;
- gfc_match_omp_variable_list (" (", &list);
+ gfc_match_omp_variable_list (" (", &list, true);
if (gfc_match_omp_eos () != MATCH_YES)
{
gfc_free_namelist (list);
@@ -693,53 +701,100 @@ resolve_omp_clauses (gfc_code *code)
for (; n != NULL; n = n->next)
{
if (!n->sym->attr.threadprivate)
- gfc_error ("Non-THREADPRIVATE object %s in COPYIN clause",
- n->sym->name);
+ 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",
- n->sym->name);
+ gfc_error ("COPYIN clause object %s is ALLOCATABLE at %L",
+ n->sym->name, &code->loc);
}
break;
case OMP_LIST_COPYPRIVATE:
for (; n != NULL; n = n->next)
{
if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
- gfc_error ("Assumed size array %s in COPYPRIVATE clause",
- n->sym->name);
+ 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",
- n->sym->name);
+ gfc_error ("COPYPRIVATE clause object %s is ALLOCATABLE"
+ " at %L", n->sym->name, &code->loc);
}
break;
case OMP_LIST_SHARED:
for (; n != NULL; n = n->next)
if (n->sym->attr.threadprivate)
- gfc_error ("THREADPRIVATE object %s in SHARED clause",
- n->sym->name);
+ gfc_error ("THREADPRIVATE object %s in SHARED clause at %L",
+ n->sym->name, &code->loc);
break;
default:
for (; n != NULL; n = n->next)
{
if (n->sym->attr.threadprivate)
- gfc_error ("THREADPRIVATE object %s in %s clause",
- n->sym->name, name);
+ gfc_error ("THREADPRIVATE object %s in %s clause at %L",
+ n->sym->name, name, &code->loc);
if (list != OMP_LIST_PRIVATE)
{
if (n->sym->attr.pointer)
- gfc_error ("POINTER object %s in %s clause",
- n->sym->name, name);
+ 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",
- name, n->sym->name);
+ gfc_error ("%s clause object %s is ALLOCATABLE at %L",
+ name, n->sym->name, &code->loc);
}
if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
- gfc_error ("Assumed size array %s in %s clause",
- n->sym->name, name);
+ gfc_error ("Assumed size array %s in %s clause at %L",
+ n->sym->name, name, &code->loc);
if (n->sym->attr.in_namelist
&& (list < OMP_LIST_REDUCTION_FIRST
|| list > OMP_LIST_REDUCTION_LAST))
gfc_error ("Variable %s in %s clause is used in"
- " NAMELIST statement", n->sym->name, name);
+ " NAMELIST statement at %L",
+ n->sym->name, name, &code->loc);
+ switch (list)
+ {
+ case OMP_LIST_PLUS:
+ case OMP_LIST_MULT:
+ case OMP_LIST_SUB:
+ if (!gfc_numeric_ts (&n->sym->ts))
+ gfc_error ("%c REDUCTION variable %s is %s at %L",
+ list == OMP_LIST_PLUS ? '+'
+ : list == OMP_LIST_MULT ? '*' : '-',
+ n->sym->name, gfc_typename (&n->sym->ts),
+ &code->loc);
+ break;
+ case OMP_LIST_AND:
+ case OMP_LIST_OR:
+ case OMP_LIST_EQV:
+ case OMP_LIST_NEQV:
+ if (n->sym->ts.type != BT_LOGICAL)
+ gfc_error ("%s REDUCTION variable %s must be LOGICAL"
+ " at %L",
+ list == OMP_LIST_AND ? ".AND."
+ : list == OMP_LIST_OR ? ".OR."
+ : list == OMP_LIST_EQV ? ".EQV." : ".NEQV.",
+ n->sym->name, &code->loc);
+ break;
+ case OMP_LIST_MAX:
+ case OMP_LIST_MIN:
+ if (n->sym->ts.type != BT_INTEGER
+ && n->sym->ts.type != BT_REAL)
+ gfc_error ("%s REDUCTION variable %s must be"
+ " INTEGER or REAL at %L",
+ list == OMP_LIST_MAX ? "MAX" : "MIN",
+ n->sym->name, &code->loc);
+ break;
+ case OMP_LIST_IAND:
+ case OMP_LIST_IOR:
+ case OMP_LIST_IEOR:
+ if (n->sym->ts.type != BT_INTEGER)
+ gfc_error ("%s REDUCTION variable %s must be INTEGER"
+ " at %L",
+ list == OMP_LIST_IAND ? "IAND"
+ : list == OMP_LIST_MULT ? "IOR" : "IEOR",
+ n->sym->name, &code->loc);
+ break;
+ default:
+ break;
+ }
}
break;
}
--- gcc/testsuite/gfortran.dg/gomp/reduction1.f90.jj 2005-10-14 13:47:04.000000000 +0200
+++ gcc/testsuite/gfortran.dg/gomp/reduction1.f90 2005-10-14 14:09:24.000000000 +0200
@@ -0,0 +1,130 @@
+! { dg-do compile }
+
+subroutine foo (ia1)
+integer :: i1, i2, i3
+integer, dimension (*) :: ia1
+integer, dimension (10) :: ia2
+real :: r1
+real, dimension (5) :: ra1
+double precision :: d1
+double precision, dimension (4) :: da1
+complex :: c1
+complex, dimension (7) :: ca1
+logical :: l1
+logical, dimension (3) :: la1
+character (5) :: a1
+type t
+ integer :: i
+end type
+type(t) :: t1
+type(t), dimension (2) :: ta1
+real, pointer :: p1 => NULL()
+integer, allocatable :: aa1 (:,:)
+save i2
+!$omp threadprivate (i2)
+common /blk/ i1
+
+!$omp parallel reduction (+:i3, ia2, r1, ra1, d1, da1, c1, ca1)
+!$omp end parallel
+!$omp parallel reduction (*:i3, ia2, r1, ra1, d1, da1, c1, ca1)
+!$omp end parallel
+!$omp parallel reduction (-:i3, ia2, r1, ra1, d1, da1, c1, ca1)
+!$omp end parallel
+!$omp parallel reduction (.and.:l1, la1)
+!$omp end parallel
+!$omp parallel reduction (.or.:l1, la1)
+!$omp end parallel
+!$omp parallel reduction (.eqv.:l1, la1)
+!$omp end parallel
+!$omp parallel reduction (.neqv.:l1, la1)
+!$omp end parallel
+!$omp parallel reduction (min:i3, ia2, r1, ra1, d1, da1)
+!$omp end parallel
+!$omp parallel reduction (max:i3, ia2, r1, ra1, d1, da1)
+!$omp end parallel
+!$omp parallel reduction (iand:i3, ia2)
+!$omp end parallel
+!$omp parallel reduction (ior:i3, ia2)
+!$omp end parallel
+!$omp parallel reduction (ieor:i3, ia2)
+!$omp end parallel
+!$omp parallel reduction (+:/blk/) ! { dg-error "Syntax error" }
+!$omp end parallel ! { dg-error "Unexpected" }
+!$omp parallel reduction (+:i2) ! { dg-error "THREADPRIVATE object" }
+!$omp end parallel
+!$omp parallel reduction (*:p1) ! { dg-error "POINTER object" }
+!$omp end parallel
+!$omp parallel reduction (-:aa1) ! { dg-error "is ALLOCATABLE" }
+!$omp end parallel
+!$omp parallel reduction (*:ia1) ! { dg-error "Assumed size" }
+!$omp end parallel
+!$omp parallel reduction (+:l1) ! { dg-error "is LOGICAL" }
+!$omp end parallel
+!$omp parallel reduction (*:la1) ! { dg-error "is LOGICAL" }
+!$omp end parallel
+!$omp parallel reduction (-:a1) ! { dg-error "is CHARACTER" }
+!$omp end parallel
+!$omp parallel reduction (+:t1) ! { dg-error "is TYPE" }
+!$omp end parallel
+!$omp parallel reduction (*:ta1) ! { dg-error "is TYPE" }
+!$omp end parallel
+!$omp parallel reduction (.and.:i3) ! { dg-error "must be LOGICAL" }
+!$omp end parallel
+!$omp parallel reduction (.or.:ia2) ! { dg-error "must be LOGICAL" }
+!$omp end parallel
+!$omp parallel reduction (.eqv.:r1) ! { dg-error "must be LOGICAL" }
+!$omp end parallel
+!$omp parallel reduction (.neqv.:ra1) ! { dg-error "must be LOGICAL" }
+!$omp end parallel
+!$omp parallel reduction (.and.:d1) ! { dg-error "must be LOGICAL" }
+!$omp end parallel
+!$omp parallel reduction (.or.:da1) ! { dg-error "must be LOGICAL" }
+!$omp end parallel
+!$omp parallel reduction (.eqv.:c1) ! { dg-error "must be LOGICAL" }
+!$omp end parallel
+!$omp parallel reduction (.neqv.:ca1) ! { dg-error "must be LOGICAL" }
+!$omp end parallel
+!$omp parallel reduction (.and.:a1) ! { dg-error "must be LOGICAL" }
+!$omp end parallel
+!$omp parallel reduction (.or.:t1) ! { dg-error "must be LOGICAL" }
+!$omp end parallel
+!$omp parallel reduction (.eqv.:ta1) ! { dg-error "must be LOGICAL" }
+!$omp end parallel
+!$omp parallel reduction (min:c1) ! { dg-error "must be INTEGER or REAL" }
+!$omp end parallel
+!$omp parallel reduction (max:ca1) ! { dg-error "must be INTEGER or REAL" }
+!$omp end parallel
+!$omp parallel reduction (max:l1) ! { dg-error "must be INTEGER or REAL" }
+!$omp end parallel
+!$omp parallel reduction (min:la1) ! { dg-error "must be INTEGER or REAL" }
+!$omp end parallel
+!$omp parallel reduction (max:a1) ! { dg-error "must be INTEGER or REAL" }
+!$omp end parallel
+!$omp parallel reduction (min:t1) ! { dg-error "must be INTEGER or REAL" }
+!$omp end parallel
+!$omp parallel reduction (max:ta1) ! { dg-error "must be INTEGER or REAL" }
+!$omp end parallel
+!$omp parallel reduction (iand:r1) ! { dg-error "must be INTEGER" }
+!$omp end parallel
+!$omp parallel reduction (ior:ra1) ! { dg-error "must be INTEGER" }
+!$omp end parallel
+!$omp parallel reduction (ieor:d1) ! { dg-error "must be INTEGER" }
+!$omp end parallel
+!$omp parallel reduction (ior:da1) ! { dg-error "must be INTEGER" }
+!$omp end parallel
+!$omp parallel reduction (iand:c1) ! { dg-error "must be INTEGER" }
+!$omp end parallel
+!$omp parallel reduction (ior:ca1) ! { dg-error "must be INTEGER" }
+!$omp end parallel
+!$omp parallel reduction (ieor:l1) ! { dg-error "must be INTEGER" }
+!$omp end parallel
+!$omp parallel reduction (iand:la1) ! { dg-error "must be INTEGER" }
+!$omp end parallel
+!$omp parallel reduction (ior:a1) ! { dg-error "must be INTEGER" }
+!$omp end parallel
+!$omp parallel reduction (ieor:t1) ! { dg-error "must be INTEGER" }
+!$omp end parallel
+!$omp parallel reduction (iand:ta1) ! { dg-error "must be INTEGER" }
+!$omp end parallel
+
+end subroutine
--- libgomp/testsuite/libgomp.fortran/threadprivate1.f90.jj 2005-10-13 12:33:49.000000000 +0200
+++ libgomp/testsuite/libgomp.fortran/threadprivate1.f90 2005-10-14 17:43:11.000000000 +0200
@@ -1,11 +1,12 @@
! { dg-do run }
+
module threadprivate1
double precision :: d
!$omp threadprivate (d)
end module threadprivate1
+!$ use omp_lib
use threadprivate1
- integer omp_get_thread_num
logical :: l
l = .false.
!$omp parallel num_threads (4) reduction (.or.:l)
--- libgomp/testsuite/libgomp.fortran/character2.f90.jj 2005-10-12 22:03:32.000000000 +0200
+++ libgomp/testsuite/libgomp.fortran/character2.f90 2005-10-14 17:41:01.000000000 +0200
@@ -14,7 +14,6 @@ contains
character (len = n) :: t
character (len = n) :: u
integer, dimension (n + 4) :: s
- integer omp_get_thread_num
logical :: l
integer :: m
r = ''
--- libgomp/testsuite/libgomp.fortran/reduction1.f90.jj 2005-10-14 14:47:47.000000000 +0200
+++ libgomp/testsuite/libgomp.fortran/reduction1.f90 2005-10-14 16:24:35.000000000 +0200
@@ -0,0 +1,181 @@
+! { dg-do run }
+!$ use omp_lib
+
+ integer :: i, ia (6), n, cnt
+ real :: r, ra (4)
+ double precision :: d, da (5)
+ complex :: c, ca (3)
+ logical :: v
+
+ i = 1
+ ia = 2
+ r = 3
+ ra = 4
+ d = 5.5
+ da = 6.5
+ c = cmplx (7.5, 1.5)
+ ca = cmplx (8.5, -3.0)
+ v = .false.
+ cnt = -1
+
+!$omp parallel num_threads (3) private (n) reduction (.or.:v) &
+!$omp & reduction (+:i, ia, r, ra, d, da, c, ca)
+!$ if (i .ne. 0 .or. any (ia .ne. 0)) v = .true.
+!$ if (r .ne. 0 .or. any (ra .ne. 0)) v = .true.
+!$ if (d .ne. 0 .or. any (da .ne. 0)) v = .true.
+!$ if (c .ne. cmplx (0) .or. any (ca .ne. cmplx (0))) v = .true.
+ n = omp_get_thread_num ()
+ if (n .eq. 0) then
+ cnt = omp_get_num_threads ()
+ i = 4
+ ia(3:5) = -2
+ r = 5
+ ra(1:2) = 6.5
+ d = -2.5
+ da(2:4) = 8.5
+ c = cmplx (2.5, -3.5)
+ ca(1) = cmplx (4.5, 5)
+ else if (n .eq. 1) then
+ i = 2
+ ia(4:6) = 5
+ r = 1
+ ra(2:4) = -1.5
+ d = 8.5
+ da(1:3) = 2.5
+ c = cmplx (0.5, -3)
+ ca(2:3) = cmplx (-1, 6)
+ else
+ i = 1
+ ia = 1
+ r = -1
+ ra = -1
+ d = 1
+ da = -1
+ c = 1
+ ca = cmplx (-1, 0)
+ end if
+!$omp end parallel
+ if (v) call abort
+ if (cnt .eq. 3) then
+ if (i .ne. 8 .or. any (ia .ne. (/3, 3, 1, 6, 6, 8/))) call abort
+ if (r .ne. 8 .or. any (ra .ne. (/9.5, 8.0, 1.5, 1.5/))) call abort
+ if (d .ne. 12.5 .or. any (da .ne. (/8.0, 16.5, 16.5, 14.0, 5.5/))) call abort
+ if (c .ne. cmplx (11.5, -5)) call abort
+ if (ca(1) .ne. cmplx (12, 2)) call abort
+ if (ca(2) .ne. cmplx (6.5, 3) .or. ca(2) .ne. ca(3)) call abort
+ end if
+
+ i = -1
+ ia = -2
+ r = -3
+ ra = -4
+ d = -5.5
+ da = -6.5
+ c = cmplx (-7.5, -1.5)
+ ca = cmplx (-8.5, 3.0)
+ v = .false.
+ cnt = -1
+
+!$omp parallel num_threads (3) private (n) reduction (.or.:v) &
+!$omp & reduction (-:i, ia, r, ra, d, da, c, ca)
+!$ if (i .ne. 0 .or. any (ia .ne. 0)) v = .true.
+!$ if (r .ne. 0 .or. any (ra .ne. 0)) v = .true.
+!$ if (d .ne. 0 .or. any (da .ne. 0)) v = .true.
+!$ if (c .ne. cmplx (0) .or. any (ca .ne. cmplx (0))) v = .true.
+ n = omp_get_thread_num ()
+ if (n .eq. 0) then
+ cnt = omp_get_num_threads ()
+ i = 4
+ ia(3:5) = -2
+ r = 5
+ ra(1:2) = 6.5
+ d = -2.5
+ da(2:4) = 8.5
+ c = cmplx (2.5, -3.5)
+ ca(1) = cmplx (4.5, 5)
+ else if (n .eq. 1) then
+ i = 2
+ ia(4:6) = 5
+ r = 1
+ ra(2:4) = -1.5
+ d = 8.5
+ da(1:3) = 2.5
+ c = cmplx (0.5, -3)
+ ca(2:3) = cmplx (-1, 6)
+ else
+ i = 1
+ ia = 1
+ r = -1
+ ra = -1
+ d = 1
+ da = -1
+ c = 1
+ ca = cmplx (-1, 0)
+ end if
+!$omp end parallel
+ if (v) call abort
+ if (cnt .eq. 3) then
+ if (i .ne. -8 .or. any (ia .ne. (/-3, -3, -1, -6, -6, -8/))) call abort
+ if (r .ne. -8 .or. any (ra .ne. (/-9.5, -8.0, -1.5, -1.5/))) call abort
+ if (d .ne. -12.5 .or. any (da .ne. (/-8.0, -16.5, -16.5, -14.0, -5.5/))) call abort
+ if (c .ne. cmplx (-11.5, 5)) call abort
+ if (ca(1) .ne. cmplx (-12, -2)) call abort
+ if (ca(2) .ne. cmplx (-6.5, -3) .or. ca(2) .ne. ca(3)) call abort
+ end if
+
+ i = 1
+ ia = 2
+ r = 4
+ ra = 8
+ d = 16
+ da = 32
+ c = 2
+ ca = cmplx (0, 2)
+ v = .false.
+ cnt = -1
+
+!$omp parallel num_threads (3) private (n) reduction (.or.:v) &
+!$omp & reduction (*:i, ia, r, ra, d, da, c, ca)
+!$ if (i .ne. 1 .or. any (ia .ne. 1)) v = .true.
+!$ if (r .ne. 1 .or. any (ra .ne. 1)) v = .true.
+!$ if (d .ne. 1 .or. any (da .ne. 1)) v = .true.
+!$ if (c .ne. cmplx (1) .or. any (ca .ne. cmplx (1))) v = .true.
+ n = omp_get_thread_num ()
+ if (n .eq. 0) then
+ cnt = omp_get_num_threads ()
+ i = 3
+ ia(3:5) = 2
+ r = 0.5
+ ra(1:2) = 2
+ d = -1
+ da(2:4) = -2
+ c = 2.5
+ ca(1) = cmplx (-5, 0)
+ else if (n .eq. 1) then
+ i = 2
+ ia(4:6) = -2
+ r = 8
+ ra(2:4) = -0.5
+ da(1:3) = -1
+ c = -3
+ ca(2:3) = cmplx (0, -1)
+ else
+ ia = 2
+ r = 0.5
+ ra = 0.25
+ d = 2.5
+ da = -1
+ c = cmplx (0, -1)
+ ca = cmplx (-1, 0)
+ end if
+!$omp end parallel
+ if (v) call abort
+ if (cnt .eq. 3) then
+ if (i .ne. 6 .or. any (ia .ne. (/4, 4, 8, -16, -16, -8/))) call abort
+ if (r .ne. 8 .or. any (ra .ne. (/4., -2., -1., -1./))) call abort
+ if (d .ne. -40 .or. any (da .ne. (/32., -64., -64., 64., -32./))) call abort
+ if (c .ne. cmplx (0, 15)) call abort
+ if (ca(1) .ne. cmplx (0, 10)) call abort
+ if (ca(2) .ne. cmplx (-2, 0) .or. ca(2) .ne. ca(3)) call abort
+ end if
+end
--- libgomp/testsuite/libgomp.fortran/reduction2.f90.jj 2005-10-14 16:01:28.000000000 +0200
+++ libgomp/testsuite/libgomp.fortran/reduction2.f90 2005-10-14 16:25:15.000000000 +0200
@@ -0,0 +1,73 @@
+! { dg-do run }
+!$ use omp_lib
+
+ logical :: l, la (4), m, ma (4), v
+ integer :: n, cnt
+
+ l = .true.
+ la = (/.true., .false., .true., .true./)
+ m = .false.
+ ma = (/.false., .false., .false., .true./)
+ v = .false.
+ cnt = -1
+
+!$omp parallel num_threads (3) private (n) reduction (.or.:v) &
+!$omp & reduction (.and.:l, la) reduction (.or.:m, ma)
+!$ if (.not. l .or. any (.not. la)) v = .true.
+!$ if (m .or. any (ma)) v = .true.
+ n = omp_get_thread_num ()
+ if (n .eq. 0) then
+ cnt = omp_get_num_threads ()
+ l = .false.
+ la(3) = .false.
+ ma(2) = .true.
+ else if (n .eq. 1) then
+ l = .false.
+ la(4) = .false.
+ ma(1) = .true.
+ else
+ la(3) = .false.
+ m = .true.
+ ma(1) = .true.
+ end if
+!$omp end parallel
+ if (v) call abort
+ if (cnt .eq. 3) then
+ if (l .or. any (la .neqv. (/.true., .false., .false., .false./))) call abort
+ if (.not. m .or. any (ma .neqv. (/.true., .true., .false., .true./))) call abort
+ end if
+
+ l = .true.
+ la = (/.true., .false., .true., .true./)
+ m = .false.
+ ma = (/.false., .false., .false., .true./)
+ v = .false.
+ cnt = -1
+
+!$omp parallel num_threads (3) private (n) reduction (.or.:v) &
+!$omp & reduction (.eqv.:l, la) reduction (.neqv.:m, ma)
+!$ if (.not. l .or. any (.not. la)) v = .true.
+!$ if (m .or. any (ma)) v = .true.
+ n = omp_get_thread_num ()
+ if (n .eq. 0) then
+ cnt = omp_get_num_threads ()
+ l = .false.
+ la(3) = .false.
+ ma(2) = .true.
+ else if (n .eq. 1) then
+ l = .false.
+ la(4) = .false.
+ ma(1) = .true.
+ else
+ la(3) = .false.
+ m = .true.
+ ma(1) = .true.
+ end if
+!$omp end parallel
+ if (v) call abort
+ if (cnt .eq. 3) then
+ if (.not. l .or. any (la .neqv. (/.true., .false., .true., .false./))) call abort
+ if (.not. m .or. any (ma .neqv. (/.false., .true., .false., .true./))) call abort
+ end if
+
+end
--- libgomp/testsuite/libgomp.fortran/reduction3.f90.jj 2005-10-14 16:25:26.000000000 +0200
+++ libgomp/testsuite/libgomp.fortran/reduction3.f90 2005-10-14 17:01:23.000000000 +0200
@@ -0,0 +1,103 @@
+! { dg-do run }
+!$ use omp_lib
+
+ integer (kind = 4) :: i, ia (6), n, cnt
+ real :: r, ra (4)
+ double precision :: d, da (5)
+ logical :: v
+
+ i = 1
+ ia = 2
+ r = 3
+ ra = 4
+ d = 5.5
+ da = 6.5
+ v = .false.
+ cnt = -1
+
+!$omp parallel num_threads (3) private (n) reduction (.or.:v) &
+!$omp & reduction (max:i, ia, r, ra, d, da)
+!$ if (i .ne. -2147483648 .or. any (ia .ne. -2147483648)) v = .true.
+!$ if (r .ge. -1.0d38 .or. any (ra .ge. -1.0d38)) v = .true.
+!$ if (d .ge. -1.0d300 .or. any (da .ge. -1.0d300)) v = .true.
+ n = omp_get_thread_num ()
+ if (n .eq. 0) then
+ cnt = omp_get_num_threads ()
+ i = 4
+ ia(3:5) = -2
+ ia(1) = 7
+ r = 5
+ ra(1:2) = 6.5
+ d = -2.5
+ da(2:4) = 8.5
+ else if (n .eq. 1) then
+ i = 2
+ ia(4:6) = 5
+ r = 1
+ ra(2:4) = -1.5
+ d = 8.5
+ da(1:3) = 2.5
+ else
+ i = 1
+ ia = 1
+ r = -1
+ ra = -1
+ d = 1
+ da = -1
+ end if
+!$omp end parallel
+ if (v) call abort
+ if (cnt .eq. 3) then
+ if (i .ne. 4 .or. any (ia .ne. (/7, 2, 2, 5, 5, 5/))) call abort
+ if (r .ne. 5 .or. any (ra .ne. (/6.5, 6.5, 4., 4./))) call abort
+ if (d .ne. 8.5 .or. any (da .ne. (/6.5, 8.5, 8.5, 8.5, 6.5/))) call abort
+ end if
+
+ i = 1
+ ia = 2
+ r = 3
+ ra = 4
+ d = 5.5
+ da = 6.5
+ v = .false.
+ cnt = -1
+
+!$omp parallel num_threads (3) private (n) reduction (.or.:v) &
+!$omp & reduction (min:i, ia, r, ra, d, da)
+!$ if (i .ne. 2147483647 .or. any (ia .ne. 2147483647)) v = .true.
+!$ if (r .le. 1.0d38 .or. any (ra .le. 1.0d38)) v = .true.
+!$ if (d .le. 1.0d300 .or. any (da .le. 1.0d300)) v = .true.
+ n = omp_get_thread_num ()
+ if (n .eq. 0) then
+ cnt = omp_get_num_threads ()
+ i = 4
+ ia(3:5) = -2
+ ia(1) = 7
+ r = 5
+ ra(1:2) = 6.5
+ d = -2.5
+ da(2:4) = 8.5
+ else if (n .eq. 1) then
+ i = 2
+ ia(4:6) = 5
+ r = 1
+ ra(2:4) = -1.5
+ d = 8.5
+ da(1:3) = 2.5
+ else
+ i = 1
+ ia = 1
+ r = -1
+ ra = 7
+ ra(3) = -8.5
+ d = 1
+ da(1:4) = 6
+ end if
+!$omp end parallel
+ if (v) call abort
+ if (cnt .eq. 3) then
+ if (i .ne. 1 .or. any (ia .ne. (/1, 1, -2, -2, -2, 1/))) call abort
+ if (r .ne. -1 .or. any (ra .ne. (/4., -1.5, -8.5, -1.5/))) call abort
+ if (d .ne. -2.5 .or. any (da .ne. (/2.5, 2.5, 2.5, 6., 6.5/))) call abort
+ end if
+end
--- libgomp/testsuite/libgomp.fortran/reduction4.f90.jj 2005-10-14 17:03:47.000000000 +0200
+++ libgomp/testsuite/libgomp.fortran/reduction4.f90 2005-10-14 17:37:32.000000000 +0200
@@ -0,0 +1,56 @@
+! { dg-do run }
+!$ use omp_lib
+
+ integer (kind = 4) :: i, ia (6), j, ja (6), k, ka (6), ta (6), n, cnt, x
+ logical :: v
+
+ i = Z'ffff0f'
+ ia = Z'f0ff0f'
+ j = Z'0f0000'
+ ja = Z'0f5a00'
+ k = Z'055aa0'
+ ka = Z'05a5a5'
+ v = .false.
+ cnt = -1
+ x = Z'ffffffff'
+
+!$omp parallel num_threads (3) private (n) reduction (.or.:v) &
+!$omp & reduction (iand:i, ia) reduction (ior:j, ja) reduction (ieor:k, ka)
+!$ if (i .ne. x .or. any (ia .ne. x)) v = .true.
+!$ if (j .ne. 0 .or. any (ja .ne. 0)) v = .true.
+!$ if (k .ne. 0 .or. any (ka .ne. 0)) v = .true.
+ n = omp_get_thread_num ()
+ if (n .eq. 0) then
+ cnt = omp_get_num_threads ()
+ i = Z'ff7fff'
+ ia(3:5) = Z'fffff1'
+ j = Z'078000'
+ ja(1:3) = 1
+ k = Z'78'
+ ka(3:6) = Z'f0f'
+ else if (n .eq. 1) then
+ i = Z'ffff77'
+ ia(2:5) = Z'ffafff'
+ j = Z'007800'
+ ja(2:5) = 8
+ k = Z'57'
+ ka(3:4) = Z'f0108'
+ else
+ i = Z'777fff'
+ ia(1:2) = Z'fffff3'
+ j = Z'000780'
+ ja(5:6) = Z'f00'
+ k = Z'1000'
+ ka(6:6) = Z'777'
+ end if
+!$omp end parallel
+ if (v) call abort
+ if (cnt .eq. 3) then
+ ta = (/Z'f0ff03', Z'f0af03', Z'f0af01', Z'f0af01', Z'f0af01', Z'f0ff0f'/)
+ if (i .ne. Z'777f07' .or. any (ia .ne. ta)) call abort
+ ta = (/Z'f5a01', Z'f5a09', Z'f5a09', Z'f5a08', Z'f5f08', Z'f5f00'/)
+ if (j .ne. Z'fff80' .or. any (ja .ne. ta)) call abort
+ ta = (/Z'5a5a5', Z'5a5a5', Z'aaba2', Z'aaba2', Z'5aaaa', Z'5addd'/)
+ if (k .ne. Z'54a8f' .or. any (ka .ne. ta)) call abort
+ end if
+end
Jakub
More information about the Gcc-patches
mailing list