OpenMP/Fortran: Partially fix non-rect loop nests [PR107424] 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. gcc/fortran/trans-openmp.cc | 241 ++++++-- .../goacc/privatization-1-compute-loop.f90 | 6 +- .../goacc/privatization-1-routine_gang-loop.f90 | 3 +- .../libgomp.fortran/non-rectangular-loop-1.f90 | 668 +++++++++++++++++++++ .../libgomp.fortran/non-rectangular-loop-1a.f90 | 374 ++++++++++++ .../libgomp.fortran/non-rectangular-loop-2.f90 | 243 ++++++++ .../libgomp.fortran/non-rectangular-loop-3.f90 | 212 +++++++ .../libgomp.fortran/non-rectangular-loop-4.f90 | 215 +++++++ .../libgomp.fortran/non-rectangular-loop-5.f90 | 28 + 9 files changed, 1941 insertions(+), 49 deletions(-) diff --git a/gcc/fortran/trans-openmp.cc b/gcc/fortran/trans-openmp.cc index 5283d0ce5f3..2d16f3be8ea 100644 --- a/gcc/fortran/trans-openmp.cc +++ b/gcc/fortran/trans-openmp.cc @@ -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 *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_conv_expr_val (&se, code->ext.iterator->step); gfc_add_block_to_block (pblock, &se.pre); - from = gfc_evaluate_now (se.expr, pblock); + step = 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); + if (integer_onep (step)) + simple = 1; + else if (tree_int_cst_equal (step, integer_minus_one_node)) + simple = -1; 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; + 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)) + { + 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); + } + from = se.expr; - /* Special case simple loops. */ - if (VAR_P (dovar)) + 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)) { - 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->end); + gfc_add_block_to_block (pblock, &se.pre); + if (!DECL_P (se.expr)) + se.expr = gfc_evaluate_now (se.expr, pblock); } - else + 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); } diff --git a/gcc/testsuite/gfortran.dg/goacc/privatization-1-compute-loop.f90 b/gcc/testsuite/gfortran.dg/goacc/privatization-1-compute-loop.f90 index 13772c185ce..ad5e11abf91 100644 --- a/gcc/testsuite/gfortran.dg/goacc/privatization-1-compute-loop.f90 +++ b/gcc/testsuite/gfortran.dg/goacc/privatization-1-compute-loop.f90 @@ -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 } diff --git a/gcc/testsuite/gfortran.dg/goacc/privatization-1-routine_gang-loop.f90 b/gcc/testsuite/gfortran.dg/goacc/privatization-1-routine_gang-loop.f90 index 6878d856919..c5c2f2b9845 100644 --- a/gcc/testsuite/gfortran.dg/goacc/privatization-1-routine_gang-loop.f90 +++ b/gcc/testsuite/gfortran.dg/goacc/privatization-1-routine_gang-loop.f90 @@ -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 } diff --git a/libgomp/testsuite/libgomp.fortran/non-rectangular-loop-1.f90 b/libgomp/testsuite/libgomp.fortran/non-rectangular-loop-1.f90 new file mode 100644 index 00000000000..dbbd18a1444 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/non-rectangular-loop-1.f90 @@ -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 diff --git a/libgomp/testsuite/libgomp.fortran/non-rectangular-loop-1a.f90 b/libgomp/testsuite/libgomp.fortran/non-rectangular-loop-1a.f90 new file mode 100644 index 00000000000..77aa887942e --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/non-rectangular-loop-1a.f90 @@ -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 diff --git a/libgomp/testsuite/libgomp.fortran/non-rectangular-loop-2.f90 b/libgomp/testsuite/libgomp.fortran/non-rectangular-loop-2.f90 new file mode 100644 index 00000000000..0cea61e5f0d --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/non-rectangular-loop-2.f90 @@ -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 diff --git a/libgomp/testsuite/libgomp.fortran/non-rectangular-loop-3.f90 b/libgomp/testsuite/libgomp.fortran/non-rectangular-loop-3.f90 new file mode 100644 index 00000000000..c97cd99f71c --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/non-rectangular-loop-3.f90 @@ -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 diff --git a/libgomp/testsuite/libgomp.fortran/non-rectangular-loop-4.f90 b/libgomp/testsuite/libgomp.fortran/non-rectangular-loop-4.f90 new file mode 100644 index 00000000000..ef2bd61f180 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/non-rectangular-loop-4.f90 @@ -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 diff --git a/libgomp/testsuite/libgomp.fortran/non-rectangular-loop-5.f90 b/libgomp/testsuite/libgomp.fortran/non-rectangular-loop-5.f90 new file mode 100644 index 00000000000..643ab796a84 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/non-rectangular-loop-5.f90 @@ -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