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); }
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_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); }
tree gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src) { tree type = TREE_TYPE (dest), ptr, size, esize, rank, call; stmtblock_t block; if (! GFC_DESCRIPTOR_TYPE_P (type) || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE) return build2_v (MODIFY_EXPR, dest, src); gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_FIRSTPRIVATE); /* Allocatable arrays in FIRSTPRIVATE clauses need to be allocated and copied from SRC. */ gfc_start_block (&block); gfc_add_modify (&block, dest, src); rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1]; size = gfc_conv_descriptor_ubound_get (dest, rank); size = fold_build2 (MINUS_EXPR, gfc_array_index_type, size, gfc_conv_descriptor_lbound_get (dest, 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 (dest, 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, dest, ptr); call = build_call_expr_loc (input_location, built_in_decls[BUILT_IN_MEMCPY], 3, ptr, fold_convert (pvoid_type_node, gfc_conv_descriptor_data_get (src)), size); gfc_add_expr_to_block (&block, fold_convert (void_type_node, call)); return gfc_finish_block (&block); }
tree gfc_omp_clause_assign_op (tree clause ATTRIBUTE_UNUSED, tree dest, tree src) { tree type = TREE_TYPE (dest), rank, size, esize, call; stmtblock_t block; if (! GFC_DESCRIPTOR_TYPE_P (type) || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE) return build2_v (MODIFY_EXPR, dest, src); /* Handle copying allocatable arrays. */ gfc_start_block (&block); rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1]; size = gfc_conv_descriptor_ubound_get (dest, rank); size = fold_build2 (MINUS_EXPR, gfc_array_index_type, size, gfc_conv_descriptor_lbound_get (dest, 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 (dest, 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); call = build_call_expr_loc (input_location, built_in_decls[BUILT_IN_MEMCPY], 3, fold_convert (pvoid_type_node, gfc_conv_descriptor_data_get (dest)), fold_convert (pvoid_type_node, gfc_conv_descriptor_data_get (src)), size); gfc_add_expr_to_block (&block, fold_convert (void_type_node, call)); return gfc_finish_block (&block); }
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); }
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_do (gfc_code *code, stmtblock_t *pblock, gfc_omp_clauses *do_clauses, tree par_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; gfc_omp_clauses *clauses = code->ext.omp_clauses; int i, collapse = clauses->collapse; tree dovar_init = NULL_TREE; if (collapse <= 0) collapse = 1; code = code->block->next; gcc_assert (code->op == EXEC_DO); init = make_tree_vec (collapse); cond = make_tree_vec (collapse); incr = make_tree_vec (collapse); if (pblock == NULL) { gfc_start_block (&block); pblock = █ } omp_clauses = gfc_trans_omp_clauses (pblock, do_clauses, code->loc); for (i = 0; i < collapse; i++) { int simple = 0; int dovar_found = 0; tree dovar_decl; 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) dovar_found = 1; else 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++; } /* 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); dovar_decl = dovar; /* Special case simple loops. */ if (TREE_CODE (dovar) == VAR_DECL) { if (integer_onep (step)) simple = 1; else if (tree_int_cst_equal (step, integer_minus_one_node)) simple = -1; } else dovar_decl = gfc_trans_omp_variable (code->ext.iterator->var->symtree->n.sym); /* Loop body. */ if (simple) { TREE_VEC_ELT (init, i) = build2_v (MODIFY_EXPR, dovar, from); TREE_VEC_ELT (cond, i) = fold_build2 (simple > 0 ? LE_EXPR : GE_EXPR, boolean_type_node, dovar, to); TREE_VEC_ELT (incr, i) = fold_build2 (PLUS_EXPR, type, dovar, step); TREE_VEC_ELT (incr, i) = fold_build2 (MODIFY_EXPR, type, dovar, TREE_VEC_ELT (incr, i)); } 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"); TREE_VEC_ELT (init, i) = build2_v (MODIFY_EXPR, count, build_int_cst (type, 0)); TREE_VEC_ELT (cond, i) = fold_build2 (LT_EXPR, boolean_type_node, count, tmp); TREE_VEC_ELT (incr, i) = fold_build2 (PLUS_EXPR, type, count, build_int_cst (type, 1)); TREE_VEC_ELT (incr, i) = fold_build2 (MODIFY_EXPR, type, count, TREE_VEC_ELT (incr, i)); /* Initialize DOVAR. */ tmp = fold_build2 (MULT_EXPR, type, count, step); tmp = fold_build2 (PLUS_EXPR, type, from, tmp); dovar_init = tree_cons (dovar, tmp, dovar_init); } if (!dovar_found) { tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE); OMP_CLAUSE_DECL (tmp) = dovar_decl; omp_clauses = gfc_trans_add_clause (tmp, omp_clauses); } else if (dovar_found == 2) { tree c = NULL; tmp = NULL; if (!simple) { /* If dovar is lastprivate, but different counter is used, dovar += step needs to be added to OMP_CLAUSE_LASTPRIVATE_STMT, otherwise the copied dovar will have the value on entry of the last loop, rather than value after iterator increment. */ tmp = gfc_evaluate_now (step, pblock); tmp = fold_build2 (PLUS_EXPR, type, dovar, tmp); tmp = fold_build2 (MODIFY_EXPR, type, dovar, tmp); for (c = omp_clauses; c ; c = OMP_CLAUSE_CHAIN (c)) if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LASTPRIVATE && OMP_CLAUSE_DECL (c) == dovar_decl) { OMP_CLAUSE_LASTPRIVATE_STMT (c) = tmp; break; } } if (c == NULL && par_clauses != NULL) { for (c = par_clauses; c ; c = OMP_CLAUSE_CHAIN (c)) if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LASTPRIVATE && OMP_CLAUSE_DECL (c) == dovar_decl) { tree l = build_omp_clause (input_location, OMP_CLAUSE_LASTPRIVATE); OMP_CLAUSE_DECL (l) = dovar_decl; OMP_CLAUSE_CHAIN (l) = omp_clauses; OMP_CLAUSE_LASTPRIVATE_STMT (l) = tmp; omp_clauses = l; OMP_CLAUSE_SET_CODE (c, OMP_CLAUSE_SHARED); break; } } gcc_assert (simple || c != NULL); } if (!simple) { tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE); OMP_CLAUSE_DECL (tmp) = count; omp_clauses = gfc_trans_add_clause (tmp, omp_clauses); } if (i + 1 < collapse) code = code->block->next; } if (pblock != &block) { pushlevel (0); gfc_start_block (&block); } gfc_start_block (&body); dovar_init = nreverse (dovar_init); while (dovar_init) { gfc_add_modify (&body, TREE_PURPOSE (dovar_init), TREE_VALUE (dovar_init)); dovar_init = TREE_CHAIN (dovar_init); } /* 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); }