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; }