This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[gortran, PATCH] Fix PR 18937
- From: Tobias Schlüter <tobias dot schlueter at physik dot uni-muenchen dot de>
- To: Fortran List <fortran at gcc dot gnu dot org>, gcc-patches <gcc-patches at gcc dot gnu dot org>, stevenb dot gcc at gmail dot com
- Date: Sun, 25 Mar 2007 23:36:51 +0200
- Subject: [gortran, PATCH] Fix PR 18937
Hi,
this patch fixes the quadratic bottleneck in the resolution of branches
by essentially doing what Steven Bosscher suggested in PR18540: for
every block keep track of the branch targets allowed within, merging
them as one descends through to the innermost blocks. The data
structure employed for this purpose is chosen to be a bitmap, which is
allocated of an obstack which is thrown away once the code unit is resolved.
Of course, life is not as simple as one would hope: in order to
determine if a branch is valid we have to know if the branch target is
an END {DO,SELECT,IF} statement (can someone point me to the relevant
quote in the standard, I couldn't seem to find it. I just recreated
what the code -- I believe unsuccessfully -- attempted to do before).
Since we don't store explicit pointer to these, and they're outside the
block for IF and SELECT blocks, but inside for DO, I had to go through a
few contortions, but the final result is somewhat satisfying: since one
has to iterate through each block to find all labels, it comes at no
additional cost to also record the last statement in the block. When
resolving a branch we now go up the code_stack and look at the last
statement of each block, checking if it's the branch target and the
EXEC_NOP corresponding to an END* statement with a label. The code then
calls gfc_notify_std as appropriate.
Built and tested on i386-darwin. Ok for the mainline?
- Tobi
:ADDPATCH fortran:
2007-03-25 Tobias Schlüter <tobi@gcc.gnu.org>
PR fortran/18937
fortran/
* resolve.c: Include obstack.h and bitmap.h. New variable
labels_obstack.
(code_stack): Add tail and reachable_labels fields.
(reachable_labels): New function.
(resolve_branch): Rework to use new fields in code_stack.
(resolve_code): Call reachable_labels.
(resolve_codes): Allocate and free labels_obstack.
testsuite/
* gfortran.dg/goto_2.f90: New.
* gfortran.dg/pr17708.f90: Rename to ...
* gfortran.dg/goto_3.f90: ... this, add comment pointing to PR.
Index: fortran/resolve.c
===================================================================
*** fortran/resolve.c (revision 123197)
--- fortran/resolve.c (working copy)
*************** Software Foundation, 51 Franklin Street,
*** 24,29 ****
--- 24,31 ----
#include "system.h"
#include "flags.h"
#include "gfortran.h"
+ #include "obstack.h"
+ #include "bitmap.h"
#include "arith.h" /* For gfc_compare_expr(). */
#include "dependency.h"
*************** typedef enum seq_type
*** 35,47 ****
}
seq_type;
! /* Stack to push the current if we descend into a block during
! resolution. See resolve_branch() and resolve_code(). */
typedef struct code_stack
{
! struct gfc_code *head, *current;
struct code_stack *prev;
}
code_stack;
--- 37,53 ----
}
seq_type;
! /* Stack to keep track of the nesting of blocks as we move through the
! code. See resolve_branch() and resolve_code(). */
typedef struct code_stack
{
! struct gfc_code *head, *current, *tail;
struct code_stack *prev;
+
+ /* This bitmap keeps track of the targets valid for a branch from
+ inside this block. */
+ bitmap reachable_labels;
}
code_stack;
*************** static int specification_expr = 0;
*** 66,71 ****
--- 72,80 ----
/* The id of the last entry seen. */
static int current_entry_id;
+ /* We use bitmaps to determine if a branch target is valid. */
+ static bitmap_obstack labels_obstack;
+
int
gfc_is_formal_arg (void)
{
*************** resolve_transfer (gfc_code *code)
*** 4395,4427 ****
/*********** Toplevel code resolution subroutines ***********/
/* Given a branch to a label and a namespace, if the branch is conforming.
! The code node described where the branch is located. */
static void
resolve_branch (gfc_st_label *label, gfc_code *code)
{
- gfc_code *block, *found;
code_stack *stack;
- gfc_st_label *lp;
if (label == NULL)
return;
- lp = label;
/* Step one: is this a valid branching target? */
! if (lp->defined == ST_LABEL_UNKNOWN)
{
! gfc_error ("Label %d referenced at %L is never defined", lp->value,
! &lp->where);
return;
}
! if (lp->defined != ST_LABEL_TARGET)
{
gfc_error ("Statement at %L is not a valid branch target statement "
! "for the branch statement at %L", &lp->where, &code->loc);
return;
}
--- 4404,4466 ----
/*********** Toplevel code resolution subroutines ***********/
+ /* Find the set of labels that are reachable from this block. We also
+ record the last statement in each block so that we don't have to do
+ a linear search to find the END DO statements of the blocks. */
+
+ static void
+ reachable_labels (gfc_code *block)
+ {
+ gfc_code *c;
+
+ if (!block)
+ return;
+
+ cs_base->reachable_labels = bitmap_obstack_alloc (&labels_obstack);
+
+ /* Collect labels in this block. */
+ for (c = block; c; c = c->next)
+ {
+ if (c->here)
+ bitmap_set_bit (cs_base->reachable_labels, c->here->value);
+
+ if (!c->next && cs_base->prev)
+ cs_base->prev->tail = c;
+ }
+
+ /* Merge with labels from parent block. */
+ if (cs_base->prev)
+ {
+ gcc_assert (cs_base->prev->reachable_labels);
+ bitmap_ior_into (cs_base->reachable_labels,
+ cs_base->prev->reachable_labels);
+ }
+ }
+
/* Given a branch to a label and a namespace, if the branch is conforming.
! The code node describes where the branch is located. */
static void
resolve_branch (gfc_st_label *label, gfc_code *code)
{
code_stack *stack;
if (label == NULL)
return;
/* Step one: is this a valid branching target? */
! if (label->defined == ST_LABEL_UNKNOWN)
{
! gfc_error ("Label %d referenced at %L is never defined", label->value,
! &label->where);
return;
}
! if (label->defined != ST_LABEL_TARGET)
{
gfc_error ("Statement at %L is not a valid branch target statement "
! "for the branch statement at %L", &label->where, &code->loc);
return;
}
*************** resolve_branch (gfc_st_label *label, gfc
*** 4433,4484 ****
return;
}
! /* Step three: Try to find the label in the parse tree. To do this,
! we traverse the tree block-by-block: first the block that
! contains this GOTO, then the block that it is nested in, etc. We
! can ignore other blocks because branching into another block is
! not allowed. */
!
! found = NULL;
!
! for (stack = cs_base; stack; stack = stack->prev)
! {
! for (block = stack->head; block; block = block->next)
! {
! if (block->here == label)
! {
! found = block;
! break;
! }
! }
!
! if (found)
! break;
! }
! if (found == NULL)
{
/* The label is not in an enclosing block, so illegal. This was
! allowed in Fortran 66, so we allow it as extension. We also
! forego further checks if we run into this. */
gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
! "as the GOTO statement at %L", &lp->where, &code->loc);
return;
}
/* Step four: Make sure that the branching target is legal if
! the statement is an END {SELECT,DO,IF}. */
! if (found->op == EXEC_NOP)
! {
! for (stack = cs_base; stack; stack = stack->prev)
! if (stack->current->next == found)
! break;
! if (stack == NULL)
! gfc_notify_std (GFC_STD_F95_DEL, "Obsolete: GOTO at %L jumps to END "
! "of construct at %L", &code->loc, &found->loc);
}
}
--- 4472,4521 ----
return;
}
! /* Step three: See if the label is in the same block as the
! branching statement. The hard work has been done by setting up
! the bitmap reachable_labels. */
! if (!bitmap_bit_p (cs_base->reachable_labels, label->value))
{
/* The label is not in an enclosing block, so illegal. This was
! allowed in Fortran 66, so we allow it as extension. No
! further checks are necessary in this case. */
gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
! "as the GOTO statement at %L", &label->where,
! &code->loc);
return;
}
/* Step four: Make sure that the branching target is legal if
! the statement is an END {SELECT,IF}. */
! for (stack = cs_base; stack; stack = stack->prev)
! if (stack->current->next && stack->current->next->here == label)
! break;
! if (stack && stack->current->next->op == EXEC_NOP)
! {
! gfc_notify_std (GFC_STD_F95_DEL, "Obsolete: GOTO at %L jumps to "
! "END of construct at %L", &code->loc,
! &stack->current->next->loc);
! return; /* We know this is not an END DO. */
}
+
+ /* Step five: Make sure that we're not jumping to the end of a DO
+ loop from within the loop. */
+
+ for (stack = cs_base; stack; stack = stack->prev)
+ if ((stack->current->op == EXEC_DO
+ || stack->current->op == EXEC_DO_WHILE)
+ && stack->tail->here == label && stack->tail->op == EXEC_NOP)
+ {
+ gfc_notify_std (GFC_STD_F95_DEL, "Obsolete: GOTO at %L jumps "
+ "to END of construct at %L", &code->loc,
+ &stack->tail->loc);
+ return;
+
+ }
}
*************** resolve_code (gfc_code *code, gfc_namesp
*** 5004,5009 ****
--- 5041,5048 ----
frame.head = code;
cs_base = &frame;
+ reachable_labels (code);
+
for (; code; code = code->next)
{
frame.current = code;
*************** resolve_codes (gfc_namespace *ns)
*** 7322,7328 ****
--- 7361,7370 ----
cs_base = NULL;
/* Set to an out of range value. */
current_entry_id = -1;
+
+ bitmap_obstack_initialize (&labels_obstack);
resolve_code (ns->code, ns);
+ bitmap_obstack_release (&labels_obstack);
}
Index: testsuite/gfortran.dg/goto_2.f90
===================================================================
*** testsuite/gfortran.dg/goto_2.f90 (revision 0)
--- testsuite/gfortran.dg/goto_2.f90 (revision 0)
***************
*** 0 ****
--- 1,59 ----
+ ! { dg-do run }
+ ! Checks for corrects warnings if branching to then end of a
+ ! construct at various nesting levels
+ subroutine check_if(i)
+ goto 10
+ if (i > 0) goto 40
+ if (i < 0) then
+ goto 40
+ 10 end if
+ if (i == 0) then
+ i = i+1
+ goto 20 ! { dg-warning "jumps to END of construct" }
+ goto 40
+ 20 end if ! { dg-warning "jumps to END of construct" }
+ if (i == 1) then
+ i = i+1
+ if (i == 2) then
+ goto 30 ! { dg-warning "jumps to END of construct" }
+ end if
+ goto 40
+ 30 end if ! { dg-warning "jumps to END of construct" }
+ return
+ 40 i = -1
+ end subroutine check_if
+
+ subroutine check_select(i)
+ goto 10
+ select case (i)
+ case default
+ goto 999
+ 10 end select
+ select case (i)
+ case (2)
+ i = 1
+ goto 20 ! { dg-warning "jumps to END of construct" }
+ goto 999
+ case default
+ goto 999
+ 20 end select ! { dg-warning "jumps to END of construct" }
+ j = i
+ select case (j)
+ case default
+ select case (i)
+ case (1)
+ i = 2
+ goto 30 ! { dg-warning "jumps to END of construct" }
+ end select
+ goto 999
+ 30 end select ! { dg-warning "jumps to END of construct" }
+ return
+ 999 i = -1
+ end subroutine check_select
+
+ i = 0
+ call check_if (i)
+ if (i /= 2) call abort ()
+ call check_select (i)
+ if (i /= 2) call abort ()
+ end
Index: testsuite/gfortran.dg/pr17708.f90
===================================================================
*** testsuite/gfortran.dg/pr17708.f90 (revision 123197)
--- testsuite/gfortran.dg/pr17708.f90 (working copy)
***************
*** 1,4 ****
--- 1,5 ----
! { dg-do run }
+ ! PR 17708: Jumping to END DO statements didn't do the right thing
program test
j = 0
do 10 i=1,3