Fortran/OpenMP: Fix handling of strictly structured blocks For strictly structured blocks, a BLOCK was created but the code was placed after the block the outer structured block. Additionally, labelled blocks were mishandled. As the code is now properly in a BLOCK, it solves additional issues. gcc/fortran/ChangeLog: * parse.cc (parse_omp_structured_block): Make the user code end up inside of BLOCK construct for strictly structured blocks; fix fallout for 'section' and 'teams'. * openmp.cc (resolve_omp_target): Fix changed BLOCK handling for teams in target checking. libgomp/ChangeLog: * testsuite/libgomp.fortran/strictly-structured-block-1.f90: New test. gcc/testsuite/ChangeLog: * gfortran.dg/block_17.f90: New test. * gfortran.dg/gomp/strictly-structured-block-5.f90: New test. gcc/fortran/openmp.cc | 2 + gcc/fortran/parse.cc | 22 +++++-- gcc/testsuite/gfortran.dg/block_17.f90 | 9 +++ .../gomp/strictly-structured-block-5.f90 | 77 ++++++++++++++++++++++ .../strictly-structured-block-1.f90 | 22 +++++++ 5 files changed, 127 insertions(+), 5 deletions(-) diff --git a/gcc/fortran/openmp.cc b/gcc/fortran/openmp.cc index dc0c8013c3d..79b5ae0e4bd 100644 --- a/gcc/fortran/openmp.cc +++ b/gcc/fortran/openmp.cc @@ -11245,6 +11245,8 @@ resolve_omp_target (gfc_code *code) if (!code->ext.omp_clauses->contains_teams_construct) return; gfc_code *c = code->block->next; + if (c->op == EXEC_BLOCK) + c = c->ext.block.ns->code; if (code->ext.omp_clauses->target_first_st_is_teams && ((GFC_IS_TEAMS_CONSTRUCT (c->op) && c->next == NULL) || (c->op == EXEC_BLOCK diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc index 58386805ffe..444baf42cbd 100644 --- a/gcc/fortran/parse.cc +++ b/gcc/fortran/parse.cc @@ -5814,7 +5814,7 @@ parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only) { gfc_statement st, omp_end_st, first_st; gfc_code *cp, *np; - gfc_state_data s; + gfc_state_data s, s2; accept_statement (omp_st); @@ -5915,13 +5915,21 @@ parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only) gfc_notify_std (GFC_STD_F2008, "BLOCK construct at %C"); my_ns = gfc_build_block_ns (gfc_current_ns); - gfc_current_ns = my_ns; - my_parent = my_ns->parent; - new_st.op = EXEC_BLOCK; new_st.ext.block.ns = my_ns; new_st.ext.block.assoc = NULL; accept_statement (ST_BLOCK); + + push_state (&s2, COMP_BLOCK, my_ns->proc_name); + gfc_current_ns = my_ns; + my_parent = my_ns->parent; + if (omp_st == ST_OMP_SECTIONS + || omp_st == ST_OMP_PARALLEL_SECTIONS) + { + np = new_level (cp); + np->op = cp->op; + } + first_st = next_statement (); st = parse_spec (first_st); } @@ -5937,6 +5945,8 @@ parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only) case ST_OMP_TEAMS_LOOP: { gfc_state_data *stk = gfc_state_stack->previous; + if (stk->state == COMP_OMP_STRICTLY_STRUCTURED_BLOCK) + stk = stk->previous; stk->tail->ext.omp_clauses->target_first_st_is_teams = true; break; } @@ -6035,8 +6045,10 @@ parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only) else if (block_construct && st == ST_END_BLOCK) { accept_statement (st); + gfc_current_ns->code = gfc_state_stack->head; gfc_current_ns = my_parent; - pop_state (); + pop_state (); /* Inner BLOCK */ + pop_state (); /* Outer COMP_OMP_STRICTLY_STRUCTURED_BLOCK */ st = next_statement (); if (st == omp_end_st) diff --git a/gcc/testsuite/gfortran.dg/block_17.f90 b/gcc/testsuite/gfortran.dg/block_17.f90 new file mode 100644 index 00000000000..6ab3106ebd0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/block_17.f90 @@ -0,0 +1,9 @@ +subroutine foo() + block + end block +end + +subroutine bar() + my_name: block + end block my_name +end diff --git a/gcc/testsuite/gfortran.dg/gomp/strictly-structured-block-5.f90 b/gcc/testsuite/gfortran.dg/gomp/strictly-structured-block-5.f90 new file mode 100644 index 00000000000..79cb9207180 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/strictly-structured-block-5.f90 @@ -0,0 +1,77 @@ +subroutine f() + !$omp parallel + block + end block + + !$omp parallel + block + inner: block + block + end block + end block inner + end block +end + +subroutine f2() + !$omp parallel + my_name : block + end block my_name + + !$omp parallel + another_block : block + inner: block + block + end block + end block inner + end block another_block +end + +subroutine f3() + !$omp parallel + my_name : block + end block my_name2 ! { dg-error "Expected label 'my_name' for END BLOCK statement" } + end block my_name ! avoid follow up errors +end subroutine + +subroutine f4 + integer :: n + n = 5 + !$omp parallel + my: block + integer :: A(n) + A(1) = 1 + end block my +end + +subroutine f4a + intrinsic :: sin + !$omp parallel + block + procedure(), pointer :: proc + procedure(sin) :: my_sin + proc => sin + end block +end subroutine + +subroutine f5(x) + !$omp parallel + block + intent(in) :: x ! { dg-error "INTENT is not allowed inside of BLOCK" } + optional :: x ! { dg-error "OPTIONAL is not allowed inside of BLOCK" } + value :: x ! { dg-error "VALUE is not allowed inside of BLOCK" } + end block +end + +subroutine f6() + !$omp parallel + myblock: block + cycle myblock ! { dg-error "CYCLE statement at .1. is not applicable to non-loop construct 'myblock'" } + end block myblock + + !$omp parallel + myblock2: block + exit myblock2 ! OK. + ! jumps to the end of the block but stays in the structured block + end block myblock2 + !$omp end parallel +end diff --git a/libgomp/testsuite/libgomp.fortran/strictly-structured-block-1.f90 b/libgomp/testsuite/libgomp.fortran/strictly-structured-block-1.f90 new file mode 100644 index 00000000000..8e7f6c8b9d3 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/strictly-structured-block-1.f90 @@ -0,0 +1,22 @@ +subroutine one + implicit none (external, type) + integer :: i, j + i = 5 + j = 6 + !$omp parallel + my_block : block + !$omp atomic write + i = 7 + exit my_block + + !$omp atomic write + j = 99 ! Should be unreachable + + ! exit should jump here - end of block but inside of it. + end block my_block + if (i /= 7) stop 1 + if (j /= 6) stop 2 +end + + call one +end