File fortran-matmul.patch of Package gcc41
gcc/fortran/
* Make-lang.in (fortran/trans-resolve.o): Depend on
fortran/dependency.h.
* gfortran.h (gfc_expr): Add an "inline_noncopying_intrinsic" flag.
* dependency.h (gfc_get_noncopying_intrinsic_argument): Declare.
(gfc_check_fncall_dependency): Change prototype.
* dependency.c (gfc_get_noncopying_intrinsic_argument): New function.
(gfc_check_argument_var_dependency): New function, split from
gfc_check_fncall_dependency.
(gfc_check_argument_dependency): New function.
(gfc_check_fncall_dependency): Replace the expression parameter with
separate symbol and argument list parameters. Generalize the function
to handle dependencies for any type of expression, not just variables.
Accept a further argument giving the intent of the expression being
tested. Ignore intent(in) arguments if that expression is also
intent(in).
* resolve.c: Include dependency.h.
(find_noncopying_intrinsics): New function.
(resolve_function, resolve_call): Call it on success.
* trans-array.h (gfc_conv_array_transpose): Declare.
(gfc_check_fncall_dependency): Remove prototype.
* trans-array.c (gfc_conv_array_transpose): New function.
* trans-intrinsic.c (gfc_conv_intrinsic_function): Don't use the
libcall handling if the expression is to be evaluated inline.
Add a case for handling inline transpose()s.
* trans-expr.c (gfc_trans_arrayfunc_assign): Adjust for the new
interface provided by gfc_check_fncall_dependency.
libgfortran/
* m4/matmul.m4: Use a different order in the special case of a
transposed first argument.
* generated/matmul_c4.c, generated/matmul_c8.c, generated/matmul_c10.c,
* generated/matmul_c16.c, generated/matmul_i4.c, generated/matmul_i8.c,
* generated/matmul_i10.c, generated/matmul_r4.c, generated/matmul_r8.c
* generated/matmul_r10.c, generated/matmul_r16.c: Regenerated.
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c.orig 2009-05-13 14:27:36.000000000 +0200
--- gcc/fortran/trans-array.c 2009-05-13 14:54:41.000000000 +0200
*************** gfc_trans_allocate_temp_array (stmtblock
*** 726,731 ****
--- 726,820 ----
}
+ /* Generate code to tranpose 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, *src_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;
+
+ src_info = &src_ss->data.info;
+ dest_info = &dest_ss->data.info;
+ gcc_assert (dest_info->dimen == 2);
+ gcc_assert (src_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), "atmp");
+ dest_info->descriptor = dest;
+ se->expr = dest;
+
+ /* Copy across the dtype field. */
+ gfc_add_modify_expr (&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] = integer_zero_node;
+ dest_info->start[n] = integer_zero_node;
+ dest_info->stride[n] = integer_one_node;
+ dest_info->dim[n] = n;
+
+ dest_index = gfc_rank_cst[n];
+ src_index = gfc_rank_cst[1 - n];
+
+ gfc_add_modify_expr (&se->pre,
+ gfc_conv_descriptor_stride (dest, dest_index),
+ gfc_conv_descriptor_stride (src, src_index));
+
+ gfc_add_modify_expr (&se->pre,
+ gfc_conv_descriptor_lbound (dest, dest_index),
+ gfc_conv_descriptor_lbound (src, src_index));
+
+ gfc_add_modify_expr (&se->pre,
+ gfc_conv_descriptor_ubound (dest, dest_index),
+ gfc_conv_descriptor_ubound (src, src_index));
+
+ if (!loop->to[n])
+ {
+ gcc_assert (integer_zerop (loop->from[n]));
+ loop->to[n] = build2 (MINUS_EXPR, gfc_array_index_type,
+ gfc_conv_descriptor_ubound (dest, dest_index),
+ gfc_conv_descriptor_lbound (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. */
+ dest_info->offset = gfc_conv_descriptor_offset (src);
+ gfc_add_modify_expr (&se->pre,
+ gfc_conv_descriptor_offset (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. */
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c.orig 2009-05-13 14:27:36.000000000 +0200
--- gcc/fortran/trans-expr.c 2009-05-13 14:33:26.000000000 +0200
*************** gfc_trans_arrayfunc_assign (gfc_expr * e
*** 3092,3098 ****
}
/* Check for a dependency. */
! if (gfc_check_fncall_dependency (expr1, expr2))
return NULL;
/* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
--- 3092,3100 ----
}
/* Check for a dependency. */
! if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
! expr2->value.function.esym,
! expr2->value.function.actual))
return NULL;
/* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
Index: gcc/fortran/trans-array.h
===================================================================
*** gcc/fortran/trans-array.h.orig 2009-05-13 14:27:36.000000000 +0200
--- gcc/fortran/trans-array.h 2009-05-13 14:33:26.000000000 +0200
*************** void gfc_conv_tmp_ref (gfc_se *);
*** 95,100 ****
--- 95,102 ----
void gfc_conv_expr_descriptor (gfc_se *, gfc_expr *, gfc_ss *);
/* Convert an array for passing as an actual function parameter. */
void gfc_conv_array_parameter (gfc_se *, gfc_expr *, gfc_ss *, int);
+ /* Evaluate and transpose a matrix expression. */
+ void gfc_conv_array_transpose (gfc_se *, gfc_expr *);
/* These work with both descriptors and descriptorless arrays. */
tree gfc_conv_array_data (tree);
*************** tree gfc_conv_descriptor_ubound (tree, t
*** 116,123 ****
/* Dependency checking for WHERE and FORALL. */
int gfc_check_dependency (gfc_expr *, gfc_expr *, gfc_expr **, int);
- /* Dependency checking for function calls. */
- int gfc_check_fncall_dependency (gfc_expr *, gfc_expr *);
/* Add pre-loop scalarization code for intrinsic functions which require
special handling. */
--- 118,123 ----
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c.orig 2009-05-13 14:27:36.000000000 +0200
--- gcc/fortran/resolve.c 2009-05-13 14:33:26.000000000 +0200
*************** Software Foundation, 51 Franklin Street,
*** 26,31 ****
--- 26,32 ----
#include "flags.h"
#include "gfortran.h"
#include "arith.h" /* For gfc_compare_expr(). */
+ #include "dependency.h"
/* Types used in equivalence statements. */
*************** resolve_global_procedure (gfc_symbol *sy
*** 1102,1107 ****
--- 1103,1126 ----
gsym->used = 1;
}
+ /* 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))
+ ap->expr->inline_noncopying_intrinsic = 1;
+ }
+
+
/************* Function resolution *************/
/* Resolve a function call known to be generic.
*************** resolve_function (gfc_expr * expr)
*** 1541,1546 ****
--- 1560,1569 ----
gfc_expr_set_symbols_referenced (expr->ts.cl->length);
}
+ if (t == SUCCESS)
+ find_noncopying_intrinsics (expr->value.function.esym,
+ expr->value.function.actual);
+
return t;
}
*************** resolve_call (gfc_code * c)
*** 1812,1842 ****
/* Resume assumed_size checking. */
need_full_assumed_size--;
- if (c->resolved_sym != NULL)
- return SUCCESS;
! switch (procedure_kind (c->symtree->n.sym))
! {
! case PTYPE_GENERIC:
! t = resolve_generic_s (c);
! break;
! case PTYPE_SPECIFIC:
! t = resolve_specific_s (c);
! break;
! case PTYPE_UNKNOWN:
! t = resolve_unknown_s (c);
! break;
! default:
! gfc_internal_error ("resolve_subroutine(): bad function type");
! }
/* Some checks of elemental subroutine actual arguments. */
if (resolve_elemental_actual (NULL, c) == FAILURE)
return FAILURE;
return t;
}
--- 1835,1867 ----
/* Resume assumed_size checking. */
need_full_assumed_size--;
! t = SUCCESS;
! if (c->resolved_sym == NULL)
! switch (procedure_kind (c->symtree->n.sym))
! {
! case PTYPE_GENERIC:
! t = resolve_generic_s (c);
! break;
! case PTYPE_SPECIFIC:
! t = resolve_specific_s (c);
! break;
! case PTYPE_UNKNOWN:
! t = resolve_unknown_s (c);
! break;
! default:
! gfc_internal_error ("resolve_subroutine(): bad function type");
! }
/* Some checks of elemental subroutine actual arguments. */
if (resolve_elemental_actual (NULL, c) == FAILURE)
return FAILURE;
+ if (t == SUCCESS)
+ find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
return t;
}
Index: gcc/fortran/Make-lang.in
===================================================================
*** gcc/fortran/Make-lang.in.orig 2009-05-13 14:27:36.000000000 +0200
--- gcc/fortran/Make-lang.in 2009-05-13 14:33:26.000000000 +0200
*************** fortran/trans-intrinsic.o: $(GFORTRAN_TR
*** 295,298 ****
--- 295,299 ----
gt-fortran-trans-intrinsic.h
fortran/dependency.o: $(GFORTRAN_TRANS_DEPS) fortran/dependency.h
fortran/trans-common.o: $(GFORTRAN_TRANS_DEPS)
+ fortran/resolve.o: fortran/dependency.h
Index: gcc/fortran/gfortran.h
===================================================================
*** gcc/fortran/gfortran.h.orig 2009-05-13 14:27:36.000000000 +0200
--- gcc/fortran/gfortran.h 2009-05-13 14:33:26.000000000 +0200
*************** typedef struct gfc_expr
*** 1164,1169 ****
--- 1164,1172 ----
/* True if it is converted from Hollerith constant. */
unsigned int from_H : 1;
+ /* 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. */
+ unsigned int inline_noncopying_intrinsic : 1;
union
{
Index: gcc/fortran/dependency.c
===================================================================
*** gcc/fortran/dependency.c.orig 2009-05-13 14:27:36.000000000 +0200
--- gcc/fortran/dependency.c 2009-05-13 14:33:26.000000000 +0200
*************** gfc_is_same_range (gfc_array_ref * ar1,
*** 175,180 ****
--- 175,206 ----
}
+ /* Some array-returning intrinsics can be implemented by reusing the
+ data from one of the array arguments. For example, TRANPOSE does
+ not necessarily need to allocate new data: it can be implemented
+ by copying the original array's descriptor and simply swapping the
+ two dimension specifications.
+
+ If EXPR is a call to such an intrinsic, return the argument
+ whose data can be reused, otherwise return NULL. */
+
+ gfc_expr *
+ gfc_get_noncopying_intrinsic_argument (gfc_expr * expr)
+ {
+ if (expr->expr_type != EXPR_FUNCTION || !expr->value.function.isym)
+ return NULL;
+
+ switch (expr->value.function.isym->generic_id)
+ {
+ case GFC_ISYM_TRANSPOSE:
+ return expr->value.function.actual->expr;
+
+ default:
+ return NULL;
+ }
+ }
+
+
/* Return true if the result of reference REF can only be constructed
using a temporary array. */
*************** gfc_ref_needs_temporary_p (gfc_ref *ref)
*** 214,236 ****
}
! /* Dependency checking for direct function return by reference.
! Returns true if the arguments of the function depend on the
! destination. This is considerably less conservative than other
! dependencies because many function arguments will already be
! copied into a temporary. */
int
! gfc_check_fncall_dependency (gfc_expr * dest, gfc_expr * fncall)
{
! gfc_actual_arglist *actual;
gfc_expr *expr;
! gcc_assert (dest->expr_type == EXPR_VARIABLE
! && fncall->expr_type == EXPR_FUNCTION);
! gcc_assert (fncall->rank > 0);
!
! for (actual = fncall->value.function.actual; actual; actual = actual->next)
{
expr = actual->expr;
--- 240,321 ----
}
! /* Return true if array variable VAR could be passed to the same function
! as argument EXPR without interfering with EXPR. INTENT is the intent
! of VAR.
!
! This is considerably less conservative than other dependencies
! because many function arguments will already be copied into a
! temporary. */
!
! static int
! gfc_check_argument_var_dependency (gfc_expr * var, sym_intent intent,
! gfc_expr * expr)
! {
! gcc_assert (var->expr_type == EXPR_VARIABLE);
! gcc_assert (var->rank > 0);
!
! switch (expr->expr_type)
! {
! case EXPR_VARIABLE:
! return (gfc_ref_needs_temporary_p (expr->ref)
! || gfc_check_dependency (var, expr, NULL, 0));
!
! case EXPR_ARRAY:
! return gfc_check_dependency (var, expr, NULL, 0);
!
! case EXPR_FUNCTION:
! if (intent != INTENT_IN && expr->inline_noncopying_intrinsic)
! {
! expr = gfc_get_noncopying_intrinsic_argument (expr);
! return gfc_check_argument_var_dependency (var, intent, expr);
! }
! return 0;
!
! default:
! return 0;
! }
! }
!
!
! /* Like gfc_check_argument_var_dependency, but extended to any
! array expression OTHER, not just variables. */
!
! static int
! gfc_check_argument_dependency (gfc_expr * other, sym_intent intent,
! gfc_expr * expr)
! {
! switch (other->expr_type)
! {
! case EXPR_VARIABLE:
! return gfc_check_argument_var_dependency (other, intent, expr);
!
! case EXPR_FUNCTION:
! if (other->inline_noncopying_intrinsic)
! {
! other = gfc_get_noncopying_intrinsic_argument (other);
! return gfc_check_argument_dependency (other, INTENT_IN, expr);
! }
! return 0;
!
! default:
! return 0;
! }
! }
!
!
! /* Like gfc_check_argument_dependency, but check all the arguments in ACTUAL.
! FNSYM is the function being called, or NULL if not known. */
int
! gfc_check_fncall_dependency (gfc_expr * other, sym_intent intent,
! gfc_symbol * fnsym, gfc_actual_arglist * actual)
{
! gfc_formal_arglist *formal;
gfc_expr *expr;
! formal = fnsym ? fnsym->formal : NULL;
! for (; actual; actual = actual->next, formal = formal ? formal->next : NULL)
{
expr = actual->expr;
*************** gfc_check_fncall_dependency (gfc_expr *
*** 238,260 ****
if (!expr)
continue;
! /* Non-variable expressions will be allocated temporaries anyway. */
! switch (expr->expr_type)
! {
! case EXPR_VARIABLE:
! if (!gfc_ref_needs_temporary_p (expr->ref)
! && gfc_check_dependency (dest, expr, NULL, 0))
! return 1;
! break;
!
! case EXPR_ARRAY:
! if (gfc_check_dependency (dest, expr, NULL, 0))
! return 1;
! break;
! default:
! break;
! }
}
return 0;
--- 323,336 ----
if (!expr)
continue;
! /* Skip intent(in) arguments if OTHER itself is intent(in). */
! if (formal
! && intent == INTENT_IN
! && formal->sym->attr.intent == INTENT_IN)
! continue;
! if (gfc_check_argument_dependency (other, intent, expr))
! return 1;
}
return 0;
Index: gcc/fortran/dependency.h
===================================================================
*** gcc/fortran/dependency.h.orig 2009-05-13 14:27:36.000000000 +0200
--- gcc/fortran/dependency.h 2009-05-13 14:33:26.000000000 +0200
*************** Software Foundation, 51 Franklin Street,
*** 22,28 ****
bool gfc_ref_needs_temporary_p (gfc_ref *);
! int gfc_check_fncall_dependency (gfc_expr *, gfc_expr *);
int gfc_check_dependency (gfc_expr *, gfc_expr *, gfc_expr **, int);
int gfc_is_same_range (gfc_array_ref *, gfc_array_ref *, int, int);
int gfc_expr_is_one (gfc_expr *, int);
--- 22,30 ----
bool gfc_ref_needs_temporary_p (gfc_ref *);
! gfc_expr *gfc_get_noncopying_intrinsic_argument (gfc_expr *);
! int gfc_check_fncall_dependency (gfc_expr *, sym_intent, gfc_symbol *,
! gfc_actual_arglist *);
int gfc_check_dependency (gfc_expr *, gfc_expr *, gfc_expr **, int);
int gfc_is_same_range (gfc_array_ref *, gfc_array_ref *, int, int);
int gfc_expr_is_one (gfc_expr *, int);
Index: gcc/fortran/trans-intrinsic.c
===================================================================
*** gcc/fortran/trans-intrinsic.c.orig 2009-05-13 14:27:36.000000000 +0200
--- gcc/fortran/trans-intrinsic.c 2009-05-13 14:33:26.000000000 +0200
*************** gfc_conv_intrinsic_function (gfc_se * se
*** 3538,3544 ****
name = &expr->value.function.name[2];
! if (expr->rank > 0)
{
lib = gfc_is_intrinsic_libcall (expr);
if (lib != 0)
--- 3538,3544 ----
name = &expr->value.function.name[2];
! if (expr->rank > 0 && !expr->inline_noncopying_intrinsic)
{
lib = gfc_is_intrinsic_libcall (expr);
if (lib != 0)
*************** gfc_conv_intrinsic_function (gfc_se * se
*** 3767,3772 ****
--- 3767,3782 ----
gfc_conv_intrinsic_bound (se, expr, 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);
+ break;
+
case GFC_ISYM_LEN:
gfc_conv_intrinsic_len (se, expr);
break;
