[gomp] Fix some Fortran OpenMP parser bugs, add atomic and do resolving
Jakub Jelinek
jakub@redhat.com
Thu Sep 22 19:49:00 GMT 2005
Hi!
Ok for gomp?
2005-09-22 Jakub Jelinek <jakub@redhat.com>
* parse.c (parse_omp_do): Call pop_state before next_statement.
* openmp.c (expr_references_sym, resolve_omp_atomic, resolve_omp_do):
New functions.
(gfc_resolve_omp_directive): Call them.
* match.c (match_exit_cycle): Issue error if EXIT or CYCLE statement
leaves an OpenMP structured block or if EXIT terminates !$omp do
loop.
* gfortran.dg/gomp/gomp.exp: New file.
* gfortran.dg/gomp/omp_atomic1.f90: New test.
* gfortran.dg/gomp/omp_do1.f90: New test.
* testsuite/libgomp.fortran/omp_parse1.f90: Add a test for !$omp do
without !$omp end do, followed immediately by subroutine end.
--- gcc/fortran/parse.c.jj 2005-09-20 10:25:18.000000000 +0200
+++ gcc/fortran/parse.c 2005-09-21 15:46:31.000000000 +0200
@@ -2289,6 +2289,8 @@ parse_omp_do (gfc_statement omp_st)
parse_do_block ();
check_do_closure ();
+ pop_state ();
+
st = next_statement ();
if (st == (omp_st == ST_OMP_DO ? ST_OMP_END_DO : ST_OMP_END_PARALLEL_DO))
{
@@ -2297,8 +2299,6 @@ parse_omp_do (gfc_statement omp_st)
gfc_clear_new_st ();
st = next_statement ();
}
-
- pop_state ();
return st;
}
--- gcc/fortran/openmp.c.jj 2005-09-20 10:25:18.000000000 +0200
+++ gcc/fortran/openmp.c 2005-09-22 18:18:19.000000000 +0200
@@ -588,6 +588,281 @@ resolve_omp_clauses (gfc_code *code)
}
}
+/* Return true if SYM is ever referenced in EXPR. */
+
+static bool
+expr_references_sym (gfc_expr *e, gfc_symbol *s)
+{
+ gfc_actual_arglist *arg;
+ if (e == NULL)
+ return false;
+ switch (e->expr_type)
+ {
+ case EXPR_CONSTANT:
+ case EXPR_NULL:
+ case EXPR_VARIABLE:
+ case EXPR_STRUCTURE:
+ case EXPR_ARRAY:
+ if (e->symtree != NULL
+ && e->symtree->n.sym == s)
+ return true;
+ return false;
+ case EXPR_SUBSTRING:
+ if (e->ref != NULL
+ && (expr_references_sym (e->ref->u.ss.start, s)
+ || expr_references_sym (e->ref->u.ss.end, s)))
+ return true;
+ return false;
+ case EXPR_OP:
+ if (expr_references_sym (e->value.op.op2, s))
+ return true;
+ return expr_references_sym (e->value.op.op1, s);
+ case EXPR_FUNCTION:
+ for (arg = e->value.function.actual; arg; arg = arg->next)
+ if (expr_references_sym (arg->expr, s))
+ return true;
+ return false;
+ default:
+ gcc_unreachable ();
+ }
+}
+
+static void
+resolve_omp_atomic (gfc_code *code)
+{
+ gfc_symbol *var;
+ gfc_expr *expr2;
+
+ code = code->block->next;
+ gcc_assert (code->op == EXEC_ASSIGN);
+ gcc_assert (code->next == NULL);
+
+ if (code->expr->expr_type != EXPR_VARIABLE
+ || code->expr->symtree == NULL
+ || code->expr->rank != 0
+ || (code->expr->ts.type != BT_INTEGER
+ && code->expr->ts.type != BT_REAL
+ && code->expr->ts.type != BT_COMPLEX
+ && code->expr->ts.type != BT_LOGICAL))
+ {
+ gfc_error ("!$OMP ATOMIC statement must set a scalar variable of"
+ " intrinsic type at %L", &code->loc);
+ return;
+ }
+
+ var = code->expr->symtree->n.sym;
+ expr2 = code->expr2;
+
+ if (expr2->expr_type == EXPR_OP)
+ {
+ gfc_expr *v = NULL, *e;
+ gfc_intrinsic_op op = expr2->value.op.operator;
+ gfc_intrinsic_op alt_op = INTRINSIC_NONE;
+
+ switch (op)
+ {
+ case INTRINSIC_PLUS:
+ alt_op = INTRINSIC_MINUS;
+ break;
+ case INTRINSIC_TIMES:
+ alt_op = INTRINSIC_DIVIDE;
+ break;
+ case INTRINSIC_MINUS:
+ alt_op = INTRINSIC_PLUS;
+ break;
+ case INTRINSIC_DIVIDE:
+ alt_op = INTRINSIC_TIMES;
+ break;
+ case INTRINSIC_AND:
+ case INTRINSIC_OR:
+ break;
+ case INTRINSIC_EQV:
+ alt_op = INTRINSIC_NEQV;
+ break;
+ case INTRINSIC_NEQV:
+ alt_op = INTRINSIC_EQV;
+ break;
+ default:
+ gfc_error ("!$OMP ATOMIC assignment operator must be"
+ " +, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L",
+ &expr2->where);
+ return;
+ }
+
+ /* Check for var = var op expr resp. var = expr op var where
+ expr doesn't reference var and var op expr is mathematically
+ equivalent to var op (expr) resp. expr op var equivalent to
+ (expr) op var. We rely here on the fact that the matcher
+ for x op1 y op2 z where op1 and op2 have equal precedence
+ returns (x op1 y) op2 z. */
+ if (expr2->value.op.op2->expr_type == EXPR_VARIABLE
+ && expr2->value.op.op2->symtree != NULL
+ && expr2->value.op.op2->symtree->n.sym == var)
+ v = expr2->value.op.op2;
+ else
+ {
+ gfc_expr **p = NULL;
+ for (e = expr2->value.op.op1; e; e = e->value.op.op1)
+ if (e->expr_type == EXPR_VARIABLE
+ && e->symtree != NULL
+ && e->symtree->n.sym == var)
+ {
+ v = e;
+ break;
+ }
+ else if (e->expr_type != EXPR_OP
+ || (e->value.op.operator != op
+ && e->value.op.operator != alt_op)
+ || e->rank != 0)
+ break;
+ else if (p == NULL)
+ p = &expr2->value.op.op1;
+ else
+ p = &(*p)->value.op.op1;
+
+ if (v == NULL)
+ {
+ gfc_error ("!$OMP ATOMIC assignment must be var = var op expr"
+ " or var = expr op var at %L", &expr2->where);
+ return;
+ }
+
+ if (v != expr2->value.op.op1)
+ {
+ e = *p;
+ switch (e->value.op.operator)
+ {
+ case INTRINSIC_MINUS:
+ case INTRINSIC_DIVIDE:
+ case INTRINSIC_EQV:
+ case INTRINSIC_NEQV:
+ gfc_error ("!$OMP ATOMIC var = var op expr not"
+ " mathematically equivalent to var = var op"
+ " (expr) at %L", &expr2->where);
+ break;
+ default:
+ break;
+ }
+
+ /* Canonicalize into var = var op (expr). */
+ gcc_assert (e->value.op.op1 == v);
+ *p = e->value.op.op2;
+ e->value.op.op2 = expr2;
+ code->expr2 = expr2 = e;
+ }
+ }
+
+ if (v == expr2->value.op.op1)
+ e = expr2->value.op.op2;
+ else
+ e = expr2->value.op.op1;
+
+ if (e->rank != 0 || expr_references_sym (e, var))
+ {
+ if (v == expr2->value.op.op1)
+ gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr"
+ " must be scalar and cannot reference var at %L",
+ &expr2->where);
+ else
+ gfc_error ("expr in !$OMP ATOMIC assignment var = expr op var"
+ " must be scalar and cannot reference var at %L",
+ &expr2->where);
+ return;
+ }
+ }
+ else if (expr2->expr_type == EXPR_FUNCTION
+ && expr2->value.function.isym != NULL
+ && expr2->value.function.esym == NULL
+ && expr2->value.function.actual != NULL
+ && expr2->value.function.actual->next != NULL)
+ {
+ gfc_actual_arglist *arg, *var_arg;
+
+ switch (expr2->value.function.isym->generic_id)
+ {
+ case GFC_ISYM_MIN:
+ case GFC_ISYM_MAX:
+ break;
+ case GFC_ISYM_IAND:
+ case GFC_ISYM_IOR:
+ case GFC_ISYM_IEOR:
+ if (expr2->value.function.actual->next->next != NULL)
+ {
+ gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR"
+ "or IEOR must have two arguments at %L",
+ &expr2->where);
+ return;
+ }
+ break;
+ default:
+ gfc_error ("!$OMP ATOMIC assignment intrinsic must be"
+ " MIN, MAX, IAND, IOR or IEOR at %L",
+ &expr2->where);
+ return;
+ }
+
+ var_arg = NULL;
+ for (arg = expr2->value.function.actual; arg; arg = arg->next)
+ {
+ if ((arg == expr2->value.function.actual
+ || (var_arg == NULL && arg->next == NULL))
+ && arg->expr->expr_type == EXPR_VARIABLE
+ && arg->expr->symtree != NULL
+ && arg->expr->symtree->n.sym == var)
+ var_arg = arg;
+ else if (expr_references_sym (arg->expr, var))
+ gfc_error ("!$OMP ATOMIC intrinsic arguments except one must not"
+ " reference %s at %L", var->name, &arg->expr->where);
+ if (arg->expr->rank != 0)
+ gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar"
+ " at %L", &arg->expr->where);
+ }
+
+ if (var_arg == NULL)
+ {
+ gfc_error ("First or last !$OMP ATOMIC intrinsic argument must"
+ " be %s at %L", var->name, &expr2->where);
+ return;
+ }
+
+ if (var_arg != expr2->value.function.actual)
+ {
+ /* Canonicalize, so that var comes first. */
+ gcc_assert (var_arg->next == NULL);
+ for (arg = expr2->value.function.actual;
+ arg->next != var_arg; arg = arg->next)
+ ;
+ var_arg->next = expr2->value.function.actual;
+ expr2->value.function.actual = var_arg;
+ arg->next = NULL;
+ }
+ }
+ else
+ gfc_error ("!$OMP ATOMIC assignment must have an operator or intrinsic"
+ " on right hand side at %L", &expr2->where);
+}
+
+static void
+resolve_omp_do (gfc_code *code)
+{
+ gfc_code *do_code;
+
+ if (code->ext.omp_clauses)
+ resolve_omp_clauses (code);
+
+ do_code = code->block->next;
+ if (do_code->op == EXEC_DO_WHILE)
+ gfc_error ("!$OMP DO cannot be a DO WHILE or DO without loop control at %L",
+ &do_code->loc);
+ else
+ {
+ gcc_assert (do_code->op == EXEC_DO);
+ if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
+ gfc_error ("!$OMP DO iteration variable must be of type integer at %L",
+ &do_code->loc);
+ }
+}
+
/* Resolve OpenMP directive clauses and check various requirements
of each directive. */
@@ -597,17 +872,21 @@ gfc_resolve_omp_directive (gfc_code *cod
switch (code->op)
{
case EXEC_OMP_DO:
- case EXEC_OMP_END_SINGLE:
- case EXEC_OMP_PARALLEL:
case EXEC_OMP_PARALLEL_DO:
+ resolve_omp_do (code);
+ break;
+ case EXEC_OMP_WORKSHARE:
+ case EXEC_OMP_PARALLEL_WORKSHARE:
+ case EXEC_OMP_PARALLEL:
case EXEC_OMP_PARALLEL_SECTIONS:
case EXEC_OMP_SECTIONS:
case EXEC_OMP_SINGLE:
- case EXEC_OMP_WORKSHARE:
- case EXEC_OMP_PARALLEL_WORKSHARE:
if (code->ext.omp_clauses)
resolve_omp_clauses (code);
break;
+ case EXEC_OMP_ATOMIC:
+ resolve_omp_atomic (code);
+ break;
default:
break;
}
--- gcc/fortran/match.c.jj 2005-09-20 10:25:17.000000000 +0200
+++ gcc/fortran/match.c 2005-09-21 23:27:13.000000000 +0200
@@ -1323,7 +1323,7 @@ cleanup:
static match
match_exit_cycle (gfc_statement st, gfc_exec_op op)
{
- gfc_state_data *p;
+ gfc_state_data *p, *o;
gfc_symbol *sym;
match m;
@@ -1350,9 +1350,11 @@ match_exit_cycle (gfc_statement st, gfc_
/* Find the loop mentioned specified by the label (or lack of a
label). */
- for (p = gfc_state_stack; p; p = p->previous)
+ for (o = NULL, p = gfc_state_stack; p; p = p->previous)
if (p->state == COMP_DO && (sym == NULL || sym == p->sym))
break;
+ else if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK)
+ o = p;
if (p == NULL)
{
@@ -1366,6 +1368,25 @@ match_exit_cycle (gfc_statement st, gfc_
return MATCH_ERROR;
}
+ if (o != NULL)
+ {
+ gfc_error ("%s statement at %C leaving OpenMP structured block",
+ gfc_ascii_statement (st));
+ return MATCH_ERROR;
+ }
+ else if (st == ST_EXIT
+ && p->previous != NULL
+ && p->previous->state == COMP_OMP_STRUCTURED_BLOCK
+ && (p->previous->head->op == EXEC_OMP_DO
+ || p->previous->head->op == EXEC_OMP_PARALLEL_DO))
+ {
+ gcc_assert (p->previous->head->next != NULL);
+ gcc_assert (p->previous->head->next->op == EXEC_DO
+ || p->previous->head->next->op == EXEC_DO_WHILE);
+ gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
+ return MATCH_ERROR;
+ }
+
/* Save the first statement in the loop - needed by the backend. */
new_st.ext.whichloop = p->head;
--- gcc/testsuite/gfortran.dg/gomp/omp_atomic1.f90.jj 2005-09-22 17:44:21.000000000 +0200
+++ gcc/testsuite/gfortran.dg/gomp/omp_atomic1.f90 2005-09-22 18:20:15.000000000 +0200
@@ -0,0 +1,38 @@
+! { dg-do compile }
+subroutine test_atomic
+ integer (kind = 4) :: a
+ integer :: b
+ real :: c, f
+ double precision :: d
+ integer, dimension (10) :: e
+ a = 1
+ b = 2
+ c = 3
+ d = 4
+ e = 5
+ f = 6
+!$omp atomic
+ a = a + 4
+!$omp atomic
+ b = 4 - b
+!$omp atomic
+ c = c * 2
+!$omp atomic
+ d = 2 / d
+!$omp atomic
+ e = 1 ! { dg-error "must set a scalar variable" }
+!$omp atomic
+ a = a ** 8 ! { dg-error "assignment operator must be" }
+!$omp atomic
+ b = b + 3 + b ! { dg-error "cannot reference" }
+!$omp atomic
+ c = c - f + 1 ! { dg-error "not mathematically equivalent to" }
+!$omp atomic
+ a = ishft (a, 1) ! { dg-error "assignment intrinsic must be" }
+!$omp atomic
+ c = min (c, 2.1, c) ! { dg-error "intrinsic arguments except one" }
+!$omp atomic
+ a = max (b, e(1)) ! { dg-error "intrinsic argument must be a" }
+!$omp atomic
+ d = 12 ! { dg-error "assignment must have an operator" }
+end subroutine test_atomic
--- gcc/testsuite/gfortran.dg/gomp/omp_do1.f90.jj 2005-09-21 16:39:03.000000000 +0200
+++ gcc/testsuite/gfortran.dg/gomp/omp_do1.f90 2005-09-22 08:14:25.000000000 +0200
@@ -0,0 +1,52 @@
+! { dg-do compile }
+! { dg-options "-fopenmp -std=gnu" }
+subroutine foo
+ integer :: i, j
+ integer, dimension (30) :: a
+ double precision :: d
+ i = 0
+!$omp do private (i)
+ do 100 ! { dg-error "cannot be a DO WHILE or DO without loop control" }
+ if (i .gt. 0) exit ! { dg-error "EXIT statement" }
+100 i = i + 1
+ i = 0
+!$omp do private (i)
+ do ! { dg-error "cannot be a DO WHILE or DO without loop control" }
+ if (i .gt. 0) exit ! { dg-error "EXIT statement" }
+ i = i + 1
+ end do
+ i = 0
+!$omp do private (i)
+ do 200 while (i .lt. 4) ! { dg-error "cannot be a DO WHILE or DO without loop control" }
+200 i = i + 1
+!$omp do private (i)
+ do while (i .lt. 8) ! { dg-error "cannot be a DO WHILE or DO without loop control" }
+ i = i + 1
+ end do
+!$omp do
+ do 300 d = 1, 30, 6 ! { dg-warning "Obsolete: REAL DO loop iterator" }
+ i = d
+300 a(i) = 1
+!$omp do
+ do d = 1, 30, 5 ! { dg-warning "Obsolete: REAL DO loop iterator" }
+ i = d
+ a(i) = 2
+ end do
+!$omp do
+ do i = 1, 30
+ if (i .eq. 16) exit ! { dg-error "EXIT statement" }
+ end do
+!$omp do
+outer: do i = 1, 30
+ do j = 5, 10
+ if (i .eq. 6 .and. j .eq. 7) exit outer ! { dg-error "EXIT statement" }
+ end do
+ end do outer
+last: do i = 1, 30
+!$omp parallel
+ if (i .eq. 21) exit last ! { dg-error "leaving OpenMP structured block" }
+!$omp end parallel
+ end do last
+end subroutine
+! { dg-error "iteration variable must be of type integer" "" { target *-*-* } 27 }
+! { dg-error "iteration variable must be of type integer" "" { target *-*-* } 31 }
--- gcc/testsuite/gfortran.dg/gomp/gomp.exp.jj 2005-09-22 08:08:14.000000000 +0200
+++ gcc/testsuite/gfortran.dg/gomp/gomp.exp 2005-09-22 08:08:10.000000000 +0200
@@ -0,0 +1,20 @@
+# GCC testsuite that uses the `dg.exp' driver.
+
+# Load support procs.
+load_lib gfortran-dg.exp
+
+# If a testcase doesn't have special options, use these.
+global DEFAULT_FFLAGS
+if ![info exists DEFAULT_FFLAGS] then {
+ set DEFAULT_FFLAGS " -fopenmp"
+}
+
+# Initialize `dg'.
+dg-init
+
+# Main loop.
+gfortran-dg-runtest [lsort \
+ [glob -nocomplain $srcdir/$subdir/*.\[fF\]{,90,95} ] ] $DEFAULT_FFLAGS
+
+# All done.
+dg-finish
--- libgomp/testsuite/libgomp.fortran/omp_parse1.f90.jj 2005-09-20 10:25:17.000000000 +0200
+++ libgomp/testsuite/libgomp.fortran/omp_parse1.f90 2005-09-21 15:43:01.000000000 +0200
@@ -53,6 +53,13 @@ contains
if (e .ne. i) call abort
end subroutine test_parallel
+ subroutine test_do_orphan
+ integer :: k, l
+!$omp parallel do private (l)
+ do 600 k = 1, 16, 2
+600 l = k
+ end subroutine test_do_orphan
+
subroutine test_do
integer :: i, j, k, l, n
integer, dimension (64) :: d
@@ -67,6 +74,7 @@ contains
if (omp_get_thread_num () .eq. 0) then
k = omp_get_num_threads ()
end if
+ call test_do_orphan
!$omp do schedule (static) firstprivate (n)
do 200 i = 1, j
if (i .eq. 1 .and. n .ne. 24) call abort
Jakub
More information about the Fortran
mailing list