trans-stmt.c

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

      /* Figure out how many elements we need.  */
      for (i = 0; i < loop.dimen; i++)
        {
	  tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
			     gfc_index_one_node, loop.from[i]);
          tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
			     tmp, loop.to[i]);
          size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
        }
      gfc_add_block_to_block (pblock, &loop.pre);
      size = gfc_evaluate_now (size, pblock);
      gfc_add_block_to_block (pblock, &loop.post);

      /* TODO: write a function that cleans up a loopinfo without freeing
         the SS chains.  Currently a NOP.  */
    }

  return size;
}


/* Calculate the overall iterator number of the nested forall construct.  */

static tree
compute_overall_iter_number (forall_info *nested_forall_info, tree inner_size,
			     stmtblock_t *inner_size_body, stmtblock_t *block)
{
  tree tmp, number;
  stmtblock_t body;

  /* TODO: optimizing the computing process.  */
  number = gfc_create_var (gfc_array_index_type, "num");
  gfc_add_modify_expr (block, number, gfc_index_zero_node);

  gfc_start_block (&body);
  if (inner_size_body)
    gfc_add_block_to_block (&body, inner_size_body);
  if (nested_forall_info)
    tmp = build2 (PLUS_EXPR, gfc_array_index_type, number,
		  inner_size);
  else
    tmp = inner_size;
  gfc_add_modify_expr (&body, number, tmp);
  tmp = gfc_finish_block (&body);

  /* Generate loops.  */
  if (nested_forall_info != NULL)
    tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 0, 1);

  gfc_add_expr_to_block (block, tmp);

  return number;
}


/* Allocate temporary for forall construct.  SIZE is the size of temporary
   needed.  PTEMP1 is returned for space free.  */

static tree
allocate_temp_for_forall_nest_1 (tree type, tree size, stmtblock_t * block,
				 tree * ptemp1)
{
  tree unit;
  tree temp1;
  tree tmp;
  tree bytesize;

  unit = TYPE_SIZE_UNIT (type);
  bytesize = fold_build2 (MULT_EXPR, gfc_array_index_type, size, unit);

  *ptemp1 = NULL;
  temp1 = gfc_do_allocate (bytesize, size, ptemp1, block, type);

  if (*ptemp1)
    tmp = gfc_build_indirect_ref (temp1);
  else
    tmp = temp1;

  return tmp;
}


/* Allocate temporary for forall construct according to the information in
   nested_forall_info.  INNER_SIZE is the size of temporary needed in the
   assignment inside forall.  PTEMP1 is returned for space free.  */

static tree
allocate_temp_for_forall_nest (forall_info * nested_forall_info, tree type,
			       tree inner_size, stmtblock_t * inner_size_body,
			       stmtblock_t * block, tree * ptemp1)
{
  tree size;

  /* Calculate the total size of temporary needed in forall construct.  */
  size = compute_overall_iter_number (nested_forall_info, inner_size,
				      inner_size_body, block);

  return allocate_temp_for_forall_nest_1 (type, size, block, ptemp1);
}


/* Handle assignments inside forall which need temporary.

    forall (i=start:end:stride; maskexpr)
      e<i> = f<i>
    end forall
   (where e,f<i> are arbitrary expressions possibly involving i
    and there is a dependency between e<i> and f<i>)
   Translates to:
    masktmp(:) = maskexpr(:)

    maskindex = 0;
    count1 = 0;
    num = 0;
    for (i = start; i <= end; i += stride)
      num += SIZE (f<i>)
    count1 = 0;
    ALLOCATE (tmp(num))
    for (i = start; i <= end; i += stride)
      {
	if (masktmp[maskindex++])
	  tmp[count1++] = f<i>
      }
    maskindex = 0;
    count1 = 0;
    for (i = start; i <= end; i += stride)
      {
	if (masktmp[maskindex++])
	  e<i> = tmp[count1++]
      }
    DEALLOCATE (tmp)
  */
static void
gfc_trans_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2, tree wheremask,
                            forall_info * nested_forall_info,
                            stmtblock_t * block)
{
  tree type;
  tree inner_size;
  gfc_ss *lss, *rss;
  tree count, count1;
  tree tmp, tmp1;
  tree ptemp1;
  stmtblock_t inner_size_body;

  /* Create vars. count1 is the current iterator number of the nested
     forall.  */
  count1 = gfc_create_var (gfc_array_index_type, "count1");

  /* Count is the wheremask index.  */
  if (wheremask)
    {
      count = gfc_create_var (gfc_array_index_type, "count");
      gfc_add_modify_expr (block, count, gfc_index_zero_node);
    }
  else
    count = NULL;

  /* Initialize count1.  */
  gfc_add_modify_expr (block, count1, gfc_index_zero_node);

  /* Calculate the size of temporary needed in the assignment. Return loop, lss
     and rss which are used in function generate_loop_for_rhs_to_temp().  */
  gfc_init_block (&inner_size_body);
  inner_size = compute_inner_temp_size (expr1, expr2, &inner_size_body,
					&lss, &rss);

  /* The type of LHS. Used in function allocate_temp_for_forall_nest */
  type = gfc_typenode_for_spec (&expr1->ts);

  /* Allocate temporary for nested forall construct according to the
     information in nested_forall_info and inner_size.  */
  tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type, inner_size,
					&inner_size_body, block, &ptemp1);

  /* Generate codes to copy rhs to the temporary .  */
  tmp = generate_loop_for_rhs_to_temp (expr2, tmp1, count, count1, lss, rss,
				       wheremask);

  /* Generate body and loops according to the information in
     nested_forall_info.  */
  tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1);
  gfc_add_expr_to_block (block, tmp);

  /* Reset count1.  */
  gfc_add_modify_expr (block, count1, gfc_index_zero_node);

  /* Reset count.  */
  if (wheremask)
    gfc_add_modify_expr (block, count, gfc_index_zero_node);

  /* Generate codes to copy the temporary to lhs.  */
  tmp = generate_loop_for_temp_to_lhs (expr1, tmp1, count, count1, wheremask);

  /* Generate body and loops according to the information in
     nested_forall_info.  */
  tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1);
  gfc_add_expr_to_block (block, tmp);

  if (ptemp1)
    {
      /* Free the temporary.  */
      tmp = gfc_chainon_list (NULL_TREE, ptemp1);
      tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
      gfc_add_expr_to_block (block, tmp);
    }
}


/* Translate pointer assignment inside FORALL which need temporary.  */

static void
gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
                                    forall_info * nested_forall_info,
                                    stmtblock_t * block)
{
  tree type;
  tree inner_size;
  gfc_ss *lss, *rss;
  gfc_se lse;
  gfc_se rse;
  gfc_ss_info *info;
  gfc_loopinfo loop;
  tree desc;
  tree parm;
  tree parmtype;
  stmtblock_t body;
  tree count;
  tree tmp, tmp1, ptemp1;

  count = gfc_create_var (gfc_array_index_type, "count");
  gfc_add_modify_expr (block, count, gfc_index_zero_node);

  inner_size = integer_one_node;
  lss = gfc_walk_expr (expr1);
  rss = gfc_walk_expr (expr2);
  if (lss == gfc_ss_terminator)
    {
      type = gfc_typenode_for_spec (&expr1->ts);
      type = build_pointer_type (type);

      /* Allocate temporary for nested forall construct according to the
         information in nested_forall_info and inner_size.  */
      tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type,
					    inner_size, NULL, block, &ptemp1);
      gfc_start_block (&body);
      gfc_init_se (&lse, NULL);
      lse.expr = gfc_build_array_ref (tmp1, count);
      gfc_init_se (&rse, NULL);
      rse.want_pointer = 1;
      gfc_conv_expr (&rse, expr2);
      gfc_add_block_to_block (&body, &rse.pre);
      gfc_add_modify_expr (&body, lse.expr,
			   fold_convert (TREE_TYPE (lse.expr), rse.expr));
      gfc_add_block_to_block (&body, &rse.post);

      /* Increment count.  */
      tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
			 count, gfc_index_one_node);
      gfc_add_modify_expr (&body, count, tmp);

      tmp = gfc_finish_block (&body);

      /* Generate body and loops according to the information in
         nested_forall_info.  */
      tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1);
      gfc_add_expr_to_block (block, tmp);

      /* Reset count.  */
      gfc_add_modify_expr (block, count, gfc_index_zero_node);

      gfc_start_block (&body);
      gfc_init_se (&lse, NULL);
      gfc_init_se (&rse, NULL);
      rse.expr = gfc_build_array_ref (tmp1, count);
      lse.want_pointer = 1;
      gfc_conv_expr (&lse, expr1);
      gfc_add_block_to_block (&body, &lse.pre);
      gfc_add_modify_expr (&body, lse.expr, rse.expr);
      gfc_add_block_to_block (&body, &lse.post);
      /* Increment count.  */
      tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
			 count, gfc_index_one_node);
      gfc_add_modify_expr (&body, count, tmp);
      tmp = gfc_finish_block (&body);

      /* Generate body and loops according to the information in
         nested_forall_info.  */
      tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1);
      gfc_add_expr_to_block (block, tmp);
    }
  else
    {
      gfc_init_loopinfo (&loop);

      /* Associate the SS with the loop.  */
      gfc_add_ss_to_loop (&loop, rss);

      /* Setup the scalarizing loops and bounds.  */
      gfc_conv_ss_startstride (&loop);

      gfc_conv_loop_setup (&loop);

      info = &rss->data.info;
      desc = info->descriptor;

      /* Make a new descriptor.  */
      parmtype = gfc_get_element_type (TREE_TYPE (desc));
      parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
                                            loop.from, loop.to, 1);

      /* Allocate temporary for nested forall construct.  */
      tmp1 = allocate_temp_for_forall_nest (nested_forall_info, parmtype,
					    inner_size, NULL, block, &ptemp1);
      gfc_start_block (&body);
      gfc_init_se (&lse, NULL);
      lse.expr = gfc_build_array_ref (tmp1, count);
      lse.direct_byref = 1;
      rss = gfc_walk_expr (expr2);
      gfc_conv_expr_descriptor (&lse, expr2, rss);

      gfc_add_block_to_block (&body, &lse.pre);
      gfc_add_block_to_block (&body, &lse.post);

      /* Increment count.  */
      tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
			 count, gfc_index_one_node);
      gfc_add_modify_expr (&body, count, tmp);

      tmp = gfc_finish_block (&body);

      /* Generate body and loops according to the information in
         nested_forall_info.  */
      tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1);
      gfc_add_expr_to_block (block, tmp);

      /* Reset count.  */
      gfc_add_modify_expr (block, count, gfc_index_zero_node);

      parm = gfc_build_array_ref (tmp1, count);
      lss = gfc_walk_expr (expr1);
      gfc_init_se (&lse, NULL);
      gfc_conv_expr_descriptor (&lse, expr1, lss);
      gfc_add_modify_expr (&lse.pre, lse.expr, parm);
      gfc_start_block (&body);
      gfc_add_block_to_block (&body, &lse.pre);
      gfc_add_block_to_block (&body, &lse.post);

      /* Increment count.  */
      tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
			 count, gfc_index_one_node);
      gfc_add_modify_expr (&body, count, tmp);

      tmp = gfc_finish_block (&body);

      tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1);
      gfc_add_expr_to_block (block, tmp);
    }
  /* Free the temporary.  */
  if (ptemp1)
    {
      tmp = gfc_chainon_list (NULL_TREE, ptemp1);
      tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
      gfc_add_expr_to_block (block, tmp);
    }
}


/* FORALL and WHERE statements are really nasty, especially when you nest
   them. All the rhs of a forall assignment must be evaluated before the
   actual assignments are performed. Presumably this also applies to all the
   assignments in an inner where statement.  */

/* Generate code for a FORALL statement.  Any temporaries are allocated as a
   linear array, relying on the fact that we process in the same order in all
   loops.

    forall (i=start:end:stride; maskexpr)
      e<i> = f<i>
      g<i> = h<i>
    end forall
   (where e,f,g,h<i> are arbitrary expressions possibly involving i)
   Translates to:
    count = ((end + 1 - start) / stride)
    masktmp(:) = maskexpr(:)

    maskindex = 0;
    for (i = start; i <= end; i += stride)
      {
        if (masktmp[maskindex++])
          e<i> = f<i>
      }
    maskindex = 0;
    for (i = start; i <= end; i += stride)
      {
        if (masktmp[maskindex++])
          g<i> = h<i>
      }

    Note that this code only works when there are no dependencies.
    Forall loop with array assignments and data dependencies are a real pain,
    because the size of the temporary cannot always be determined before the
    loop is executed.  This problem is compounded by the presence of nested
    FORALL constructs.
 */

static tree
gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
{
  stmtblock_t block;
  stmtblock_t body;
  tree *var;
  tree *start;
  tree *end;
  tree *step;
  gfc_expr **varexpr;
  tree tmp;
  tree assign;
  tree size;
  tree bytesize;
  tree tmpvar;
  tree sizevar;
  tree lenvar;
  tree maskindex;
  tree mask;
  tree pmask;
  int n;
  int nvar;
  int need_temp;
  gfc_forall_iterator *fa;
  gfc_se se;
  gfc_code *c;
  gfc_saved_var *saved_vars;
  iter_info *this_forall, *iter_tmp;
  forall_info *info, *forall_tmp;
  temporary_list *temp;

  gfc_start_block (&block);

  n = 0;
  /* Count the FORALL index number.  */
  for (fa = code->ext.forall_iterator; fa; fa = fa->next)
    n++;
  nvar = n;

  /* Allocate the space for var, start, end, step, varexpr.  */
  var = (tree *) gfc_getmem (nvar * sizeof (tree));
  start = (tree *) gfc_getmem (nvar * sizeof (tree));
  end = (tree *) gfc_getmem (nvar * sizeof (tree));
  step = (tree *) gfc_getmem (nvar * sizeof (tree));
  varexpr = (gfc_expr **) gfc_getmem (nvar * sizeof (gfc_expr *));
  saved_vars = (gfc_saved_var *) gfc_getmem (nvar * sizeof (gfc_saved_var));

  /* Allocate the space for info.  */
  info = (forall_info *) gfc_getmem (sizeof (forall_info));
  n = 0;
  for (fa = code->ext.forall_iterator; fa; fa = fa->next)
    {
      gfc_symbol *sym = fa->var->symtree->n.sym;

      /* allocate space for this_forall.  */
      this_forall = (iter_info *) gfc_getmem (sizeof (iter_info));

      /* Create a