procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

OpenMP/Fortran: Partially fix non-rect loop nests [PR107424]

Browse source 
This patch ensures that loop bounds depending on outer loop vars use the
proper TREE_VEC format. It additionally gives a sorry if such an outer
var has a non-one/non-minus-one increment as currently a count variable
is used in this case (see PR).

Finally, it avoids 'count' and just uses a local loop variable if the
step increment is +/-1.

	PR fortran/107424

gcc/fortran/ChangeLog:

	* trans-openmp.cc (struct dovar_init_d): Add 'sym' and
	'non_unit_incr' members.
	(gfc_nonrect_loop_expr): New.
	(gfc_trans_omp_do): Call it; use normal loop bounds
	for unit stride - and only create local loop var.

libgomp/ChangeLog:

	* testsuite/libgomp.fortran/non-rectangular-loop-1.f90: New test.
	* testsuite/libgomp.fortran/non-rectangular-loop-1a.f90: New test.
	* testsuite/libgomp.fortran/non-rectangular-loop-2.f90: New test.
	* testsuite/libgomp.fortran/non-rectangular-loop-3.f90: New test.
	* testsuite/libgomp.fortran/non-rectangular-loop-4.f90: New test.
	* testsuite/libgomp.fortran/non-rectangular-loop-5.f90: New test.

gcc/testsuite/ChangeLog:

	* gfortran.dg/goacc/privatization-1-compute-loop.f90: Update dg-note.
	* gfortran.dg/goacc/privatization-1-routine_gang-loop.f90: Likewise.
This commit is contained in:
Tobias Burnus 2023-02-09 15:51:13 +01:00
parent 1189d1b38e
commit ac2949574d
9 changed files with 1942 additions and 50 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

243
gcc/fortran/trans-openmp.cc
View file

@ -5116,10 +5116,138 @@ gfc_trans_omp_critical (gfc_code *code)
}
typedef struct dovar_init_d {
gfc_symbol *sym;
tree var;
tree init;
bool non_unit_iter;
} dovar_init;
static bool
gfc_nonrect_loop_expr (stmtblock_t *pblock, gfc_se *sep, int loop_n,
gfc_code *code, gfc_expr *expr, vec<dovar_init> *inits,
int simple, gfc_expr *curr_loop_var)
{
int i;
for (i = 0; i < loop_n; i++)
{
gcc_assert (code->ext.iterator->var->expr_type == EXPR_VARIABLE);
if (gfc_find_sym_in_expr (code->ext.iterator->var->symtree->n.sym, expr))
break;
code = code->block->next;
}
if (i >= loop_n)
return false;
/* Canonical format: TREE_VEC with [var, multiplier, offset]. */
gfc_symbol *var = code->ext.iterator->var->symtree->n.sym;
tree tree_var = NULL_TREE;
tree a1 = integer_one_node;
tree a2 = integer_zero_node;
if (!simple)
{
/* FIXME: Handle non-unit iter steps, cf. PR fortran/107424. */
sorry_at (gfc_get_location (&curr_loop_var->where),
"non-rectangular loop nest with step other than constant 1 "
"or -1 for %qs", curr_loop_var->symtree->n.sym->name);
return false;
}
dovar_init *di;
unsigned ix;
FOR_EACH_VEC_ELT (*inits, ix, di)
if (di->sym == var)
{
if (!di->non_unit_iter)
{
tree_var = di->init;
gcc_assert (DECL_P (tree_var));
break;
}
else
{
/* FIXME: Handle non-unit iter steps, cf. PR fortran/107424. */
sorry_at (gfc_get_location (&code->loc),
"non-rectangular loop nest with step other than constant "
"1 or -1 for %qs", var->name);
inform (gfc_get_location (&expr->where), "Used here");
return false;
}
}
if (tree_var == NULL_TREE)
tree_var = var->backend_decl;
if (expr->expr_type == EXPR_VARIABLE)
gcc_assert (expr->symtree->n.sym == var);
else if (expr->expr_type != EXPR_OP
|| (expr->value.op.op != INTRINSIC_TIMES
&& expr->value.op.op != INTRINSIC_PLUS
&& expr->value.op.op != INTRINSIC_MINUS))
gcc_unreachable ();
else
{
gfc_se se;
gfc_expr *et = NULL, *eo = NULL, *e = expr;
if (expr->value.op.op != INTRINSIC_TIMES)
{
if (gfc_find_sym_in_expr (var, expr->value.op.op1))
{
e = expr->value.op.op1;
eo = expr->value.op.op2;
}
else
{
eo = expr->value.op.op1;
e = expr->value.op.op2;
}
}
if (e->value.op.op == INTRINSIC_TIMES)
{
if (e->value.op.op1->expr_type == EXPR_VARIABLE
&& e->value.op.op1->symtree->n.sym == var)
et = e->value.op.op2;
else
{
et = e->value.op.op1;
gcc_assert (e->value.op.op2->expr_type == EXPR_VARIABLE
&& e->value.op.op2->symtree->n.sym == var);
}
}
else
gcc_assert (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == var);
if (et != NULL)
{
gfc_init_se (&se, NULL);
gfc_conv_expr_val (&se, et);
gfc_add_block_to_block (pblock, &se.pre);
a1 = se.expr;
}
if (eo != NULL)
{
gfc_init_se (&se, NULL);
gfc_conv_expr_val (&se, eo);
gfc_add_block_to_block (pblock, &se.pre);
a2 = se.expr;
if (expr->value.op.op == INTRINSIC_MINUS && expr->value.op.op2 == eo)
/* outer-var - a2. */
a2 = fold_build1 (NEGATE_EXPR, TREE_TYPE (a2), a2);
else if (expr->value.op.op == INTRINSIC_MINUS)
/* a2 - outer-var. */
a1 = fold_build1 (NEGATE_EXPR, TREE_TYPE (a1), a1);
}
a1 = DECL_P (a1) ? a1 : gfc_evaluate_now (a1, pblock);
a2 = DECL_P (a2) ? a2 : gfc_evaluate_now (a2, pblock);
}
gfc_init_se (sep, NULL);
sep->expr = make_tree_vec (3);
TREE_VEC_ELT (sep->expr, 0) = tree_var;
TREE_VEC_ELT (sep->expr, 1) = fold_convert (TREE_TYPE (tree_var), a1);
TREE_VEC_ELT (sep->expr, 2) = fold_convert (TREE_TYPE (tree_var), a2);
return true;
}
static tree
gfc_trans_omp_do (gfc_code *code, gfc_exec_op op, stmtblock_t *pblock,
@ -5127,7 +5255,7 @@ gfc_trans_omp_do (gfc_code *code, gfc_exec_op op, stmtblock_t *pblock,
{
gfc_se se;
tree dovar, stmt, from, to, step, type, init, cond, incr, orig_decls;
tree count = NULL_TREE, cycle_label, tmp, omp_clauses;
tree local_dovar = NULL_TREE, cycle_label, tmp, omp_clauses;
stmtblock_t block;
stmtblock_t body;
gfc_omp_clauses *clauses = code->ext.omp_clauses;
@ -5214,52 +5342,72 @@ gfc_trans_omp_do (gfc_code *code, gfc_exec_op op, stmtblock_t *pblock,
gfc_init_se (&se, NULL);
gfc_conv_expr_lhs (&se, code->ext.iterator->var);
gfc_add_block_to_block (pblock, &se.pre);
dovar = se.expr;
local_dovar = dovar_decl = dovar = se.expr;
type = TREE_TYPE (dovar);
gcc_assert (TREE_CODE (type) == INTEGER_TYPE);
gfc_init_se (&se, NULL);
gfc_conv_expr_val (&se, code->ext.iterator->start);
gfc_add_block_to_block (pblock, &se.pre);
from = gfc_evaluate_now (se.expr, pblock);
gfc_init_se (&se, NULL);
gfc_conv_expr_val (&se, code->ext.iterator->end);
gfc_add_block_to_block (pblock, &se.pre);
to = gfc_evaluate_now (se.expr, pblock);
gfc_init_se (&se, NULL);
gfc_conv_expr_val (&se, code->ext.iterator->step);
gfc_add_block_to_block (pblock, &se.pre);
step = gfc_evaluate_now (se.expr, pblock);
dovar_decl = dovar;
/* Special case simple loops. */
if (VAR_P (dovar))
if (integer_onep (step))
simple = 1;
else if (tree_int_cst_equal (step, integer_minus_one_node))
simple = -1;
gfc_init_se (&se, NULL);
if (!clauses->non_rectangular
|| !gfc_nonrect_loop_expr (pblock, &se, i, orig_code->block->next,
code->ext.iterator->start, &inits, simple,
code->ext.iterator->var))
{
if (integer_onep (step))
simple = 1;
else if (tree_int_cst_equal (step, integer_minus_one_node))
simple = -1;
gfc_conv_expr_val (&se, code->ext.iterator->start);
gfc_add_block_to_block (pblock, &se.pre);
if (!DECL_P (se.expr))
se.expr = gfc_evaluate_now (se.expr, pblock);
}
else
from = se.expr;
gfc_init_se (&se, NULL);
if (!clauses->non_rectangular
|| !gfc_nonrect_loop_expr (pblock, &se, i, orig_code->block->next,
code->ext.iterator->end, &inits, simple,
code->ext.iterator->var))
{
gfc_conv_expr_val (&se, code->ext.iterator->end);
gfc_add_block_to_block (pblock, &se.pre);
if (!DECL_P (se.expr))
se.expr = gfc_evaluate_now (se.expr, pblock);
}
to = se.expr;
if (!DECL_P (dovar))
dovar_decl
= gfc_trans_omp_variable (code->ext.iterator->var->symtree->n.sym,
false);
if (simple && !DECL_P (dovar))
{
const char *name = code->ext.iterator->var->symtree->n.sym->name;
local_dovar = gfc_create_var (type, name);
dovar_init e = {code->ext.iterator->var->symtree->n.sym,
dovar, local_dovar, false};
inits.safe_push (e);
}
/* Loop body. */
if (simple)
{
TREE_VEC_ELT (init, i) = build2_v (MODIFY_EXPR, dovar, from);
TREE_VEC_ELT (init, i) = build2_v (MODIFY_EXPR, local_dovar, from);
/* The condition should not be folded. */
TREE_VEC_ELT (cond, i) = build2_loc (input_location, simple > 0
? LE_EXPR : GE_EXPR,
logical_type_node, dovar, to);
logical_type_node, local_dovar,
to);
TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location, PLUS_EXPR,
type, dovar, step);
type, local_dovar, step);
TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location,
MODIFY_EXPR,
type, dovar,
type, local_dovar,
TREE_VEC_ELT (incr, i));
if (orig_decls && !clauses->orderedc)
orig_decls = NULL;
@ -5280,24 +5428,27 @@ gfc_trans_omp_do (gfc_code *code, gfc_exec_op op, stmtblock_t *pblock,
tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, type, tmp,
step);
tmp = gfc_evaluate_now (tmp, pblock);
count = gfc_create_var (type, "count");
TREE_VEC_ELT (init, i) = build2_v (MODIFY_EXPR, count,
local_dovar = gfc_create_var (type, "count");
TREE_VEC_ELT (init, i) = build2_v (MODIFY_EXPR, local_dovar,
build_int_cst (type, 0));
/* The condition should not be folded. */
TREE_VEC_ELT (cond, i) = build2_loc (input_location, LT_EXPR,
logical_type_node,
count, tmp);
local_dovar, tmp);
TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location, PLUS_EXPR,
type, count,
type, local_dovar,
build_int_cst (type, 1));
TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location,
MODIFY_EXPR, type, count,
MODIFY_EXPR, type,
local_dovar,
TREE_VEC_ELT (incr, i));
/* Initialize DOVAR. */
tmp = fold_build2_loc (input_location, MULT_EXPR, type, count, step);
tmp = fold_build2_loc (input_location, MULT_EXPR, type, local_dovar,
step);
tmp = fold_build2_loc (input_location, PLUS_EXPR, type, from, tmp);
dovar_init e = {dovar, tmp};
dovar_init e = {code->ext.iterator->var->symtree->n.sym,
dovar, tmp, true};
inits.safe_push (e);
if (clauses->orderedc)
{
@ -5312,7 +5463,7 @@ gfc_trans_omp_do (gfc_code *code, gfc_exec_op op, stmtblock_t *pblock,
if (dovar_found == 3
&& op == EXEC_OMP_SIMD
&& collapse == 1
&& !simple)
&& local_dovar != dovar)
{
for (tmp = omp_clauses; tmp; tmp = OMP_CLAUSE_CHAIN (tmp))
if (OMP_CLAUSE_CODE (tmp) == OMP_CLAUSE_LINEAR
@ -5331,11 +5482,11 @@ gfc_trans_omp_do (gfc_code *code, gfc_exec_op op, stmtblock_t *pblock,
OMP_CLAUSE_LINEAR_NO_COPYIN (tmp) = 1;
OMP_CLAUSE_DECL (tmp) = dovar_decl;
omp_clauses = gfc_trans_add_clause (tmp, omp_clauses);
if (local_dovar != dovar)
dovar_found = 3;
}
if (!simple)
dovar_found = 3;
}
else if (!dovar_found && !simple)
else if (!dovar_found && local_dovar != dovar)
{
tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE);
OMP_CLAUSE_DECL (tmp) = dovar_decl;
@ -5346,7 +5497,7 @@ gfc_trans_omp_do (gfc_code *code, gfc_exec_op op, stmtblock_t *pblock,
tree c = NULL;
tmp = NULL;
if (!simple)
if (local_dovar != dovar)
{
/* If dovar is lastprivate, but different counter is used,
dovar += step needs to be added to
@ -5356,21 +5507,19 @@ gfc_trans_omp_do (gfc_code *code, gfc_exec_op op, stmtblock_t *pblock,
if (clauses->orderedc)
{
if (clauses->collapse <= 1 || i >= clauses->collapse)
tmp = count;
tmp = local_dovar;
else
tmp = fold_build2_loc (input_location, PLUS_EXPR,
type, count, build_one_cst (type));
type, local_dovar,
build_one_cst (type));
tmp = fold_build2_loc (input_location, MULT_EXPR, type,
tmp, step);
tmp = fold_build2_loc (input_location, PLUS_EXPR, type,
from, tmp);
}
else
{
tmp = gfc_evaluate_now (step, pblock);
tmp = fold_build2_loc (input_location, PLUS_EXPR, type,
dovar, tmp);
}
tmp = fold_build2_loc (input_location, PLUS_EXPR, type,
dovar, step);
tmp = fold_build2_loc (input_location, MODIFY_EXPR, type,
dovar, tmp);
for (c = omp_clauses; c ; c = OMP_CLAUSE_CHAIN (c))
@ -5405,9 +5554,9 @@ gfc_trans_omp_do (gfc_code *code, gfc_exec_op op, stmtblock_t *pblock,
break;
}
}
gcc_assert (simple || c != NULL);
gcc_assert (local_dovar == dovar || c != NULL);
}
if (!simple)
if (local_dovar != dovar)
{
if (op != EXEC_OMP_SIMD || dovar_found == 1)
tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE);
@ -5420,7 +5569,7 @@ gfc_trans_omp_do (gfc_code *code, gfc_exec_op op, stmtblock_t *pblock,
}
else
tmp = build_omp_clause (input_location, OMP_CLAUSE_LASTPRIVATE);
OMP_CLAUSE_DECL (tmp) = count;
OMP_CLAUSE_DECL (tmp) = local_dovar;
omp_clauses = gfc_trans_add_clause (tmp, omp_clauses);
}

6
gcc/testsuite/gfortran.dg/goacc/privatization-1-compute-loop.f90
View file

@ -47,8 +47,10 @@ contains
end do
end do
!$acc end parallel
! { dg-note {variable 'count\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } l_compute$c_compute }
! { dg-note {variable 'count\.[0-9]+' in 'private' clause isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } l_loop$c_loop }
! { dg-note {variable 'i\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } l_compute$c_compute }
! { dg-note {variable 'j\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } l_compute$c_compute }
! { dg-note {variable 'i\.[0-9]+' in 'private' clause isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } l_loop$c_loop }
! { dg-note {variable 'j\.[0-9]+' in 'private' clause isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } l_loop$c_loop }
! { dg-note {variable 'i' in 'private' clause isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } l_loop$c_loop }
! { dg-note {variable 'j' in 'private' clause isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } l_loop$c_loop }
! { dg-note {variable 'a' in 'private' clause isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } l_loop$c_loop }

3
gcc/testsuite/gfortran.dg/goacc/privatization-1-routine_gang-loop.f90
View file

@ -46,7 +46,8 @@ contains
y = a
end do
end do
! { dg-note {variable 'count\.[0-9]+' in 'private' clause isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } l_loop$c_loop }
! { dg-note {variable 'i\.[0-9]+' in 'private' clause isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } l_loop$c_loop }
! { dg-note {variable 'j\.[0-9]+' in 'private' clause isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } l_loop$c_loop }
! { dg-note {variable 'i' in 'private' clause isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } l_loop$c_loop }
! { dg-note {variable 'j' in 'private' clause isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } l_loop$c_loop }
! { dg-note {variable 'a' in 'private' clause isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } l_loop$c_loop }

668
libgomp/testsuite/libgomp.fortran/non-rectangular-loop-1.f90 Normal file
View file

@ -0,0 +1,668 @@
! { dg-do run }
! { dg-additional-options "-msse2" { target sse2_runtime } }
! { dg-additional-options "-mavx" { target avx_runtime } }
! PR fortran/107424
! Nonrectangular loop nests checks
! See PR or non-rectangular-loop-1a.f90 for the commented tests
! Hint: Those use step for loop vars part of nonrectangular loop nests
module m
implicit none (type, external)
contains
! The 'k' loop uses i or j as start value
! but a constant end value such that 'lastprivate'
! should be well-defined
subroutine lastprivate_check_simd_1
integer :: n,m,p, i,j,k
n = 11
m = 23
p = 27
! Use 'i' or 'j', unit step on 'i' or on 'j' -> 4 loops
! Then same, except use non-unit step for 'k'
! !$omp simd collapse(3) lastprivate(k)
! do i = 1, n
! do j = 1, m, 2
! do k = j - 41, p
! if (k < 1 - 41 .or. k > p) error stop
! end do
! end do
! end do
! if (k /= p + 1) error stop
! !$omp simd collapse(3) lastprivate(k)
! do i = 1, n, 2
! do j = 1, m
! do k = i - 41, p
! if (k < 1 - 41 .or. k > p) error stop
! end do
! end do
! end do
! if (k /= p + 1) error stop
!$omp simd collapse(3) lastprivate(k)
do i = 1, n, 2
do j = 1, m
do k = j - 41, p
if (k < 1 - 41 .or. k > p) then
print *, i, j, k,p, " -> i, j, k, p (k < 1 - 41 .or. k > p)"
error stop
end if
end do
end do
end do
if (k /= p + 1) error stop
k = -43
m = 0
!$omp simd collapse(3) lastprivate(k)
do i = 1, n, 2
do j = 1, m
do k = j - 41, p
if (k < 1 - 41 .or. k > p) then
print *, i, j, k,p, " -> i, j, k, p (k < 1 - 41 .or. k > p)"
error stop
end if
end do
end do
end do
if (k /= -43) error stop
m = 23
!$omp simd collapse(3) lastprivate(k)
do i = 1, n
do j = 1, m, 2
do k = i - 41, p
if (k < 1 - 41 .or. k > p) error stop
end do
end do
end do
if (k /= p + 1) error stop
n = -5
k = - 70
!$omp simd collapse(3) lastprivate(k)
do i = 1, n
do j = 1, m, 2
do k = i - 41, p
if (k < 1 - 41 .or. k > p) error stop
end do
end do
end do
if (k /= -70) error stop
n = 11
! Same but 'private' for all (i,j) vars
! !$omp simd collapse(3) lastprivate(k) private(i,j)
! do i = 1, n
! do j = 1, m, 2
! do k = j - 41, p
! if (k < 1 - 41 .or. k > p) error stop
! end do
! end do
! end do
! if (k /= p + 1) error stop
!
! !$omp simd collapse(3) lastprivate(k) private(i,j)
! do i = 1, n, 2
! do j = 1, m
! do k = i - 41, p
! if (k < 1 - 41 .or. k > p) error stop
! end do
! end do
! end do
! if (k /= p + 1) error stop
!$omp simd collapse(3) lastprivate(k) private(i,j)
do i = 1, n, 2
do j = 1, m
do k = j - 41, p
if (k < 1 - 41 .or. k > p) error stop
end do
end do
end do
if (k /= p + 1) error stop
!$omp simd collapse(3) lastprivate(k) private(i,j)
do i = 1, n
do j = 1, m, 2
do k = i - 41, p
if (k < 1 - 41 .or. k > p) error stop
end do
end do
end do
if (k /= p + 1) error stop
! Same - but with lastprivate(i,j)
! !$omp simd collapse(3) lastprivate(k) lastprivate(i,j)
! do i = 1, n
! do j = 1, m, 2
! do k = j - 41, p
! if (k < 1 - 41 .or. k > p) error stop
! end do
! end do
! end do
! if (k /= p + 1) error stop
! if (i /= n + 1 .or. j /= m + 2) error stop
! !$omp simd collapse(3) lastprivate(k) lastprivate(i,j)
! do i = 1, n, 2
! do j = 1, m
! do k = i - 41, p
! if (k < 1 - 41 .or. k > p) error stop
! end do
! end do
! end do
! if (k /= p + 1) error stop
! if (i /= n + 2 .or. j /= m + 1) error stop
!$omp simd collapse(3) lastprivate(k) lastprivate(i,j)
do i = 1, n, 2
do j = 1, m
do k = j - 41, p
if (k < 1 - 41 .or. k > p) error stop
end do
end do
end do
if (k /= p + 1) error stop
if (i /= n + 2 .or. j /= m + 1) error stop
!$omp simd collapse(3) lastprivate(k) lastprivate(i,j)
do i = 1, n
do j = 1, m, 2
do k = i - 41, p
if (k < 1 - 41 .or. k > p) error stop
end do
end do
end do
if (k /= p + 1) error stop
if (i /= n + 1 .or. j /= m + 2) error stop
end subroutine lastprivate_check_simd_1
! Same but with do simd
subroutine lastprivate_check_do_simd_1
integer :: n,m,p, i,j,k
n = 11
m = 23
p = 27
! Use 'i' or 'j', unit step on 'i' or on 'j' -> 4 loops
! Then same, except use non-unit step for 'k'
! !$omp parallel do simd collapse(3) lastprivate(k)
! do i = 1, n
! do j = 1, m, 2
! do k = j - 41, p
! if (k < 1 - 41 .or. k > p) error stop
! end do
! end do
! end do
! if (k /= p + 1) error stop
! !$omp parallel do simd collapse(3) lastprivate(k)
! do i = 1, n, 2
! do j = 1, m
! do k = i - 41, p
! if (k < 1 - 41 .or. k > p) error stop
! end do
! end do
! end do
! if (k /= p + 1) error stop
!$omp parallel do simd collapse(3) lastprivate(k)
do i = 1, n, 2
do j = 1, m
do k = j - 41, p
if (k < 1 - 41 .or. k > p) error stop
end do
end do
end do
if (k /= p + 1) error stop
!$omp parallel do simd collapse(3) lastprivate(k)
do i = 1, n
do j = 1, m, 2
do k = i - 41, p
if (k < 1 - 41 .or. k > p) error stop
end do
end do
end do
if (k /= p + 1) error stop
! Same but 'private' for all (i,j) vars
! !$omp parallel do simd collapse(3) lastprivate(k) private(i,j)
! do i = 1, n
! do j = 1, m, 2
! do k = j - 41, p
! if (k < 1 - 41 .or. k > p) error stop
! end do
! end do
! end do
! if (k /= p + 1) error stop
! !$omp parallel do simd collapse(3) lastprivate(k) private(i,j)
! do i = 1, n, 2
! do j = 1, m
! do k = i - 41, p
! if (k < 1 - 41 .or. k > p) error stop
! end do
! end do
! end do
! if (k /= p + 1) error stop
!$omp parallel do simd collapse(3) lastprivate(k) private(i,j)
do i = 1, n, 2
do j = 1, m
do k = j - 41, p
if (k < 1 - 41 .or. k > p) error stop
end do
end do
end do
if (k /= p + 1) error stop
!$omp parallel do simd collapse(3) lastprivate(k) private(i,j)
do i = 1, n
do j = 1, m, 2
do k = i - 41, p
if (k < 1 - 41 .or. k > p) error stop
end do
end do
end do
if (k /= p + 1) error stop
! Same - but with lastprivate(i,j)
! !$omp parallel do simd collapse(3) lastprivate(k) lastprivate(i,j)
! do i = 1, n
! do j = 1, m, 2
! do k = j - 41, p
! if (k < 1 - 41 .or. k > p) error stop
! end do
! end do
! end do
! if (k /= p + 1) error stop
! if (i /= n + 1 .or. j /= m + 2) error stop
! !$omp parallel do simd collapse(3) lastprivate(k) lastprivate(i,j)
! do i = 1, n, 2
! do j = 1, m
! do k = i - 41, p
! if (k < 1 - 41 .or. k > p) error stop
! end do
! end do
! end do
! if (k /= p + 1) error stop
! if (i /= n + 2 .or. j /= m + 1) error stop
!$omp parallel do simd collapse(3) lastprivate(k) lastprivate(i,j)
do i = 1, n, 2
do j = 1, m
do k = j - 41, p
if (k < 1 - 41 .or. k > p) error stop
end do
end do
end do
if (k /= p + 1) error stop
if (i /= n + 2 .or. j /= m + 1) error stop
!$omp parallel do simd collapse(3) lastprivate(k) lastprivate(i,j)
do i = 1, n
do j = 1, m, 2
do k = i - 41, p
if (k < 1 - 41 .or. k > p) error stop
end do
end do
end do
if (k /= p + 1) error stop
if (i /= n + 1 .or. j /= m + 2) error stop
end subroutine lastprivate_check_do_simd_1
! Same but with do
subroutine lastprivate_check_do_1
integer :: n,m,p, i,j,k
n = 11
m = 23
p = 27
! Use 'i' or 'j', unit step on 'i' or on 'j' -> 4 loops
! Then same, except use non-unit step for 'k'
! !$omp parallel do collapse(3) lastprivate(k)
! do i = 1, n
! do j = 1, m, 2
! do k = j - 41, p
! if (k < 1 - 41 .or. k > p) error stop
! end do
! end do
! end do
! if (k /= p + 1) error stop
! !$omp parallel do collapse(3) lastprivate(k)
! do i = 1, n, 2
! do j = 1, m
! do k = i - 41, p
! if (k < 1 - 41 .or. k > p) error stop
! end do
! end do
! end do
! if (k /= p + 1) error stop
!$omp parallel do collapse(3) lastprivate(k)
do i = 1, n, 2
do j = 1, m
do k = j - 41, p
if (k < 1 - 41 .or. k > p) error stop
end do
end do
end do
if (k /= p + 1) error stop
!$omp parallel do collapse(3) lastprivate(k)
do i = 1, n
do j = 1, m, 2
do k = i - 41, p
if (k < 1 - 41 .or. k > p) error stop
end do
end do
end do
if (k /= p + 1) error stop
! Same but 'private' for all (i,j) vars
! !$omp parallel do collapse(3) lastprivate(k) private(i,j)
! do i = 1, n
! do j = 1, m, 2
! do k = j - 41, p
! if (k < 1 - 41 .or. k > p) error stop
! end do
! end do
! end do
! if (k /= p + 1) error stop
! !$omp parallel do collapse(3) lastprivate(k) private(i,j)
! do i = 1, n, 2
! do j = 1, m
! do k = i - 41, p
! if (k < 1 - 41 .or. k > p) error stop
! end do
! end do
! end do
! if (k /= p + 1) error stop
!$omp parallel do collapse(3) lastprivate(k) private(i,j)
do i = 1, n, 2
do j = 1, m
do k = j - 41, p
if (k < 1 - 41 .or. k > p) error stop
end do
end do
end do
if (k /= p + 1) error stop
!$omp parallel do collapse(3) lastprivate(k) private(i,j)
do i = 1, n
do j = 1, m, 2
do k = i - 41, p
if (k < 1 - 41 .or. k > p) error stop
end do
end do
end do
if (k /= p + 1) error stop
! Same - but with lastprivate(i,j)
! !$omp parallel do collapse(3) lastprivate(k) lastprivate(i,j)
! do i = 1, n
! do j = 1, m, 2
! do k = j - 41, p
! if (k < 1 - 41 .or. k > p) error stop
! end do
! end do
! end do
! if (k /= p + 1) error stop
! if (i /= n + 1 .or. j /= m + 2) error stop
! !$omp parallel do collapse(3) lastprivate(k) lastprivate(i,j)
! do i = 1, n, 2
! do j = 1, m
! do k = i - 41, p
! if (k < 1 - 41 .or. k > p) error stop
! end do
! end do
! end do
! if (k /= p + 1) error stop
! if (i /= n + 2 .or. j /= m + 1) error stop
!$omp parallel do collapse(3) lastprivate(k) lastprivate(i,j)
do i = 1, n, 2
do j = 1, m
do k = j - 41, p
if (k < 1 - 41 .or. k > p) error stop
end do
end do
end do
if (k /= p + 1) error stop
if (i /= n + 2 .or. j /= m + 1) error stop
!$omp parallel do collapse(3) lastprivate(k) lastprivate(i,j)
do i = 1, n
do j = 1, m, 2
do k = i - 41, p
if (k < 1 - 41 .or. k > p) error stop
end do
end do
end do
if (k /= p + 1) error stop
if (i /= n + 1 .or. j /= m + 2) error stop
end subroutine lastprivate_check_do_1
subroutine lastprivate_check_2
integer :: n,m,p, i,j,k,ll
n = 11
m = 23
p = 27
! !$omp parallel do simd collapse(3) lastprivate(p)
! do i = 1, n
! do j = 1, m,2
! do k = 1, j + 41
! do ll = 1, p, 2
! if (k > 23 + 41 .or. k < 1) error stop
! end do
! end do
! end do
! end do
! if (ll /= 29) error stop
! !$omp simd collapse(3) lastprivate(p)
! do i = 1, n
! do j = 1, m,2
! do k = 1, j + 41
! do ll = 1, p, 2
! if (k > 23 + 41 .or. k < 1) error stop
! end do
! end do
! end do
! end do
! if (ll /= 29) error stop
! !$omp simd collapse(3) lastprivate(k)
! do i = 1, n,2
! do j = 1, m
! do k = 1, i + 41
! if (k > 11 + 41 .or. k < 1) error stop
! end do
! end do
! end do
!if (k /= 53) then
! print *, k, 53
! error stop
!endif
!$omp simd collapse(3) lastprivate(k)
do i = 1, n,2
do j = 1, m
do k = 1, j + 41
if (k > 23 + 41 .or. k < 1) error stop
end do
end do
end do
if (k /= 65) then
print *, k, 65
error stop
endif
!$omp simd collapse(3) lastprivate(k)
do i = 1, n
do j = 1, m,2
do k = 1, i + 41
if (k > 11 + 41 .or. k < 1) error stop
end do
end do
end do
if (k /= 53) then
print *, k, 53
error stop
endif
! - Same but without 'private':
!!$omp simd collapse(3) lastprivate(k)
!do i = 1, n
! do j = 1, m,2
! do k = 1, j + 41
! if (k > 23 + 41 .or. k < 1) error stop
! end do
! end do
!end do
!if (k /= 65) then
! print *, k, 65
! error stop
!endif
!!$omp simd collapse(3) lastprivate(k)
!do i = 1, n,2
! do j = 1, m
! do k = 1, i + 41
! if (k > 11 + 41 .or. k < 1) error stop
! end do
! end do
!end do
!if (k /= 53) then
! print *, k, 53
! error stop
!endif
!$omp simd collapse(3) lastprivate(k)
do i = 1, n,2
do j = 1, m
do k = 1, j + 41
if (k > 23 + 41 .or. k < 1) error stop
end do
end do
end do
if (k /= 65) then
print *, k, 65
error stop
endif
!$omp simd collapse(3) lastprivate(k)
do i = 1, n
do j = 1, m,2
do k = 1, i + 41
if (k > 11 + 41 .or. k < 1) error stop
end do
end do
end do
if (k /= 53) then
print *, k, 53
error stop
endif
! - all with lastprivate
!!$omp simd collapse(3) lastprivate(k) lastprivate(i, j)
!do i = 1, n
! do j = 1, m,2
! do k = 1, j + 41
! if (k > 23 + 41 .or. k < 1) error stop
! end do
! end do
!end do
!if (k /= 65) then
! print *, k, 65
! error stop
!endif
!!$omp simd collapse(3) lastprivate(k) lastprivate(i, j)
!do i = 1, n,2
! do j = 1, m
! do k = 1, i + 41
! if (k > 11 + 41 .or. k < 1) error stop
! end do
! end do
!end do
!if (k /= 53) then
! print *, k, 53
! error stop
!endif
!$omp simd collapse(3) lastprivate(k) lastprivate(i, j)
do i = 1, n,2
do j = 1, m
do k = 1, j + 41
if (k > 23 + 41 .or. k < 1) error stop
end do
end do
end do
if (k /= 65) then
print *, k, 65
error stop
endif
!$omp simd collapse(3) lastprivate(k) lastprivate(i, j)
do i = 1, n
do j = 1, m,2
do k = 1, i + 41
if (k > 11 + 41 .or. k < 1) error stop
end do
end do
end do
if (k /= 53) then
print *, k, 53
error stop
endif
end
end module m
program main
use m
implicit none (type, external)
call lastprivate_check_simd_1
call lastprivate_check_do_simd_1
call lastprivate_check_do_1
call lastprivate_check_2
end

374
libgomp/testsuite/libgomp.fortran/non-rectangular-loop-1a.f90 Normal file
View file

@ -0,0 +1,374 @@
! { dg-do compile }
! { dg-additional-options "-msse2" { target sse2_runtime } }
! { dg-additional-options "-mavx" { target avx_runtime } }
! PR fortran/107424
! Nonrectangular loop nests checks
! ========================================================
! NOTE: The testcases are from non-rectangular-loop-1.f90,
! but commented there. Feel free to remove this
! file + uncomment them in non-rectangular-loop-1.f90
! Otherwise, you need to change it to 'dg-do run'!
! ========================================================
module m
implicit none (type, external)
contains
! The 'k' loop uses i or j as start value
! but a constant end value such that 'lastprivate'
! should be well-defined
subroutine lastprivate_check_simd_1
integer :: n,m,p, i,j,k
n = 11
m = 23
p = 27
! Use 'i' or 'j', unit step on 'i' or on 'j' -> 4 loops
! Then same, except use non-unit step for 'k'
!$omp simd collapse(3) lastprivate(k)
do i = 1, n
do j = 1, m, 2 ! { dg-message "sorry, unimplemented: non-rectangular loop nest with step other than constant 1 or -1 for 'j'" }
do k = j - 41, p ! { dg-note "Used here" }
if (k < 1 - 41 .or. k > p) error stop
end do
end do
end do
if (k /= p + 1) error stop
!$omp simd collapse(3) lastprivate(k)
do i = 1, n, 2 ! { dg-message "sorry, unimplemented: non-rectangular loop nest with step other than constant 1 or -1 for 'i'" }
do j = 1, m
do k = i - 41, p ! { dg-note "Used here" }
if (k < 1 - 41 .or. k > p) error stop
end do
end do
end do
if (k /= p + 1) error stop
! Same but 'private' for all (i,j) vars
!$omp simd collapse(3) lastprivate(k) private(i,j)
do i = 1, n
do j = 1, m, 2 ! { dg-message "sorry, unimplemented: non-rectangular loop nest with step other than constant 1 or -1 for 'j'" }
do k = j - 41, p ! { dg-note "Used here" }
if (k < 1 - 41 .or. k > p) error stop
end do
end do
end do
if (k /= p + 1) error stop
!$omp simd collapse(3) lastprivate(k) private(i,j)
do i = 1, n, 2 ! { dg-message "sorry, unimplemented: non-rectangular loop nest with step other than constant 1 or -1 for 'i'" }
do j = 1, m
do k = i - 41, p ! { dg-note "Used here" }
if (k < 1 - 41 .or. k > p) error stop
end do
end do
end do
if (k /= p + 1) error stop
! Same - but with lastprivate(i,j)
!$omp simd collapse(3) lastprivate(k) lastprivate(i,j)
do i = 1, n
do j = 1, m, 2 ! { dg-message "sorry, unimplemented: non-rectangular loop nest with step other than constant 1 or -1 for 'j'" }
do k = j - 41, p ! { dg-note "Used here" }
if (k < 1 - 41 .or. k > p) error stop
end do
end do
end do
if (k /= p + 1) error stop
if (i /= n + 1 .or. j /= m + 2) error stop
!$omp simd collapse(3) lastprivate(k) lastprivate(i,j)
do i = 1, n, 2 ! { dg-message "sorry, unimplemented: non-rectangular loop nest with step other than constant 1 or -1 for 'i'" }
do j = 1, m
do k = i - 41, p ! { dg-note "Used here" }
if (k < 1 - 41 .or. k > p) error stop
end do
end do
end do
if (k /= p + 1) error stop
if (i /= n + 2 .or. j /= m + 1) error stop
end subroutine lastprivate_check_simd_1
! Same but with do simd
subroutine lastprivate_check_do_simd_1
integer :: n,m,p, i,j,k
n = 11
m = 23
p = 27
! Use 'i' or 'j', unit step on 'i' or on 'j' -> 4 loops
! Then same, except use non-unit step for 'k'
!$omp parallel do simd collapse(3) lastprivate(k)
do i = 1, n
do j = 1, m, 2 ! { dg-message "sorry, unimplemented: non-rectangular loop nest with step other than constant 1 or -1 for 'j'" }
do k = j - 41, p ! { dg-note "Used here" }
if (k < 1 - 41 .or. k > p) error stop
end do
end do
end do
if (k /= p + 1) error stop
!$omp parallel do simd collapse(3) lastprivate(k)
do i = 1, n, 2 ! { dg-message "sorry, unimplemented: non-rectangular loop nest with step other than constant 1 or -1 for 'i'" }
do j = 1, m
do k = i - 41, p ! { dg-note "Used here" }
if (k < 1 - 41 .or. k > p) error stop
end do
end do
end do
if (k /= p + 1) error stop
! Same but 'private' for all (i,j) vars
!$omp parallel do simd collapse(3) lastprivate(k) private(i,j)
do i = 1, n
do j = 1, m, 2 ! { dg-message "sorry, unimplemented: non-rectangular loop nest with step other than constant 1 or -1 for 'j'" }
do k = j - 41, p ! { dg-note "Used here" }
if (k < 1 - 41 .or. k > p) error stop
end do
end do
end do
if (k /= p + 1) error stop
!$omp parallel do simd collapse(3) lastprivate(k) private(i,j)
do i = 1, n, 2 ! { dg-message "sorry, unimplemented: non-rectangular loop nest with step other than constant 1 or -1 for 'i'" }
do j = 1, m
do k = i - 41, p ! { dg-note "Used here" }
if (k < 1 - 41 .or. k > p) error stop
end do
end do
end do
if (k /= p + 1) error stop
! Same - but with lastprivate(i,j)
!$omp parallel do simd collapse(3) lastprivate(k) lastprivate(i,j)
do i = 1, n
do j = 1, m, 2 ! { dg-message "sorry, unimplemented: non-rectangular loop nest with step other than constant 1 or -1 for 'j'" }
do k = j - 41, p ! { dg-note "Used here" }
if (k < 1 - 41 .or. k > p) error stop
end do
end do
end do
if (k /= p + 1) error stop
if (i /= n + 1 .or. j /= m + 2) error stop
!$omp parallel do simd collapse(3) lastprivate(k) lastprivate(i,j)
do i = 1, n, 2 ! { dg-message "sorry, unimplemented: non-rectangular loop nest with step other than constant 1 or -1 for 'i'" }
do j = 1, m
do k = i - 41, p ! { dg-note "Used here" }
if (k < 1 - 41 .or. k > p) error stop
end do
end do
end do
if (k /= p + 1) error stop
if (i /= n + 2 .or. j /= m + 1) error stop
end subroutine lastprivate_check_do_simd_1
! Same but with do
subroutine lastprivate_check_do_1
integer :: n,m,p, i,j,k
n = 11
m = 23
p = 27
! Use 'i' or 'j', unit step on 'i' or on 'j' -> 4 loops
! Then same, except use non-unit step for 'k'
!$omp parallel do collapse(3) lastprivate(k)
do i = 1, n
do j = 1, m, 2 ! { dg-message "sorry, unimplemented: non-rectangular loop nest with step other than constant 1 or -1 for 'j'" }
do k = j - 41, p ! { dg-note "Used here" }
if (k < 1 - 41 .or. k > p) error stop
end do
end do
end do
if (k /= p + 1) error stop
!$omp parallel do collapse(3) lastprivate(k)
do i = 1, n, 2 ! { dg-message "sorry, unimplemented: non-rectangular loop nest with step other than constant 1 or -1 for 'i'" }
do j = 1, m
do k = i - 41, p ! { dg-note "Used here" }
if (k < 1 - 41 .or. k > p) error stop
end do
end do
end do
if (k /= p + 1) error stop
! Same but 'private' for all (i,j) vars
!$omp parallel do collapse(3) lastprivate(k) private(i,j)
do i = 1, n
do j = 1, m, 2 ! { dg-message "sorry, unimplemented: non-rectangular loop nest with step other than constant 1 or -1 for 'j'" }
do k = j - 41, p ! { dg-note "Used here" }
if (k < 1 - 41 .or. k > p) error stop
end do
end do
end do
if (k /= p + 1) error stop
!$omp parallel do collapse(3) lastprivate(k) private(i,j)
do i = 1, n, 2 ! { dg-message "sorry, unimplemented: non-rectangular loop nest with step other than constant 1 or -1 for 'i'" }
do j = 1, m
do k = i - 41, p ! { dg-note "Used here" }
if (k < 1 - 41 .or. k > p) error stop
end do
end do
end do
if (k /= p + 1) error stop
! Same - but with lastprivate(i,j)
!$omp parallel do collapse(3) lastprivate(k) lastprivate(i,j)
do i = 1, n
do j = 1, m, 2 ! { dg-message "sorry, unimplemented: non-rectangular loop nest with step other than constant 1 or -1 for 'j'" }
do k = j - 41, p ! { dg-note "Used here" }
if (k < 1 - 41 .or. k > p) error stop
end do
end do
end do
if (k /= p + 1) error stop
if (i /= n + 1 .or. j /= m + 2) error stop
!$omp parallel do collapse(3) lastprivate(k) lastprivate(i,j)
do i = 1, n, 2 ! { dg-message "sorry, unimplemented: non-rectangular loop nest with step other than constant 1 or -1 for 'i'" }
do j = 1, m
do k = i - 41, p ! { dg-note "Used here" }
if (k < 1 - 41 .or. k > p) error stop
end do
end do
end do
if (k /= p + 1) error stop
if (i /= n + 2 .or. j /= m + 1) error stop
end subroutine lastprivate_check_do_1
subroutine lastprivate_check_2
integer :: n,m,p, i,j,k,ll
n = 11
m = 23
p = 27
!$omp parallel do simd collapse(3) lastprivate(p)
do i = 1, n
do j = 1, m,2 ! { dg-message "sorry, unimplemented: non-rectangular loop nest with step other than constant 1 or -1 for 'j'" }
do k = 1, j + 41 ! { dg-note "Used here" }
do ll = 1, p, 2
if (k > 23 + 41 .or. k < 1) error stop
end do
end do
end do
end do
if (ll /= 29) error stop
!$omp simd collapse(3) lastprivate(p)
do i = 1, n
do j = 1, m,2 ! { dg-message "sorry, unimplemented: non-rectangular loop nest with step other than constant 1 or -1 for 'j'" }
do k = 1, j + 41 ! { dg-note "Used here" }
do ll = 1, p, 2
if (k > 23 + 41 .or. k < 1) error stop
end do
end do
end do
end do
if (ll /= 29) error stop
!$omp simd collapse(3) lastprivate(k)
do i = 1, n,2 ! { dg-message "sorry, unimplemented: non-rectangular loop nest with step other than constant 1 or -1 for 'i'" }
do j = 1, m
do k = 1, i + 41 ! { dg-note "Used here" }
if (k > 11 + 41 .or. k < 1) error stop
end do
end do
end do
if (k /= 53) then
print *, k, 53
error stop
endif
! - Same but without 'private':
!$omp simd collapse(3) lastprivate(k)
do i = 1, n
do j = 1, m,2 ! { dg-message "sorry, unimplemented: non-rectangular loop nest with step other than constant 1 or -1 for 'j'" }
do k = 1, j + 41 ! { dg-note "Used here" }
if (k > 23 + 41 .or. k < 1) error stop
end do
end do
end do
if (k /= 65) then
print *, k, 65
error stop
endif
!$omp simd collapse(3) lastprivate(k)
do i = 1, n,2 ! { dg-message "sorry, unimplemented: non-rectangular loop nest with step other than constant 1 or -1 for 'i'" }
do j = 1, m
do k = 1, i + 41 ! { dg-note "Used here" }
if (k > 11 + 41 .or. k < 1) error stop
end do
end do
end do
if (k /= 53) then
print *, k, 53
error stop
endif
! - all with lastprivate
!$omp simd collapse(3) lastprivate(k) lastprivate(i, j)
do i = 1, n
do j = 1, m,2 ! { dg-message "sorry, unimplemented: non-rectangular loop nest with step other than constant 1 or -1 for 'j'" }
do k = 1, j + 41 ! { dg-note "Used here" }
if (k > 23 + 41 .or. k < 1) error stop
end do
end do
end do
if (k /= 65) then
print *, k, 65
error stop
endif
!$omp simd collapse(3) lastprivate(k) lastprivate(i, j)
do i = 1, n,2 ! { dg-message "sorry, unimplemented: non-rectangular loop nest with step other than constant 1 or -1 for 'i'" }
do j = 1, m
do k = 1, i + 41 ! { dg-note "Used here" }
if (k > 11 + 41 .or. k < 1) error stop
end do
end do
end do
if (k /= 53) then
print *, k, 53
error stop
endif
end
end module m
program main
use m
implicit none (type, external)
call lastprivate_check_simd_1
call lastprivate_check_do_simd_1
call lastprivate_check_do_1
call lastprivate_check_2
end

243
libgomp/testsuite/libgomp.fortran/non-rectangular-loop-2.f90 Normal file
View file

@ -0,0 +1,243 @@
! { dg-do run }
! { dg-additional-options "-fdump-tree-original -fcheck=all" }
! PR fortran/107424
! Nonrectangular loop nests checks
! Valid patterns are:
! (1) a2 - var-outer
! (2) a1 * var-outer
! (3) a1 * var-outer + a2
! (4) a2 + a1 * var-outer
! (5) a1 * var-outer - a2
! (6) a2 - a1 * var-outer
! (7) var-outer * a1
! (8) var-outer * a1 + a2
! (9) a2 + var-outer * a1
! (10) var-outer * a1 - a2
! (11) a2 - var-outer * a1
module m
contains
! { dg-final { scan-tree-dump-times "for \\(one_two_inner = one_two_outer \\* -1 \\+ one_a2; one_two_inner <= one_two_outer \\* two_a1 \\+ 0; one_two_inner = one_two_inner \\+ 1\\)" 1 original } }
! (1) a2 - var-outer
! (2) a1 * var-outer
subroutine one_two()
implicit none
integer :: one_a2
integer :: two_a1
integer :: one_two_outer, one_two_inner
integer :: i, j
integer, allocatable :: var(:,:)
one_a2 = 13
two_a1 = 5
allocate(var(1:10, one_a2 - 10:two_a1 * 10), &
source=0)
if (size(var) <= 4) error stop
!$omp simd collapse(2)
do one_two_outer = 1, 10
do one_two_inner = one_a2 - one_two_outer, two_a1 * one_two_outer
!$omp atomic update
var(one_two_outer,one_two_inner) = var(one_two_outer,one_two_inner) + 2
end do
end do
do i = 1, 10
do j = one_a2 - i, two_a1 * i
if (var(i,j) /= 2) error stop
end do
end do
end
! { dg-final { scan-tree-dump-times "for \\(three_four_inner = three_four_outer \\* three_a1 \\+ three_a2; three_four_inner <= three_four_outer \\* four_a1 \\+ four_a2; three_four_inner = three_four_inner \\+ 1\\)" 1 original } }
! (3) a1 * var-outer + a2
! (4) a2 + a1 * var-outer
subroutine three_four()
implicit none
integer :: three_a1, three_a2
integer :: four_a1, four_a2
integer :: three_four_outer, three_four_inner
integer :: i, j
integer, allocatable :: var(:,:)
three_a1 = 2
three_a2 = 3
four_a1 = 3
four_a2 = 5
allocate(var(1:10, three_a1 * 1 + three_a2:four_a2 + four_a1 * 10), &
source=0)
if (size(var) <= 4) error stop
!$omp simd collapse(2)
do three_four_outer = 1, 10
do three_four_inner = three_a1 * three_four_outer + three_a2, four_a2 + four_a1 * three_four_outer
!$omp atomic update
var(three_four_outer, three_four_inner) = var(three_four_outer, three_four_inner) + 2
end do
end do
do i = 1, 10
do j = three_a1 * i + three_a2, four_a2 + four_a1 * i
if (var(i,j) /= 2) error stop
end do
end do
end
! { dg-final { scan-tree-dump-times "for \\(five_six_inner = five_six_outer \\* five_a1 \\+ D\\.\[0-9\]+; five_six_inner <= five_six_outer \\* D\\.\[0-9\]+ \\+ six_a2; five_six_inner = five_six_inner \\+ 1\\)" 1 original } }
! (5) a1 * var-outer - a2
! (6) a2 - a1 * var-outer
subroutine five_six()
implicit none
integer :: five_a1, five_a2
integer :: six_a1, six_a2
integer :: five_six_outer, five_six_inner
integer :: i, j
integer, allocatable :: var(:,:)
five_a1 = 2
five_a2 = -3
six_a1 = 3
six_a2 = 20
allocate(var(1:10, five_a1 * 1 - five_a2:six_a2 - six_a1 * 1), &
source=0)
if (size(var) <= 4) error stop
!$omp simd collapse(2)
do five_six_outer = 1, 10
do five_six_inner = five_a1 * five_six_outer - five_a2, six_a2 - six_a1 * five_six_outer
!$omp atomic update
var(five_six_outer, five_six_inner) = var(five_six_outer, five_six_inner) + 2
end do
end do
do i = 1, 10
do j = five_a1 * i - five_a2, six_a2 - six_a1 * i
if (var(i,j) /= 2) error stop
end do
end do
end
! { dg-final { scan-tree-dump-times "for \\(seven_eight_inner = seven_eight_outer \\* seven_a1 \\+ 0; seven_eight_inner <= seven_eight_outer \\* eight_a1 \\+ eight_a2; seven_eight_inner = seven_eight_inner \\+ 1\\)" 1 original } }
! (7) var-outer * a1
! (8) var-outer * a1 + a2
subroutine seven_eight()
implicit none
integer :: seven_a1
integer :: eight_a1, eight_a2
integer :: seven_eight_outer, seven_eight_inner
integer :: i, j
integer, allocatable :: var(:,:)
seven_a1 = 3
eight_a1 = 2
eight_a2 = -4
allocate(var(1:10, 1 * seven_a1 : 10 * eight_a1 + eight_a2), &
source=0)
if (size(var) <= 4) error stop
!$omp simd collapse(2)
do seven_eight_outer = 1, 10
do seven_eight_inner = seven_eight_outer * seven_a1, seven_eight_outer * eight_a1 + eight_a2
!$omp atomic update
var(seven_eight_outer, seven_eight_inner) = var(seven_eight_outer, seven_eight_inner) + 2
end do
end do
do i = 1, 10
do j = i * seven_a1, i * eight_a1 + eight_a2
if (var(i,j) /= 2) error stop
end do
end do
end
! { dg-final { scan-tree-dump-times "for \\(nine_ten_inner = nine_ten_outer \\* nine_a1 \\+ nine_a2; nine_ten_inner <= nine_ten_outer \\* ten_a1 \\+ D\\.\[0-9\]+; nine_ten_inner = nine_ten_inner \\+ 1\\)" 1 original } }
! (9) a2 + var-outer * a1
! (10) var-outer * a1 - a2
subroutine nine_ten()
implicit none
integer :: nine_a1, nine_a2
integer :: ten_a1, ten_a2
integer :: nine_ten_outer, nine_ten_inner
integer :: i, j
integer, allocatable :: var(:,:)
nine_a1 = 3
nine_a2 = 5
ten_a1 = 2
ten_a2 = 3
allocate(var(1:10, nine_a2 + 1 * nine_a1:10 * ten_a1 - ten_a2), &
source=0)
if (size(var) <= 4) error stop
!$omp simd collapse(2)
do nine_ten_outer = 1, 10
do nine_ten_inner = nine_a2 + nine_ten_outer * nine_a1, nine_ten_outer * ten_a1 - ten_a2
!$omp atomic update
var(nine_ten_outer, nine_ten_inner) = var(nine_ten_outer, nine_ten_inner) + 2
end do
end do
do i = 1, 10
do j = nine_a2 + i * nine_a1, i * ten_a1 - ten_a2
if (var(i,j) /= 2) error stop
end do
end do
end
! { dg-final { scan-tree-dump-times "for \\(eleven_inner = eleven_outer \\* D\\.\[0-9\]+ \\+ eleven_a2; eleven_inner <= 10; eleven_inner = eleven_inner \\+ 1\\)" 1 original } }
! (11) a2 - var-outer * a1
subroutine eleven()
implicit none
integer :: eleven_a1, eleven_a2
integer :: eleven_outer, eleven_inner
integer :: i, j
integer, allocatable :: var(:,:)
eleven_a1 = 2
eleven_a2 = 3
allocate(var(1:10, eleven_a2 - 10 * eleven_a1 : 10), &
source=0)
if (size(var) <= 4) error stop
!$omp simd collapse(2)
do eleven_outer = 1, 10
do eleven_inner = eleven_a2 - eleven_outer * eleven_a1, 10
!$omp atomic update
var(eleven_outer, eleven_inner) = var(eleven_outer, eleven_inner) + 2
end do
end do
do i = 1, 10
do j = eleven_a2 - i * eleven_a1, 10
if (var(i,j) /= 2) error stop
end do
end do
end
end module m
program main
use m
implicit none
call one_two()
call three_four()
call five_six()
call seven_eight()
call nine_ten()
call eleven()
end

212
libgomp/testsuite/libgomp.fortran/non-rectangular-loop-3.f90 Normal file
View file

@ -0,0 +1,212 @@
! { dg-additional-options "-fdump-tree-original" }
! PR fortran/107424
module m
contains
subroutine foo (av, avo, a0, a0o, a1, a2, a3, a4)
implicit none
integer, value :: av
integer, value, optional :: avo
integer :: a0
integer, optional :: a0o
integer, pointer :: a1
integer, pointer, optional :: a2
integer, allocatable :: a3
integer, allocatable, optional :: a4
integer :: a5
integer, pointer :: a6
integer, allocatable :: a7
integer :: arr(20,10), ref(20,10)
integer :: j, i
allocate(a6, a7)
ref = 44
do i = 1, 10
do j = i, 20
ref(j, i) = j + 100 * i
end do
end do
! { dg-final { scan-tree-dump-times "for \\(av = 1; av <= 10; av = av \\+ 1\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "for \\(j = av \\* 1 \\+ 0; j <= 20; j = j \\+ 1\\)" 1 "original" } }
! -> no temp var
arr = 44
av = 99; j = 99
!$omp simd collapse(2) lastprivate(av,j)
do av = 1, 10
do j = av, 20
arr(j, av) = j + 100 * av
end do
end do
if (any (ref /= arr)) error stop
if (av /= 11 .or. j /= 21) error stop
! { dg-final { scan-tree-dump-times "for \\(avo = 1; avo <= 10; avo = avo \\+ 1\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "for \\(j = avo \\* 1 \\+ 0; j <= 20; j = j \\+ 1\\)" 1 "original" } }
! -> no temp var
arr = 44
avo = 99; j = 99
!$omp simd collapse(2) lastprivate(avo, j)
do avo = 1, 10
do j = avo, 20
arr(j, avo) = j + 100 * avo
end do
end do
if (any (ref /= arr)) error stop
if (avo /= 11 .or. j /= 21) error stop
! { dg-final { scan-tree-dump-times "for \\(a0\\.\[0-9\]+ = 1; a0\\.\[0-9\]+ <= 10; a0\\.\[0-9\]+ = a0\\.\[0-9\]+ \\+ 1\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "for \\(j = a0\\.\[0-9\]+ \\* 1 \\+ 0; j <= 20; j = j \\+ 1\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "\\*a0 = a0\\.\[0-9\]+;" 1 "original" } }
arr = 44
a0 = 99; j = 99
!$omp simd collapse(2) lastprivate(a0,j)
do a0 = 1, 10
do j = a0, 20
arr(j, a0) = j + 100 * a0
end do
end do
if (any (ref /= arr)) error stop
if (a0 /= 11 .or. j /= 21) error stop
! { dg-final { scan-tree-dump-times "for \\(a0o\\.\[0-9\]+ = 1; a0o\\.\[0-9\]+ <= 10; a0o\\.\[0-9\]+ = a0o\\.\[0-9\]+ \\+ 1\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "for \\(j = a0o\\.\[0-9\]+ \\* 1 \\+ 0; j <= 20; j = j \\+ 1\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "\\*a0o = a0o\\.\[0-9\]+;" 1 "original" } }
arr = 44
a0o = 99; j = 99
!$omp simd collapse(2) lastprivate(a0o,j)
do a0o = 1, 10
do j = a0o, 20
arr(j, a0o) = j + 100 * a0o
end do
end do
if (any (ref /= arr)) error stop
if (a0o /= 11 .or. j /= 21) error stop
! { dg-final { scan-tree-dump-times "for \\(a1\\.\[0-9\]+ = 1; a1\\.\[0-9\]+ <= 10; a1\\.\[0-9\]+ = a1\\.\[0-9\]+ \\+ 1\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "for \\(j = a1\\.\[0-9\]+ \\* 1 \\+ 0; j <= 20; j = j \\+ 1\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "\\*\\*a1 = a1\\.\[0-9\]+;" 1 "original" } }
arr = 44
a1 = 99; j = 99
! no last private for 'a1' as "The initial status of a private pointer is undefined."
!$omp simd collapse(2) lastprivate(j)
do a1 = 1, 10
do j = a1, 20
arr(j, a1) = j + 100 * a1
end do
end do
if (any (ref /= arr)) error stop
if (j /= 21) error stop
! { dg-final { scan-tree-dump-times "for \\(a2\\.\[0-9\]+ = 1; a2\\.\[0-9\]+ <= 10; a2\\.\[0-9\]+ = a2\\.\[0-9\]+ \\+ 1\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "for \\(j = a2\\.\[0-9\]+ \\* 1 \\+ 0; j <= 20; j = j \\+ 1\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "\\*\\*a2 = a2\\.\[0-9\]+;" 1 "original" } }
arr = 44
a2 = 99; j = 99
! no last private for 'a2' as "The initial status of a private pointer is undefined."
!$omp simd collapse(2) lastprivate(j)
do a2 = 1, 10
do j = a2, 20
arr(j, a2) = j + 100 * a2
end do
end do
if (any (ref /= arr)) error stop
if (j /= 21) error stop
! { dg-final { scan-tree-dump-times "for \\(a3\\.\[0-9\]+ = 1; a3\\.\[0-9\]+ <= 10; a3\\.\[0-9\]+ = a3\\.\[0-9\]+ \\+ 1\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "for \\(j = a3\\.\[0-9\]+ \\* 1 \\+ 0; j <= 20; j = j \\+ 1\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "\\*\\*a3 = a3\\.\[0-9\]+;" 1 "original" } }
arr = 44
a3 = 99; j = 99
!$omp simd collapse(2) lastprivate(a3,j)
do a3 = 1, 10
do j = a3, 20
arr(j, a3) = j + 100 * a3
end do
end do
if (any (ref /= arr)) error stop
if (a3 /= 11 .or. j /= 21) error stop
! { dg-final { scan-tree-dump-times "for \\(a4\\.\[0-9\]+ = 1; a4\\.\[0-9\]+ <= 10; a4\\.\[0-9\]+ = a4\\.\[0-9\]+ \\+ 1\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "for \\(j = a4\\.\[0-9\]+ \\* 1 \\+ 0; j <= 20; j = j \\+ 1\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "\\*\\*a4 = a4\\.\[0-9\]+;" 1 "original" } }
arr = 44
a4 = 99; j = 99
!$omp simd collapse(2) lastprivate(a4,j)
do a4 = 1, 10
do j = a4, 20
arr(j, a4) = j + 100 * a4
end do
end do
if (any (ref /= arr)) error stop
if (a4 /= 11 .or. j /= 21) error stop
! { dg-final { scan-tree-dump-times "for \\(a5 = 1; a5 <= 10; a5 = a5 \\+ 1\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "for \\(j = a5 \\* 1 \\+ 0; j <= 20; j = j \\+ 1\\)" 1 "original" } }
! -> no temp var
arr = 44
a5 = 99; j = 99
!$omp simd collapse(2) lastprivate(a5,j)
do a5 = 1, 10
do j = a5, 20
arr(j, a5) = j + 100 * a5
end do
end do
if (any (ref /= arr)) error stop
if (a5 /= 11 .or. j /= 21) error stop
! { dg-final { scan-tree-dump-times "for \\(a6\\.\[0-9\]+ = 1; a6\\.\[0-9\]+ <= 10; a6\\.\[0-9\]+ = a6\\.\[0-9\]+ \\+ 1\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "for \\(j = a6\\.\[0-9\]+ \\* 1 \\+ 0; j <= 20; j = j \\+ 1\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "\\*a6 = a6\\.\[0-9\]+;" 1 "original" } }
arr = 44
a6 = 99; j = 99
! no last private for 'a6' as "The initial status of a private pointer is undefined."
!$omp simd collapse(2) lastprivate(j)
do a6 = 1, 10
do j = a6, 20
arr(j, a6) = j + 100 * a6
end do
end do
if (any (ref /= arr)) error stop
if (j /= 21) error stop
! { dg-final { scan-tree-dump-times "for \\(a7\\.\[0-9\]+ = 1; a7\\.\[0-9\]+ <= 10; a7\\.\[0-9\]+ = a7\\.\[0-9\]+ \\+ 1\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "for \\(j = a7\\.\[0-9\]+ \\* 1 \\+ 0; j <= 20; j = j \\+ 1\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "\\*a7 = a7\\.\[0-9\]+;" 1 "original" } }
arr = 44
a7 = 99; j = 99
!$omp simd collapse(2) lastprivate(a7,j)
do a7 = 1, 10
do j = a7, 20
arr(j, a7) = j + 100 * a7
end do
end do
if (any (ref /= arr)) error stop
if (a7 /= 11 .or. j /= 21) error stop
deallocate(a6, a7)
end
end module m
use m
implicit none
integer :: av
integer :: avo
integer :: a0
integer :: a0o
integer, pointer :: a1
integer, pointer :: a2
integer, allocatable :: a3
integer, allocatable :: a4
av = -99; avo = -99
allocate(a1,a2,a3,a4)
call foo (av, avo, a0, a0o, a1, a2, a3, a4)
deallocate(a1,a2,a3,a4)
end

215
libgomp/testsuite/libgomp.fortran/non-rectangular-loop-4.f90 Normal file
View file

@ -0,0 +1,215 @@
! { dg-additional-options "-fdump-tree-original" }
! PR fortran/107424
! Same as non-rectangular-loop-4.f90 but expr in upper bound
module m
contains
subroutine foo (av, avo, a0, a0o, a1, a2, a3, a4)
implicit none
integer, value :: av
integer, value, optional :: avo
integer :: a0
integer, optional :: a0o
integer, pointer :: a1
integer, pointer, optional :: a2
integer, allocatable :: a3
integer, allocatable, optional :: a4
integer :: a5
integer, pointer :: a6
integer, allocatable :: a7
integer :: arr(20,10), ref(20,10)
integer :: j, i, lp_i, lp_j
allocate(a6, a7)
ref = 44
do i = 1, 10
do j = 1, i*2-1
ref(j, i) = j + 100 * i
end do
end do
lp_i = i; lp_j = j
! { dg-final { scan-tree-dump-times "for \\(av = 1; av <= 10; av = av \\+ 1\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "for \\(j = 1; j <= av \\* 2 \\+ -1; j = j \\+ 1\\)" 1 "original" } }
! -> no temp var
arr = 44
av = 99; j = 99
!$omp simd collapse(2) lastprivate(av,j)
do av = 1, 10
do j = 1, av*2-1
arr(j, av) = j + 100 * av
end do
end do
if (any (ref /= arr)) error stop
if (av /= lp_i .or. j /= lp_j) error stop
! { dg-final { scan-tree-dump-times "for \\(avo = 1; avo <= 10; avo = avo \\+ 1\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "for \\(j = 1; j <= avo \\* 2 \\+ -1; j = j \\+ 1\\)" 1 "original" } }
! -> no temp var
arr = 44
avo = 99; j = 99
!$omp simd collapse(2) lastprivate(avo, j)
do avo = 1, 10
do j = 1, avo*2-1
arr(j, avo) = j + 100 * avo
end do
end do
if (any (ref /= arr)) error stop
if (avo /= lp_i .or. j /= lp_j) error stop
! { dg-final { scan-tree-dump-times "for \\(a0\\.\[0-9\]+ = 1; a0\\.\[0-9\]+ <= 10; a0\\.\[0-9\]+ = a0\\.\[0-9\]+ \\+ 1\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "for \\(j = 1; j <= a0\\.\[0-9\]+ \\* 2 \\+ -1; j = j \\+ 1\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "\\*a0 = a0\\.\[0-9\]+;" 1 "original" } }
arr = 44
a0 = 99; j = 99
!$omp simd collapse(2) lastprivate(a0,j)
do a0 = 1, 10
do j = 1, a0*2-1
arr(j, a0) = j + 100 * a0
end do
end do
if (any (ref /= arr)) error stop
if (a0 /= lp_i .or. j /= lp_j) error stop
! { dg-final { scan-tree-dump-times "for \\(a0o\\.\[0-9\]+ = 1; a0o\\.\[0-9\]+ <= 10; a0o\\.\[0-9\]+ = a0o\\.\[0-9\]+ \\+ 1\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "for \\(j = 1; j <= a0o\\.\[0-9\]+ \\* 2 \\+ -1; j = j \\+ 1\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "\\*a0o = a0o\\.\[0-9\]+;" 1 "original" } }
arr = 44
a0o = 99; j = 99
!$omp simd collapse(2) lastprivate(a0o,j)
do a0o = 1, 10
do j = 1, a0o*2-1
arr(j, a0o) = j + 100 * a0o
end do
end do
if (any (ref /= arr)) error stop
if (a0o /= lp_i .or. j /= lp_j) error stop
! { dg-final { scan-tree-dump-times "for \\(a1\\.\[0-9\]+ = 1; a1\\.\[0-9\]+ <= 10; a1\\.\[0-9\]+ = a1\\.\[0-9\]+ \\+ 1\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "for \\(j = 1; j <= a1\\.\[0-9\]+ \\* 2 \\+ -1; j = j \\+ 1\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "\\*\\*a1 = a1\\.\[0-9\]+;" 1 "original" } }
arr = 44
a1 = 99; j = 99
! no last private for 'a1' as "The initial status of a private pointer is undefined."
!$omp simd collapse(2) lastprivate(j)
do a1 = 1, 10
do j = 1, a1*2-1
arr(j, a1) = j + 100 * a1
end do
end do
if (any (ref /= arr)) error stop
if (j /= lp_j) error stop
! { dg-final { scan-tree-dump-times "for \\(a2\\.\[0-9\]+ = 1; a2\\.\[0-9\]+ <= 10; a2\\.\[0-9\]+ = a2\\.\[0-9\]+ \\+ 1\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "for \\(j = 1; j <= a2\\.\[0-9\]+ \\* 2 \\+ -1; j = j \\+ 1\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "\\*\\*a2 = a2\\.\[0-9\]+;" 1 "original" } }
arr = 44
a2 = 99; j = 99
! no last private for 'a2' as "The initial status of a private pointer is undefined."
!$omp simd collapse(2) lastprivate(j)
do a2 = 1, 10
do j = 1, a2*2-1
arr(j, a2) = j + 100 * a2
end do
end do
if (any (ref /= arr)) error stop
if (j /= lp_j) error stop
! { dg-final { scan-tree-dump-times "for \\(a3\\.\[0-9\]+ = 1; a3\\.\[0-9\]+ <= 10; a3\\.\[0-9\]+ = a3\\.\[0-9\]+ \\+ 1\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "for \\(j = 1; j <= a3\\.\[0-9\]+ \\* 2 \\+ -1; j = j \\+ 1\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "\\*\\*a3 = a3\\.\[0-9\]+;" 1 "original" } }
arr = 44
a3 = 99; j = 99
!$omp simd collapse(2) lastprivate(a3,j)
do a3 = 1, 10
do j = 1, a3*2-1
arr(j, a3) = j + 100 * a3
end do
end do
if (any (ref /= arr)) error stop
if (a3 /= lp_i .or. j /= lp_j) error stop
! { dg-final { scan-tree-dump-times "for \\(a4\\.\[0-9\]+ = 1; a4\\.\[0-9\]+ <= 10; a4\\.\[0-9\]+ = a4\\.\[0-9\]+ \\+ 1\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "for \\(j = 1; j <= a4\\.\[0-9\]+ \\* 2 \\+ -1; j = j \\+ 1\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "\\*\\*a4 = a4\\.\[0-9\]+;" 1 "original" } }
arr = 44
a4 = 99; j = 99
!$omp simd collapse(2) lastprivate(a4,j)
do a4 = 1, 10
do j = 1, a4*2-1
arr(j, a4) = j + 100 * a4
end do
end do
if (any (ref /= arr)) error stop
if (a4 /= lp_i .or. j /= lp_j) error stop
! { dg-final { scan-tree-dump-times "for \\(a5 = 1; a5 <= 10; a5 = a5 \\+ 1\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "for \\(j = 1; j <= a5 \\* 2 \\+ -1; j = j \\+ 1\\)" 1 "original" } }
! -> no temp var
arr = 44
a5 = 99; j = 99
!$omp simd collapse(2) lastprivate(a5,j)
do a5 = 1, 10
do j = 1, a5*2-1
arr(j, a5) = j + 100 * a5
end do
end do
if (any (ref /= arr)) error stop
if (a5 /= lp_i .or. j /= lp_j) error stop
! { dg-final { scan-tree-dump-times "for \\(a6\\.\[0-9\]+ = 1; a6\\.\[0-9\]+ <= 10; a6\\.\[0-9\]+ = a6\\.\[0-9\]+ \\+ 1\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "for \\(j = 1; j <= a6\\.\[0-9\]+ \\* 2 \\+ -1; j = j \\+ 1\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "\\*a6 = a6\\.\[0-9\]+;" 1 "original" } }
arr = 44
a6 = 99; j = 99
! no last private for 'a6' as "The initial status of a private pointer is undefined."
!$omp simd collapse(2) lastprivate(j)
do a6 = 1, 10
do j = 1, a6*2-1
arr(j, a6) = j + 100 * a6
end do
end do
if (any (ref /= arr)) error stop
if (j /= lp_j) error stop
! { dg-final { scan-tree-dump-times "for \\(a7\\.\[0-9\]+ = 1; a7\\.\[0-9\]+ <= 10; a7\\.\[0-9\]+ = a7\\.\[0-9\]+ \\+ 1\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "for \\(j = 1; j <= a7\\.\[0-9\]+ \\* 2 \\+ -1; j = j \\+ 1\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "\\*a7 = a7\\.\[0-9\]+;" 1 "original" } }
arr = 44
a7 = 99; j = 99
!$omp simd collapse(2) lastprivate(a7,j)
do a7 = 1, 10
do j = 1, a7*2-1
arr(j, a7) = j + 100 * a7
end do
end do
if (any (ref /= arr)) error stop
if (a7 /= lp_i .or. j /= lp_j) error stop
deallocate(a6, a7)
end
end module m
use m
implicit none
integer :: av
integer :: avo
integer :: a0
integer :: a0o
integer, pointer :: a1
integer, pointer :: a2
integer, allocatable :: a3
integer, allocatable :: a4
av = -99; avo = -99
allocate(a1,a2,a3,a4)
call foo (av, avo, a0, a0o, a1, a2, a3, a4)
deallocate(a1,a2,a3,a4)
end

28
libgomp/testsuite/libgomp.fortran/non-rectangular-loop-5.f90 Normal file
View file

@ -0,0 +1,28 @@
! { dg-do compile }
! { dg-additional-options "-msse2" { target sse2_runtime } }
! { dg-additional-options "-mavx" { target avx_runtime } }
! PR fortran/107424
! Nonrectangular loop nests checks
!$omp simd collapse(2)
do i = 1, 10
do j = i, 10, 2 ! { dg-message "sorry, unimplemented: non-rectangular loop nest with step other than constant 1 or -1 for 'j'" }
end do
end do
!$omp do collapse(2) lastprivate(j) ! { dg-error "lastprivate variable 'j' is private in outer context" }
do i = 1, 10
do j = i, 10, 2 ! { dg-message "sorry, unimplemented: non-rectangular loop nest with step other than constant 1 or -1 for 'j'" }
end do
end do
if (i /= 11) stop 1
!$omp simd collapse(2) lastprivate(j)
do i = 1, 10
do j = i, 10, 2 ! { dg-message "sorry, unimplemented: non-rectangular loop nest with step other than constant 1 or -1 for 'j'" }
end do
end do
if (i /= 11) stop 1
end