@@ -91,7 +91,6 @@ along with GCC; see the file COPYING3. If not see
#include "trans-const.h"
#include "dependency.h"
-static gfc_ss *gfc_walk_subexpr (gfc_ss *, gfc_expr *);
static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor_base);
/* The contents of this structure aren't actually used, just the address. */
@@ -905,96 +904,6 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post,
}
-/* Generate code to transpose array EXPR by creating a new descriptor
- in which the dimension specifications have been reversed. */
-
-void
-gfc_conv_array_transpose (gfc_se * se, gfc_expr * expr)
-{
- tree dest, src, dest_index, src_index;
- gfc_loopinfo *loop;
- gfc_ss_info *dest_info;
- gfc_ss *dest_ss, *src_ss;
- gfc_se src_se;
- int n;
-
- loop = se->loop;
-
- src_ss = gfc_walk_expr (expr);
- dest_ss = se->ss;
-
- dest_info = &dest_ss->data.info;
- gcc_assert (dest_info->dimen == 2);
-
- /* Get a descriptor for EXPR. */
- gfc_init_se (&src_se, NULL);
- gfc_conv_expr_descriptor (&src_se, expr, src_ss);
- gfc_add_block_to_block (&se->pre, &src_se.pre);
- gfc_add_block_to_block (&se->post, &src_se.post);
- src = src_se.expr;
-
- /* Allocate a new descriptor for the return value. */
- dest = gfc_create_var (TREE_TYPE (src), "transp");
- dest_info->descriptor = dest;
- se->expr = dest;
-
- /* Copy across the dtype field. */
- gfc_add_modify (&se->pre,
- gfc_conv_descriptor_dtype (dest),
- gfc_conv_descriptor_dtype (src));
-
- /* Copy the dimension information, renumbering dimension 1 to 0 and
- 0 to 1. */
- for (n = 0; n < 2; n++)
- {
- dest_info->delta[n] = gfc_index_zero_node;
- dest_info->start[n] = gfc_index_zero_node;
- dest_info->end[n] = gfc_index_zero_node;
- dest_info->stride[n] = gfc_index_one_node;
- dest_info->dim[n] = n;
-
- dest_index = gfc_rank_cst[n];
- src_index = gfc_rank_cst[1 - n];
-
- gfc_conv_descriptor_stride_set (&se->pre, dest, dest_index,
- gfc_conv_descriptor_stride_get (src, src_index));
-
- gfc_conv_descriptor_lbound_set (&se->pre, dest, dest_index,
- gfc_conv_descriptor_lbound_get (src, src_index));
-
- gfc_conv_descriptor_ubound_set (&se->pre, dest, dest_index,
- gfc_conv_descriptor_ubound_get (src, src_index));
-
- if (!loop->to[n])
- {
- gcc_assert (integer_zerop (loop->from[n]));
- loop->to[n] =
- fold_build2 (MINUS_EXPR, gfc_array_index_type,
- gfc_conv_descriptor_ubound_get (dest, dest_index),
- gfc_conv_descriptor_lbound_get (dest, dest_index));
- }
- }
-
- /* Copy the data pointer. */
- dest_info->data = gfc_conv_descriptor_data_get (src);
- gfc_conv_descriptor_data_set (&se->pre, dest, dest_info->data);
-
- /* Copy the offset. This is not changed by transposition; the top-left
- element is still at the same offset as before, except where the loop
- starts at zero. */
- if (!integer_zerop (loop->from[0]))
- dest_info->offset = gfc_conv_descriptor_offset_get (src);
- else
- dest_info->offset = gfc_index_zero_node;
-
- gfc_conv_descriptor_offset_set (&se->pre, dest,
- dest_info->offset);
-
- if (dest_info->dimen > loop->temp_dim)
- loop->temp_dim = dest_info->dimen;
-}
-
-
/* Return the number of iterations in a loop that starts at START,
ends at END, and has step STEP. */
@@ -6861,7 +6770,7 @@ gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
/* Walk an expression. Add walked expressions to the head of the SS chain.
A wholly scalar expression will not be added. */
-static gfc_ss *
+gfc_ss *
gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
{
gfc_ss *head;
@@ -64,6 +64,8 @@ void gfc_trans_static_array_pointer (gfc_symbol *);
/* Generate scalarization information for an expression. */
gfc_ss *gfc_walk_expr (gfc_expr *);
+/* Workhorse for gfc_walk_expr. */
+gfc_ss *gfc_walk_subexpr (gfc_ss *, gfc_expr *);
/* Walk the arguments of an elemental function. */
gfc_ss *gfc_walk_elemental_function_args (gfc_ss *, gfc_actual_arglist *,
gfc_ss_type);
@@ -5524,13 +5524,9 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
break;
case GFC_ISYM_TRANSPOSE:
- if (se->ss && se->ss->useflags)
- {
- gfc_conv_tmp_array_ref (se);
- gfc_advance_se_ss_chain (se);
- }
- else
- gfc_conv_array_transpose (se, expr->value.function.actual->expr);
+ /* The scalarizer has already been set up for reversed dimension access
+ order ; now we just get the argument value normally. */
+ gfc_conv_expr (se, expr->value.function.actual->expr);
break;
case GFC_ISYM_LEN:
@@ -5743,6 +5739,64 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
}
+static gfc_ss *
+walk_inline_intrinsic_transpose (gfc_ss *ss, gfc_expr *expr)
+{
+ gfc_ss *arg_ss, *tmp_ss;
+ gfc_actual_arglist *arg;
+
+ arg = expr->value.function.actual;
+
+ gcc_assert (arg->expr);
+
+ arg_ss = gfc_walk_subexpr (gfc_ss_terminator, arg->expr);
+ gcc_assert (arg_ss != gfc_ss_terminator);
+
+ for (tmp_ss = arg_ss; ; tmp_ss = tmp_ss->next)
+ {
+ if (tmp_ss->type != GFC_SS_SCALAR
+ && tmp_ss->type != GFC_SS_REFERENCE)
+ {
+ int tmp_dim;
+ gfc_ss_info *info;
+
+ info = &tmp_ss->data.info;
+ gcc_assert (info->dimen == 2);
+
+ /* We just invert dimensions. */
+ tmp_dim = info->dim[0];
+ info->dim[0] = info->dim[1];
+ info->dim[1] = tmp_dim;
+ }
+
+ /* Stop when tmp_ss points to the last valid element of the chain... */
+ if (tmp_ss->next == gfc_ss_terminator)
+ break;
+ }
+
+ /* ... so that we can attach the rest of the chain to it. */
+ tmp_ss->next = ss;
+
+ return arg_ss;
+}
+
+
+static gfc_ss *
+walk_inline_intrinsic_function (gfc_ss * ss, gfc_expr * expr)
+{
+
+ switch (expr->value.function.isym->id)
+ {
+ case GFC_ISYM_TRANSPOSE:
+ return walk_inline_intrinsic_transpose (ss, expr);
+
+ default:
+ gcc_unreachable ();
+ }
+ gcc_unreachable ();
+}
+
+
/* This generates code to execute before entering the scalarization loop.
Currently does nothing. */
@@ -5803,8 +5857,28 @@ gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
return newss;
}
+
+
+/* Return whether the function call expression EXPR will be expanded
+ inline by gfc_conv_intrinsic_function. */
+bool
+gfc_inline_intrinsic_function_p (gfc_expr *expr)
+{
+ if (!expr->value.function.isym)
+ return false;
+ switch (expr->value.function.isym->id)
+ {
+ case GFC_ISYM_TRANSPOSE:
+ return true;
+
+ default:
+ return false;
+ }
+}
+
+
/* Returns nonzero if the specified intrinsic function call maps directly to
an external library call. Should only be used for functions that return
arrays. */
@@ -5815,6 +5889,9 @@ gfc_is_intrinsic_libcall (gfc_expr * expr)
gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
gcc_assert (expr->rank > 0);
+ if (gfc_inline_intrinsic_function_p (expr))
+ return 0;
+
switch (expr->value.function.isym->id)
{
case GFC_ISYM_ALL:
@@ -5832,7 +5909,6 @@ gfc_is_intrinsic_libcall (gfc_expr * expr)
case GFC_ISYM_SUM:
case GFC_ISYM_SHAPE:
case GFC_ISYM_SPREAD:
- case GFC_ISYM_TRANSPOSE:
case GFC_ISYM_YN2:
/* Ignore absent optional parameters. */
return 1;
@@ -5858,11 +5934,15 @@ gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
gcc_assert (isym);
if (isym->elemental)
- return gfc_walk_elemental_function_args (ss, expr->value.function.actual, GFC_SS_SCALAR);
+ return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
+ GFC_SS_SCALAR);
if (expr->rank == 0)
return ss;
+ if (gfc_inline_intrinsic_function_p (expr))
+ return walk_inline_intrinsic_function (ss, expr);
+
if (gfc_is_intrinsic_libcall (expr))
return gfc_walk_intrinsic_libfunc (ss, expr);
@@ -345,7 +345,12 @@ tree gfc_builtin_decl_for_float_kind (enum built_in_function, int);
/* Intrinsic function handling. */
void gfc_conv_intrinsic_function (gfc_se *, gfc_expr *);
-/* Does an intrinsic map directly to an external library call. */
+/* Is the intrinsic expanded inline. */
+bool gfc_inline_intrinsic_function_p (gfc_expr *);
+
+/* Does an intrinsic map directly to an external library call
+ This is true for array-returning intrinsics, unless
+ gfc_inline_intrinsic_function_p returns true. */
int gfc_is_intrinsic_libcall (gfc_expr *);
tree gfc_conv_intrinsic_move_alloc (gfc_code *);
This is the actual patch (others are regression fixes). We special case walking transpose and invert dimensions there. Then evaluating transpose simplifies to evaluating its argument. The error message in transpose_2.f90 is changed from: Incorrect extent in return value of TRANSPOSE intrinsic in dimension 1: is 2, should be 3 to: Array bound mismatch for dimension 1 of array 'b' (3/2) I prefer the original message, but as the code is invalid, and we output a sensible error message, I've decided not to bother and update the testsuite pattern. There is a last minute regression introduced by this patch. It is fixed by the follow-up patch 11/11, which I intend to commit together with this one so that nothing breaks on trunk (well, hopefully). OK for trunk? 2010-09-03 Mikael Morin <mikael@gcc.gnu.org> * trans-array.c (gfc_conv_array_transpose): Remove. (gfc_walk_subexpr): Make non-static. Move prototype... * trans-array.h (gfc_walk_subexpr): ... here. * trans-intrinsic.c (gfc_conv_intrinsic_function): Update transpose handling. (walk_inline_intrinsic_transpose, walk_inline_intrinsic_function, gfc_inline_intrinsic_function_p): New. (gfc_is_intrinsic_libcall): Return early in inline intrinsic case. Remove transpose from the libcall list. (gfc_walk_intrinsic_function): Special case inline intrinsic. * trans.h (gfc_inline_intrinsic_function_p): New prototype. 2010-09-03 Mikael Morin <mikael@gcc.gnu.org> * gfortran.dg/inline_transpose_1.f90: Update temporary's locations and counts. * gfortran.dg/transpose_2.f90: Update error message. diff --git a/inline_transpose_1.f90 b/inline_transpose_1.f90 index b353a91..0e72402 100644 --- a/inline_transpose_1.f90 +++ b/inline_transpose_1.f90 @@ -1,5 +1,5 @@ ! { dg-do run } -! { dg-options "-fdump-tree-original -Warray-temporaries" } +! { dg-options "-fdump-tree-original -fdump-tree-optimized -Warray-temporaries -fbounds-check" } implicit none @@ -29,7 +29,7 @@ c = transpose(a) if (any(c /= q)) call abort - write(u,*) transpose(a) ! Unnecessary { dg-warning "Creating array temporary" } + write(u,*) transpose(a) write(v,*) q if (u /= v) call abort @@ -37,10 +37,10 @@ e = r f = s - g = transpose(e+f) ! Unnecessary { dg-warning "Creating array temporary" } + g = transpose(e+f) if (any(g /= r + s)) call abort - write(u,*) transpose(e+f) ! 2 Unnecessary temps { dg-warning "Creating array temporary" } + write(u,*) transpose(e+f) write(v,*) r + s if (u /= v) call abort @@ -48,7 +48,7 @@ e = transpose(e) ! { dg-warning "Creating array temporary" } if (any(e /= s)) call abort - write(u,*) transpose(transpose(e)) ! Unnecessary { dg-warning "Creating array temporary" } + write(u,*) transpose(transpose(e)) write(v,*) s if (u /= v) call abort @@ -56,15 +56,15 @@ e = transpose(e+f) ! { dg-warning "Creating array temporary" } if (any(e /= 2*r)) call abort - write(u,*) transpose(transpose(e+f))-f ! 2 Unnecessary temps { dg-warning "Creating array temporary" } + write(u,*) transpose(transpose(e+f))-f write(v,*) 2*r if (u /= v) call abort - a = foo(transpose(c)) + a = foo(transpose(c)) ! Unnecessary { dg-warning "Creating array temporary" } if (any(a /= p+1)) call abort - write(u,*) foo(transpose(c)) ! { dg-warning "Creating array temporary" } + write(u,*) foo(transpose(c)) ! 2 temps, should be 1 { dg-warning "Creating array temporary" } write(v,*) p+1 if (u /= v) call abort @@ -72,15 +72,15 @@ c = transpose(foo(a)) ! Unnecessary { dg-warning "Creating array temporary" } if (any(c /= q+2)) call abort - write(u,*) transpose(foo(a)) ! 2 temps, should be 1 { dg-warning "Creating array temporary" } + write(u,*) transpose(foo(a)) ! { dg-warning "Creating array temporary" } write(v,*) q+2 if (u /= v) call abort - e = foo(transpose(e)) ! { dg-warning "Creating array temporary" } + e = foo(transpose(e)) ! 2 temps, should be 1 { dg-warning "Creating array temporary" } if (any(e /= 2*s+1)) call abort - write(u,*) transpose(foo(transpose(e))-1) ! 3 temps, should be 1 { dg-warning "Creating array temporary" } + write(u,*) transpose(foo(transpose(e))-1) ! 2 temps, should be 1 { dg-warning "Creating array temporary" } write(v,*) 2*s+1 if (u /= v) call abort @@ -88,23 +88,23 @@ e = transpose(foo(e)) ! { dg-warning "Creating array temporary" } if (any(e /= 2*r+2)) call abort - write(u,*) transpose(foo(transpose(e)-1)) ! 4 temps, should be 2 { dg-warning "Creating array temporary" } + write(u,*) transpose(foo(transpose(e)-1)) ! 2 temps { dg-warning "Creating array temporary" } write(v,*) 2*r+2 if (u /= v) call abort - a = bar(transpose(c)) ! Unnecessary { dg-warning "Creating array temporary" } + a = bar(transpose(c)) if (any(a /= p+4)) call abort - write(u,*) bar(transpose(c)) ! Unnecessary { dg-warning "Creating array temporary" } + write(u,*) bar(transpose(c)) write(v,*) p+4 if (u /= v) call abort - c = transpose(bar(a)) ! Unnecessary { dg-warning "Creating array temporary" } + c = transpose(bar(a)) if (any(c /= q+6)) call abort - write(u,*) transpose(bar(a)) ! 2 Unnecessary temps { dg-warning "Creating array temporary" } + write(u,*) transpose(bar(a)) write(v,*) q+6 if (u /= v) call abort @@ -112,7 +112,7 @@ e = bar(transpose(e)) ! { dg-warning "Creating array temporary" } if (any(e /= 2*s+4)) call abort - write(u,*) transpose(bar(transpose(e)))-2 ! 3 Unnecessary temps { dg-warning "Creating array temporary" } + write(u,*) transpose(bar(transpose(e)))-2 write(v,*) 2*s+4 if (u /= v) call abort @@ -120,50 +120,49 @@ e = transpose(bar(e)) ! { dg-warning "Creating array temporary" } if (any(e /= 2*r+6)) call abort - write(u,*) transpose(transpose(bar(e))-2) ! 4 Unnecessary temps { dg-warning "Creating array temporary" } + write(u,*) transpose(transpose(bar(e))-2) write(v,*) 2*r+6 if (u /= v) call abort - if (any(a /= transpose(transpose(a)))) call abort ! Unnecessary { dg-warning "Creating array temporary" } + if (any(a /= transpose(transpose(a)))) call abort ! optimized away write(u,*) a - write(v,*) transpose(transpose(a)) ! Unnecessary { dg-warning "Creating array temporary" } + write(v,*) transpose(transpose(a)) if (u /= v) call abort b = a * a - if (any(transpose(a+b) /= transpose(a)+transpose(b))) call abort ! 4 unnecessary temps { dg-warning "Creating array temporary" } + if (any(transpose(a+b) /= transpose(a)+transpose(b))) call abort ! optimized away - write(u,*) transpose(a+b) ! 2 unnecessary temps { dg-warning "Creating array temporary" } - write(v,*) transpose(a) + transpose(b) ! 2 unnecessary temps { dg-warning "Creating array temporary" } + write(u,*) transpose(a+b) + write(v,*) transpose(a) + transpose(b) if (u /= v) call abort - if (any(transpose(matmul(a,c)) /= matmul(transpose(c), transpose(a)))) call abort ! 3 temps, should be 2 { dg-warning "Creating array temporary" } + if (any(transpose(matmul(a,c)) /= matmul(transpose(c), transpose(a)))) call abort ! 4 temps, should be 2 { dg-warning "Creating array temporary" } - write(u,*) transpose(matmul(a,c)) ! 2 temps, should be 1 { dg-warning "Creating array temporary" } - write(v,*) matmul(transpose(c), transpose(a)) ! { 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" } if (u /= v) call abort - if (any(transpose(matmul(e,a)) /= matmul(transpose(a), transpose(e)))) call abort ! 3 temps, should be 2 { dg-warning "Creating array temporary" } + if (any(transpose(matmul(e,a)) /= matmul(transpose(a), transpose(e)))) call abort ! 4 temps, should be 2 { dg-warning "Creating array temporary" } - write(u,*) transpose(matmul(e,a)) ! 2 temps, should be 1 { dg-warning "Creating array temporary" } - write(v,*) matmul(transpose(a), transpose(e)) ! { 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" } if (u /= v) call abort - call baz (transpose(a)) + call baz (transpose(a)) ! Unnecessary { dg-warning "Creating array temporary" } - call toto (f, transpose (e)) ! Unnecessary { dg-warning "Creating array temporary" } + call toto (f, transpose (e)) if (any (f /= 4 * s + 12)) call abort - call toto (f, transpose (f)) ! { dg-warning "Creating array temporary" } + call toto (f, transpose (f)) ! { dg-warning "Creating array temporary" } if (any (f /= 8 * r + 24)) call abort - contains function foo (x) @@ -189,5 +188,8 @@ end subroutine toto end -! { dg-final { scan-tree-dump-times "struct\[^\\n\]*atmp" 60 "original" } } +! { dg-final { scan-tree-dump-times "struct\[^\\n\]*atmp" 34 "original" } } +! { 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 { cleanup-tree-dump "original" } } +! { dg-final { cleanup-tree-dump "optimized" } } diff --git a/transpose_2.f90 b/transpose_2.f90 index d48651a..37033eb 100644 --- a/transpose_2.f90 +++ b/transpose_2.f90 @@ -15,4 +15,5 @@ program main b = 2.1 b = transpose(a) end program main -! { dg-output "Fortran runtime error: Incorrect extent in return value of TRANSPOSE intrinsic in dimension 1: is 2, should be 3" } +! { dg-output "Fortran runtime error: Array bound mismatch for dimension 1 of +! array 'b' (3/2)" }