Fortran: Add support for OMP non-rectangular loops.

This patch adds support for OMP 5.1 "canonical loop nest form" to the
Fortran front end, marks non-rectangular loops for processing
by the middle end, and implements missing checks in the gimplifier
for additional prohibitions on non-rectangular loops.

Note that the OMP spec also prohibits non-rectangular loops with the TILE
construct; that construct hasn't been implemented yet, so that error will
need to be filled in later.

	gcc/fortran/
	* gfortran.h (struct gfc_omp_clauses): Add non_rectangular bit.
	* openmp.cc (is_outer_iteration_variable): New function.
	(expr_is_invariant): New function.
	(bound_expr_is_canonical): New function.
	(resolve_omp_do): Replace existing non-rectangularity error with
	check for canonical form and setting non_rectangular bit.
	* trans-openmp.cc (gfc_trans_omp_do): Transfer non_rectangular
	flag to generated tree structure.

	gcc/
	* gimplify.cc (gimplify_omp_for): Update messages for SCHEDULED
	and ORDERED clause conflict errors.  Add check for GRAINSIZE and
	NUM_TASKS on TASKLOOP.

	gcc/testsuite/
	* c-c++-common/gomp/loop-6.c (f3): New function to test TASKLOOP
	diagnostics.
	* gfortran.dg/gomp/collapse1.f90: Update expected messages.
	* gfortran.dg/gomp/pr85313.f90: Remove dg-error on non-rectangular
	loops that are now accepted.
	* gfortran.dg/gomp/non-rectangular-loop.f90: New file.
	* gfortran.dg/gomp/canonical-loop-1.f90: New file.
	* gfortran.dg/gomp/canonical-loop-2.f90: New file.
This commit is contained in:
Sandra Loosemore 2022-05-05 11:37:16 -07:00
parent 982fd4cd76
commit 705bcedf6e
10 changed files with 672 additions and 25 deletions

View file

@ -1533,6 +1533,7 @@ typedef struct gfc_omp_clauses
unsigned simd:1, threads:1, depend_source:1, destroy:1, order_concurrent:1;
unsigned order_unconstrained:1, order_reproducible:1, capture:1;
unsigned grainsize_strict:1, num_tasks_strict:1, compare:1, weak:1;
unsigned non_rectangular:1;
ENUM_BITFIELD (gfc_omp_sched_kind) sched_kind:3;
ENUM_BITFIELD (gfc_omp_device_type) device_type:2;
ENUM_BITFIELD (gfc_omp_memorder) memorder:3;

View file

@ -8446,6 +8446,105 @@ gfc_resolve_omp_local_vars (gfc_namespace *ns)
gfc_traverse_ns (ns, handle_local_var);
}
/* CODE is an OMP loop construct. Return true if VAR matches an iteration
variable outer to level DEPTH. */
static bool
is_outer_iteration_variable (gfc_code *code, int depth, gfc_symbol *var)
{
int i;
gfc_code *do_code = code->block->next;
for (i = 1; i < depth; i++)
{
gfc_symbol *ivar = do_code->ext.iterator->var->symtree->n.sym;
if (var == ivar)
return true;
do_code = do_code->block->next;
}
return false;
}
/* CODE is an OMP loop construct. Return true if EXPR does not reference
any iteration variables outer to level DEPTH. */
static bool
expr_is_invariant (gfc_code *code, int depth, gfc_expr *expr)
{
int i;
gfc_code *do_code = code->block->next;
for (i = 1; i < depth; i++)
{
gfc_symbol *ivar = do_code->ext.iterator->var->symtree->n.sym;
if (gfc_find_sym_in_expr (ivar, expr))
return false;
do_code = do_code->block->next;
}
return true;
}
/* CODE is an OMP loop construct. Return true if EXPR matches one of the
canonical forms for a bound expression. It may include references to
an iteration variable outer to level DEPTH; set OUTER_VARP if so. */
static bool
bound_expr_is_canonical (gfc_code *code, int depth, gfc_expr *expr,
gfc_symbol **outer_varp)
{
gfc_expr *expr2 = NULL;
/* Rectangular case. */
if (depth == 0 || expr_is_invariant (code, depth, expr))
return true;
/* Any simple variable that didn't pass expr_is_invariant must be
an outer_var. */
if (expr->expr_type == EXPR_VARIABLE && expr->rank == 0)
{
*outer_varp = expr->symtree->n.sym;
return true;
}
/* All other permitted forms are binary operators. */
if (expr->expr_type != EXPR_OP)
return false;
/* Check for plus/minus a loop invariant expr. */
if (expr->value.op.op == INTRINSIC_PLUS
|| expr->value.op.op == INTRINSIC_MINUS)
{
if (expr_is_invariant (code, depth, expr->value.op.op1))
expr2 = expr->value.op.op2;
else if (expr_is_invariant (code, depth, expr->value.op.op2))
expr2 = expr->value.op.op1;
else
return false;
}
else
expr2 = expr;
/* Check for a product with a loop-invariant expr. */
if (expr2->expr_type == EXPR_OP
&& expr2->value.op.op == INTRINSIC_TIMES)
{
if (expr_is_invariant (code, depth, expr2->value.op.op1))
expr2 = expr2->value.op.op2;
else if (expr_is_invariant (code, depth, expr2->value.op.op2))
expr2 = expr2->value.op.op1;
else
return false;
}
/* What's left must be a reference to an outer loop variable. */
if (expr2->expr_type == EXPR_VARIABLE
&& expr2->rank == 0
&& is_outer_iteration_variable (code, depth, expr2->symtree->n.sym))
{
*outer_varp = expr2->symtree->n.sym;
return true;
}
return false;
}
static void
resolve_omp_do (gfc_code *code)
{
@ -8564,8 +8663,15 @@ resolve_omp_do (gfc_code *code)
if (collapse <= 0)
collapse = 1;
}
/* While the spec defines the loop nest depth independently of the COLLAPSE
clause, in practice the middle end only pays attention to the COLLAPSE
depth and treats any further inner loops as the final-loop-body. So
here we also check canonical loop nest form only for the number of
outer loops specified by the COLLAPSE clause too. */
for (i = 1; i <= collapse; i++)
{
gfc_symbol *start_var = NULL, *end_var = NULL;
if (do_code->op == EXEC_DO_WHILE)
{
gfc_error ("%s cannot be a DO WHILE or DO without loop control "
@ -8606,26 +8712,43 @@ resolve_omp_do (gfc_code *code)
"LINEAR at %L", name, &do_code->loc);
break;
}
if (i > 1)
if (is_outer_iteration_variable (code, i, dovar))
{
gfc_code *do_code2 = code->block->next;
int j;
for (j = 1; j < i; j++)
{
gfc_symbol *ivar = do_code2->ext.iterator->var->symtree->n.sym;
if (dovar == ivar
|| gfc_find_sym_in_expr (ivar, do_code->ext.iterator->start)
|| gfc_find_sym_in_expr (ivar, do_code->ext.iterator->end)
|| gfc_find_sym_in_expr (ivar, do_code->ext.iterator->step))
{
gfc_error ("%s collapsed loops don't form rectangular "
"iteration space at %L", name, &do_code->loc);
break;
}
do_code2 = do_code2->block->next;
}
gfc_error ("%s iteration variable used in more than one loop at %L",
name, &do_code->loc);
break;
}
else if (!bound_expr_is_canonical (code, i,
do_code->ext.iterator->start,
&start_var))
{
gfc_error ("%s loop start expression not in canonical form at %L",
name, &do_code->loc);
break;
}
else if (!bound_expr_is_canonical (code, i,
do_code->ext.iterator->end,
&end_var))
{
gfc_error ("%s loop end expression not in canonical form at %L",
name, &do_code->loc);
break;
}
else if (start_var && end_var && start_var != end_var)
{
gfc_error ("%s loop bounds reference different "
"iteration variables at %L", name, &do_code->loc);
break;
}
else if (!expr_is_invariant (code, i, do_code->ext.iterator->step))
{
gfc_error ("%s loop increment not in canonical form at %L",
name, &do_code->loc);
break;
}
if (start_var || end_var)
code->ext.omp_clauses->non_rectangular = 1;
for (c = do_code->next; c; c = c->next)
if (c->op != EXEC_NOP && c->op != EXEC_CONTINUE)
{

View file

@ -5411,6 +5411,7 @@ gfc_trans_omp_do (gfc_code *code, gfc_exec_op op, stmtblock_t *pblock,
OMP_FOR_INCR (stmt) = incr;
if (orig_decls)
OMP_FOR_ORIG_DECLS (stmt) = orig_decls;
OMP_FOR_NON_RECTANGULAR (stmt) = clauses->non_rectangular;
gfc_add_expr_to_block (&block, stmt);
vec_free (doacross_steps);

View file

@ -12509,11 +12509,11 @@ gimplify_omp_for (tree *expr_p, gimple_seq *pre_p)
OMP_CLAUSE_SCHEDULE))
error_at (EXPR_LOCATION (for_stmt),
"%qs clause may not appear on non-rectangular %qs",
"schedule", "for");
"schedule", lang_GNU_Fortran () ? "do" : "for");
if (omp_find_clause (OMP_FOR_CLAUSES (for_stmt), OMP_CLAUSE_ORDERED))
error_at (EXPR_LOCATION (for_stmt),
"%qs clause may not appear on non-rectangular %qs",
"ordered", "for");
"ordered", lang_GNU_Fortran () ? "do" : "for");
}
break;
case OMP_DISTRIBUTE:
@ -12528,6 +12528,19 @@ gimplify_omp_for (tree *expr_p, gimple_seq *pre_p)
ort = ORT_ACC;
break;
case OMP_TASKLOOP:
if (OMP_FOR_NON_RECTANGULAR (inner_for_stmt ? inner_for_stmt : for_stmt))
{
if (omp_find_clause (OMP_FOR_CLAUSES (for_stmt),
OMP_CLAUSE_GRAINSIZE))
error_at (EXPR_LOCATION (for_stmt),
"%qs clause may not appear on non-rectangular %qs",
"grainsize", "taskloop");
if (omp_find_clause (OMP_FOR_CLAUSES (for_stmt),
OMP_CLAUSE_NUM_TASKS))
error_at (EXPR_LOCATION (for_stmt),
"%qs clause may not appear on non-rectangular %qs",
"num_tasks", "taskloop");
}
if (omp_find_clause (OMP_FOR_CLAUSES (for_stmt), OMP_CLAUSE_UNTIED))
ort = ORT_UNTIED_TASKLOOP;
else

View file

@ -111,3 +111,17 @@ f2 (void)
for (j = i; j < 64; j++)
;
}
void
f3 (void)
{
int i = 0, j = 0;
#pragma omp taskloop collapse(2) grainsize(4) /* { dg-error "'grainsize' clause may not appear on non-rectangular 'taskloop'" } */
for (i = 0; i < 64; i++)
for (j = i; j < 64; j++)
;
#pragma omp taskloop collapse(2) num_tasks(4) /* { dg-error "'num_tasks' clause may not appear on non-rectangular 'taskloop'" } */
for (i = 0; i < 64; i++)
for (j = i; j < 64; j++)
;
}

View file

@ -0,0 +1,224 @@
! { dg-do compile }
! { dg-options "-fopenmp" }
! Test that all specified forms of canonical loop bounds are accepted,
! including non-rectangular loops.
subroutine s1 (a1, a2)
integer :: a1, a2
integer :: i, j
!$omp do collapse(2)
do i = 1, 16
do j = a2, 16
end do
end do
!$omp do collapse(2)
do i = 1, 16
do j = i, 16
end do
end do
!$omp do collapse(2)
do i = 1, 16
do j = i + a2, 16
end do
end do
!$omp do collapse(2)
do i = 1, 16
do j = a2 + i, 16
end do
end do
!$omp do collapse(2)
do i = 1, 16
do j = i - a2, 16
end do
end do
!$omp do collapse(2)
do i = 1, 16
do j = a2 - i, 16
end do
end do
!$omp do collapse(2)
do i = 1, 16
do j = a1 * i, 16
end do
end do
!$omp do collapse(2)
do i = 1, 16
do j = a1 * i + a2, 16
end do
end do
!$omp do collapse(2)
do i = 1, 16
do j = a2 + a1 * i , 16
end do
end do
!$omp do collapse(2)
do i = 1, 16
do j = a1 * i - a2, 16
end do
end do
!$omp do collapse(2)
do i = 1, 16
do j = a2 - a1 * i, 16
end do
end do
!$omp do collapse(2)
do i = 1, 16
do j = i * a1, 16
end do
end do
!$omp do collapse(2)
do i = 1, 16
do j = i * a1 + a2, 16
end do
end do
!$omp do collapse(2)
do i = 1, 16
do j = a2 + i * a1, 16
end do
end do
!$omp do collapse(2)
do i = 1, 16
do j = i * a1 - a2, 16
end do
end do
!$omp do collapse(2)
do i = 1, 16
do j = a2 - i * a1, 16
end do
end do
end subroutine
subroutine s2 (a1, a2)
integer :: a1, a2
integer :: i, j
!$omp do collapse(2)
do i = 1, 16
do j = 1, a2
end do
end do
!$omp do collapse(2)
do i = 1, 16
do j = 1, i
end do
end do
!$omp do collapse(2)
do i = 1, 16
do j = 1, i + a2
end do
end do
!$omp do collapse(2)
do i = 1, 16
do j = 1, a2 + i
end do
end do
!$omp do collapse(2)
do i = 1, 16
do j = 1, i - a2
end do
end do
!$omp do collapse(2)
do i = 1, 16
do j = 1, a2 - i
end do
end do
!$omp do collapse(2)
do i = 1, 16
do j = 1, a1 * i
end do
end do
!$omp do collapse(2)
do i = 1, 16
do j = 1, a1 * i + a2
end do
end do
!$omp do collapse(2)
do i = 1, 16
do j = 1, a2 + a1 * i
end do
end do
!$omp do collapse(2)
do i = 1, 16
do j = 1, a1 * i - a2
end do
end do
!$omp do collapse(2)
do i = 1, 16
do j = 1, a2 - a1 * i
end do
end do
!$omp do collapse(2)
do i = 1, 16
do j = 1, i * a1
end do
end do
!$omp do collapse(2)
do i = 1, 16
do j = 1, i * a1 + a2
end do
end do
!$omp do collapse(2)
do i = 1, 16
do j = 1, a2 + i * a1
end do
end do
!$omp do collapse(2)
do i = 1, 16
do j = 1, i * a1 - a2
end do
end do
!$omp do collapse(2)
do i = 1, 16
do j = 1, a2 - i * a1
end do
end do
end subroutine
subroutine s3 (a1, a2)
integer :: a1, a2
integer :: i, j, k
!$omp do collapse(3)
do i = 1, 16
do j = 1, i
do k = j, 16
end do
end do
end do
end subroutine

View file

@ -0,0 +1,44 @@
! { dg-do compile }
! { dg-options "-fopenmp" }
! Test that various non-canonical loops are rejected with a diagnostic.
subroutine s1 (a1, a2)
integer :: a1, a2
integer :: i, j
!$omp do collapse(2)
do i = 1, 16
do j = i * i, 16 ! { dg-error "not in canonical form" }
end do
end do
!$omp do collapse(2)
do i = 1, 16
do j = MAX (i, 8), 16 ! { dg-error "not in canonical form" }
end do
end do
!$omp do collapse(2)
do i = 1, 16
do j = 1, 16, i ! { dg-error "not in canonical form" }
end do
end do
!$omp do collapse(3)
do i = 1, 16
do j = 1, 16
do k = i, j ! { dg-error "reference different iteration variables" }
end do
end do
end do
!$omp do collapse(3)
do i = 1, 16
do j = 1, 16
do k = 1, i + j ! { dg-error "not in canonical form" }
end do
end do
end do
end subroutine

View file

@ -19,7 +19,7 @@ subroutine collapse1
end do
!$omp parallel do collapse(2)
do i = 1, 5, 2
do j = i + 1, 7, i ! { dg-error "collapsed loops don.t form rectangular iteration space" }
do j = i + 1, 7, i ! { dg-error "loop increment not in canonical form" }
end do
end do
!$omp parallel do collapse(2) shared(j)
@ -49,7 +49,7 @@ subroutine collapse1_2
integer :: i
!$omp parallel do collapse(2)
do i = -6, 6 ! { dg-error "cannot be redefined inside loop beginning" }
do i = 4, 6 ! { dg-error "collapsed loops don.t form rectangular iteration space|cannot be redefined" }
do i = 4, 6 ! { dg-error "iteration variable used in more than one loop|cannot be redefined" }
end do
end do
end subroutine collapse1_2

View file

@ -0,0 +1,227 @@
! { dg-do compile }
! { dg-options "-fopenmp" }
! Test that errors are given for cases where there are constraints
! disallowing nonrectangular loops.
! Work-sharing loop disallows "schedule" and "ordered" clauses.
subroutine s1 (a1, a2)
integer :: a1, a2
integer :: i, j
!$omp do collapse(2) schedule(static) ! { dg-error "'schedule' clause may not appear on non-rectangular 'do'" }
do i = 1, 16
do j = 1, i
end do
end do
!$omp do collapse(2) schedule(static) ! { dg-error "'schedule' clause may not appear on non-rectangular 'do'" }
do i = 1, 16
do j = i, 16
end do
end do
!$omp do collapse(2) ordered ! { dg-error "'ordered' clause may not appear on non-rectangular 'do'" }
do i = 1, 16
do j = 1, i
end do
end do
!$omp do collapse(2) ordered ! { dg-error "'ordered' clause may not appear on non-rectangular 'do'" }
do i = 1, 16
do j = i, 16
end do
end do
! Derived constructs
!$omp do simd collapse(2) schedule(static) ! { dg-error "'schedule' clause may not appear on non-rectangular 'do'" }
do i = 1, 16
do j = 1, i
end do
end do
!$omp parallel do collapse(2) schedule(static) ! { dg-error "'schedule' clause may not appear on non-rectangular 'do'" }
do i = 1, 16
do j = 1, i
end do
end do
!$omp parallel do simd collapse(2) schedule(static) ! { dg-error "'schedule' clause may not appear on non-rectangular 'do'" }
do i = 1, 16
do j = 1, i
end do
end do
!$omp target parallel do collapse(2) schedule(static) ! { dg-error "'schedule' clause may not appear on non-rectangular 'do'" }
do i = 1, 16
do j = 1, i
end do
end do
!$omp target parallel do collapse(2) schedule(static) ! { dg-error "'schedule' clause may not appear on non-rectangular 'do'" }
do i = 1, 16
do j = 1, i
end do
end do
end subroutine
! Distribute construct disallows "dist_schedule" clause.
subroutine s2 (a1, a2)
integer :: a1, a2
integer :: i, j
!$omp distribute collapse(2) dist_schedule(static) ! { dg-error "'dist_schedule' clause may not appear on non-rectangular 'distribute'" }
do i = 1, 16
do j = 1, i
end do
end do
!$omp distribute collapse(2) dist_schedule(static) ! { dg-error "'dist_schedule' clause may not appear on non-rectangular 'distribute'" }
do i = 1, 16
do j = i, 16
end do
end do
! Derived constructs
!$omp distribute simd collapse(2) dist_schedule(static) ! { dg-error "'dist_schedule' clause may not appear on non-rectangular 'distribute'" }
do i = 1, 16
do j = i, 16
end do
end do
!$omp distribute parallel do collapse(2) dist_schedule(static) ! { dg-error "'dist_schedule' clause may not appear on non-rectangular 'distribute'" }
do i = 1, 16
do j = i, 16
end do
end do
!$omp distribute parallel do simd collapse(2) dist_schedule(static) ! { dg-error "'dist_schedule' clause may not appear on non-rectangular 'distribute'" }
do i = 1, 16
do j = i, 16
end do
end do
!$omp teams distribute collapse(2) dist_schedule(static) ! { dg-error "'dist_schedule' clause may not appear on non-rectangular 'distribute'" }
do i = 1, 16
do j = i, 16
end do
end do
!$omp teams distribute simd collapse(2) dist_schedule(static) ! { dg-error "'dist_schedule' clause may not appear on non-rectangular 'distribute'" }
do i = 1, 16
do j = i, 16
end do
end do
!$omp teams distribute parallel do collapse(2) dist_schedule(static) ! { dg-error "'dist_schedule' clause may not appear on non-rectangular 'distribute'" }
do i = 1, 16
do j = i, 16
end do
end do
!$omp teams distribute parallel do simd collapse(2) dist_schedule(static) ! { dg-error "'dist_schedule' clause may not appear on non-rectangular 'distribute'" }
do i = 1, 16
do j = i, 16
end do
end do
!$omp target teams distribute collapse(2) dist_schedule(static) ! { dg-error "'dist_schedule' clause may not appear on non-rectangular 'distribute'" }
do i = 1, 16
do j = i, 16
end do
end do
!$omp target teams distribute simd collapse(2) dist_schedule(static) ! { dg-error "'dist_schedule' clause may not appear on non-rectangular 'distribute'" }
do i = 1, 16
do j = i, 16
end do
end do
!$omp target teams distribute parallel do collapse(2) dist_schedule(static) ! { dg-error "'dist_schedule' clause may not appear on non-rectangular 'distribute'" }
do i = 1, 16
do j = i, 16
end do
end do
!$omp target teams distribute parallel do simd collapse(2) dist_schedule(static) ! { dg-error "'dist_schedule' clause may not appear on non-rectangular 'distribute'" }
do i = 1, 16
do j = i, 16
end do
end do
end subroutine
! Taskloop construct disallows "grainsize" and "num_tasks" clauses.
subroutine s3 (a1, a2)
integer :: a1, a2
integer :: i, j
!$omp taskloop collapse(2) grainsize(4) ! { dg-error "'grainsize' clause may not appear on non-rectangular 'taskloop'" }
do i = 1, 16
do j = 1, i
end do
end do
!$omp taskloop collapse(2) grainsize(4) ! { dg-error "'grainsize' clause may not appear on non-rectangular 'taskloop'" }
do i = 1, 16
do j = i, 16
end do
end do
!$omp taskloop collapse(2) num_tasks(4) ! { dg-error "'num_tasks' clause may not appear on non-rectangular 'taskloop'" }
do i = 1, 16
do j = 1, i
end do
end do
!$omp taskloop collapse(2) num_tasks(4) ! { dg-error "'num_tasks' clause may not appear on non-rectangular 'taskloop'" }
do i = 1, 16
do j = i, 16
end do
end do
! Derived constructs
!$omp taskloop simd collapse(2) grainsize(4) ! { dg-error "'grainsize' clause may not appear on non-rectangular 'taskloop'" }
do i = 1, 16
do j = 1, i
end do
end do
!$omp masked taskloop collapse(2) grainsize(4) ! { dg-error "'grainsize' clause may not appear on non-rectangular 'taskloop'" }
do i = 1, 16
do j = 1, i
end do
end do
!$omp masked taskloop simd collapse(2) grainsize(4) ! { dg-error "'grainsize' clause may not appear on non-rectangular 'taskloop'" }
do i = 1, 16
do j = 1, i
end do
end do
!$omp parallel masked taskloop collapse(2) grainsize(4) ! { dg-error "'grainsize' clause may not appear on non-rectangular 'taskloop'" }
do i = 1, 16
do j = 1, i
end do
end do
!$omp parallel masked taskloop simd collapse(2) grainsize(4) ! { dg-error "'grainsize' clause may not appear on non-rectangular 'taskloop'" }
do i = 1, 16
do j = 1, i
end do
end do
end subroutine
! TODO: not yet implemented
! The tile construct disallows all non-rectangular loops.

View file

@ -3,7 +3,7 @@
!$omp do collapse(3)
do i = 1, 10
do j = i, 20 ! { dg-error "form rectangular iteration space" }
do j = i, 20
do k = 1, 2
end do
end do
@ -11,14 +11,14 @@
!$omp do collapse(3)
do i = 1, 10
do j = 1, 5
do k = i, 20 ! { dg-error "form rectangular iteration space" }
do k = i, 20
end do
end do
end do
!$omp do collapse(3)
do i = 1, 10
do j = 1, 5
do k = j, 20 ! { dg-error "form rectangular iteration space" }
do k = j, 20
end do
end do
end do