@@ -4858,10 +4858,14 @@ gfc_trans_omp_teams (gfc_code *code, gfc
gfc_split_omp_clauses (code, clausesa);
}
if (flag_openmp)
- omp_clauses
- = chainon (omp_clauses,
- gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_TEAMS],
- code->loc));
+ {
+ omp_clauses
+ = chainon (omp_clauses,
+ gfc_trans_omp_clauses (&block,
+ &clausesa[GFC_OMP_SPLIT_TEAMS],
+ code->loc));
+ pushlevel ();
+ }
switch (code->op)
{
case EXEC_OMP_TARGET_TEAMS:
@@ -4881,6 +4885,7 @@ gfc_trans_omp_teams (gfc_code *code, gfc
}
if (flag_openmp)
{
+ stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
stmt = build2_loc (input_location, OMP_TEAMS, void_type_node, stmt,
omp_clauses);
if (combined)
@@ -0,0 +1,8 @@
+! PR fortran/92756
+
+program pr92756
+ integer :: i
+ !$omp teams distribute parallel do
+ do i = 1, 64
+ end do
+end
@@ -0,0 +1,19 @@
+program teams1
+ use omp_lib
+!$omp teams thread_limit (2)
+ if (omp_in_parallel ()) stop 1
+ if (omp_get_level () .ne. 0) stop 2
+ if (omp_get_ancestor_thread_num (0) .ne. 0) stop 3
+ if (omp_get_ancestor_thread_num (1) .ne. -1) stop 4
+ call omp_set_dynamic (.false.)
+ call omp_set_nested (.true.)
+!$omp parallel num_threads (2)
+ if (.not. omp_in_parallel ()) stop 5
+ if (omp_get_level () .ne. 1) stop 6
+ if (omp_get_ancestor_thread_num (0) .ne. 0) stop 7
+ if (omp_get_ancestor_thread_num (1) &
+& .ne. omp_get_thread_num ()) stop 8
+ if (omp_get_ancestor_thread_num (2) .ne. -1) stop 9
+!$omp end parallel
+!$omp end teams
+end program
@@ -0,0 +1,140 @@
+program teams2
+ use omp_lib
+ integer :: i, j, err
+ err = 0
+!$omp teams reduction(+:err)
+ err = err + bar (0, 0, 0)
+!$omp end teams
+ if (err .ne. 0) stop 1
+!$omp teams reduction(+:err)
+ err = err + bar (1, 0, 0)
+!$omp end teams
+ if (err .ne. 0) stop 2
+!$omp teams reduction(+:err)
+!$omp distribute
+ do i = 0, 63
+ err = err + bar (2, i, 0)
+ end do
+!$omp end teams
+ if (err .ne. 0) stop 3
+!$omp teams reduction(+:err)
+!$omp distribute
+ do i = 0, 63
+!$omp parallel do reduction(+:err)
+ do j = 0, 31
+ err = err + bar (3, i, j)
+ end do
+ end do
+!$omp end teams
+ if (err .ne. 0) stop 4
+contains
+ subroutine foo (x, y, z, a, b)
+ integer :: x, y, z, a, b(64), i, j
+ if (x .eq. 0) then
+ do i = 0, 63
+!$omp parallel do shared (a, b)
+ do j = 0, 31
+ call foo (3, i, j, a, b)
+ end do
+ end do
+ else if (x .eq. 1) then
+!$omp distribute dist_schedule (static, 1)
+ do i = 0, 63
+!$omp parallel do shared (a, b)
+ do j = 0, 31
+ call foo (3, i, j, a, b)
+ end do
+ end do
+ else if (x .eq. 2) then
+!$omp parallel do shared (a, b)
+ do j = 0, 31
+ call foo (3, y, j, a, b)
+ end do
+ else
+!$omp atomic
+ b(y + 1) = b(y + 1) + z
+!$omp end atomic
+!$omp atomic
+ a = a + 1
+!$omp end atomic
+ end if
+ end subroutine
+
+ integer function bar (x, y, z)
+ use omp_lib
+ integer :: x, y, z, a, b(64), i, c, d, e, f
+ a = 8
+ do i = 0, 63
+ b(i + 1) = i
+ end do
+ call foo (x, y, z, a, b)
+ if (x .eq. 0) then
+ if (a .ne. 8 + 64 * 32) then
+ bar = 1
+ return
+ end if
+ do i = 0, 63
+ if (b(i + 1) .ne. i + 31 * 32 / 2) then
+ bar = 1
+ return
+ end if
+ end do
+ else if (x .eq. 1) then
+ c = omp_get_num_teams ()
+ d = omp_get_team_num ()
+ e = d
+ f = 0
+ do i = 0, 63
+ if (i .eq. e) then
+ if (b(i + 1) .ne. i + 31 * 32 / 2) then
+ bar = 1
+ return
+ end if
+ f = f + 1
+ e = e + c
+ else if (b(i + 1) .ne. i) then
+ bar = 1
+ return
+ end if
+ end do
+ if (a .lt. 8 .or. a > 8 + f * 32) then
+ bar = 1
+ return
+ end if
+ else if (x .eq. 2) then
+ if (a .ne. 8 + 32) then
+ bar = 1
+ return
+ end if
+ do i = 0, 63
+ if (i .eq. y) then
+ c = 31 * 32 / 2
+ else
+ c = 0
+ end if
+ if (b(i + 1) .ne. i + c) then
+ bar = 1
+ return
+ end if
+ end do
+ else if (x .eq. 3) then
+ if (a .ne. 8 + 1) then
+ bar = 1
+ return
+ end if
+ do i = 0, 63
+ if (i .eq. y) then
+ c = z
+ else
+ c = 0
+ end if
+ if (b (i + 1) .ne. i + c) then
+ bar = 1
+ return
+ end if
+ end do
+ end if
+ bar = 0
+ return
+ end function
+end program
Hi! In OpenMP 4.5, the gomp/teams1.f90 code was invalid and diagnosed in the middle-end. In OpenMP 5.0, it is valid and the diagnostics in the middle-end has been removed, but the Fortran side hasn't been adjusted and so the middle-end ICEs on it. The following patch just does the minimal FE changes needed so that it works, plus includes libgomp.c/teams-{1,2}.c testcases ported from C to Fortran. Bootstrapped/regtested on x86_64-linux and i686-linux, committed to trunk. For GCC 9, I think it might be better to conditionally (for Fortran only) restore the diagnostics in the middle-end. 2019-12-04 Jakub Jelinek <jakub@redhat.com> PR fortran/92756 * trans-openmp.c (gfc_trans_omp_teams): Wrap OMP_TEAMS body into a BIND_EXPR with a forced BLOCK. * gfortran.dg/gomp/teams1.f90: New test. * testsuite/libgomp.fortran/teams1.f90: New test. * testsuite/libgomp.fortran/teams2.f90: New test. Jakub