#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "tree.h"
#include "tree-gimple.h"
#include "ggc.h"
#include "toplev.h"
#include "real.h"
#include "gfortran.h"
#include "trans.h"
#include "trans-stmt.h"
#include "trans-types.h"
#include "trans-array.h"
#include "trans-const.h"
#include "arith.h"
bool
gfc_omp_privatize_by_reference (tree decl)
{
tree type = TREE_TYPE (decl);
if (TREE_CODE (type) == REFERENCE_TYPE)
return true;
if (TREE_CODE (type) == POINTER_TYPE)
{
if (!DECL_ARTIFICIAL (decl))
return true;
if (DECL_LANG_SPECIFIC (decl)
&& GFC_DECL_SAVED_DESCRIPTOR (decl))
return true;
}
return false;
}
enum omp_clause_default_kind
gfc_omp_predetermined_sharing (tree decl)
{
if (DECL_ARTIFICIAL (decl) && ! GFC_DECL_RESULT (decl))
return OMP_CLAUSE_DEFAULT_SHARED;
if (GFC_DECL_CRAY_POINTEE (decl))
return OMP_CLAUSE_DEFAULT_PRIVATE;
if (GFC_DECL_COMMON_OR_EQUIV (decl) && ! DECL_HAS_VALUE_EXPR_P (decl))
return OMP_CLAUSE_DEFAULT_SHARED;
if (GFC_DECL_RESULT (decl) && ! DECL_HAS_VALUE_EXPR_P (decl))
return OMP_CLAUSE_DEFAULT_SHARED;
return OMP_CLAUSE_DEFAULT_UNSPECIFIED;
}
tree
gfc_omp_clause_default_ctor (tree clause ATTRIBUTE_UNUSED, tree decl)
{
tree type = TREE_TYPE (decl);
stmtblock_t block;
if (! GFC_DESCRIPTOR_TYPE_P (type))
return NULL;
gfc_init_block (&block);
gfc_conv_descriptor_data_set (&block, decl, null_pointer_node);
return gfc_finish_block (&block);
}
bool
gfc_omp_disregard_value_expr (tree decl, bool shared)
{
if (GFC_DECL_COMMON_OR_EQUIV (decl)
&& DECL_HAS_VALUE_EXPR_P (decl))
{
tree value = DECL_VALUE_EXPR (decl);
if (TREE_CODE (value) == COMPONENT_REF
&& TREE_CODE (TREE_OPERAND (value, 0)) == VAR_DECL
&& GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value, 0)))
{
return ! shared;
}
}
if (GFC_DECL_RESULT (decl) && DECL_HAS_VALUE_EXPR_P (decl))
return ! shared;
return false;
}
bool
gfc_omp_private_debug_clause (tree decl, bool shared)
{
if (GFC_DECL_CRAY_POINTEE (decl))
return true;
if (GFC_DECL_COMMON_OR_EQUIV (decl)
&& DECL_HAS_VALUE_EXPR_P (decl))
{
tree value = DECL_VALUE_EXPR (decl);
if (TREE_CODE (value) == COMPONENT_REF
&& TREE_CODE (TREE_OPERAND (value, 0)) == VAR_DECL
&& GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value, 0)))
return shared;
}
return false;
}
void
gfc_omp_firstprivatize_type_sizes (struct gimplify_omp_ctx *ctx, tree type)
{
if (GFC_ARRAY_TYPE_P (type) || GFC_DESCRIPTOR_TYPE_P (type))
{
int r;
gcc_assert (TYPE_LANG_SPECIFIC (type) != NULL);
for (r = 0; r < GFC_TYPE_ARRAY_RANK (type); r++)
{
omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_LBOUND (type, r));
omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_UBOUND (type, r));
omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_STRIDE (type, r));
}
omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_SIZE (type));
omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_OFFSET (type));
}
}
static inline tree
gfc_trans_add_clause (tree node, tree tail)
{
OMP_CLAUSE_CHAIN (node) = tail;
return node;
}
static tree
gfc_trans_omp_variable (gfc_symbol *sym)
{
tree t = gfc_get_symbol_decl (sym);
tree parent_decl;
int parent_flag;
bool return_value;
bool alternate_entry;
bool entry_master;
return_value = sym->attr.function && sym->result == sym;
alternate_entry = sym->attr.function && sym->attr.entry
&& sym->result == sym;
entry_master = sym->attr.result
&& sym->ns->proc_name->attr.entry_master
&& !gfc_return_by_reference (sym->ns->proc_name);
parent_decl = DECL_CONTEXT (current_function_decl);
if ((t == parent_decl && return_value)
|| (sym->ns && sym->ns->proc_name
&& sym->ns->proc_name->backend_decl == parent_decl
&& (alternate_entry || entry_master)))
parent_flag = 1;
else
parent_flag = 0;
if (return_value && (t == current_function_decl || parent_flag))
t = gfc_get_fake_result_decl (sym, parent_flag);
else if (alternate_entry
&& (sym->ns->proc_name->backend_decl == current_function_decl
|| parent_flag))
{
gfc_entry_list *el = NULL;
for (el = sym->ns->entries; el; el = el->next)
if (sym == el->sym)
{
t = gfc_get_fake_result_decl (sym, parent_flag);
break;
}
}
else if (entry_master
&& (sym->ns->proc_name->backend_decl == current_function_decl
|| parent_flag))
t = gfc_get_fake_result_decl (sym, parent_flag);
return t;
}
static tree
gfc_trans_omp_variable_list (enum omp_clause_code code, gfc_namelist *namelist,
tree list)
{
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 (code);
OMP_CLAUSE_DECL (node) = t;
list = gfc_trans_add_clause (node, list);
}
}
return list;
}
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;
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;
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);
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);
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 = gfc_copy_expr (e1);
e3 = gfc_copy_expr (e3);
t = gfc_resolve_expr (e4);
gcc_assert (t == SUCCESS);
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;
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;
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;
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;
}
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;
}
static tree gfc_trans_omp_sections (gfc_code *, gfc_omp_clauses *);
static tree gfc_trans_omp_workshare (gfc_code *, gfc_omp_clauses *);
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);
}
static tree
gfc_trans_omp_barrier (void)
{
tree decl = built_in_decls [BUILT_IN_GOMP_BARRIER];
return build_function_call_expr (decl, NULL);
}
static tree
gfc_trans_omp_critical (gfc_code *code)
{
tree name = NULL_TREE, stmt;
if (code->ext.omp_name != NULL)
name = get_identifier (code->ext.omp_name);
stmt = gfc_trans_code (code->block->next);
return build2_v (OMP_CRITICAL, stmt, name);
}
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;
}
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);
if (integer_onep (step))
simple = 1;
else if (tree_int_cst_equal (step, integer_minus_one_node))
simple = -1;
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
{
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);
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_label = gfc_build_label_decl (NULL_TREE);
code->block->backend_decl = tree_cons (cycle_label, NULL, NULL);
tmp = gfc_trans_omp_code (code->block->next, true);
gfc_add_expr_to_block (&body, tmp);
if (TREE_USED (cycle_label))
{
tmp = build1_v (LABEL_EXPR, cycle_label);
gfc_add_expr_to_block (&body, tmp);
}
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);
}
static tree
gfc_trans_omp_flush (void)
{
tree decl = built_in_decls [BUILT_IN_SYNCHRONIZE];
return build_function_call_expr (decl, NULL);
}
static tree
gfc_trans_omp_master (gfc_code *code)
{
tree stmt = gfc_trans_code (code->block->next);
if (IS_EMPTY_STMT (stmt))
return stmt;
return build1_v (OMP_MASTER, stmt);
}
static tree
gfc_trans_omp_ordered (gfc_code *code)
{
return build1_v (OMP_ORDERED, gfc_trans_code (code->block->next));
}
static tree
gfc_trans_omp_parallel (gfc_code *code)
{
stmtblock_t block;
tree stmt, omp_clauses;
gfc_start_block (&block);
omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
code->loc);
stmt = gfc_trans_omp_code (code->block->next, true);
stmt = build4_v (OMP_PARALLEL, stmt, omp_clauses, NULL, NULL);
gfc_add_expr_to_block (&block, stmt);
return gfc_finish_block (&block);
}
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 (¶llel_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;
parallel_clauses.sched_kind = OMP_SCHED_NONE;
parallel_clauses.chunk_size = NULL;
parallel_clauses.ordered = false;
omp_clauses = gfc_trans_omp_clauses (&block, ¶llel_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);
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);
}
static tree
gfc_trans_omp_parallel_sections (gfc_code *code)
{
stmtblock_t block;
gfc_omp_clauses section_clauses;
tree stmt, omp_clauses;
memset (§ion_clauses, 0, sizeof (section_clauses));
section_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_sections (code, §ion_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);
}
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);
}
static tree
gfc_trans_omp_sections (gfc_code *code, gfc_omp_clauses *clauses)
{
stmtblock_t block, body;
tree omp_clauses, stmt;
bool has_lastprivate = clauses->lists[OMP_LIST_LASTPRIVATE] != NULL;
gfc_start_block (&block);
omp_clauses = gfc_trans_omp_clauses (&block, clauses, code->loc);
gfc_init_block (&body);
for (code = code->block; code; code = code->block)
{
stmt = gfc_trans_omp_code (code->next,
has_lastprivate && code->block == NULL);
if (! IS_EMPTY_STMT (stmt))
{
stmt = build1_v (OMP_SECTION, stmt);
gfc_add_expr_to_block (&body, stmt);
}
}
stmt = gfc_finish_block (&body);
stmt = build2_v (OMP_SECTIONS, stmt, omp_clauses);
gfc_add_expr_to_block (&block, stmt);
return gfc_finish_block (&block);
}
static tree
gfc_trans_omp_single (gfc_code *code, gfc_omp_clauses *clauses)
{
tree omp_clauses = gfc_trans_omp_clauses (NULL, clauses, code->loc);
tree stmt = gfc_trans_omp_code (code->block->next, true);
stmt = build2_v (OMP_SINGLE, stmt, omp_clauses);
return stmt;
}
static tree
gfc_trans_omp_workshare (gfc_code *code, gfc_omp_clauses *clauses)
{
return gfc_trans_omp_single (code, clauses);
}
tree
gfc_trans_omp_directive (gfc_code *code)
{
switch (code->op)
{
case EXEC_OMP_ATOMIC:
return gfc_trans_omp_atomic (code);
case EXEC_OMP_BARRIER:
return gfc_trans_omp_barrier ();
case EXEC_OMP_CRITICAL:
return gfc_trans_omp_critical (code);
case EXEC_OMP_DO:
return gfc_trans_omp_do (code, NULL, code->ext.omp_clauses);
case EXEC_OMP_FLUSH:
return gfc_trans_omp_flush ();
case EXEC_OMP_MASTER:
return gfc_trans_omp_master (code);
case EXEC_OMP_ORDERED:
return gfc_trans_omp_ordered (code);
case EXEC_OMP_PARALLEL:
return gfc_trans_omp_parallel (code);
case EXEC_OMP_PARALLEL_DO:
return gfc_trans_omp_parallel_do (code);
case EXEC_OMP_PARALLEL_SECTIONS:
return gfc_trans_omp_parallel_sections (code);
case EXEC_OMP_PARALLEL_WORKSHARE:
return gfc_trans_omp_parallel_workshare (code);
case EXEC_OMP_SECTIONS:
return gfc_trans_omp_sections (code, code->ext.omp_clauses);
case EXEC_OMP_SINGLE:
return gfc_trans_omp_single (code, code->ext.omp_clauses);
case EXEC_OMP_WORKSHARE:
return gfc_trans_omp_workshare (code, code->ext.omp_clauses);
default:
gcc_unreachable ();
}
}