+2010-09-11 Mikael Morin <mikael@gcc.gnu.org>
+
+ * gfortran.h (gfc_expr): Remove inline_noncopying_intrinsic attribute.
+ * dependency.c (gfc_check_dependency): Don't depend on
+ expr's inline_noncopying_intrinsic_attribute.
+ * dependency.c (gfc_check_argument_var_dependency,
+ gfc_check_argument_dependency): Ditto. Recursively check dependency
+ as NOT_ELEMENTAL in the non-copying (=transpose) case.
+ * trans-intrinsic.c (gfc_conv_intrinsic_function): Ditto.
+ * resolve.c (find_noncopying_intrinsics): Remove.
+ (resolve_function, resolve_call): Remove call to
+ find_noncopying_intrinsics.
+
+ * 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-10 Mikael Morin <mikael@gcc.gnu.org>
* trans-expr.c (expr_is_variable): New function taking non-copying
return gfc_check_dependency (var, expr, 1);
case EXPR_FUNCTION:
- if (intent != INTENT_IN && expr->inline_noncopying_intrinsic
- && (arg = gfc_get_noncopying_intrinsic_argument (expr))
- && gfc_check_argument_var_dependency (var, intent, arg, elemental))
- return 1;
- if (elemental)
+ if (intent != INTENT_IN)
+ {
+ arg = gfc_get_noncopying_intrinsic_argument (expr);
+ if (arg != NULL)
+ return gfc_check_argument_var_dependency (var, intent, arg,
+ NOT_ELEMENTAL);
+ }
+
+ if (elemental != NOT_ELEMENTAL)
{
if ((expr->value.function.esym
&& expr->value.function.esym->attr.elemental)
return gfc_check_argument_var_dependency (other, intent, expr, elemental);
case EXPR_FUNCTION:
- if (other->inline_noncopying_intrinsic)
- {
- other = gfc_get_noncopying_intrinsic_argument (other);
- return gfc_check_argument_dependency (other, INTENT_IN, expr,
- elemental);
- }
+ other = gfc_get_noncopying_intrinsic_argument (other);
+ if (other != NULL)
+ return gfc_check_argument_dependency (other, INTENT_IN, expr,
+ NOT_ELEMENTAL);
+
return 0;
default:
return 1;
case EXPR_FUNCTION:
- if (expr2->inline_noncopying_intrinsic)
+ if (gfc_get_noncopying_intrinsic_argument (expr2) != NULL)
identical = 1;
+
/* Remember possible differences between elemental and
transformational functions. All functions inside a FORALL
will be pure. */
locus where;
- /* True if the expression is a call to a function that returns an array,
- and if we have decided not to allocate temporary data for that array.
- is_boz is true if the integer is regarded as BOZ bitpatten and is_snan
+ /* is_boz is true if the integer is regarded as BOZ bitpatten and is_snan
denotes a signalling not-a-number. */
- unsigned int inline_noncopying_intrinsic : 1, is_boz : 1, is_snan : 1;
+ unsigned int is_boz : 1, is_snan : 1;
/* Sometimes, when an error has been emitted, it is necessary to prevent
it from recurring. */
}
-/* Go through each actual argument in ACTUAL and see if it can be
- implemented as an inlined, non-copying intrinsic. FNSYM is the
- function being called, or NULL if not known. */
-
-static void
-find_noncopying_intrinsics (gfc_symbol *fnsym, gfc_actual_arglist *actual)
-{
- gfc_actual_arglist *ap;
- gfc_expr *expr;
-
- for (ap = actual; ap; ap = ap->next)
- if (ap->expr
- && (expr = gfc_get_noncopying_intrinsic_argument (ap->expr))
- && !gfc_check_fncall_dependency (expr, INTENT_IN, fnsym, actual,
- NOT_ELEMENTAL))
- ap->expr->inline_noncopying_intrinsic = 1;
-}
-
-
/* This function does the checking of references to global procedures
as defined in sections 18.1 and 14.1, respectively, of the Fortran
77 and 95 standards. It checks for a gsymbol for the name, making
gfc_expr_set_symbols_referenced (expr->ts.u.cl->length);
}
- if (t == SUCCESS
- && !((expr->value.function.esym
- && expr->value.function.esym->attr.elemental)
- ||
- (expr->value.function.isym
- && expr->value.function.isym->elemental)))
- find_noncopying_intrinsics (expr->value.function.esym,
- expr->value.function.actual);
-
/* Make sure that the expression has a typespec that works. */
if (expr->ts.type == BT_UNKNOWN)
{
if (resolve_elemental_actual (NULL, c) == FAILURE)
return FAILURE;
- if (t == SUCCESS && !(c->resolved_sym && c->resolved_sym->attr.elemental))
- find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
return t;
}
#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. */
}
-/* 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_loc (input_location, 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. */
/* 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;
/* 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);
name = &expr->value.function.name[2];
- if (expr->rank > 0 && !expr->inline_noncopying_intrinsic)
+ if (expr->rank > 0)
{
lib = gfc_is_intrinsic_libcall (expr);
if (lib != 0)
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:
}
+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. */
}
+/* 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. */
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:
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;
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);
/* 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 *);
+2010-09-11 Mikael Morin <mikael@gcc.gnu.org>
+
+ * gfortran.dg/inline_transpose_1.f90: Update temporary's locations
+ and counts. Check that transpose is not called.
+ * gfortran.dg/transpose_2.f90: Update error message.
+
2010-09-10 Rodrigo Rivas Costa <rodrigorivascosta@gmail.com>
PR c++/43824
! { dg-do run }
-! { dg-options "-fdump-tree-original -Warray-temporaries" }
+! { dg-options "-fdump-tree-original -fdump-tree-optimized -Warray-temporaries -fbounds-check" }
implicit none
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
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
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
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
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
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
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
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" }
end subroutine toto
end
-! { dg-final { scan-tree-dump-times "struct\[^\\n\]*atmp" 60 "original" } }
-! { dg-final { cleanup-tree-dump "original" } }
+! 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" } }
+!
+! 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" } }
+!
+! cleanup
+! { #dg-final { cleanup-tree-dump "original" } }
+! { dg-final { cleanup-tree-dump "optimized" } }
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)" }
projects / thirdparty / gcc.git / commitdiff
