Hello world,
after Paul's fix for allocate on assignment (thanks Paul!), here is a
patch for the original test case from PR 22572, where the bounds of
the function are unknown at compile time. This uses an allocatable
temporary.
In the long run, another option is to use interface mapping to evaluate
the bounds of intrinsics and explicit-shape functions. For this, it
would be necessary to write a front-end-only version of
gfc_evaluate_now, which would be complicated by the desire not to
disturb common function elimination, so I've put that on the back burner
for now.
Regression-tested. OK for trunk?
Thomas
2011-05-01 Thomas Koenig <tkoe...@gcc.gnu.org>
PR fortran/22572
* frontend-passes.c (cfe_register_funcs): Also register functions
for potential elimination if the rank is > 0, the shape is unknown
and reallocate on assignment is active.
(create_var): For rank > 0 functions with unknown shape, create
an allocatable temporary.
2011-05-01 Thomas Koenig <tkoe...@gcc.gnu.org>
PR fortran/22572
* function_optimize_7.f90: New test case.
Index: frontend-passes.c
===================================================================
--- frontend-passes.c (Revision 173214)
+++ frontend-passes.c (Arbeitskopie)
@@ -152,11 +152,11 @@ cfe_register_funcs (gfc_expr **e, int *walk_subtre
if ((*e)->ts.type == BT_CHARACTER)
return 0;
- /* If we don't know the shape at compile time, we do not create a temporary
- variable to hold the intermediate result. FIXME: Change this later when
- allocation on assignment works for intrinsics. */
+ /* If we don't know the shape at compile time, we create an allocatable
+ temporary variable to hold the intermediate result, but only if
+ allocation on assignment is active. */
- if ((*e)->rank > 0 && (*e)->shape == NULL)
+ if ((*e)->rank > 0 && (*e)->shape == NULL && !gfc_option.flag_realloc_lhs)
return 0;
/* Skip the test for pure functions if -faggressive-function-elimination
@@ -250,22 +250,38 @@ create_var (gfc_expr * e)
symbol = symtree->n.sym;
symbol->ts = e->ts;
- symbol->as = gfc_get_array_spec ();
- symbol->as->rank = e->rank;
- symbol->as->type = AS_EXPLICIT;
- for (i=0; i<e->rank; i++)
+
+ if (e->rank > 0)
{
- gfc_expr *p, *q;
+ symbol->as = gfc_get_array_spec ();
+ symbol->as->rank = e->rank;
+
+ if (e->shape == NULL)
+ {
+ /* We don't know the shape at compile time, so we use an
+ allocatable. */
+ symbol->as->type = AS_DEFERRED;
+ symbol->attr.allocatable = 1;
+ }
+ else
+ {
+ symbol->as->type = AS_EXPLICIT;
+ /* Copy the shape. */
+ for (i=0; i<e->rank; i++)
+ {
+ gfc_expr *p, *q;
- p = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
- &(e->where));
- mpz_set_si (p->value.integer, 1);
- symbol->as->lower[i] = p;
-
- q = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
- &(e->where));
- mpz_set (q->value.integer, e->shape[i]);
- symbol->as->upper[i] = q;
+ p = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
+ &(e->where));
+ mpz_set_si (p->value.integer, 1);
+ symbol->as->lower[i] = p;
+
+ q = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
+ &(e->where));
+ mpz_set (q->value.integer, e->shape[i]);
+ symbol->as->upper[i] = q;
+ }
+ }
}
symbol->attr.flavor = FL_VARIABLE;
! { dg-do compile }
! { dg-options "-O -fdump-tree-original -Warray-temporaries" }
subroutine xx(n, m, a, b, c, d, x, z, i, s_in, s_out)
implicit none
integer, intent(in) :: n, m
real, intent(in), dimension(n,n) :: a, b, c
real, intent(out), dimension(n,n) :: d
real, intent(in), dimension(n,m) :: s_in
real, intent(out), dimension(m) :: s_out
integer, intent(out) :: i
real, intent(inout) :: x
real, intent(out) :: z
character(60) :: line
real, external :: ext_func
interface
elemental function element(x)
real, intent(in) :: x
real :: elem
end function element
pure function mypure(x)
real, intent(in) :: x
integer :: mypure
end function mypure
elemental impure function elem_impure(x)
real, intent(in) :: x
real :: elem_impure
end function elem_impure
end interface
d = matmul(a,b) + matmul(a,b) ! { dg-warning "Creating array temporary" }
z = sin(x) + cos(x) + sin(x) + cos(x)
x = ext_func(a) + 23 + ext_func(a)
z = element(x) + element(x)
i = mypure(x) - mypure(x)
z = elem_impure(x) - elem_impure(x)
s_out = sum(s_in,1) + 3.14 / sum(s_in,1) ! { dg-warning "Creating array
temporary" }
end subroutine xx
! { dg-final { scan-tree-dump-times "matmul_r4" 1 "original" } }
! { dg-final { scan-tree-dump-times "__builtin_sinf" 1 "original" } }
! { dg-final { scan-tree-dump-times "__builtin_cosf" 1 "original" } }
! { dg-final { scan-tree-dump-times "ext_func" 2 "original" } }
! { dg-final { scan-tree-dump-times "element" 1 "original" } }
! { dg-final { scan-tree-dump-times "mypure" 1 "original" } }
! { dg-final { scan-tree-dump-times "elem_impure" 2 "original" } }
! { dg-final { scan-tree-dump-times "sum_r4" 1 "original" } }
! { dg-final { cleanup-tree-dump "original" } }
