trans-array.c

gcc-fortran,linux使用fortran的编译软件。很好用的。

}


/* Generate code to allocate an array temporary, or create a variable to
   hold the data.  If size is NULL, zero the descriptor so that the
   callee will allocate the array.  If DEALLOC is true, also generate code to
   free the array afterwards.

   Initialization code is added to PRE and finalization code to POST.
   DYNAMIC is true if the caller may want to extend the array later
   using realloc.  This prevents us from putting the array on the stack.  */

static void
gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
                                  gfc_ss_info * info, tree size, tree nelem,
                                  bool dynamic, bool dealloc)
{
  tree tmp;
  tree args;
  tree desc;
  bool onstack;

  desc = info->descriptor;
  info->offset = gfc_index_zero_node;
  if (size == NULL_TREE || integer_zerop (size))
    {
      /* A callee allocated array.  */
      gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
      onstack = FALSE;
    }
  else
    {
      /* Allocate the temporary.  */
      onstack = !dynamic && gfc_can_put_var_on_stack (size);

      if (onstack)
	{
	  /* Make a temporary variable to hold the data.  */
	  tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (nelem), nelem,
			     integer_one_node);
	  tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
				  tmp);
	  tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
				  tmp);
	  tmp = gfc_create_var (tmp, "A");
	  tmp = gfc_build_addr_expr (NULL, tmp);
	  gfc_conv_descriptor_data_set (pre, desc, tmp);
	}
      else
	{
	  /* Allocate memory to hold the data.  */
	  args = gfc_chainon_list (NULL_TREE, size);

	  if (gfc_index_integer_kind == 4)
	    tmp = gfor_fndecl_internal_malloc;
	  else if (gfc_index_integer_kind == 8)
	    tmp = gfor_fndecl_internal_malloc64;
	  else
	    gcc_unreachable ();
	  tmp = gfc_build_function_call (tmp, args);
	  tmp = gfc_evaluate_now (tmp, pre);
	  gfc_conv_descriptor_data_set (pre, desc, tmp);
	}
    }
  info->data = gfc_conv_descriptor_data_get (desc);

  /* The offset is zero because we create temporaries with a zero
     lower bound.  */
  tmp = gfc_conv_descriptor_offset (desc);
  gfc_add_modify_expr (pre, tmp, gfc_index_zero_node);

  if (dealloc && !onstack)
    {
      /* Free the temporary.  */
      tmp = gfc_conv_descriptor_data_get (desc);
      tmp = fold_convert (pvoid_type_node, tmp);
      tmp = gfc_chainon_list (NULL_TREE, tmp);
      tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
      gfc_add_expr_to_block (post, tmp);
    }
}


/* Generate code to allocate and initialize the descriptor for a temporary
   array.  This is used for both temporaries needed by the scalarizer, and
   functions returning arrays.  Adjusts the loop variables to be zero-based,
   and calculates the loop bounds for callee allocated arrays.
   Also fills in the descriptor, data and offset fields of info if known.
   Returns the size of the array, or NULL for a callee allocated array.

   PRE, POST, DYNAMIC and DEALLOC are as for gfc_trans_allocate_array_storage.
 */

tree
gfc_trans_allocate_temp_array (stmtblock_t * pre, stmtblock_t * post,
                               gfc_loopinfo * loop, gfc_ss_info * info,
                               tree eltype, bool dynamic, bool dealloc)
{
  tree type;
  tree desc;
  tree tmp;
  tree size;
  tree nelem;
  int n;
  int dim;

  gcc_assert (info->dimen > 0);
  /* Set the lower bound to zero.  */
  for (dim = 0; dim < info->dimen; dim++)
    {
      n = loop->order[dim];
      if (n < loop->temp_dim)
	gcc_assert (integer_zerop (loop->from[n]));
      else
	{
	  /* Callee allocated arrays may not have a known bound yet.  */
          if (loop->to[n])
              loop->to[n] = fold_build2 (MINUS_EXPR, gfc_array_index_type,
					 loop->to[n], loop->from[n]);
	  loop->from[n] = gfc_index_zero_node;
	}

      info->delta[dim] = gfc_index_zero_node;
      info->start[dim] = gfc_index_zero_node;
      info->stride[dim] = gfc_index_one_node;
      info->dim[dim] = dim;
    }

  /* Initialize the descriptor.  */
  type =
    gfc_get_array_type_bounds (eltype, info->dimen, loop->from, loop->to, 1);
  desc = gfc_create_var (type, "atmp");
  GFC_DECL_PACKED_ARRAY (desc) = 1;

  info->descriptor = desc;
  size = gfc_index_one_node;

  /* Fill in the array dtype.  */
  tmp = gfc_conv_descriptor_dtype (desc);
  gfc_add_modify_expr (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));

  /*
     Fill in the bounds and stride.  This is a packed array, so:

     size = 1;
     for (n = 0; n < rank; n++)
       {
	 stride[n] = size
	 delta = ubound[n] + 1 - lbound[n];
         size = size * delta;
       }
     size = size * sizeof(element);
  */

  for (n = 0; n < info->dimen; n++)
    {
      if (loop->to[n] == NULL_TREE)
        {
	  /* For a callee allocated array express the loop bounds in terms
	     of the descriptor fields.  */
          tmp = build2 (MINUS_EXPR, gfc_array_index_type,
			gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]),
			gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]));
          loop->to[n] = tmp;
          size = NULL_TREE;
          continue;
        }
        
      /* Store the stride and bound components in the descriptor.  */
      tmp = gfc_conv_descriptor_stride (desc, gfc_rank_cst[n]);
      gfc_add_modify_expr (pre, tmp, size);

      tmp = gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]);
      gfc_add_modify_expr (pre, tmp, gfc_index_zero_node);

      tmp = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]);
      gfc_add_modify_expr (pre, tmp, loop->to[n]);

      tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
			 loop->to[n], gfc_index_one_node);

      size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
      size = gfc_evaluate_now (size, pre);
    }

  /* Get the size of the array.  */
  nelem = size;
  if (size)
    size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
			TYPE_SIZE_UNIT (gfc_get_element_type (type)));

  gfc_trans_allocate_array_storage (pre, post, info, size, nelem, dynamic,
                                    dealloc);

  if (info->dimen > loop->temp_dim)
    loop->temp_dim = info->dimen;

  return size;
}


/* Return the number of iterations in a loop that starts at START,
   ends at END, and has step STEP.  */

static tree
gfc_get_iteration_count (tree start, tree end, tree step)
{
  tree tmp;
  tree type;

  type = TREE_TYPE (step);
  tmp = fold_build2 (MINUS_EXPR, type, end, start);
  tmp = fold_build2 (FLOOR_DIV_EXPR, type, tmp, step);
  tmp = fold_build2 (PLUS_EXPR, type, tmp, build_int_cst (type, 1));
  tmp = fold_build2 (MAX_EXPR, type, tmp, build_int_cst (type, 0));
  return fold_convert (gfc_array_index_type, tmp);
}


/* Extend the data in array DESC by EXTRA elements.  */

static void
gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
{
  tree args;
  tree tmp;
  tree size;
  tree ubound;

  if (integer_zerop (extra))
    return;

  ubound = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);

  /* Add EXTRA to the upper bound.  */
  tmp = build2 (PLUS_EXPR, gfc_array_index_type, ubound, extra);
  gfc_add_modify_expr (pblock, ubound, tmp);

  /* Get the value of the current data pointer.  */
  tmp = gfc_conv_descriptor_data_get (desc);
  args = gfc_chainon_list (NULL_TREE, tmp);

  /* Calculate the new array size.  */
  size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
  tmp = build2 (PLUS_EXPR, gfc_array_index_type, ubound, gfc_index_one_node);
  tmp = build2 (MULT_EXPR, gfc_array_index_type, tmp, size);
  args = gfc_chainon_list (args, tmp);

  /* Pick the appropriate realloc function.  */
  if (gfc_index_integer_kind == 4)
    tmp = gfor_fndecl_internal_realloc;
  else if (gfc_index_integer_kind == 8)
    tmp = gfor_fndecl_internal_realloc64;
  else
    gcc_unreachable ();

  /* Set the new data pointer.  */
  tmp = gfc_build_function_call (tmp, args);
  gfc_conv_descriptor_data_set (pblock, desc, tmp);
}


/* Return true if the bounds of iterator I can only be determined
   at run time.  */

static inline bool
gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
{
  return (i->start->expr_type != EXPR_CONSTANT
	  || i->end->expr_type != EXPR_CONSTANT
	  || i->step->expr_type != EXPR_CONSTANT);
}


/* Split the size of constructor element EXPR into the sum of two terms,
   one of which can be determined at compile time and one of which must
   be calculated at run time.  Set *SIZE to the former and return true
   if the latter might be nonzero.  */

static bool
gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
{
  if (expr->expr_type == EXPR_ARRAY)
    return gfc_get_array_constructor_size (size, expr->value.constructor);
  else if (expr->rank > 0)
    {
      /* Calculate everything at run time.  */
      mpz_set_ui (*size, 0);
      return true;
    }
  else
    {
      /* A single element.  */
      mpz_set_ui (*size, 1);
      return false;
    }
}


/* Like gfc_get_array_constructor_element_size, but applied to the whole
   of array constructor C.  */

static bool
gfc_get_array_constructor_size (mpz_t * size, gfc_constructor * c)
{
  gfc_iterator *i;
  mpz_t val;
  mpz_t len;
  bool dynamic;

  mpz_set_ui (*size, 0);
  mpz_init (len);
  mpz_init (val);

  dynamic = false;
  for (; c; c = c->next)
    {
      i = c->iterator;
      if (i && gfc_iterator_has_dynamic_bounds (i))
	dynamic = true;
      else
	{
	  dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
	  if (i)
	    {
	      /* Multiply the static part of the element size by the
		 number of iterations.  */
	      mpz_sub (val, i->end->value.integer, i->start->value.integer);
	      mpz_fdiv_q (val, val, i->step->value.integer);
	      mpz_add_ui (val, val, 1);
	      if (mpz_sgn (val) > 0)
		mpz_mul (len, len, val);
	      else
		mpz_set_ui (len, 0);
	    }
	  mpz_add (*size, *size, len);
	}
    }
  mpz_clear (len);
  mpz_clear (val);
  return dynamic;
}


/* Make sure offset is a variable.  */

static void
gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
			 tree * offsetvar)
{
  /* We should have already created the offset variable.  We cannot
     create it here because we may be in an inner scope.  */
  gcc_assert (*offsetvar != NULL_TREE);
  gfc_add_modify_expr (pblock, *offsetvar, *poffset);
  *poffset = *offsetvar;
  TREE_USED (*offsetvar) = 1;
}


/* Assign an element of an array constructor.  */

static void
gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
			      tree offset, gfc_se * se, gfc_expr * expr)
{
  tree tmp;
  tree args;

  gfc_conv_expr (se, expr);

  /* Store the value.  */
  tmp = gfc_build_indirect_ref (gfc_conv_descriptor_data_get (desc));
  tmp = gfc_build_array_ref (tmp, offset);
  if (expr->ts.type == BT_CHARACTER)
    {
      gfc_conv_string_parameter (se);
      if (POINTER_TYPE_P (TREE_TYPE (tmp)))
	{
	  /* The temporary is an array of pointers.  */
	  se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
	  gfc_add_modify_expr (&se->pre, tmp, se->expr);
	}
      else
	{
	  /* The temporary is an array of string values.  */
	  tmp = gfc_build_addr_expr (pchar_type_node, tmp);
	  /* We know the temporary and the value will be the same length,
	     so can use memcpy.  */
	  args = gfc_chainon_list (NULL_TREE, tmp);
	  args = gfc_chainon_list (args, se->expr);
	  args = gfc_chainon_list (args, se->string_length);
	  tmp = built_in_decls[BUILT_IN_MEMCPY];
	  tmp = gfc_build_function_call (tmp, args);
	  gfc_add_expr_to_block (&se->pre, tmp);
	}
    }
  else
    {
      /* TODO: Should the frontend already have done this conversion?  */
      se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
      gfc_add_modify_expr (&se->pre, tmp, se->expr);
    }

  gfc_add_block_to_block (pblock, &se->pre);
  gfc_add_block_to_block (pblock, &se->post);
}


/* Add the contents of an array to the constructor.  DYNAMIC is as for
   gfc_trans_array_constructor_value.  */

static void
gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
				      tree type ATTRIBUTE_UNUSED,
				      tree desc, gfc_expr * expr,
				      tree * poffset, tree * offsetvar,
				      bool dynamic)
{
  gfc_se se;
  gfc_ss *ss;
  gfc_loopinfo loop;
  stmtblock_t body;
  tree tmp;
  tree size;
  int n;

  /* We need this to be a variable so we can increment it.  */
  gfc_put_offset_into_var (pblock, poffset, offsetvar);

  gfc_init_se (&se, NULL);

  /* Walk the array expression.  */
  ss = gfc_walk_expr (expr);
  gcc_assert (ss != gfc_ss_terminator);

  /* Initialize the scalarizer.  */
  gfc_init_loopinfo (&loop);
  gfc_add_ss_to_loop (&loop, ss);

  /* Initialize the loop.  */
  gfc_conv_ss_startstride (&loop);
  gfc_conv_loop_setup (&loop);

  /* Make sure the constructed array has room for the new data.  */
  if (dynamic)
    {
      /* Set SIZE to the total number of elements in the subarray.  */
      size = gfc_index_one_node;
      for (n = 0; n < loop.dimen; n++)
	{
	  tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
					 gfc_index_one_node);
	  size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
	}

      /* Grow the constructed array by SIZE elements.  */
      gfc_grow_array (&loop.pre, desc, size);
    }

  /* Make the loop body.  */
  gfc_mark_ss_chain_used (ss, 1);
  gfc_start_scalarized_body (&loop, &body);
  gfc_copy_loopinfo_to_se (&se, &loop);
  se.ss = ss;

  if (expr->ts.type == BT_CHARACTER)
    gfc_todo_error ("character arrays in constructors");

  gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
  gcc_assert (se.ss == gfc_ss_terminator);

  /* Increment the offset.  */
  tmp = build2 (PLUS_EXPR, gfc_array_index_type, *poffset, gfc_index_one_node);
  gfc_add_modify_expr (&body, *poffset, tmp);

  /* Finish the loop.  */