* [patch, fortran] Fix for PR 47676
@ 2014-12-30 10:21 Thomas Koenig
2015-01-05 11:52 ` *ping* " Thomas Koenig
2015-01-05 18:55 ` H.J. Lu
0 siblings, 2 replies; 5+ messages in thread
From: Thomas Koenig @ 2014-12-30 10:21 UTC (permalink / raw)
To: fortran, gcc-patches
[-- Attachment #1: Type: text/plain, Size: 1633 bytes --]
Hello world,
this patch fixes the long-standing bug. A missing temporary
causes an invalid read in realloc_on_assign_5.f03 which
only becomes noticable when setting MALLOC_CHECK_ or when
using valgrind. The bug has three duplicates in the
data base, so people keep stumbling across this.
I have to confess I could not find the right way to put
this into the normal dependency code; the assumption that
the string copying will "do the right thing" is too deeply
embedded in the code, or I have been looking at the wrong places.
So I took the approach of using the big hammer of a frontend
pass to fix this up.
I would definitely like to see this bug fixed for 5.0. If anybody
has a better idea on how to tackle this in a timely manner, please
let me know.
Otherwise, OK for trunk? What about the other branches?
Regression-tested.
2014-12-29 Thomas Koenig <tkoenig@gcc.gnu.org>
PR fortran/47674
* dependency.c (gfc_discard_nops): Add prototype.
* dependency.c (discard_nops): Rename to gfc_discard_nops,
make non-static.
(gfc_discard_nops): Use gfc_discard_nops.
(gfc_dep_difference): Likewise.
* frontend-passes.c (realloc_strings): New function.
Add prototype.
(gfc_run_passes): Call realloc_strings.
(realloc_string_callback): New function.
(create_var): Add prototype. Handle case of a
scalar character variable.
(optimize_trim): Do not handle allocatable variables.
2014-12-29 Thomas Koenig <tkoenig@gcc.gnu.org>
PR fortran/47674
* gfortran.dg/realloc_on_assign_25.f90: New test.
[-- Attachment #2: p5.diff --]
[-- Type: text/x-patch, Size: 10283 bytes --]
Index: dependency.c
===================================================================
--- dependency.c (Revision 219011)
+++ dependency.c (Arbeitskopie)
@@ -243,8 +243,8 @@ gfc_dep_compare_functions (gfc_expr *e1, gfc_expr
/* Helper function to look through parens, unary plus and widening
integer conversions. */
-static gfc_expr*
-discard_nops (gfc_expr *e)
+gfc_expr *
+gfc_discard_nops (gfc_expr *e)
{
gfc_actual_arglist *arglist;
@@ -297,8 +297,8 @@ gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2)
if (e1 == NULL && e2 == NULL)
return 0;
- e1 = discard_nops (e1);
- e2 = discard_nops (e2);
+ e1 = gfc_discard_nops (e1);
+ e2 = gfc_discard_nops (e2);
if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_PLUS)
{
@@ -515,8 +515,8 @@ gfc_dep_difference (gfc_expr *e1, gfc_expr *e2, mp
if (e1->ts.type != BT_INTEGER || e2->ts.type != BT_INTEGER)
return false;
- e1 = discard_nops (e1);
- e2 = discard_nops (e2);
+ e1 = gfc_discard_nops (e1);
+ e2 = gfc_discard_nops (e2);
/* Inizialize tentatively, clear if we don't return anything. */
mpz_init (*result);
@@ -531,8 +531,8 @@ gfc_dep_difference (gfc_expr *e1, gfc_expr *e2, mp
if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_PLUS)
{
- e1_op1 = discard_nops (e1->value.op.op1);
- e1_op2 = discard_nops (e1->value.op.op2);
+ e1_op1 = gfc_discard_nops (e1->value.op.op1);
+ e1_op2 = gfc_discard_nops (e1->value.op.op2);
/* Case 2: (X + c1) - X = c1. */
if (e1_op2->expr_type == EXPR_CONSTANT
@@ -552,8 +552,8 @@ gfc_dep_difference (gfc_expr *e1, gfc_expr *e2, mp
if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS)
{
- e2_op1 = discard_nops (e2->value.op.op1);
- e2_op2 = discard_nops (e2->value.op.op2);
+ e2_op1 = gfc_discard_nops (e2->value.op.op1);
+ e2_op2 = gfc_discard_nops (e2->value.op.op2);
if (e1_op2->expr_type == EXPR_CONSTANT)
{
@@ -597,8 +597,8 @@ gfc_dep_difference (gfc_expr *e1, gfc_expr *e2, mp
if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
{
- e2_op1 = discard_nops (e2->value.op.op1);
- e2_op2 = discard_nops (e2->value.op.op2);
+ e2_op1 = gfc_discard_nops (e2->value.op.op1);
+ e2_op2 = gfc_discard_nops (e2->value.op.op2);
if (e1_op2->expr_type == EXPR_CONSTANT)
{
@@ -627,8 +627,8 @@ gfc_dep_difference (gfc_expr *e1, gfc_expr *e2, mp
if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_MINUS)
{
- e1_op1 = discard_nops (e1->value.op.op1);
- e1_op2 = discard_nops (e1->value.op.op2);
+ e1_op1 = gfc_discard_nops (e1->value.op.op1);
+ e1_op2 = gfc_discard_nops (e1->value.op.op2);
if (e1_op2->expr_type == EXPR_CONSTANT)
{
@@ -642,8 +642,8 @@ gfc_dep_difference (gfc_expr *e1, gfc_expr *e2, mp
if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS)
{
- e2_op1 = discard_nops (e2->value.op.op1);
- e2_op2 = discard_nops (e2->value.op.op2);
+ e2_op1 = gfc_discard_nops (e2->value.op.op1);
+ e2_op2 = gfc_discard_nops (e2->value.op.op2);
/* Case 11: (X - c1) - (X + c2) = -( c1 + c2). */
if (e2_op2->expr_type == EXPR_CONSTANT
@@ -668,8 +668,8 @@ gfc_dep_difference (gfc_expr *e1, gfc_expr *e2, mp
if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
{
- e2_op1 = discard_nops (e2->value.op.op1);
- e2_op2 = discard_nops (e2->value.op.op2);
+ e2_op1 = gfc_discard_nops (e2->value.op.op1);
+ e2_op2 = gfc_discard_nops (e2->value.op.op2);
/* Case 13: (X - c1) - (X - c2) = c2 - c1. */
if (e2_op2->expr_type == EXPR_CONSTANT
@@ -685,8 +685,8 @@ gfc_dep_difference (gfc_expr *e1, gfc_expr *e2, mp
{
if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
{
- e2_op1 = discard_nops (e2->value.op.op1);
- e2_op2 = discard_nops (e2->value.op.op2);
+ e2_op1 = gfc_discard_nops (e2->value.op.op1);
+ e2_op2 = gfc_discard_nops (e2->value.op.op2);
/* Case 14: (c1 - X) - (c2 - X) == c1 - c2. */
if (gfc_dep_compare_expr (e1_op2, e2_op2) == 0)
@@ -702,8 +702,8 @@ gfc_dep_difference (gfc_expr *e1, gfc_expr *e2, mp
if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS)
{
- e2_op1 = discard_nops (e2->value.op.op1);
- e2_op2 = discard_nops (e2->value.op.op2);
+ e2_op1 = gfc_discard_nops (e2->value.op.op1);
+ e2_op2 = gfc_discard_nops (e2->value.op.op2);
/* Case 15: X - (X + c2) = -c2. */
if (e2_op2->expr_type == EXPR_CONSTANT
@@ -723,8 +723,8 @@ gfc_dep_difference (gfc_expr *e1, gfc_expr *e2, mp
if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
{
- e2_op1 = discard_nops (e2->value.op.op1);
- e2_op2 = discard_nops (e2->value.op.op2);
+ e2_op1 = gfc_discard_nops (e2->value.op.op1);
+ e2_op2 = gfc_discard_nops (e2->value.op.op2);
/* Case 17: X - (X - c2) = c2. */
if (e2_op2->expr_type == EXPR_CONSTANT
Index: dependency.h
===================================================================
--- dependency.h (Revision 219011)
+++ dependency.h (Arbeitskopie)
@@ -40,3 +40,5 @@ int gfc_expr_is_one (gfc_expr *, int);
int gfc_dep_resolver(gfc_ref *, gfc_ref *, gfc_reverse *);
int gfc_are_equivalenced_arrays (gfc_expr *, gfc_expr *);
+
+gfc_expr * gfc_discard_nops (gfc_expr *);
Index: frontend-passes.c
===================================================================
--- frontend-passes.c (Revision 219011)
+++ frontend-passes.c (Arbeitskopie)
@@ -42,6 +42,8 @@ static bool is_empty_string (gfc_expr *e);
static void doloop_warn (gfc_namespace *);
static void optimize_reduction (gfc_namespace *);
static int callback_reduction (gfc_expr **, int *, void *);
+static void realloc_strings (gfc_namespace *);
+static gfc_expr *create_var (gfc_expr *);
/* How deep we are inside an argument list. */
@@ -113,8 +115,53 @@ gfc_run_passes (gfc_namespace *ns)
expr_array.release ();
}
+
+ if (flag_realloc_lhs)
+ realloc_strings (ns);
}
+/* Callback for each gfc_code node invoked from check_realloc_strings.
+ For an allocatable LHS string which also appears as a variable on
+ the RHS, replace
+
+ a = a(x:y)
+
+ with
+
+ tmp = a(x:y)
+ a = tmp
+ */
+
+static int
+realloc_string_callback (gfc_code **c, int *walk_subtrees,
+ void *data ATTRIBUTE_UNUSED)
+{
+ gfc_expr *expr1, *expr2;
+ gfc_code *co = *c;
+ gfc_expr *n;
+
+ *walk_subtrees = 0;
+ if (co->op != EXEC_ASSIGN)
+ return 0;
+
+ expr1 = co->expr1;
+ if (expr1->ts.type != BT_CHARACTER || expr1->rank != 0
+ || !expr1->symtree->n.sym->attr.allocatable)
+ return 0;
+
+ expr2 = gfc_discard_nops (co->expr2);
+ if (expr2->expr_type != EXPR_VARIABLE)
+ return 0;
+
+ if (!gfc_check_dependency (expr1, expr2, true))
+ return 0;
+
+ current_code = c;
+ n = create_var (expr2);
+ co->expr2 = n;
+ return 0;
+}
+
/* Callback for each gfc_code node invoked through gfc_code_walker
from optimize_namespace. */
@@ -430,7 +477,53 @@ is_fe_temp (gfc_expr *e)
return e->symtree->n.sym->attr.fe_temp;
}
+/* Determine the length of a string, if it can be evaluated as a constant
+ expression. Return a newly allocated gfc_expr or NULL on failure.
+ If the user specified a substring which is potentially longer than
+ the string itself, the string will be padded with spaces, which
+ is harmless. */
+static gfc_expr *
+constant_string_length (gfc_expr *e)
+{
+
+ gfc_expr *length;
+ gfc_ref *ref;
+ gfc_expr *res;
+ mpz_t value;
+
+ if (e->ts.u.cl)
+ {
+ length = e->ts.u.cl->length;
+ if (length && length->expr_type == EXPR_CONSTANT)
+ return gfc_copy_expr(length);
+ }
+
+ /* Return length of substring, if constant. */
+ for (ref = e->ref; ref; ref = ref->next)
+ {
+ if (ref->type == REF_SUBSTRING
+ && gfc_dep_difference (ref->u.ss.end, ref->u.ss.start, &value))
+ {
+ res = gfc_get_constant_expr (BT_INTEGER, gfc_charlen_int_kind,
+ &e->where);
+
+ mpz_add_ui (res->value.integer, value, 1);
+ mpz_clear (value);
+ return res;
+ }
+ }
+
+ /* Return length of char symbol, if constant. */
+
+ if (e->symtree->n.sym->ts.u.cl && e->symtree->n.sym->ts.u.cl->length
+ && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
+ return gfc_copy_expr (e->symtree->n.sym->ts.u.cl->length);
+
+ return NULL;
+
+}
+
/* Returns a new expression (a variable) to be used in place of the old one,
with an assignment statement before the current statement to set
the value of the variable. Creates a new BLOCK for the statement if
@@ -525,6 +618,20 @@ create_var (gfc_expr * e)
}
}
+ if (e->ts.type == BT_CHARACTER && e->rank == 0)
+ {
+ gfc_expr *length;
+
+ length = constant_string_length (e);
+ if (length)
+ {
+ symbol->ts.u.cl = gfc_new_charlen (ns, NULL);
+ symbol->ts.u.cl->length = length;
+ }
+ else
+ symbol->attr.allocatable = 1;
+ }
+
symbol->attr.flavor = FL_VARIABLE;
symbol->attr.referenced = 1;
symbol->attr.dimension = e->rank > 0;
@@ -849,7 +956,27 @@ optimize_namespace (gfc_namespace *ns)
}
}
+/* Handle dependencies for allocatable strings which potentially redefine
+ themselves in an assignment. */
+
static void
+realloc_strings (gfc_namespace *ns)
+{
+ current_ns = ns;
+ gfc_code_walker (&ns->code, realloc_string_callback, dummy_expr_callback, NULL);
+
+ for (ns = ns->contained; ns; ns = ns->sibling)
+ {
+ if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
+ {
+ // current_ns = ns;
+ realloc_strings (ns);
+ }
+ }
+
+}
+
+static void
optimize_reduction (gfc_namespace *ns)
{
current_ns = ns;
@@ -1567,6 +1694,11 @@ optimize_trim (gfc_expr *e)
if (a->expr_type != EXPR_VARIABLE)
return false;
+ /* This would pessimize the idiom a = trim(a) for reallocatable strings. */
+
+ if (a->symtree->n.sym->attr.allocatable)
+ return false;
+
/* Follow all references to find the correct place to put the newly
created reference. FIXME: Also handle substring references and
array references. Array references cause strange regressions at
[-- Attachment #3: realloc_on_assign_25.f90 --]
[-- Type: text/x-fortran, Size: 490 bytes --]
! { dg-do run }
! PR 47674 - this would segfault if MALLOC_PERTURB is set.
! This checks a code path where it is not possible to determine
! the length of the string at compile time.
!
program main
implicit none
character(:), allocatable :: a
integer :: m, n
a = 'a'
if (a .ne. 'a') call abort
a = a // 'x'
if (a .ne. 'ax') call abort
if (len (a) .ne. 2) call abort
n = 2
m = 2
a = a(m:n)
if (a .ne. 'x') call abort
if (len (a) .ne. 1) call abort
end program main
^ permalink raw reply [flat|nested] 5+ messages in thread
* *ping* [patch, fortran] Fix for PR 47676
2014-12-30 10:21 [patch, fortran] Fix for PR 47676 Thomas Koenig
@ 2015-01-05 11:52 ` Thomas Koenig
2015-01-05 18:02 ` Marek Polacek
2015-01-05 18:55 ` H.J. Lu
1 sibling, 1 reply; 5+ messages in thread
From: Thomas Koenig @ 2015-01-05 11:52 UTC (permalink / raw)
To: fortran, gcc-patches
Am 30.12.2014 um 01:25 schrieb Thomas Koenig:
> Hello world,
>
> this patch fixes the long-standing bug. A missing temporary
> causes an invalid read in realloc_on_assign_5.f03 which
> only becomes noticable when setting MALLOC_CHECK_ or when
> using valgrind. The bug has three duplicates in the
> data base, so people keep stumbling across this.
Ping ?
https://gcc.gnu.org/ml/fortran/2014-12/msg00137.html
^ permalink raw reply [flat|nested] 5+ messages in thread
* Re: *ping* [patch, fortran] Fix for PR 47676
2015-01-05 11:52 ` *ping* " Thomas Koenig
@ 2015-01-05 18:02 ` Marek Polacek
0 siblings, 0 replies; 5+ messages in thread
From: Marek Polacek @ 2015-01-05 18:02 UTC (permalink / raw)
To: Thomas Koenig; +Cc: fortran, gcc-patches
On Mon, Jan 05, 2015 at 12:51:55PM +0100, Thomas Koenig wrote:
> Am 30.12.2014 um 01:25 schrieb Thomas Koenig:
> > Hello world,
> >
> > this patch fixes the long-standing bug. A missing temporary
> > causes an invalid read in realloc_on_assign_5.f03 which
> > only becomes noticable when setting MALLOC_CHECK_ or when
> > using valgrind. The bug has three duplicates in the
> > data base, so people keep stumbling across this.
>
> Ping ?
>
> https://gcc.gnu.org/ml/fortran/2014-12/msg00137.html
This breaks the build because you haven't committed the
dependency.h part.
Marek
^ permalink raw reply [flat|nested] 5+ messages in thread
* Re: [patch, fortran] Fix for PR 47676
2014-12-30 10:21 [patch, fortran] Fix for PR 47676 Thomas Koenig
2015-01-05 11:52 ` *ping* " Thomas Koenig
@ 2015-01-05 18:55 ` H.J. Lu
2015-01-05 19:22 ` Thomas Koenig
1 sibling, 1 reply; 5+ messages in thread
From: H.J. Lu @ 2015-01-05 18:55 UTC (permalink / raw)
To: Thomas Koenig; +Cc: fortran, gcc-patches
On Mon, Dec 29, 2014 at 4:25 PM, Thomas Koenig <tkoenig@netcologne.de> wrote:
> Hello world,
>
> this patch fixes the long-standing bug. A missing temporary
> causes an invalid read in realloc_on_assign_5.f03 which
> only becomes noticable when setting MALLOC_CHECK_ or when
> using valgrind. The bug has three duplicates in the
> data base, so people keep stumbling across this.
>
> I have to confess I could not find the right way to put
> this into the normal dependency code; the assumption that
> the string copying will "do the right thing" is too deeply
> embedded in the code, or I have been looking at the wrong places.
>
> So I took the approach of using the big hammer of a frontend
> pass to fix this up.
>
> I would definitely like to see this bug fixed for 5.0. If anybody
> has a better idea on how to tackle this in a timely manner, please
> let me know.
>
> Otherwise, OK for trunk? What about the other branches?
>
> Regression-tested.
>
> 2014-12-29 Thomas Koenig <tkoenig@gcc.gnu.org>
>
> PR fortran/47674
> * dependency.c (gfc_discard_nops): Add prototype.
> * dependency.c (discard_nops): Rename to gfc_discard_nops,
> make non-static.
> (gfc_discard_nops): Use gfc_discard_nops.
> (gfc_dep_difference): Likewise.
> * frontend-passes.c (realloc_strings): New function.
> Add prototype.
> (gfc_run_passes): Call realloc_strings.
> (realloc_string_callback): New function.
> (create_var): Add prototype. Handle case of a
> scalar character variable.
> (optimize_trim): Do not handle allocatable variables.
>
On Linux/x86, I got
../../src-trunk/gcc/fortran/frontend-passes.c: In function ‘int
realloc_string_callback(gfc_code**, int*, void*)’:
../../src-trunk/gcc/fortran/frontend-passes.c:152:38: error:
‘gfc_discard_nops’ was not declared in this scope
expr2 = gfc_discard_nops (co->expr2);
^
make[6]: *** [fortran/frontend-passes.o] Error 1
--
H.J.
^ permalink raw reply [flat|nested] 5+ messages in thread
* Re: [patch, fortran] Fix for PR 47676
2015-01-05 18:55 ` H.J. Lu
@ 2015-01-05 19:22 ` Thomas Koenig
0 siblings, 0 replies; 5+ messages in thread
From: Thomas Koenig @ 2015-01-05 19:22 UTC (permalink / raw)
To: fortran, gcc-patches; +Cc: hjl.tools, polacek
Am 05.01.2015 um 19:55 schrieb H.J. Lu:
> On Linux/x86, I got
>
> ../../src-trunk/gcc/fortran/frontend-passes.c: In function âint
> realloc_string_callback(gfc_code**, int*, void*)â:
> ../../src-trunk/gcc/fortran/frontend-passes.c:152:38: error:
> âgfc_discard_nopsâ was not declared in this scope
> expr2 = gfc_discard_nops (co->expr2);
> ^
> make[6]: *** [fortran/frontend-passes.o] Error 1
Fixed, sorry for the breakage.
Thomas
^ permalink raw reply [flat|nested] 5+ messages in thread
end of thread, other threads:[~2015-01-05 19:22 UTC | newest]
Thread overview: 5+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2014-12-30 10:21 [patch, fortran] Fix for PR 47676 Thomas Koenig
2015-01-05 11:52 ` *ping* " Thomas Koenig
2015-01-05 18:02 ` Marek Polacek
2015-01-05 18:55 ` H.J. Lu
2015-01-05 19:22 ` Thomas Koenig
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).