This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[Patch, fortran] PR17298 - Array valued TRANSFER intrinsic
- From: Paul Thomas <paulthomas2 at wanadoo dot fr>
- To: Steve Kargl <sgk at troutmask dot apl dot washington dot edu>
- Cc: "'fortran at gcc dot gnu dot org'" <fortran at gcc dot gnu dot org>, patch <gcc-patches at gcc dot gnu dot org>, Tobias Schlüter <tobias dot schlueter at physik dot uni-muenchen dot de>
- Date: Thu, 16 Mar 2006 22:21:03 +0100
- Subject: [Patch, fortran] PR17298 - Array valued TRANSFER intrinsic
:ADDPATCH fortran:
This patch adds the array valued version of the TRANSFER intrinsic,
which is PR17298 and various of its friends. It does NOT, however, fix
PR18769 that uses transfer in an initialization expression. This is
another bug altogether and requires that initializers be able to cope
with expressions that are not simplifiable to a constant.
Steve Kargl and I have both concluded that TRANSFER would be an
exceedingly fecund .m4 macro. The fact that three arguments are
involved, one of which is optional an another being scalar or array,
just results in way too many separate library functions.
Having written a front-end version, I am now not quite so convinced of
that it would not have been much less work to write the macro! That
said, it is now done and seems to work correctly.
The patch borrows heavily from trans-expr.c(gfc_conv_function_call) and
trans-array.c(gfc_conv_array_parameter). The arguments are treated one
after another without a loop because they all do different things.
The call is as follows:
DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
where:
typeof<DEST> = typeof<MOLD>
and:
N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
sizeof (DEST(0) * SIZE).
The argument SOURCE is converted into a pointer to the data to be
transferred and a total size of the source, in bytes. The data pointed
to is packed, if necessary.
MOLD is only required for the destination word length in bytes. The
resolution stage has already made sure that the destination type and
kind information appear in the expression for the function call.
SIZE, if it is present, is converted into the number of bytes to be
transferred; ie. the actual argument multiplied by the destination word
length.
Much of the code is concerned with ensuring that the number of bytes
actually transferred is the minimum of the total source length, size in
bytes and, if it is not a temporary, the destination length. The
correctness of these conditions is probed in the testcases.
A temporary descriptor is passed as the gfc_se expression, whose pointer
is either directly to SOURCE or to the packed version of SOURCE.
Unpacking is not necessary because SOURCE is unchanged by the transfer.
However, packed data is freed.
The first testcase represents a history of the problems that I
encountered along the way. As such, it is probably unnecessarily
detailed but it does test most, if not all, the essential features. The
second is a limited foray into transferring derived types. This, of
course, requires the code be compiled with -fpack-derived to do anything
transportable.
One nice thing about such a patch is that it cannot break anything that
already worked, being hidden behind an ICE, and that the regtesting is
rather trivial in consequence.
In spite of that:- regtested on FC3/Athlon1700. OK for mainline?
Paul
2006-03-16 Paul Thomas <pault@gcc.gnu.org>
PR fortran/17298
*trans-intrinsic.c (gfc_conv_intrinsic_array_transfer): New function
to implement array valued TRANSFER intrinsic.
(gfc_conv_intrinsic_function): Call the new function if TRANSFER
and non-null se->ss.
(gfc_walk_intrinsic_function): Treat TRANSFER as one of the special
cases by calling gfc_walk_intrinsic_libfunc directly.
2006-03-16 Paul Thomas <pault@gcc.gnu.org>
PR fortran/17298
* gfortran.dg/transfer_array_intrinsic_1.f90: New test.
* gfortran.dg/transfer_array_intrinsic_2.f90: New test.
Index: gcc/fortran/trans-intrinsic.c
===================================================================
*** gcc/fortran/trans-intrinsic.c (revision 112139)
--- gcc/fortran/trans-intrinsic.c (working copy)
*************** gfc_conv_intrinsic_adjust (gfc_se * se,
*** 2461,2466 ****
--- 2461,2681 ----
}
+ /* Array transfer statement.
+ DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
+ where:
+ typeof<DEST> = typeof<MOLD>
+ and:
+ N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
+ sizeof (DEST(0) * SIZE). */
+
+ static void
+ gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr)
+ {
+ tree tmp;
+ tree extent;
+ tree source;
+ tree source_bytes;
+ tree dest_word_len;
+ tree size_words;
+ tree size_bytes;
+ tree upper;
+ tree lower;
+ tree stride;
+ tree stmt;
+ gfc_actual_arglist *arg;
+ gfc_se argse;
+ gfc_ss *ss;
+ gfc_ss_info *info;
+ stmtblock_t block;
+ int n;
+
+ gcc_assert (se->loop);
+ info = &se->ss->data.info;
+
+ /* Convert SOURCE. The output from this stage is:-
+ source_bytes = length of the source in bytes
+ source = pointer to the source data. */
+ arg = expr->value.function.actual;
+ gfc_init_se (&argse, NULL);
+ ss = gfc_walk_expr (arg->expr);
+
+ source_bytes = gfc_create_var (gfc_array_index_type, NULL);
+
+ /* Obtain the pointer to source and the length of source in bytes. */
+ if (ss == gfc_ss_terminator)
+ {
+ gfc_conv_expr_reference (&argse, arg->expr);
+ source = argse.expr;
+
+ /* Obtain the source word length. */
+ tmp = size_in_bytes(TREE_TYPE(TREE_TYPE (source)));
+ tmp = fold_convert (gfc_array_index_type, tmp);
+ }
+ else
+ {
+ gfc_init_se (&argse, NULL);
+ argse.want_pointer = 0;
+ gfc_conv_expr_descriptor (&argse, arg->expr, ss);
+ source = gfc_conv_descriptor_data_get (argse.expr);
+
+ /* Repack the source if not a full variable array. */
+ if (!(arg->expr->expr_type == EXPR_VARIABLE
+ && arg->expr->ref->u.ar.type == AR_FULL))
+ {
+ tmp = build_fold_addr_expr (argse.expr);
+ tmp = gfc_chainon_list (NULL_TREE, tmp);
+ source = build_function_call_expr (gfor_fndecl_in_pack, tmp);
+ source = gfc_evaluate_now (source, &argse.pre);
+
+ /* Free the temporary. */
+ gfc_start_block (&block);
+ tmp = convert (pvoid_type_node, source);
+ tmp = gfc_chainon_list (NULL_TREE, tmp);
+ tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
+ gfc_add_expr_to_block (&block, tmp);
+ stmt = gfc_finish_block (&block);
+
+ /* Clean up if it was repacked. */
+ gfc_init_block (&block);
+ tmp = gfc_conv_array_data (argse.expr);
+ tmp = build2 (NE_EXPR, boolean_type_node, source, tmp);
+ tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
+ gfc_add_expr_to_block (&block, tmp);
+ gfc_add_block_to_block (&block, &se->post);
+ gfc_init_block (&se->post);
+ gfc_add_block_to_block (&se->post, &block);
+ }
+
+ /* Obtain the source word length. */
+ tmp = gfc_get_element_type (TREE_TYPE(argse.expr));
+ tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
+
+ /* Obtain the size of the array in bytes. */
+ extent = gfc_create_var (gfc_array_index_type, NULL);
+ for (n = 0; n < arg->expr->rank; n++)
+ {
+ tree idx;
+ idx = gfc_rank_cst[n];
+ gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
+ stride = gfc_conv_descriptor_stride (argse.expr, idx);
+ lower = gfc_conv_descriptor_lbound (argse.expr, idx);
+ upper = gfc_conv_descriptor_ubound (argse.expr, idx);
+ tmp = build2 (MINUS_EXPR, gfc_array_index_type,
+ upper, lower);
+ gfc_add_modify_expr (&argse.pre, extent, tmp);
+ tmp = build2 (PLUS_EXPR, gfc_array_index_type,
+ extent, gfc_index_one_node);
+ tmp = build2 (MULT_EXPR, gfc_array_index_type,
+ tmp, source_bytes);
+ }
+ }
+
+ gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
+ gfc_add_block_to_block (&se->pre, &argse.pre);
+ gfc_add_block_to_block (&se->post, &argse.post);
+
+ /* Now convert MOLD. The sole output is:
+ dest_word_len = destination word length in bytes. */
+ arg = arg->next;
+
+ gfc_init_se (&argse, NULL);
+ ss = gfc_walk_expr (arg->expr);
+
+ if (ss == gfc_ss_terminator)
+ {
+ gfc_conv_expr_reference (&argse, arg->expr);
+ tmp = TREE_TYPE(TREE_TYPE (argse.expr));
+ tmp = fold_convert (gfc_array_index_type, size_in_bytes(tmp));
+ }
+ else
+ {
+ gfc_init_se (&argse, NULL);
+ argse.want_pointer = 0;
+ gfc_conv_expr_descriptor (&argse, arg->expr, ss);
+ tmp = gfc_get_element_type (TREE_TYPE(argse.expr));
+ tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
+ }
+
+ dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
+ gfc_add_modify_expr (&se->pre, dest_word_len, tmp);
+
+ /* Finally convert SIZE, if it is present. */
+ arg = arg->next;
+ size_words = gfc_create_var (gfc_array_index_type, NULL);
+
+ if (arg->expr)
+ {
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr_reference (&argse, arg->expr);
+ tmp = convert (gfc_array_index_type,
+ build_fold_indirect_ref (argse.expr));
+ gfc_add_block_to_block (&se->pre, &argse.pre);
+ gfc_add_block_to_block (&se->post, &argse.post);
+ }
+ else
+ tmp = NULL_TREE;
+
+ size_bytes = gfc_create_var (gfc_array_index_type, NULL);
+ if (tmp != NULL_TREE)
+ {
+ tmp = build2 (MULT_EXPR, gfc_array_index_type,
+ tmp, dest_word_len);
+ tmp = build2 (MIN_EXPR, gfc_array_index_type, tmp, source_bytes);
+ }
+ else
+ tmp = source_bytes;
+
+ gfc_add_modify_expr (&se->pre, size_bytes, tmp);
+ gfc_add_modify_expr (&se->pre, size_words,
+ build2 (CEIL_DIV_EXPR, gfc_array_index_type,
+ size_bytes, dest_word_len));
+
+ /* Evaluate the bounds of the result. If the loop range exists, we have
+ to check if it is too large. If so, we modify loop->to be consistent
+ with min(size, size(source)). Otherwise, size is made consistent with
+ the loop range, so that the right number of bytes is transferred.*/
+ n = se->loop->order[0];
+ if (se->loop->to[n] != NULL_TREE)
+ {
+ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ se->loop->to[n], se->loop->from[n]);
+ tmp = build2 (PLUS_EXPR, gfc_array_index_type,
+ tmp, gfc_index_one_node);
+ tmp = build2 (MIN_EXPR, gfc_array_index_type,
+ tmp, size_words);
+ gfc_add_modify_expr (&se->pre, size_words, tmp);
+ gfc_add_modify_expr (&se->pre, size_bytes,
+ build2 (MULT_EXPR, gfc_array_index_type,
+ size_words, dest_word_len));
+ upper = build2 (PLUS_EXPR, gfc_array_index_type,
+ size_words, se->loop->from[n]);
+ upper = build2 (MINUS_EXPR, gfc_array_index_type,
+ upper, gfc_index_one_node);
+ }
+ else
+ {
+ upper = build2 (MINUS_EXPR, gfc_array_index_type,
+ size_words, gfc_index_one_node);
+ se->loop->from[n] = gfc_index_zero_node;
+ }
+
+ se->loop->to[n] = upper;
+
+ /* Build a destination descriptor, using the pointer, source, as the
+ data field. This is already allocated so set callee_alloc. */
+ tmp = gfc_typenode_for_spec (&expr->ts);
+ gfc_trans_create_temp_array (&se->pre, &se->post, se->loop,
+ info, tmp, false, false, true);
+
+ tmp = fold_convert (pvoid_type_node, source);
+ gfc_conv_descriptor_data_set (&se->pre, info->descriptor, tmp);
+ se->expr = info->descriptor;
+ if (expr->ts.type == BT_CHARACTER)
+ se->string_length = dest_word_len;
+ }
+
+
/* Scalar transfer statement.
TRANSFER (source, mold) = *(typeof<mold> *)&source. */
*************** gfc_conv_intrinsic_transfer (gfc_se * se
*** 2473,2480 ****
tree ptr;
gfc_ss *ss;
- gcc_assert (!se->ss);
-
/* Get a pointer to the source. */
arg = expr->value.function.actual;
ss = gfc_walk_expr (arg->expr);
--- 2688,2693 ----
*************** gfc_conv_intrinsic_function (gfc_se * se
*** 3374,3380 ****
break;
case GFC_ISYM_TRANSFER:
! gfc_conv_intrinsic_transfer (se, expr);
break;
case GFC_ISYM_TTYNAM:
--- 3587,3606 ----
break;
case GFC_ISYM_TRANSFER:
! if (se->ss)
! {
! if (se->ss->useflags)
! {
! /* Access the previously obtained result. */
! gfc_conv_tmp_array_ref (se);
! gfc_advance_se_ss_chain (se);
! break;
! }
! else
! gfc_conv_intrinsic_array_transfer (se, expr);
! }
! else
! gfc_conv_intrinsic_transfer (se, expr);
break;
case GFC_ISYM_TTYNAM:
*************** gfc_walk_intrinsic_function (gfc_ss * ss
*** 3558,3563 ****
--- 3784,3792 ----
case GFC_ISYM_UBOUND:
return gfc_walk_intrinsic_bound (ss, expr);
+ case GFC_ISYM_TRANSFER:
+ return gfc_walk_intrinsic_libfunc (ss, expr);
+
default:
/* This probably meant someone forgot to add an intrinsic to the above
list(s) when they implemented it, or something's gone horribly wrong.
Index: gcc/testsuite/gfortran.dg/transfer_array_intrinsic_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/transfer_array_intrinsic_1.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/transfer_array_intrinsic_1.f90 (revision 0)
***************
*** 0 ****
--- 1,118 ----
+ ! { dg-do run }
+ ! Tests the patch to implement the array version of the TRANSFER
+ ! intrinsic (PR17298).
+ ! Contributed by Paul Thomas <pault@gcc.gnu.org>
+
+ character(8) :: ch(2) = (/"lmnoPQRS","LMNOpqrs"/)
+
+ ! tests numeric transfers(including PR testcase).
+
+ call test1 ()
+
+ ! tests numeric/character transfers.
+
+ call test2 ()
+
+ ! Test dummies, automatic objects and assumed character length.
+
+ call test3 (ch, ch, ch, 8)
+
+ contains
+
+ subroutine test1 ()
+ complex(4) :: z = (1.0, 2.0)
+ real(4) :: cmp(2), a(4, 4)
+ integer(2) :: it(4, 2, 4), jt(32)
+
+ ! The PR testcase.
+
+ cmp = transfer (z, cmp) * 2.0
+ if (any (cmp .ne. (/2.0, 4.0/))) call abort ()
+
+ ! Check that size smaller than the source word length is OK.
+
+ z = (-1.0, -2.0)
+ cmp = transfer (z, cmp, 1) * 8.0
+ if (any (cmp .ne. (/-8.0, 4.0/))) call abort ()
+
+ ! Check multi-dimensional sources and that transfer works as an actual
+ ! argument of reshape.
+
+ a = reshape ((/(rand (), i = 1, 16)/), (/4,4/))
+ jt = transfer (a, it)
+ it = reshape (jt, (/4, 2, 4/))
+ if (any (reshape (transfer (it, a), (/4,4/)) .ne. a)) call abort ()
+
+ end subroutine test1
+
+ subroutine test2 ()
+ integer(4) :: y(4), z(2)
+ character(4) :: ch(4)
+ y = (/(i + ishft (i + 1, 8) + ishft (i + 2, 16) &
+ + ishft (i + 3, 24), i = 65, 80 , 4)/)
+
+ ! Check source array sections in both directions.
+
+ ch = "wxyz"
+ ch = transfer (y(2:4:2), ch)
+ if (any (ch .ne. (/"EFGH","MNOP","wxyz","wxyz"/))) call abort ()
+ ch = "wxyz"
+ ch = transfer (y(4:2:-2), ch)
+ if (any (ch .ne. (/"MNOP","EFGH","wxyz","wxyz"/))) call abort ()
+
+ ! Check that a complete array transfers with size absent.
+
+ ch = transfer (y, ch)
+ if (any (ch .ne. (/"ABCD","EFGH","IJKL","MNOP"/))) call abort ()
+
+ ! Check that a character array section is OK
+
+ z = transfer (ch(2:3), y)
+ if (any (z .ne. y(2:3))) call abort ()
+
+ ! Check dest array sections in both directions.
+
+ ch = "wxyz"
+ ch(3:4) = transfer (y, ch, 2)
+ if (any (ch .ne. (/"wxyz","wxyz","ABCD","EFGH"/))) call abort ()
+ ch = "wxyz"
+ ch(3:2:-1) = transfer (y, ch, 3)
+ if (any (ch .ne. (/"wxyz","EFGH","ABCD","wxyz"/))) call abort ()
+
+ ! Check that too large a value of size is cut off.
+
+ ch = "wxyz"
+ ch(1:2) = transfer (y, ch, 3)
+ if (any (ch .ne. (/"ABCD","EFGH","wxyz","wxyz"/))) call abort ()
+
+ ! Make sure that character to numeric is OK.
+
+ z = transfer (ch, y)
+ if (any (y(1:2) .ne. z)) call abort ()
+
+ end subroutine test2
+
+ subroutine test3 (ch1, ch2, ch3, clen)
+ integer clen
+ character(8) :: ch1(:)
+ character(*) :: ch2(2)
+ character(clen) :: ch3(2)
+ character(8) :: cntrl(2) = (/"lmnoPQRS","LMNOpqrs"/)
+ integer(8) :: ic(2)
+ ic = transfer (cntrl, ic)
+
+ ! Check assumed shape.
+
+ if (any (ic .ne. transfer (ch1, ic))) call abort ()
+
+ ! Check assumed character length.
+
+ if (any (ic .ne. transfer (ch2, ic))) call abort ()
+
+ ! Check automatic character length.
+
+ if (any (ic .ne. transfer (ch3, ic))) call abort ()
+
+ end subroutine test3
+
+ end
Index: gcc/testsuite/gfortran.dg/transfer_array_intrinsic_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/transfer_array_intrinsic_2.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/transfer_array_intrinsic_2.f90 (revision 0)
***************
*** 0 ****
--- 1,23 ----
+ ! { dg-do run }
+ ! { dg-options "-fpack-derived" }
+ call test3()
+ contains
+ subroutine test3 ()
+ type mytype
+ sequence
+ real(8) :: x = 3.14159
+ character(4) :: ch = "wxyz"
+ integer(2) :: i = 77
+ end type mytype
+ type(mytype) :: z(2)
+ character(1) :: c(32)
+ character(4) :: chr
+ real(8) :: a
+ integer(2) :: l
+ equivalence (a, c(15)), (chr, c(23)), (l, c(27))
+ c = transfer(z, c)
+ if (a .ne. z(1)%x) call abort ()
+ if (chr .ne. z(1)%ch) call abort ()
+ if (l .ne. z(1)%i) call abort ()
+ end subroutine test3
+ end