tree
gfc_omp_clause_default_ctor (tree clause, tree decl, tree outer)
{
tree type = TREE_TYPE (decl), rank, size, esize, ptr, cond, then_b, else_b;
stmtblock_t block, cond_block;
if (! GFC_DESCRIPTOR_TYPE_P (type)
|| GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
return NULL;
gcc_assert (outer != NULL);
gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_PRIVATE
|| OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LASTPRIVATE);
/* Allocatable arrays in PRIVATE clauses need to be set to
"not currently allocated" allocation status if outer
array is "not currently allocated", otherwise should be allocated. */
gfc_start_block (&block);
gfc_init_block (&cond_block);
gfc_add_modify (&cond_block, decl, outer);
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), &cond_block);
ptr = gfc_allocate_array_with_status (&cond_block,
build_int_cst (pvoid_type_node, 0),
size, NULL, NULL);
gfc_conv_descriptor_data_set (&cond_block, decl, ptr);
then_b = gfc_finish_block (&cond_block);
gfc_init_block (&cond_block);
gfc_conv_descriptor_data_set (&cond_block, decl, null_pointer_node);
else_b = gfc_finish_block (&cond_block);
cond = fold_build2 (NE_EXPR, boolean_type_node,
fold_convert (pvoid_type_node,
gfc_conv_descriptor_data_get (outer)),
null_pointer_node);
gfc_add_expr_to_block (&block, build3 (COND_EXPR, void_type_node,
cond, then_b, else_b));
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)
{
/* Last section is special because of lastprivate, so even if it
is empty, chain it in. */
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);
}
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;
/* Allocatable arrays in PRIVATE clauses need to be set to
"not currently allocated" allocation status. */
gfc_init_block (&block);
gfc_conv_descriptor_data_set (&block, decl, null_pointer_node);
return gfc_finish_block (&block);
}
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_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 = █
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;
}
