Skip to content

R
riscv-gcc-1
Commit 0b4f2770 by Mikael Morin
Options

re PR fortran/45648 (Unnecessary temporary for transpose calls as actual argument.) 

2010-09-21  Mikael Morin  <mikael@gcc.gnu.org>

	PR fortran/45648
	* trans-array.c (gfc_conv_expr_descriptor): Calculate dim out of n and
	info->dim.

	PR fortran/45648
	* trans-array.c (gfc_conv_expr_descriptor): Unset full if we are
	accessing dimensions in reversed order. 

	PR fortran/45648
	* trans-array.c (gfc_conv_expr_descriptor): Special case noncopying
	intrinsic function call. 

	* trans-array.c (gfc_conv_expr_descriptor): Remove ss lookup.
	Update asserts accordingly.

	PR fortran/45648
	* trans.h (gfc_se): New field force_tmp. 
	* trans-expr.c (gfc_conv_procedure_call): Check for argument alias
	and set parmse.force_tmp if some alias is found. 
	* trans-array.c (gfc_conv_expr_descriptor): Force a temporary creation
	if se->force_tmp is set. 

2010-09-21  Mikael Morin  <mikael@gcc.gnu.org>

	PR fortran/45648
	* gfortran.dg/inline_transpose_1.f90: Update temporary's locations
	and counts. Add non-elemental function call check.

	PR fortran/45648
	* gfortran.dg/inline_transpose_1.f90: Add function calls with aliasing
	arguments checks. Update temporary counts.
	* gfortran.dg/transpose_optimization_1.f90: New.

From-SVN: r164494
parent 5e68c77a
Showing with 284 additions and 53 deletions
gcc/fortran/ChangeLog
2010-09-21 Mikael Morin <mikael@gcc.gnu.org>
PR fortran/45648
* trans-array.c (gfc_conv_expr_descriptor): Calculate dim out of n and
info->dim.
PR fortran/45648
* trans-array.c (gfc_conv_expr_descriptor): Unset full if we are
accessing dimensions in reversed order.
PR fortran/45648
* trans-array.c (gfc_conv_expr_descriptor): Special case noncopying
intrinsic function call.
* trans-array.c (gfc_conv_expr_descriptor): Remove ss lookup.
Update asserts accordingly.
PR fortran/45648
* trans.h (gfc_se): New field force_tmp.
* trans-expr.c (gfc_conv_procedure_call): Check for argument alias
and set parmse.force_tmp if some alias is found.
* trans-array.c (gfc_conv_expr_descriptor): Force a temporary creation
if se->force_tmp is set.
2010-09-20 Janus Weil <janus@gcc.gnu.org>
PR fortran/45438
......
gcc/fortran/trans-array.c
......@@ -5136,7 +5136,6 @@ get_array_charlen (gfc_expr *expr, gfc_se *se)
}
/* Convert an array for passing as an actual argument. Expressions and
vector subscripts are evaluated and stored in a temporary, which is then
passed. For whole arrays the descriptor is passed. For array sections
......@@ -5158,13 +5157,18 @@ get_array_charlen (gfc_expr *expr, gfc_se *se)
EXPR is the right-hand side of a pointer assignment and
se->expr is the descriptor for the previously-evaluated
left-hand side. The function creates an assignment from
EXPR to se->expr. */
EXPR to se->expr.
The se->force_tmp flag disables the non-copying descriptor optimization
that is used for transpose. It may be used in cases where there is an
alias between the transpose argument and another argument in the same
function call. */
void
gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
{
gfc_loopinfo loop;
gfc_ss *secss;
gfc_ss_info *info;
int need_tmp;
int n;
......@@ -5175,7 +5179,9 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
tree offset;
int full;
bool subref_array_target = false;
gfc_expr *arg;
gcc_assert (ss != NULL);
gcc_assert (ss != gfc_ss_terminator);
/* Special case things we know we can pass easily. */
......@@ -5185,22 +5191,21 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
/* If we have a linear array section, we can pass it directly.
Otherwise we need to copy it into a temporary. */
/* Find the SS for the array section. */
secss = ss;
while (secss != gfc_ss_terminator && secss->type != GFC_SS_SECTION)
secss = secss->next;
gcc_assert (secss != gfc_ss_terminator);
info = &secss->data.info;
gcc_assert (ss->type == GFC_SS_SECTION);
gcc_assert (ss->expr == expr);
info = &ss->data.info;
/* Get the descriptor for the array. */
gfc_conv_ss_descriptor (&se->pre, secss, 0);
gfc_conv_ss_descriptor (&se->pre, ss, 0);
desc = info->descriptor;
subref_array_target = se->direct_byref && is_subref_array (expr);
need_tmp = gfc_ref_needs_temporary_p (expr->ref)
&& !subref_array_target;
if (se->force_tmp)
need_tmp = 1;
if (need_tmp)
full = 0;
else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
......@@ -5216,6 +5221,14 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
full = gfc_full_array_ref_p (info->ref, NULL);
if (full)
for (n = 0; n < info->dimen; n++)
if (info->dim[n] != n)
{
full = 0;
break;
}
if (full)
{
if (se->direct_byref && !se->byref_noassign)
{
......@@ -5245,30 +5258,45 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
break;
case EXPR_FUNCTION:
/* We don't need to copy data in some cases. */
arg = gfc_get_noncopying_intrinsic_argument (expr);
if (arg)
{
/* This is a call to transpose... */
gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
/* ... which has already been handled by the scalarizer, so
that we just need to get its argument's descriptor. */
gfc_conv_expr_descriptor (se, expr->value.function.actual->expr, ss);
return;
}
/* A transformational function return value will be a temporary
array descriptor. We still need to go through the scalarizer
to create the descriptor. Elemental functions ar handled as
arbitrary expressions, i.e. copy to a temporary. */
secss = ss;
/* Look for the SS for this function. */
while (secss != gfc_ss_terminator
&& (secss->type != GFC_SS_FUNCTION || secss->expr != expr))
secss = secss->next;
if (se->direct_byref)
{
gcc_assert (secss != gfc_ss_terminator);
gcc_assert (ss->type == GFC_SS_FUNCTION && ss->expr == expr);
/* For pointer assignments pass the descriptor directly. */
se->ss = secss;
if (se->ss == NULL)
se->ss = ss;
else
gcc_assert (se->ss == ss);
se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
gfc_conv_expr (se, expr);
return;
}
if (secss == gfc_ss_terminator)
if (ss->expr != expr)
{
/* Elemental function. */
gcc_assert ((expr->value.function.esym != NULL
&& expr->value.function.esym->attr.elemental)
|| (expr->value.function.isym != NULL
&& expr->value.function.isym->elemental));
need_tmp = 1;
if (expr->ts.type == BT_CHARACTER
&& expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
......@@ -5279,7 +5307,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
else
{
/* Transformational function. */
info = &secss->data.info;
info = &ss->data.info;
need_tmp = 0;
}
break;
......@@ -5292,12 +5320,10 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
{
need_tmp = 0;
info = &ss->data.info;
secss = ss;
}
else
{
need_tmp = 1;
secss = NULL;
info = NULL;
}
break;
......@@ -5305,11 +5331,15 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
default:
/* Something complicated. Copy it into a temporary. */
need_tmp = 1;
secss = NULL;
info = NULL;
break;
}
/* If we are creating a temporary, we don't need to bother about aliases
anymore. */
if (need_tmp)
se->force_tmp = 0;
gfc_init_loopinfo (&loop);
/* Associate the SS with the loop. */
......@@ -5421,7 +5451,6 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
se->string_length = gfc_get_expr_charlen (expr);
desc = info->descriptor;
gcc_assert (secss && secss != gfc_ss_terminator);
if (se->direct_byref && !se->byref_noassign)
{
/* For pointer assignments we fill in the destination. */
......@@ -5439,12 +5468,11 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
}
offset = gfc_index_zero_node;
dim = 0;
/* The following can be somewhat confusing. We have two
descriptors, a new one and the original array.
{parm, parmtype, dim} refer to the new one.
{desc, type, n, secss, loop} refer to the original, which maybe
{desc, type, n, loop} refer to the original, which maybe
a descriptorless array.
The bounds of the scalarization are the bounds of the section.
We don't have to worry about numeric overflows when calculating
......@@ -5479,9 +5507,6 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
}
else
{
/* Check we haven't somehow got out of sync. */
gcc_assert (info->dim[dim] == n);
/* Evaluate and remember the start of the section. */
start = info->start[n];
stride = gfc_evaluate_now (stride, &loop.pre);
......@@ -5505,6 +5530,14 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
/* Vector subscripts need copying and are handled elsewhere. */
if (info->ref)
gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
/* look for the corresponding scalarizer dimension: dim. */
for (dim = 0; dim < ndim; dim++)
if (info->dim[dim] == n)
break;
/* loop exited early: the DIM being looked for has been found. */
gcc_assert (dim < ndim);
/* Set the new lower bound. */
from = loop.from[dim];
......@@ -5559,8 +5592,6 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
/* Store the new stride. */
gfc_conv_descriptor_stride_set (&loop.pre, parm,
gfc_rank_cst[dim], stride);
dim++;
}
if (se->data_not_needed)
......
gcc/fortran/trans-expr.c
......@@ -2770,7 +2770,7 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
int
gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
gfc_actual_arglist * arg, gfc_expr * expr,
gfc_actual_arglist * args, gfc_expr * expr,
VEC(tree,gc) *append_args)
{
gfc_interface_mapping mapping;
......@@ -2789,6 +2789,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
VEC(tree,gc) *stringargs;
tree result = NULL;
gfc_formal_arglist *formal;
gfc_actual_arglist *arg;
int has_alternate_specifier = 0;
bool need_interface_mapping;
bool callee_alloc;
......@@ -2809,7 +2810,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
gfc_clear_ts (&ts);
if (sym->from_intmod == INTMOD_ISO_C_BINDING
&& conv_isocbinding_procedure (se, sym, arg))
&& conv_isocbinding_procedure (se, sym, args))
return 0;
gfc_is_proc_ptr_comp (expr, &comp);
......@@ -2859,7 +2860,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
}
/* Evaluate the arguments. */
for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
for (arg = args; arg != NULL;
arg = arg->next, formal = formal ? formal->next : NULL)
{
e = arg->expr;
fsym = formal ? formal->sym : NULL;
......@@ -3040,6 +3042,24 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
else
f = f || !sym->attr.always_explicit;
/* If the argument is a function call that may not create
a temporary for the result, we have to check that we
can do it, i.e. that there is no alias between this
argument and another one. */
if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
{
sym_intent intent;
if (fsym != NULL)
intent = fsym->attr.intent;
else
intent = INTENT_UNKNOWN;
if (gfc_check_fncall_dependency (e, intent, sym, args,
NOT_ELEMENTAL))
parmse.force_tmp = 1;
}
if (e->expr_type == EXPR_VARIABLE
&& is_subref_array (e))
/* The actual argument is a component reference to an
......
gcc/fortran/trans.h
......@@ -81,6 +81,11 @@ typedef struct gfc_se
/* If set, gfc_conv_procedure_call does not put byref calls into se->pre. */
unsigned no_function_call:1;
/* If set, we will force the creation of a temporary. Useful to disable
non-copying procedure argument passing optimizations, when some function
args alias. */
unsigned force_tmp:1;
/* Scalarization parameters. */
struct gfc_se *parent;
struct gfc_ss *ss;
......
gcc/testsuite/ChangeLog
2010-09-21 Mikael Morin <mikael@gcc.gnu.org>
PR fortran/45648
* gfortran.dg/inline_transpose_1.f90: Update temporary's locations
and counts. Add non-elemental function call check.
PR fortran/45648
* gfortran.dg/inline_transpose_1.f90: Add function calls with aliasing
arguments checks. Update temporary counts.
* gfortran.dg/transpose_optimization_1.f90: New.
2010-09-21 Nicola Pero <nicola.pero@meta-innovation.com>
Merge from 'apple/trunk' branch on FSF servers.
......
gcc/testsuite/gfortran.dg/inline_transpose_1.f90
......@@ -61,10 +61,10 @@
if (u /= v) call abort
a = foo(transpose(c)) ! Unnecessary { dg-warning "Creating array temporary" }
a = foo(transpose(c))
if (any(a /= p+1)) call abort
write(u,*) foo(transpose(c)) ! 2 temps, should be 1 { dg-warning "Creating array temporary" }
write(u,*) foo(transpose(c)) ! { dg-warning "Creating array temporary" }
write(v,*) p+1
if (u /= v) call abort
......@@ -77,10 +77,10 @@
if (u /= v) call abort
e = foo(transpose(e)) ! 2 temps, should be 1 { dg-warning "Creating array temporary" }
e = foo(transpose(e)) ! { dg-warning "Creating array temporary" }
if (any(e /= 2*s+1)) call abort
write(u,*) transpose(foo(transpose(e))-1) ! 2 temps, should be 1 { dg-warning "Creating array temporary" }
write(u,*) transpose(foo(transpose(e))-1) ! { dg-warning "Creating array temporary" }
write(v,*) 2*s+1
if (u /= v) call abort
......@@ -141,28 +141,46 @@
if (u /= v) call abort
if (any(transpose(matmul(a,c)) /= matmul(transpose(c), transpose(a)))) call abort ! 4 temps, should be 2 { dg-warning "Creating array temporary" }
if (any(transpose(matmul(a,c)) /= matmul(transpose(c), transpose(a)))) call abort ! 2 temps { dg-warning "Creating array temporary" }
write(u,*) transpose(matmul(a,c)) ! { dg-warning "Creating array temporary" }
write(v,*) matmul(transpose(c), transpose(a)) ! 3 temps, should be 1 { dg-warning "Creating array temporary" }
write(v,*) matmul(transpose(c), transpose(a)) ! { dg-warning "Creating array temporary" }
if (u /= v) call abort
if (any(transpose(matmul(e,a)) /= matmul(transpose(a), transpose(e)))) call abort ! 4 temps, should be 2 { dg-warning "Creating array temporary" }
if (any(transpose(matmul(e,a)) /= matmul(transpose(a), transpose(e)))) call abort ! 2 temps { dg-warning "Creating array temporary" }
write(u,*) transpose(matmul(e,a)) ! { dg-warning "Creating array temporary" }
write(v,*) matmul(transpose(a), transpose(e)) ! 3 temps, should be 1 { dg-warning "Creating array temporary" }
write(v,*) matmul(transpose(a), transpose(e)) ! { dg-warning "Creating array temporary" }
if (u /= v) call abort
call baz (transpose(a)) ! Unnecessary { dg-warning "Creating array temporary" }
call baz (transpose(a))
call toto (f, transpose (e))
if (any (f /= 4 * s + 12)) call abort
call toto (f, transpose (f)) ! { dg-warning "Creating array temporary" }
if (any (f /= 8 * r + 24)) call abort
call toto1 (a, transpose (c))
if (any (a /= 2 * p + 12)) call abort
call toto1 (e, transpose (e)) ! { dg-warning "Creating array temporary" }
if (any (e /= 4 * s + 12)) call abort
call toto2 (c, transpose (a))
if (any (c /= 2 * q + 13)) call abort
call toto2 (e, transpose(e)) ! { dg-warning "Creating array temporary" }
if (any (e /= 4 * r + 13)) call abort
call toto2 (e, transpose(transpose(e))) ! { dg-warning "Creating array temporary" }
if (any (e /= 4 * r + 14)) call abort
call toto3 (e, transpose(e))
if (any (e /= 4 * r + 14)) call abort
call titi (nx, e, transpose(e)) ! { dg-warning "Creating array temporary" }
if (any (e /= 4 * s + 17)) call abort
contains
......@@ -182,22 +200,38 @@
integer, intent(in) :: x(:,:)
end subroutine baz
elemental subroutine toto (x, y)
elemental subroutine toto1 (x, y)
integer, intent(out) :: x
integer, intent(in) :: y
x = y + y
end subroutine toto
end subroutine toto1
subroutine toto2 (x, y)
integer, dimension(:,:), intent(out) :: x
integer, dimension(:,:), intent(in) :: y
x = y + 1
end subroutine toto2
subroutine toto3 (x, y)
integer, dimension(:,:), intent(in) :: x, y
end subroutine toto3
end
subroutine titi (n, x, y)
integer :: n, x(n,n), y(n,n)
x = y + 3
end subroutine titi
! No call to transpose
! { dg-final { scan-tree-dump-times "_gfortran_transpose" 0 "original" } }
!
! 34 temporaries
! { dg-final { scan-tree-dump-times "struct\[^\\n\]*atmp" 34 "original" } }
! 24 temporaries
! { dg-final { scan-tree-dump-times "struct\[^\\n\]*atmp" 24 "original" } }
!
! 2 tests optimized out
! { dg-final { scan-tree-dump-times "_gfortran_abort" 34 "original" } }
! { # Commented out as failing at -O0: dg-final { scan-tree-dump-times "_gfortran_abort" 32 "optimized" } }
! { dg-final { scan-tree-dump-times "_gfortran_abort" 39 "original" } }
! { # Commented out as failing at -O0: dg-final { scan-tree-dump-times "_gfortran_abort" 37 "optimized" } }
!
! cleanup
! { dg-final { cleanup-tree-dump "original" } }
......
gcc/testsuite/gfortran.dg/transpose_optimization_1.f90 0 → 100644
! { dg-do compile }
! { dg-options "-Warray-temporaries -fdump-tree-original" }
!
! PR fortran/45648
! Non-copying descriptor transpose optimization (for function call args).
!
! Contributed by Richard Sandiford <richard@codesourcery.com>
module foo
interface
subroutine ext1 (a, b)
real, intent (in), dimension (:, :) :: a, b
end subroutine ext1
subroutine ext2 (a, b)
real, intent (in), dimension (:, :) :: a
real, intent (out), dimension (:, :) :: b
end subroutine ext2
subroutine ext3 (a, b)
real, dimension (:, :) :: a, b
end subroutine ext3
end interface
contains
! No temporary needed here.
subroutine test1 (n, a, b, c)
integer :: n
real, dimension (n, n) :: a, b, c
a = matmul (transpose (b), c)
end subroutine test1
! No temporary either, as we know the arguments to matmul are intent(in)
subroutine test2 (n, a, b)
integer :: n
real, dimension (n, n) :: a, b
a = matmul (transpose (b), b)
end subroutine test2
! No temporary needed.
subroutine test3 (n, a, b, c)
integer :: n
real, dimension (n, n) :: a, c
real, dimension (n+4, n+4) :: b
a = matmul (transpose (b (2:n+1, 3:n+2)), c)
end subroutine test3
! A temporary is needed for the result of either the transpose or matmul.
subroutine test4 (n, a, b)
integer :: n
real, dimension (n, n) :: a, b
a = matmul (transpose (a), b) ! { dg-warning "Creating array temporary" }
end subroutine test4
! The temporary is needed here since the second argument to imp1
! has unknown intent.
subroutine test5 (n, a)
integer :: n
real, dimension (n, n) :: a
call imp1 (transpose (a), a) ! { dg-warning "Creating array temporary" }
end subroutine test5
! No temporaries are needed here; imp1 can't modify either argument.
! We have to pack the arguments, however.
subroutine test6 (n, a, b)
integer :: n
real, dimension (n, n) :: a, b
call imp1 (transpose (a), transpose (b)) ! { dg-warning "Creating array temporary" }
end subroutine test6
! No temporaries are needed here; imp1 can't modify either argument.
! We don't have to pack the arguments.
subroutine test6_bis (n, a, b)
integer :: n
real, dimension (n, n) :: a, b
call ext3 (transpose (a), transpose (b))
end subroutine test6_bis
! No temporary is neede here; the second argument is intent(in).
subroutine test7 (n, a)
integer :: n
real, dimension (n, n) :: a
call ext1 (transpose (a), a)
end subroutine test7
! The temporary is needed here though.
subroutine test8 (n, a)
integer :: n
real, dimension (n, n) :: a
call ext2 (transpose (a), a) ! { dg-warning "Creating array temporary" }
end subroutine test8
! Silly, but we don't need any temporaries here.
subroutine test9 (n, a)
integer :: n
real, dimension (n, n) :: a
call ext1 (transpose (transpose (a)), a)
end subroutine test9
! The outer transpose needs a temporary; the inner one doesn't.
subroutine test10 (n, a)
integer :: n
real, dimension (n, n) :: a
call ext2 (transpose (transpose (a)), a) ! { dg-warning "Creating array temporary" }
end subroutine test10
end module foo
! { dg-final { scan-tree-dump-times "struct\[^\\n\]*atmp" 4 "original" } }
! { dg-final { cleanup-tree-dump "original" } }
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment