This is the mail archive of the fortran@gcc.gnu.org mailing list for the GNU Fortran 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]

(Re)allocation of allocatable arrays on assignment - F2003


Dear All,

At a recent #gfortran meeting, I undertook to implement the F2003
feature of automatic (re)allocation of allocatable arrays.  As usual,
what I thought would be a simple task turned out to be not quite
so..... Although the patch is not so big, it intervenes to modify some
of the values for loop->to's and array references already established
by the scalarizer.  With hindsight it looks simple but I did not get
there as fast as I would have liked :-(

An additional wrinkle is that the translation of array constructors
with variable length took me a bit unaware because the loop->to value
is established by the lhs, in this case.  Thus, where realloaction
needs to occur, the array descriptor bounds and the loop->to have to
be adjusted to the actual size of the array.

There is a list of TODOs in the testcase below.  However, before I
leap on a plane to Korea, for our biennial international conference, I
thought that I would let you see where I have got to.  It bootstraps
and regtests on RHEL5.3/i686.

The most important input that I need from the world at large is how to
minimize the impact on legacy code; ie. whether this should be the
F2003 default.  My opinion is that it should be, even if this brings
some penalty with it.  I have some ideas how to ameliorate this
problem that appear in the TODOs.

Cheers

Paul

! { dg-do run }
! Tests the patch that implements F2003 automatic allocation and
! reallocation of allocatable arrays on assignment.
!
! TODO:
! 1] Discuss on list whether this should be the default.
! 2] Understand why the branch to allocation is not working in the
!    case that an array is in an undefined state - see below for
!    the assignment to b.
! 3] Check all the modifications to trans-array.c very carefully.
! 4] Insert and overall condition to bypass the new code when lhs
!    and rhs have the same length and are known at runtime.
! 5] Insert a runtime condition to jump past the code when the
!    lhs and rhs lengths are equal.
! 6] Tidy up the code.
!
  integer(4), allocatable :: a(:), b(:)
  integer(4) :: j

! Note that 'b' must be allocated for b = a to work.  Why?
  allocate(a(1), b(0))
  deallocate(b)

  a = [4,3,2,1]
  if (size(a, 1) .ne. 4) call abort
  if (any (a .ne. [4,3,2,1])) call abort

  a = [((10 - i), i = 1, 10)]  ! Implicit reallocation.
  if (size(a, 1) .ne. 10) call abort
  if (any (a .ne. [((10 - i), i = 1, 10)])) call abort

  if (size(b, 1) .ne. 0) call abort
  b = a
  if (size(b, 1) .ne. 10) call abort
  if (any (b .ne. a)) call abort

  a = [4,3,2,1]
  if (size(a, 1) .ne. 4) call abort
  if (any (a .ne. [4,3,2,1])) call abort

  a = b
  if (size(a, 1) .ne. 10) call abort
  if (any (a .ne. [((10 - i), i = 1, 10)])) call abort

  j = 20
  a = [(i, i = 1, j)]  ! This caused all manner of problems :-(
  if (size(a, 1) .ne. 20) call abort
  if (any (a .ne. [(i, i = 1, j)])) call abort

  a = foo (15)
  if (size(a, 1) .ne. 15) call abort
  if (any (a .ne. [((i + 15), i = 1, n)])) call abort
contains
  function foo (n) result(res)
    integer(4), allocatable, dimension(:) :: res
    integer(4) :: n
    allocate (res(n))
    res = [((i + 15), i = 1, n)]
  end function foo
end


-- 
The knack of flying is learning how to throw yourself at the ground and miss.
? ? ?? --Hitchhikers Guide to the Galaxy
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c	(revision 164755)
--- gcc/fortran/trans-expr.c	(working copy)
*************** gfc_trans_assignment_1 (gfc_expr * expr1
*** 5744,5749 ****
--- 5744,5752 ----
  	  gfc_add_expr_to_block (&body, tmp);
  	}
  
+       /* Allocate or reallocate lhs of allocatable array.  */
+       gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2);
+ 
        /* Generate the copying loops.  */
        gfc_trans_scalarizing_loops (&loop, &body);
  
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c	(revision 164755)
--- gcc/fortran/trans-array.c	(working copy)
*************** gfc_trans_array_constructor (gfc_loopinf
*** 1830,1835 ****
--- 1830,1836 ----
    tree offsetvar;
    tree desc;
    tree type;
+   tree tmp;
    bool dynamic;
    bool old_first_len, old_typespec_chararray_ctor;
    tree old_first_len_val;
*************** gfc_trans_array_constructor (gfc_loopinf
*** 1942,1947 ****
--- 1943,1951 ----
  	}
      }
  
+   if (TREE_CODE (loop->to[0]) == VAR_DECL)
+     dynamic = true;
+ 
    gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, &ss->data.info,
  			       type, NULL_TREE, dynamic, true, false, where);
  
*************** gfc_trans_array_constructor (gfc_loopinf
*** 1956,1967 ****
    /* If the array grows dynamically, the upper bound of the loop variable
       is determined by the array's final upper bound.  */
    if (dynamic)
!     loop->to[0] = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]);
  
    if (TREE_USED (offsetvar))
      pushdecl (offsetvar);
    else
      gcc_assert (INTEGER_CST_P (offset));
  #if 0
    /* Disable bound checking for now because it's probably broken.  */
    if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
--- 1960,1982 ----
    /* If the array grows dynamically, the upper bound of the loop variable
       is determined by the array's final upper bound.  */
    if (dynamic)
!     {
!       tmp = fold_build2_loc (input_location, MINUS_EXPR,
! 			     gfc_array_index_type,
! 			     offsetvar, gfc_index_one_node);
!       tmp = gfc_evaluate_now (tmp, &loop->pre);
!       gfc_conv_descriptor_ubound_set (&loop->pre, desc, gfc_rank_cst[0], tmp);
!       if (loop->to[0] && TREE_CODE (loop->to[0]) == VAR_DECL)
! 	gfc_add_modify (&loop->pre, loop->to[0], tmp);
!       else
! 	loop->to[0] = tmp;
!     }
  
    if (TREE_USED (offsetvar))
      pushdecl (offsetvar);
    else
      gcc_assert (INTEGER_CST_P (offset));
+ 
  #if 0
    /* Disable bound checking for now because it's probably broken.  */
    if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
*************** gfc_copy_only_alloc_comp (gfc_symbol * d
*** 6449,6454 ****
--- 6464,6634 ----
  }
  
  
+ /* Allocate the lhs of an assignment to an allocatable array, otherwise
+    reallocate it.  */
+ 
+ void
+ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
+ 				      gfc_expr *expr1,
+ 				      gfc_expr *expr2)
+ {
+   stmtblock_t realloc_block;
+   stmtblock_t alloc_block;
+   stmtblock_t fblock;
+   gfc_ss *rss;
+   gfc_ss *lss;
+   tree realloc_expr;
+   tree alloc_expr;
+   tree size1;
+   tree size2;
+   tree array1;
+   tree cond;
+   tree tmp;
+   tree desc;
+   tree desc2;
+   int n, dim;
+ 
+   if (!expr1->symtree->n.sym->attr.allocatable
+ 	|| (expr1->ref && expr1->ref->type == REF_ARRAY
+ 	      && expr1->ref->u.ar.type != AR_FULL)
+ 	|| !expr2->rank)
+     return;
+ 
+   /* Find the ss for the lhs.  */
+   lss = loop->ss;
+   for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
+     if (lss->expr == expr1)
+       break;
+ 
+   if (lss == gfc_ss_terminator)
+     return;
+ 
+   /* Find the ss for the rhs.  */
+   rss = loop->ss;
+   for (; rss && rss != gfc_ss_terminator; rss = rss->loop_chain)
+     if (rss->expr == expr2)
+       break;
+ 
+   if (rss == gfc_ss_terminator)
+     return;
+ 
+   gfc_start_block (&fblock);
+ 
+   /* Since the lhs is alloctable, it must be a descriptor.  Get the data
+      and the array size in bytes.  */
+   desc = lss->data.info.descriptor;
+   gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
+   array1 = gfc_conv_descriptor_data_get (desc);
+   size1 = gfc_conv_descriptor_size (desc, expr1->rank);
+ 
+ 
+   tmp = gfc_get_element_type (TREE_TYPE (desc));
+   size1 = fold_build2_loc (input_location, MULT_EXPR,
+ 			   gfc_array_index_type,
+ 			   TYPE_SIZE_UNIT (tmp), size1);    
+ 
+   /* Use the gfc_ss for the array and the loop for the dimensions.  Get
+      the rhs size and set the lhs descriptor accordingly.  */
+   desc2 = rss->data.info.descriptor;
+ 
+   if (desc2 && TREE_CODE (TREE_TYPE (desc2)) == RECORD_TYPE)
+     {
+ 
+       size2 = gfc_conv_descriptor_size (desc2, expr2->rank);
+       size2 = gfc_evaluate_now (size2, &fblock);
+ 
+       for (n = 0; n < expr2->rank; n++)
+ 	{
+ 	  dim = lss->data.info.dim[n];
+ 	  tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ 				 gfc_array_index_type,
+ 				 gfc_conv_descriptor_ubound_get (desc2,
+ 								 gfc_rank_cst[n]),
+ 				 gfc_conv_descriptor_lbound_get (desc2,
+ 								 gfc_rank_cst[n]));
+ 	  /* Reset the loop to the rhs size.  */
+ 	  if (loop->to[dim]
+ 		&& TREE_CODE (loop->to[dim]) == VAR_DECL)
+ 	    gfc_add_modify (&fblock, loop->to[dim], tmp);
+ 
+ 	  tmp = fold_build2_loc (input_location, PLUS_EXPR,
+ 				 gfc_array_index_type,
+ 				 tmp, gfc_index_one_node);
+ 
+ 	  gfc_conv_descriptor_lbound_set (&fblock, desc,
+ 					  gfc_rank_cst[n],
+ 					  gfc_index_one_node);
+ 	  gfc_conv_descriptor_ubound_set (&fblock, desc,
+ 					  gfc_rank_cst[n], tmp);
+ 	}
+     }
+   else
+     {
+       size2 = gfc_index_one_node;   
+       for (n = 0; n < expr2->rank; n++)
+ 	{
+ 	  dim = rss->data.info.dim[n];
+ 	  tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ 				 gfc_array_index_type,
+ 				 loop->to[dim], loop->from[dim]);
+ 	  tmp = fold_build2_loc (input_location, PLUS_EXPR,
+ 				 gfc_array_index_type,
+ 				 tmp, gfc_index_one_node);
+ 	  size2 = fold_build2_loc (input_location, MULT_EXPR,
+ 				   gfc_array_index_type,
+ 				   tmp, size2);
+ 	  gfc_conv_descriptor_lbound_set (&fblock, desc,
+ 					  gfc_rank_cst[n],
+ 					  gfc_index_one_node);
+ 	  gfc_conv_descriptor_ubound_set (&fblock, desc,
+ 					  gfc_rank_cst[n], tmp);
+ 	}
+     }
+   tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
+   tmp = fold_convert (gfc_array_index_type, tmp);
+   size2 = fold_build2_loc (input_location, MULT_EXPR,
+ 			   gfc_array_index_type,
+ 			   tmp, size2);
+   size2 = fold_convert (size_type_node, size2);
+ 
+   /* Realloc expression.  Note that the scalarizer uses desc.data
+      in the array reference - (*desc.data)[<element>]. */
+   gfc_init_block (&realloc_block);
+   tmp = build_call_expr_loc (input_location,
+ 			     built_in_decls[BUILT_IN_REALLOC], 2,
+ 			     fold_convert (pvoid_type_node, array1),
+ 			     size2);
+   gfc_conv_descriptor_data_set (&realloc_block,
+ 				desc, tmp);
+   realloc_expr = gfc_finish_block (&realloc_block);
+ 
+   /* Malloc expression.  */
+   gfc_init_block (&alloc_block);
+   tmp = build_call_expr_loc (input_location,
+ 			     built_in_decls[BUILT_IN_MALLOC], 1,
+ 			     size2);
+   gfc_conv_descriptor_data_set (&alloc_block,
+ 				desc, tmp);
+   alloc_expr = gfc_finish_block (&alloc_block);
+ 
+   /* Malloc if not allocated; realloc otherwise.  */
+   cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+ 			  array1, build_int_cst (TREE_TYPE (array1), 0));
+   tmp = build3_v (COND_EXPR, cond, alloc_expr, realloc_expr);
+   gfc_add_expr_to_block (&fblock, tmp);
+ 
+   if (lss->data.info.data
+ 	&& TREE_CODE (lss->data.info.data) == VAR_DECL)
+     {
+       tmp = gfc_conv_descriptor_data_get (desc);
+       gfc_add_modify (&fblock, lss->data.info.data, tmp);
+     }
+ 
+   tmp = gfc_finish_block (&fblock);
+   gfc_add_expr_to_block (&loop->pre, tmp);
+ }
+ 
+ 
  /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
     Do likewise, recursively if necessary, with the allocatable components of
     derived types.  */
Index: gcc/fortran/trans-array.h
===================================================================
*** gcc/fortran/trans-array.h	(revision 164755)
--- gcc/fortran/trans-array.h	(working copy)
*************** tree gfc_copy_alloc_comp (gfc_symbol *, 
*** 57,62 ****
--- 57,64 ----
  
  tree gfc_copy_only_alloc_comp (gfc_symbol *, tree, tree, int);
  
+ void gfc_alloc_allocatable_for_assignment (gfc_loopinfo*, gfc_expr*, gfc_expr*);
+ 
  /* Add initialization for deferred arrays.  */
  void gfc_trans_deferred_array (gfc_symbol *, gfc_wrapped_block *);
  /* Generate an initializer for a static pointer or allocatable array.  */

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