Fortran/OpenMP: Fix handling of strictly structured blocks
Checks
Commit Message
Strictly structured blocks are '!$omp <some directive>' directly
followed by 'BLOCK ... END BLOCK', i.e. a Fortran block construct.
I did run into this issue because 'integer :: n; n = 5; !$omp ...;
block; integer :: A(n)' was not accepted.
Well, it turned out that was because the BLOCK handling was not quite right.
In an unrelated patch, I got an ICE for an empty labelled BLOCK - but
only without -fopenmp. I was not quite sure that we had a testcase for
it - my 'grep' attempt did not find one but we use plenty of BLOCK.
Hence, I added another BLOCK testcase.
Comments, remarks, suggestions?
If not, I will later commit it.
Tobias
-----------------
Siemens Electronic Design Automation GmbH; Anschrift: Arnulfstraße 201, 80634 München; Gesellschaft mit beschränkter Haftung; Geschäftsführer: Thomas Heurung, Frank Thürauf; Sitz der Gesellschaft: München; Registergericht München, HRB 106955
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(-)
@@ -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
@@ -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)
new file mode 100644
@@ -0,0 +1,9 @@
+subroutine foo()
+ block
+ end block
+end
+
+subroutine bar()
+ my_name: block
+ end block my_name
+end
new file mode 100644
@@ -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
new file mode 100644
@@ -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