Exemplo n.º 1
0
tree
gfc_finish_block (stmtblock_t * stmtblock)
{
  tree decl;
  tree expr;
  tree block;

  expr = stmtblock->head;
  if (!expr)
    expr = build_empty_stmt ();

  stmtblock->head = NULL_TREE;

  if (stmtblock->has_scope)
    {
      decl = getdecls ();

      if (decl)
	{
	  block = poplevel (1, 0, 0);
	  expr = build3_v (BIND_EXPR, decl, expr, block);
	}
      else
	poplevel (0, 0, 0);
    }

  return expr;
}
Exemplo n.º 2
0
void
gfc_trans_runtime_check (tree cond, const char * msgid, stmtblock_t * pblock,
			 locus * where)
{
  stmtblock_t block;
  tree body;
  tree tmp;
  tree args;
  char * message;
  int line;

  if (integer_zerop (cond))
    return;

  /* The code to generate the error.  */
  gfc_start_block (&block);

  if (where)
    {
#ifdef USE_MAPPED_LOCATION
      line = LOCATION_LINE (where->lb->location);
#else 
      line = where->lb->linenum;
#endif
      asprintf (&message, "%s (in file '%s', at line %d)", _(msgid),
		where->lb->file->filename, line);
    }
  else
    asprintf (&message, "%s (in file '%s', around line %d)", _(msgid),
	      gfc_source_file, input_line + 1);

  tmp = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const(message));
  gfc_free(message);
  args = gfc_chainon_list (NULL_TREE, tmp);

  tmp = build_function_call_expr (gfor_fndecl_runtime_error, args);
  gfc_add_expr_to_block (&block, tmp);

  body = gfc_finish_block (&block);

  if (integer_onep (cond))
    {
      gfc_add_expr_to_block (pblock, body);
    }
  else
    {
      /* Tell the compiler that this isn't likely.  */
      cond = fold_convert (long_integer_type_node, cond);
      tmp = gfc_chainon_list (NULL_TREE, cond);
      tmp = gfc_chainon_list (tmp, build_int_cst (long_integer_type_node, 0));
      cond = build_function_call_expr (built_in_decls[BUILT_IN_EXPECT], tmp);
      cond = fold_convert (boolean_type_node, cond);

      tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt ());
      gfc_add_expr_to_block (pblock, tmp);
    }
}
Exemplo n.º 3
0
void
gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock,
			 locus * where, const char * msgid, ...)
{
  va_list ap;
  stmtblock_t block;
  tree body;
  tree tmp;
  tree tmpvar = NULL;

  if (integer_zerop (cond))
    return;

  if (once)
    {
       tmpvar = gfc_create_var (boolean_type_node, "print_warning");
       TREE_STATIC (tmpvar) = 1;
       DECL_INITIAL (tmpvar) = boolean_true_node;
       gfc_add_expr_to_block (pblock, tmpvar);
    }

  gfc_start_block (&block);

  /* The code to generate the error.  */
  va_start (ap, msgid);
  gfc_add_expr_to_block (&block,
			 gfc_trans_runtime_error_vararg (error, where,
							 msgid, ap));

  if (once)
    gfc_add_modify (&block, tmpvar, boolean_false_node);

  body = gfc_finish_block (&block);

  if (integer_onep (cond))
    {
      gfc_add_expr_to_block (pblock, body);
    }
  else
    {
      /* Tell the compiler that this isn't likely.  */
      if (once)
	cond = fold_build2 (TRUTH_AND_EXPR, long_integer_type_node, tmpvar,
			    cond);
      else
	cond = fold_convert (long_integer_type_node, cond);

      tmp = build_int_cst (long_integer_type_node, 0);
      cond = build_call_expr_loc (input_location,
			      built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp);
      cond = fold_convert (boolean_type_node, cond);

      tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt (input_location));
      gfc_add_expr_to_block (pblock, tmp);
    }
}
Exemplo n.º 4
0
static tree
gfc_trans_omp_code (gfc_code *code, bool force_empty)
{
  tree stmt;

  pushlevel (0);
  stmt = gfc_trans_code (code);
  if (TREE_CODE (stmt) != BIND_EXPR)
    {
      if (!IS_EMPTY_STMT (stmt) || force_empty)
	{
	  tree block = poplevel (1, 0, 0);
	  stmt = build3_v (BIND_EXPR, NULL, stmt, block);
	}
      else
	poplevel (0, 0, 0);
    }
  else
    poplevel (0, 0, 0);
  return stmt;
}
Exemplo n.º 5
0
static tree
gfc_trans_omp_parallel_do (gfc_code *code)
{
  stmtblock_t block, *pblock = NULL;
  gfc_omp_clauses parallel_clauses, do_clauses;
  tree stmt, omp_clauses = NULL_TREE;

  gfc_start_block (&block);

  memset (&do_clauses, 0, sizeof (do_clauses));
  if (code->ext.omp_clauses != NULL)
    {
      memcpy (&parallel_clauses, code->ext.omp_clauses,
	      sizeof (parallel_clauses));
      do_clauses.sched_kind = parallel_clauses.sched_kind;
      do_clauses.chunk_size = parallel_clauses.chunk_size;
      do_clauses.ordered = parallel_clauses.ordered;
      do_clauses.collapse = parallel_clauses.collapse;
      parallel_clauses.sched_kind = OMP_SCHED_NONE;
      parallel_clauses.chunk_size = NULL;
      parallel_clauses.ordered = false;
      parallel_clauses.collapse = 0;
      omp_clauses = gfc_trans_omp_clauses (&block, &parallel_clauses,
					   code->loc);
    }
  do_clauses.nowait = true;
  if (!do_clauses.ordered && do_clauses.sched_kind != OMP_SCHED_STATIC)
    pblock = █
  else
    pushlevel (0);
  stmt = gfc_trans_omp_do (code, pblock, &do_clauses, omp_clauses);
  if (TREE_CODE (stmt) != BIND_EXPR)
    stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
  else
    poplevel (0, 0, 0);
  stmt = build2 (OMP_PARALLEL, void_type_node, stmt, omp_clauses);
  OMP_PARALLEL_COMBINED (stmt) = 1;
  gfc_add_expr_to_block (&block, stmt);
  return gfc_finish_block (&block);
}
Exemplo n.º 6
0
static tree
gfc_trans_omp_parallel_workshare (gfc_code *code)
{
  stmtblock_t block;
  gfc_omp_clauses workshare_clauses;
  tree stmt, omp_clauses;

  memset (&workshare_clauses, 0, sizeof (workshare_clauses));
  workshare_clauses.nowait = true;

  gfc_start_block (&block);
  omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
				       code->loc);
  pushlevel (0);
  stmt = gfc_trans_omp_workshare (code, &workshare_clauses);
  if (TREE_CODE (stmt) != BIND_EXPR)
    stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
  else
    poplevel (0, 0, 0);
  stmt = build4_v (OMP_PARALLEL, stmt, omp_clauses, NULL, NULL);
  OMP_PARALLEL_COMBINED (stmt) = 1;
  gfc_add_expr_to_block (&block, stmt);
  return gfc_finish_block (&block);
}
Exemplo n.º 7
0
static void
gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where)
{
  gfc_symtree *root1 = NULL, *root2 = NULL, *root3 = NULL, *root4 = NULL;
  gfc_symtree *symtree1, *symtree2, *symtree3, *symtree4 = NULL;
  gfc_symbol init_val_sym, outer_sym, intrinsic_sym;
  gfc_expr *e1, *e2, *e3, *e4;
  gfc_ref *ref;
  tree decl, backend_decl, stmt;
  locus old_loc = gfc_current_locus;
  const char *iname;
  try t;

  decl = OMP_CLAUSE_DECL (c);
  gfc_current_locus = where;

  /* Create a fake symbol for init value.  */
  memset (&init_val_sym, 0, sizeof (init_val_sym));
  init_val_sym.ns = sym->ns;
  init_val_sym.name = sym->name;
  init_val_sym.ts = sym->ts;
  init_val_sym.attr.referenced = 1;
  init_val_sym.declared_at = where;
  init_val_sym.attr.flavor = FL_VARIABLE;
  backend_decl = omp_reduction_init (c, gfc_sym_type (&init_val_sym));
  init_val_sym.backend_decl = backend_decl;

  /* Create a fake symbol for the outer array reference.  */
  outer_sym = *sym;
  outer_sym.as = gfc_copy_array_spec (sym->as);
  outer_sym.attr.dummy = 0;
  outer_sym.attr.result = 0;
  outer_sym.attr.flavor = FL_VARIABLE;
  outer_sym.backend_decl = create_tmp_var_raw (TREE_TYPE (decl), NULL);

  /* Create fake symtrees for it.  */
  symtree1 = gfc_new_symtree (&root1, sym->name);
  symtree1->n.sym = sym;
  gcc_assert (symtree1 == root1);

  symtree2 = gfc_new_symtree (&root2, sym->name);
  symtree2->n.sym = &init_val_sym;
  gcc_assert (symtree2 == root2);

  symtree3 = gfc_new_symtree (&root3, sym->name);
  symtree3->n.sym = &outer_sym;
  gcc_assert (symtree3 == root3);

  /* Create expressions.  */
  e1 = gfc_get_expr ();
  e1->expr_type = EXPR_VARIABLE;
  e1->where = where;
  e1->symtree = symtree1;
  e1->ts = sym->ts;
  e1->ref = ref = gfc_get_ref ();
  ref->u.ar.where = where;
  ref->u.ar.as = sym->as;
  ref->u.ar.type = AR_FULL;
  ref->u.ar.dimen = 0;
  t = gfc_resolve_expr (e1);
  gcc_assert (t == SUCCESS);

  e2 = gfc_get_expr ();
  e2->expr_type = EXPR_VARIABLE;
  e2->where = where;
  e2->symtree = symtree2;
  e2->ts = sym->ts;
  t = gfc_resolve_expr (e2);
  gcc_assert (t == SUCCESS);

  e3 = gfc_copy_expr (e1);
  e3->symtree = symtree3;
  t = gfc_resolve_expr (e3);
  gcc_assert (t == SUCCESS);

  iname = NULL;
  switch (OMP_CLAUSE_REDUCTION_CODE (c))
    {
    case PLUS_EXPR:
    case MINUS_EXPR:
      e4 = gfc_add (e3, e1);
      break;
    case MULT_EXPR:
      e4 = gfc_multiply (e3, e1);
      break;
    case TRUTH_ANDIF_EXPR:
      e4 = gfc_and (e3, e1);
      break;
    case TRUTH_ORIF_EXPR:
      e4 = gfc_or (e3, e1);
      break;
    case EQ_EXPR:
      e4 = gfc_eqv (e3, e1);
      break;
    case NE_EXPR:
      e4 = gfc_neqv (e3, e1);
      break;
    case MIN_EXPR:
      iname = "min";
      break;
    case MAX_EXPR:
      iname = "max";
      break;
    case BIT_AND_EXPR:
      iname = "iand";
      break;
    case BIT_IOR_EXPR:
      iname = "ior";
      break;
    case BIT_XOR_EXPR:
      iname = "ieor";
      break;
    default:
      gcc_unreachable ();
    }
  if (iname != NULL)
    {
      memset (&intrinsic_sym, 0, sizeof (intrinsic_sym));
      intrinsic_sym.ns = sym->ns;
      intrinsic_sym.name = iname;
      intrinsic_sym.ts = sym->ts;
      intrinsic_sym.attr.referenced = 1;
      intrinsic_sym.attr.intrinsic = 1;
      intrinsic_sym.attr.function = 1;
      intrinsic_sym.result = &intrinsic_sym;
      intrinsic_sym.declared_at = where;

      symtree4 = gfc_new_symtree (&root4, iname);
      symtree4->n.sym = &intrinsic_sym;
      gcc_assert (symtree4 == root4);

      e4 = gfc_get_expr ();
      e4->expr_type = EXPR_FUNCTION;
      e4->where = where;
      e4->symtree = symtree4;
      e4->value.function.isym = gfc_find_function (iname);
      e4->value.function.actual = gfc_get_actual_arglist ();
      e4->value.function.actual->expr = e3;
      e4->value.function.actual->next = gfc_get_actual_arglist ();
      e4->value.function.actual->next->expr = e1;
    }
  /* e1 and e3 have been stored as arguments of e4, avoid sharing.  */
  e1 = gfc_copy_expr (e1);
  e3 = gfc_copy_expr (e3);
  t = gfc_resolve_expr (e4);
  gcc_assert (t == SUCCESS);

  /* Create the init statement list.  */
  pushlevel (0);
  stmt = gfc_trans_assignment (e1, e2, false);
  if (TREE_CODE (stmt) != BIND_EXPR)
    stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
  else
    poplevel (0, 0, 0);
  OMP_CLAUSE_REDUCTION_INIT (c) = stmt;

  /* Create the merge statement list.  */
  pushlevel (0);
  stmt = gfc_trans_assignment (e3, e4, false);
  if (TREE_CODE (stmt) != BIND_EXPR)
    stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
  else
    poplevel (0, 0, 0);
  OMP_CLAUSE_REDUCTION_MERGE (c) = stmt;

  /* And stick the placeholder VAR_DECL into the clause as well.  */
  OMP_CLAUSE_REDUCTION_PLACEHOLDER (c) = outer_sym.backend_decl;

  gfc_current_locus = old_loc;

  gfc_free_expr (e1);
  gfc_free_expr (e2);
  gfc_free_expr (e3);
  gfc_free_expr (e4);
  gfc_free (symtree1);
  gfc_free (symtree2);
  gfc_free (symtree3);
  if (symtree4)
    gfc_free (symtree4);
  gfc_free_array_spec (outer_sym.as);
}

static tree
gfc_trans_omp_reduction_list (gfc_namelist *namelist, tree list, 
			      enum tree_code reduction_code, locus where)
{
  for (; namelist != NULL; namelist = namelist->next)
    if (namelist->sym->attr.referenced)
      {
	tree t = gfc_trans_omp_variable (namelist->sym);
	if (t != error_mark_node)
	  {
	    tree node = build_omp_clause (OMP_CLAUSE_REDUCTION);
	    OMP_CLAUSE_DECL (node) = t;
	    OMP_CLAUSE_REDUCTION_CODE (node) = reduction_code;
	    if (namelist->sym->attr.dimension)
	      gfc_trans_omp_array_reduction (node, namelist->sym, where);
	    list = gfc_trans_add_clause (node, list);
	  }
      }
  return list;
}

static tree
gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
		       locus where)
{
  tree omp_clauses = NULL_TREE, chunk_size, c, old_clauses;
  int list;
  enum omp_clause_code clause_code;
  gfc_se se;

  if (clauses == NULL)
    return NULL_TREE;

  for (list = 0; list < OMP_LIST_NUM; list++)
    {
      gfc_namelist *n = clauses->lists[list];

      if (n == NULL)
	continue;
      if (list >= OMP_LIST_REDUCTION_FIRST
	  && list <= OMP_LIST_REDUCTION_LAST)
	{
	  enum tree_code reduction_code;
	  switch (list)
	    {
	    case OMP_LIST_PLUS:
	      reduction_code = PLUS_EXPR;
	      break;
	    case OMP_LIST_MULT:
	      reduction_code = MULT_EXPR;
	      break;
	    case OMP_LIST_SUB:
	      reduction_code = MINUS_EXPR;
	      break;
	    case OMP_LIST_AND:
	      reduction_code = TRUTH_ANDIF_EXPR;
	      break;
	    case OMP_LIST_OR:
	      reduction_code = TRUTH_ORIF_EXPR;
	      break;
	    case OMP_LIST_EQV:
	      reduction_code = EQ_EXPR;
	      break;
	    case OMP_LIST_NEQV:
	      reduction_code = NE_EXPR;
	      break;
	    case OMP_LIST_MAX:
	      reduction_code = MAX_EXPR;
	      break;
	    case OMP_LIST_MIN:
	      reduction_code = MIN_EXPR;
	      break;
	    case OMP_LIST_IAND:
	      reduction_code = BIT_AND_EXPR;
	      break;
	    case OMP_LIST_IOR:
	      reduction_code = BIT_IOR_EXPR;
	      break;
	    case OMP_LIST_IEOR:
	      reduction_code = BIT_XOR_EXPR;
	      break;
	    default:
	      gcc_unreachable ();
	    }
	  old_clauses = omp_clauses;
	  omp_clauses
	    = gfc_trans_omp_reduction_list (n, omp_clauses, reduction_code,
					    where);
	  continue;
	}
      switch (list)
	{
	case OMP_LIST_PRIVATE:
	  clause_code = OMP_CLAUSE_PRIVATE;
	  goto add_clause;
	case OMP_LIST_SHARED:
	  clause_code = OMP_CLAUSE_SHARED;
	  goto add_clause;
	case OMP_LIST_FIRSTPRIVATE:
	  clause_code = OMP_CLAUSE_FIRSTPRIVATE;
	  goto add_clause;
	case OMP_LIST_LASTPRIVATE:
	  clause_code = OMP_CLAUSE_LASTPRIVATE;
	  goto add_clause;
	case OMP_LIST_COPYIN:
	  clause_code = OMP_CLAUSE_COPYIN;
	  goto add_clause;
	case OMP_LIST_COPYPRIVATE:
	  clause_code = OMP_CLAUSE_COPYPRIVATE;
	  /* FALLTHROUGH */
	add_clause:
	  omp_clauses
	    = gfc_trans_omp_variable_list (clause_code, n, omp_clauses);
	  break;
	default:
	  break;
	}
    }

  if (clauses->if_expr)
    {
      tree if_var;

      gfc_init_se (&se, NULL);
      gfc_conv_expr (&se, clauses->if_expr);
      gfc_add_block_to_block (block, &se.pre);
      if_var = gfc_evaluate_now (se.expr, block);
      gfc_add_block_to_block (block, &se.post);

      c = build_omp_clause (OMP_CLAUSE_IF);
      OMP_CLAUSE_IF_EXPR (c) = if_var;
      omp_clauses = gfc_trans_add_clause (c, omp_clauses);
    }

  if (clauses->num_threads)
    {
      tree num_threads;

      gfc_init_se (&se, NULL);
      gfc_conv_expr (&se, clauses->num_threads);
      gfc_add_block_to_block (block, &se.pre);
      num_threads = gfc_evaluate_now (se.expr, block);
      gfc_add_block_to_block (block, &se.post);

      c = build_omp_clause (OMP_CLAUSE_NUM_THREADS);
      OMP_CLAUSE_NUM_THREADS_EXPR (c) = num_threads;
      omp_clauses = gfc_trans_add_clause (c, omp_clauses);
    }

  chunk_size = NULL_TREE;
  if (clauses->chunk_size)
    {
      gfc_init_se (&se, NULL);
      gfc_conv_expr (&se, clauses->chunk_size);
      gfc_add_block_to_block (block, &se.pre);
      chunk_size = gfc_evaluate_now (se.expr, block);
      gfc_add_block_to_block (block, &se.post);
    }

  if (clauses->sched_kind != OMP_SCHED_NONE)
    {
      c = build_omp_clause (OMP_CLAUSE_SCHEDULE);
      OMP_CLAUSE_SCHEDULE_CHUNK_EXPR (c) = chunk_size;
      switch (clauses->sched_kind)
	{
	case OMP_SCHED_STATIC:
	  OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_STATIC;
	  break;
	case OMP_SCHED_DYNAMIC:
	  OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_DYNAMIC;
	  break;
	case OMP_SCHED_GUIDED:
	  OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_GUIDED;
	  break;
	case OMP_SCHED_RUNTIME:
	  OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_RUNTIME;
	  break;
	default:
	  gcc_unreachable ();
	}
      omp_clauses = gfc_trans_add_clause (c, omp_clauses);
    }

  if (clauses->default_sharing != OMP_DEFAULT_UNKNOWN)
    {
      c = build_omp_clause (OMP_CLAUSE_DEFAULT);
      switch (clauses->default_sharing)
	{
	case OMP_DEFAULT_NONE:
	  OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_NONE;
	  break;
	case OMP_DEFAULT_SHARED:
	  OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_SHARED;
	  break;
	case OMP_DEFAULT_PRIVATE:
	  OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_PRIVATE;
	  break;
	default:
	  gcc_unreachable ();
	}
      omp_clauses = gfc_trans_add_clause (c, omp_clauses);
    }

  if (clauses->nowait)
    {
      c = build_omp_clause (OMP_CLAUSE_NOWAIT);
      omp_clauses = gfc_trans_add_clause (c, omp_clauses);
    }

  if (clauses->ordered)
    {
      c = build_omp_clause (OMP_CLAUSE_ORDERED);
      omp_clauses = gfc_trans_add_clause (c, omp_clauses);
    }

  return omp_clauses;
}
Exemplo n.º 8
0
static void
gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where)
{
  gfc_symtree *root1 = NULL, *root2 = NULL, *root3 = NULL, *root4 = NULL;
  gfc_symtree *symtree1, *symtree2, *symtree3, *symtree4 = NULL;
  gfc_symbol init_val_sym, outer_sym, intrinsic_sym;
  gfc_expr *e1, *e2, *e3, *e4;
  gfc_ref *ref;
  tree decl, backend_decl, stmt;
  locus old_loc = gfc_current_locus;
  const char *iname;
  gfc_try t;

  decl = OMP_CLAUSE_DECL (c);
  gfc_current_locus = where;

  /* Create a fake symbol for init value.  */
  memset (&init_val_sym, 0, sizeof (init_val_sym));
  init_val_sym.ns = sym->ns;
  init_val_sym.name = sym->name;
  init_val_sym.ts = sym->ts;
  init_val_sym.attr.referenced = 1;
  init_val_sym.declared_at = where;
  init_val_sym.attr.flavor = FL_VARIABLE;
  backend_decl = omp_reduction_init (c, gfc_sym_type (&init_val_sym));
  init_val_sym.backend_decl = backend_decl;

  /* Create a fake symbol for the outer array reference.  */
  outer_sym = *sym;
  outer_sym.as = gfc_copy_array_spec (sym->as);
  outer_sym.attr.dummy = 0;
  outer_sym.attr.result = 0;
  outer_sym.attr.flavor = FL_VARIABLE;
  outer_sym.backend_decl = create_tmp_var_raw (TREE_TYPE (decl), NULL);

  /* Create fake symtrees for it.  */
  symtree1 = gfc_new_symtree (&root1, sym->name);
  symtree1->n.sym = sym;
  gcc_assert (symtree1 == root1);

  symtree2 = gfc_new_symtree (&root2, sym->name);
  symtree2->n.sym = &init_val_sym;
  gcc_assert (symtree2 == root2);

  symtree3 = gfc_new_symtree (&root3, sym->name);
  symtree3->n.sym = &outer_sym;
  gcc_assert (symtree3 == root3);

  /* Create expressions.  */
  e1 = gfc_get_expr ();
  e1->expr_type = EXPR_VARIABLE;
  e1->where = where;
  e1->symtree = symtree1;
  e1->ts = sym->ts;
  e1->ref = ref = gfc_get_ref ();
  ref->type = REF_ARRAY;
  ref->u.ar.where = where;
  ref->u.ar.as = sym->as;
  ref->u.ar.type = AR_FULL;
  ref->u.ar.dimen = 0;
  t = gfc_resolve_expr (e1);
  gcc_assert (t == SUCCESS);

  e2 = gfc_get_expr ();
  e2->expr_type = EXPR_VARIABLE;
  e2->where = where;
  e2->symtree = symtree2;
  e2->ts = sym->ts;
  t = gfc_resolve_expr (e2);
  gcc_assert (t == SUCCESS);

  e3 = gfc_copy_expr (e1);
  e3->symtree = symtree3;
  t = gfc_resolve_expr (e3);
  gcc_assert (t == SUCCESS);

  iname = NULL;
  switch (OMP_CLAUSE_REDUCTION_CODE (c))
    {
    case PLUS_EXPR:
    case MINUS_EXPR:
      e4 = gfc_add (e3, e1);
      break;
    case MULT_EXPR:
      e4 = gfc_multiply (e3, e1);
      break;
    case TRUTH_ANDIF_EXPR:
      e4 = gfc_and (e3, e1);
      break;
    case TRUTH_ORIF_EXPR:
      e4 = gfc_or (e3, e1);
      break;
    case EQ_EXPR:
      e4 = gfc_eqv (e3, e1);
      break;
    case NE_EXPR:
      e4 = gfc_neqv (e3, e1);
      break;
    case MIN_EXPR:
      iname = "min";
      break;
    case MAX_EXPR:
      iname = "max";
      break;
    case BIT_AND_EXPR:
      iname = "iand";
      break;
    case BIT_IOR_EXPR:
      iname = "ior";
      break;
    case BIT_XOR_EXPR:
      iname = "ieor";
      break;
    default:
      gcc_unreachable ();
    }
  if (iname != NULL)
    {
      memset (&intrinsic_sym, 0, sizeof (intrinsic_sym));
      intrinsic_sym.ns = sym->ns;
      intrinsic_sym.name = iname;
      intrinsic_sym.ts = sym->ts;
      intrinsic_sym.attr.referenced = 1;
      intrinsic_sym.attr.intrinsic = 1;
      intrinsic_sym.attr.function = 1;
      intrinsic_sym.result = &intrinsic_sym;
      intrinsic_sym.declared_at = where;

      symtree4 = gfc_new_symtree (&root4, iname);
      symtree4->n.sym = &intrinsic_sym;
      gcc_assert (symtree4 == root4);

      e4 = gfc_get_expr ();
      e4->expr_type = EXPR_FUNCTION;
      e4->where = where;
      e4->symtree = symtree4;
      e4->value.function.isym = gfc_find_function (iname);
      e4->value.function.actual = gfc_get_actual_arglist ();
      e4->value.function.actual->expr = e3;
      e4->value.function.actual->next = gfc_get_actual_arglist ();
      e4->value.function.actual->next->expr = e1;
    }
  /* e1 and e3 have been stored as arguments of e4, avoid sharing.  */
  e1 = gfc_copy_expr (e1);
  e3 = gfc_copy_expr (e3);
  t = gfc_resolve_expr (e4);
  gcc_assert (t == SUCCESS);

  /* Create the init statement list.  */
  pushlevel (0);
  if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
      && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl)) == GFC_ARRAY_ALLOCATABLE)
    {
      /* If decl is an allocatable array, it needs to be allocated
	 with the same bounds as the outer var.  */
      tree type = TREE_TYPE (decl), rank, size, esize, ptr;
      stmtblock_t block;

      gfc_start_block (&block);

      gfc_add_modify (&block, decl, outer_sym.backend_decl);
      rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
      size = gfc_conv_descriptor_ubound_get (decl, rank);
      size = fold_build2 (MINUS_EXPR, gfc_array_index_type, size,
			  gfc_conv_descriptor_lbound_get (decl, rank));
      size = fold_build2 (PLUS_EXPR, gfc_array_index_type, size,
			  gfc_index_one_node);
      if (GFC_TYPE_ARRAY_RANK (type) > 1)
	size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
			    gfc_conv_descriptor_stride_get (decl, rank));
      esize = fold_convert (gfc_array_index_type,
			    TYPE_SIZE_UNIT (gfc_get_element_type (type)));
      size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, esize);
      size = gfc_evaluate_now (fold_convert (size_type_node, size), &block);
      ptr = gfc_allocate_array_with_status (&block,
					    build_int_cst (pvoid_type_node, 0),
					    size, NULL, NULL);
      gfc_conv_descriptor_data_set (&block, decl, ptr);
      gfc_add_expr_to_block (&block, gfc_trans_assignment (e1, e2, false));
      stmt = gfc_finish_block (&block);
    }
  else
    stmt = gfc_trans_assignment (e1, e2, false);
  if (TREE_CODE (stmt) != BIND_EXPR)
    stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
  else
    poplevel (0, 0, 0);
  OMP_CLAUSE_REDUCTION_INIT (c) = stmt;

  /* Create the merge statement list.  */
  pushlevel (0);
  if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
      && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl)) == GFC_ARRAY_ALLOCATABLE)
    {
      /* If decl is an allocatable array, it needs to be deallocated
	 afterwards.  */
      stmtblock_t block;

      gfc_start_block (&block);
      gfc_add_expr_to_block (&block, gfc_trans_assignment (e3, e4, false));
      gfc_add_expr_to_block (&block, gfc_trans_dealloc_allocated (decl));
      stmt = gfc_finish_block (&block);
    }
  else
    stmt = gfc_trans_assignment (e3, e4, false);
  if (TREE_CODE (stmt) != BIND_EXPR)
    stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
  else
    poplevel (0, 0, 0);
  OMP_CLAUSE_REDUCTION_MERGE (c) = stmt;

  /* And stick the placeholder VAR_DECL into the clause as well.  */
  OMP_CLAUSE_REDUCTION_PLACEHOLDER (c) = outer_sym.backend_decl;

  gfc_current_locus = old_loc;

  gfc_free_expr (e1);
  gfc_free_expr (e2);
  gfc_free_expr (e3);
  gfc_free_expr (e4);
  gfc_free (symtree1);
  gfc_free (symtree2);
  gfc_free (symtree3);
  if (symtree4)
    gfc_free (symtree4);
  gfc_free_array_spec (outer_sym.as);
}
Exemplo n.º 9
0
static tree
gfc_trans_omp_workshare (gfc_code *code, gfc_omp_clauses *clauses)
{
  tree res, tmp, stmt;
  stmtblock_t block, *pblock = NULL;
  stmtblock_t singleblock;
  int saved_ompws_flags;
  bool singleblock_in_progress = false;
  /* True if previous gfc_code in workshare construct is not workshared.  */
  bool prev_singleunit;

  code = code->block->next;

  pushlevel (0);

  if (!code)
    return build_empty_stmt (input_location);

  gfc_start_block (&block);
  pblock = &block;

  ompws_flags = OMPWS_WORKSHARE_FLAG;
  prev_singleunit = false;

  /* Translate statements one by one to trees until we reach
     the end of the workshare construct.  Adjacent gfc_codes that
     are a single unit of work are clustered and encapsulated in a
     single OMP_SINGLE construct.  */
  for (; code; code = code->next)
    {
      if (code->here != 0)
	{
	  res = gfc_trans_label_here (code);
	  gfc_add_expr_to_block (pblock, res);
	}

      /* No dependence analysis, use for clauses with wait.
	 If this is the last gfc_code, use default omp_clauses.  */
      if (code->next == NULL && clauses->nowait)
	ompws_flags |= OMPWS_NOWAIT;

      /* By default, every gfc_code is a single unit of work.  */
      ompws_flags |= OMPWS_CURR_SINGLEUNIT;
      ompws_flags &= ~OMPWS_SCALARIZER_WS;

      switch (code->op)
	{
	case EXEC_NOP:
	  res = NULL_TREE;
	  break;

	case EXEC_ASSIGN:
	  res = gfc_trans_assign (code);
	  break;

	case EXEC_POINTER_ASSIGN:
	  res = gfc_trans_pointer_assign (code);
	  break;

	case EXEC_INIT_ASSIGN:
	  res = gfc_trans_init_assign (code);
	  break;

	case EXEC_FORALL:
	  res = gfc_trans_forall (code);
	  break;

	case EXEC_WHERE:
	  res = gfc_trans_where (code);
	  break;

	case EXEC_OMP_ATOMIC:
	  res = gfc_trans_omp_directive (code);
	  break;

	case EXEC_OMP_PARALLEL:
	case EXEC_OMP_PARALLEL_DO:
	case EXEC_OMP_PARALLEL_SECTIONS:
	case EXEC_OMP_PARALLEL_WORKSHARE:
	case EXEC_OMP_CRITICAL:
	  saved_ompws_flags = ompws_flags;
	  ompws_flags = 0;
	  res = gfc_trans_omp_directive (code);
	  ompws_flags = saved_ompws_flags;
	  break;
	
	default:
	  internal_error ("gfc_trans_omp_workshare(): Bad statement code");
	}

      gfc_set_backend_locus (&code->loc);

      if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
	{
	  if (prev_singleunit)
	    {
	      if (ompws_flags & OMPWS_CURR_SINGLEUNIT)
		/* Add current gfc_code to single block.  */
		gfc_add_expr_to_block (&singleblock, res);
	      else
		{
		  /* Finish single block and add it to pblock.  */
		  tmp = gfc_finish_block (&singleblock);
		  tmp = build2 (OMP_SINGLE, void_type_node, tmp, NULL_TREE);
		  gfc_add_expr_to_block (pblock, tmp);
		  /* Add current gfc_code to pblock.  */
		  gfc_add_expr_to_block (pblock, res);
		  singleblock_in_progress = false;
		}
	    }
	  else
	    {
	      if (ompws_flags & OMPWS_CURR_SINGLEUNIT)
		{
		  /* Start single block.  */
		  gfc_init_block (&singleblock);
		  gfc_add_expr_to_block (&singleblock, res);
		  singleblock_in_progress = true;
		}
	      else
		/* Add the new statement to the block.  */
		gfc_add_expr_to_block (pblock, res);
	    }
	  prev_singleunit = (ompws_flags & OMPWS_CURR_SINGLEUNIT) != 0;
	}
    }

  /* Finish remaining SINGLE block, if we were in the middle of one.  */
  if (singleblock_in_progress)
    {
      /* Finish single block and add it to pblock.  */
      tmp = gfc_finish_block (&singleblock);
      tmp = build2 (OMP_SINGLE, void_type_node, tmp,
		    clauses->nowait
		    ? build_omp_clause (input_location, OMP_CLAUSE_NOWAIT)
		    : NULL_TREE);
      gfc_add_expr_to_block (pblock, tmp);
    }

  stmt = gfc_finish_block (pblock);
  if (TREE_CODE (stmt) != BIND_EXPR)
    {
      if (!IS_EMPTY_STMT (stmt))
	{
	  tree bindblock = poplevel (1, 0, 0);
	  stmt = build3_v (BIND_EXPR, NULL, stmt, bindblock);
	}
      else
	poplevel (0, 0, 0);
    }
  else
    poplevel (0, 0, 0);

  ompws_flags = 0;
  return stmt;
}