예제 #1
0
tree
gfc_evaluate_now (tree expr, stmtblock_t * pblock)
{
  tree var;

  if (CONSTANT_CLASS_P (expr))
    return expr;

  var = gfc_create_var (TREE_TYPE (expr), NULL);
  gfc_add_modify_expr (pblock, var, expr);

  return var;
}
예제 #2
0
static tree
gfc_trans_omp_do (gfc_code *code, stmtblock_t *pblock,
		  gfc_omp_clauses *do_clauses)
{
  gfc_se se;
  tree dovar, stmt, from, to, step, type, init, cond, incr;
  tree count = NULL_TREE, cycle_label, tmp, omp_clauses;
  stmtblock_t block;
  stmtblock_t body;
  int simple = 0;
  bool dovar_found = false;
  gfc_omp_clauses *clauses = code->ext.omp_clauses;

  code = code->block->next;
  gcc_assert (code->op == EXEC_DO);

  if (pblock == NULL)
    {
      gfc_start_block (&block);
      pblock = █
    }

  omp_clauses = gfc_trans_omp_clauses (pblock, do_clauses, code->loc);
  if (clauses)
    {
      gfc_namelist *n;
      for (n = clauses->lists[OMP_LIST_LASTPRIVATE]; n != NULL; n = n->next)
	if (code->ext.iterator->var->symtree->n.sym == n->sym)
	  break;
      if (n == NULL)
	for (n = clauses->lists[OMP_LIST_PRIVATE]; n != NULL; n = n->next)
	  if (code->ext.iterator->var->symtree->n.sym == n->sym)
	    break;
      if (n != NULL)
	dovar_found = true;
    }

  /* Evaluate all the expressions in the iterator.  */
  gfc_init_se (&se, NULL);
  gfc_conv_expr_lhs (&se, code->ext.iterator->var);
  gfc_add_block_to_block (pblock, &se.pre);
  dovar = se.expr;
  type = TREE_TYPE (dovar);
  gcc_assert (TREE_CODE (type) == INTEGER_TYPE);

  gfc_init_se (&se, NULL);
  gfc_conv_expr_val (&se, code->ext.iterator->start);
  gfc_add_block_to_block (pblock, &se.pre);
  from = gfc_evaluate_now (se.expr, pblock);

  gfc_init_se (&se, NULL);
  gfc_conv_expr_val (&se, code->ext.iterator->end);
  gfc_add_block_to_block (pblock, &se.pre);
  to = gfc_evaluate_now (se.expr, pblock);

  gfc_init_se (&se, NULL);
  gfc_conv_expr_val (&se, code->ext.iterator->step);
  gfc_add_block_to_block (pblock, &se.pre);
  step = gfc_evaluate_now (se.expr, pblock);

  /* Special case simple loops.  */
  if (integer_onep (step))
    simple = 1;
  else if (tree_int_cst_equal (step, integer_minus_one_node))
    simple = -1;

  /* Loop body.  */
  if (simple)
    {
      init = build2_v (MODIFY_EXPR, dovar, from);
      cond = build2 (simple > 0 ? LE_EXPR : GE_EXPR, boolean_type_node,
		     dovar, to);
      incr = fold_build2 (PLUS_EXPR, type, dovar, step);
      incr = fold_build2 (MODIFY_EXPR, type, dovar, incr);
      if (pblock != &block)
	{
	  pushlevel (0);
	  gfc_start_block (&block);
	}
      gfc_start_block (&body);
    }
  else
    {
      /* STEP is not 1 or -1.  Use:
	 for (count = 0; count < (to + step - from) / step; count++)
	   {
	     dovar = from + count * step;
	     body;
	   cycle_label:;
	   }  */
      tmp = fold_build2 (MINUS_EXPR, type, step, from);
      tmp = fold_build2 (PLUS_EXPR, type, to, tmp);
      tmp = fold_build2 (TRUNC_DIV_EXPR, type, tmp, step);
      tmp = gfc_evaluate_now (tmp, pblock);
      count = gfc_create_var (type, "count");
      init = build2_v (MODIFY_EXPR, count, build_int_cst (type, 0));
      cond = build2 (LT_EXPR, boolean_type_node, count, tmp);
      incr = fold_build2 (PLUS_EXPR, type, count, build_int_cst (type, 1));
      incr = fold_build2 (MODIFY_EXPR, type, count, incr);

      if (pblock != &block)
	{
	  pushlevel (0);
	  gfc_start_block (&block);
	}
      gfc_start_block (&body);

      /* Initialize DOVAR.  */
      tmp = fold_build2 (MULT_EXPR, type, count, step);
      tmp = build2 (PLUS_EXPR, type, from, tmp);
      gfc_add_modify_expr (&body, dovar, tmp);
    }

  if (!dovar_found)
    {
      tmp = build_omp_clause (OMP_CLAUSE_PRIVATE);
      OMP_CLAUSE_DECL (tmp) = dovar;
      omp_clauses = gfc_trans_add_clause (tmp, omp_clauses);
    }
  if (!simple)
    {
      tmp = build_omp_clause (OMP_CLAUSE_PRIVATE);
      OMP_CLAUSE_DECL (tmp) = count;
      omp_clauses = gfc_trans_add_clause (tmp, omp_clauses);
    }

  /* Cycle statement is implemented with a goto.  Exit statement must not be
     present for this loop.  */
  cycle_label = gfc_build_label_decl (NULL_TREE);

  /* Put these labels where they can be found later. We put the
     labels in a TREE_LIST node (because TREE_CHAIN is already
     used). cycle_label goes in TREE_PURPOSE (backend_decl), exit
     label in TREE_VALUE (backend_decl).  */

  code->block->backend_decl = tree_cons (cycle_label, NULL, NULL);

  /* Main loop body.  */
  tmp = gfc_trans_omp_code (code->block->next, true);
  gfc_add_expr_to_block (&body, tmp);

  /* Label for cycle statements (if needed).  */
  if (TREE_USED (cycle_label))
    {
      tmp = build1_v (LABEL_EXPR, cycle_label);
      gfc_add_expr_to_block (&body, tmp);
    }

  /* End of loop body.  */
  stmt = make_node (OMP_FOR);

  TREE_TYPE (stmt) = void_type_node;
  OMP_FOR_BODY (stmt) = gfc_finish_block (&body);
  OMP_FOR_CLAUSES (stmt) = omp_clauses;
  OMP_FOR_INIT (stmt) = init;
  OMP_FOR_COND (stmt) = cond;
  OMP_FOR_INCR (stmt) = incr;
  gfc_add_expr_to_block (&block, stmt);

  return gfc_finish_block (&block);
}
예제 #3
0
static tree
gfc_trans_omp_atomic (gfc_code *code)
{
  gfc_se lse;
  gfc_se rse;
  gfc_expr *expr2, *e;
  gfc_symbol *var;
  stmtblock_t block;
  tree lhsaddr, type, rhs, x;
  enum tree_code op = ERROR_MARK;
  bool var_on_left = false;

  code = code->block->next;
  gcc_assert (code->op == EXEC_ASSIGN);
  gcc_assert (code->next == NULL);
  var = code->expr->symtree->n.sym;

  gfc_init_se (&lse, NULL);
  gfc_init_se (&rse, NULL);
  gfc_start_block (&block);

  gfc_conv_expr (&lse, code->expr);
  gfc_add_block_to_block (&block, &lse.pre);
  type = TREE_TYPE (lse.expr);
  lhsaddr = gfc_build_addr_expr (NULL, lse.expr);

  expr2 = code->expr2;
  if (expr2->expr_type == EXPR_FUNCTION
      && expr2->value.function.isym->generic_id == GFC_ISYM_CONVERSION)
    expr2 = expr2->value.function.actual->expr;

  if (expr2->expr_type == EXPR_OP)
    {
      gfc_expr *e;
      switch (expr2->value.op.operator)
	{
	case INTRINSIC_PLUS:
	  op = PLUS_EXPR;
	  break;
	case INTRINSIC_TIMES:
	  op = MULT_EXPR;
	  break;
	case INTRINSIC_MINUS:
	  op = MINUS_EXPR;
	  break;
	case INTRINSIC_DIVIDE:
	  if (expr2->ts.type == BT_INTEGER)
	    op = TRUNC_DIV_EXPR;
	  else
	    op = RDIV_EXPR;
	  break;
	case INTRINSIC_AND:
	  op = TRUTH_ANDIF_EXPR;
	  break;
	case INTRINSIC_OR:
	  op = TRUTH_ORIF_EXPR;
	  break;
	case INTRINSIC_EQV:
	  op = EQ_EXPR;
	  break;
	case INTRINSIC_NEQV:
	  op = NE_EXPR;
	  break;
	default:
	  gcc_unreachable ();
	}
      e = expr2->value.op.op1;
      if (e->expr_type == EXPR_FUNCTION
	  && e->value.function.isym->generic_id == GFC_ISYM_CONVERSION)
	e = e->value.function.actual->expr;
      if (e->expr_type == EXPR_VARIABLE
	  && e->symtree != NULL
	  && e->symtree->n.sym == var)
	{
	  expr2 = expr2->value.op.op2;
	  var_on_left = true;
	}
      else
	{
	  e = expr2->value.op.op2;
	  if (e->expr_type == EXPR_FUNCTION
	      && e->value.function.isym->generic_id == GFC_ISYM_CONVERSION)
	    e = e->value.function.actual->expr;
	  gcc_assert (e->expr_type == EXPR_VARIABLE
		      && e->symtree != NULL
		      && e->symtree->n.sym == var);
	  expr2 = expr2->value.op.op1;
	  var_on_left = false;
	}
      gfc_conv_expr (&rse, expr2);
      gfc_add_block_to_block (&block, &rse.pre);
    }
  else
    {
      gcc_assert (expr2->expr_type == EXPR_FUNCTION);
      switch (expr2->value.function.isym->generic_id)
	{
	case GFC_ISYM_MIN:
	  op = MIN_EXPR;
	  break;
	case GFC_ISYM_MAX:
	  op = MAX_EXPR;
	  break;
	case GFC_ISYM_IAND:
	  op = BIT_AND_EXPR;
	  break;
	case GFC_ISYM_IOR:
	  op = BIT_IOR_EXPR;
	  break;
	case GFC_ISYM_IEOR:
	  op = BIT_XOR_EXPR;
	  break;
	default:
	  gcc_unreachable ();
	}
      e = expr2->value.function.actual->expr;
      gcc_assert (e->expr_type == EXPR_VARIABLE
		  && e->symtree != NULL
		  && e->symtree->n.sym == var);

      gfc_conv_expr (&rse, expr2->value.function.actual->next->expr);
      gfc_add_block_to_block (&block, &rse.pre);
      if (expr2->value.function.actual->next->next != NULL)
	{
	  tree accum = gfc_create_var (TREE_TYPE (rse.expr), NULL);
	  gfc_actual_arglist *arg;

	  gfc_add_modify_expr (&block, accum, rse.expr);
	  for (arg = expr2->value.function.actual->next->next; arg;
	       arg = arg->next)
	    {
	      gfc_init_block (&rse.pre);
	      gfc_conv_expr (&rse, arg->expr);
	      gfc_add_block_to_block (&block, &rse.pre);
	      x = fold_build2 (op, TREE_TYPE (accum), accum, rse.expr);
	      gfc_add_modify_expr (&block, accum, x);
	    }

	  rse.expr = accum;
	}

      expr2 = expr2->value.function.actual->next->expr;
    }

  lhsaddr = save_expr (lhsaddr);
  rhs = gfc_evaluate_now (rse.expr, &block);
  x = convert (TREE_TYPE (rhs), build_fold_indirect_ref (lhsaddr));

  if (var_on_left)
    x = fold_build2 (op, TREE_TYPE (rhs), x, rhs);
  else
    x = fold_build2 (op, TREE_TYPE (rhs), rhs, x);

  if (TREE_CODE (TREE_TYPE (rhs)) == COMPLEX_TYPE
      && TREE_CODE (type) != COMPLEX_TYPE)
    x = build1 (REALPART_EXPR, TREE_TYPE (TREE_TYPE (rhs)), x);

  x = build2_v (OMP_ATOMIC, lhsaddr, convert (type, x));
  gfc_add_expr_to_block (&block, x);

  gfc_add_block_to_block (&block, &lse.pre);
  gfc_add_block_to_block (&block, &rse.pre);

  return gfc_finish_block (&block);
}