This is the mail archive of the gcc-patches@gcc.gnu.org mailing list for the GCC project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

[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

Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]