diff options
Diffstat (limited to 'gcc/fortran/trans-openmp.c')
| -rw-r--r-- | gcc/fortran/trans-openmp.c | 1203 |
1 files changed, 1203 insertions, 0 deletions
diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c new file mode 100644 index 0000000..44be1b7 --- /dev/null +++ b/gcc/fortran/trans-openmp.c @@ -0,0 +1,1203 @@ +/* OpenMP directive translation -- generate GCC trees from gfc_code. + Copyright (C) 2005, 2006 Free Software Foundation, Inc. + Contributed by Jakub Jelinek <jakub@redhat.com> + +This file is part of GCC. + +GCC is free software; you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free +Software Foundation; either version 2, or (at your option) any later +version. + +GCC is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with GCC; see the file COPYING. If not, write to the Free +Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA +02110-1301, USA. */ + + +#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" + + +/* True if OpenMP should privatize what this DECL points to rather + than the DECL itself. */ + +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) + { + /* POINTER/ALLOCATABLE have aggregate types, all user variables + that have POINTER_TYPE type are supposed to be privatized + by reference. */ + if (!DECL_ARTIFICIAL (decl)) + return true; + + /* Some arrays are expanded as DECL_ARTIFICIAL pointers + by the frontend. */ + if (DECL_LANG_SPECIFIC (decl) + && GFC_DECL_SAVED_DESCRIPTOR (decl)) + return true; + } + + return false; +} + +/* True if OpenMP sharing attribute of DECL is predetermined. */ + +enum omp_clause_default_kind +gfc_omp_predetermined_sharing (tree decl) +{ + if (DECL_ARTIFICIAL (decl) && ! GFC_DECL_RESULT (decl)) + return OMP_CLAUSE_DEFAULT_SHARED; + + /* Cray pointees shouldn't be listed in any clauses and should be + gimplified to dereference of the corresponding Cray pointer. + Make them all private, so that they are emitted in the debug + information. */ + if (GFC_DECL_CRAY_POINTEE (decl)) + return OMP_CLAUSE_DEFAULT_PRIVATE; + + /* COMMON and EQUIVALENCE decls are shared. They + are only referenced through DECL_VALUE_EXPR of the variables + contained in them. If those are privatized, they will not be + gimplified to the COMMON or EQUIVALENCE decls. */ + 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; +} + +/* Return true if DECL's DECL_VALUE_EXPR (if any) should be + disregarded in OpenMP construct, because it is going to be + remapped during OpenMP lowering. SHARED is true if DECL + is going to be shared, false if it is going to be privatized. */ + +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))) + { + /* If variable in COMMON or EQUIVALENCE is privatized, return + true, as just that variable is supposed to be privatized, + not the whole COMMON or whole EQUIVALENCE. + For shared variables in COMMON or EQUIVALENCE, let them be + gimplified to DECL_VALUE_EXPR, so that for multiple shared vars + from the same COMMON or EQUIVALENCE just one sharing of the + whole COMMON or EQUIVALENCE is enough. */ + return ! shared; + } + } + + if (GFC_DECL_RESULT (decl) && DECL_HAS_VALUE_EXPR_P (decl)) + return ! shared; + + return false; +} + +/* Return true if DECL that is shared iff SHARED is true should + be put into OMP_CLAUSE_PRIVATE with OMP_CLAUSE_PRIVATE_DEBUG + flag set. */ + +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; +} + +/* Register language specific type size variables as potentially OpenMP + firstprivate variables. */ + +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); + + /* Special case for assigning the return value of a function. + Self recursive functions must have an explicit return value. */ + if (t == current_function_decl && sym->attr.function + && (sym->result == sym)) + t = gfc_get_fake_result_decl (sym); + + /* Similarly for alternate entry points. */ + else if (sym->attr.function && sym->attr.entry + && (sym->result == sym) + && sym->ns->proc_name->backend_decl == current_function_decl) + { + 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); + break; + } + } + + else if (sym->attr.result + && sym->ns->proc_name->backend_decl == current_function_decl + && sym->ns->proc_name->attr.entry_master + && !gfc_return_by_reference (sym->ns->proc_name)) + t = gfc_get_fake_result_decl (sym); + + 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; + 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; + 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.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. */ + OMP_CLAUSE_REDUCTION_INIT (c) = gfc_trans_assignment (e1, e2); + + /* Create the merge statement list. */ + OMP_CLAUSE_REDUCTION_MERGE (c) = gfc_trans_assignment (e3, e4); + + /* 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; +} + +/* Like gfc_trans_code, but force creation of a BIND_EXPR around it. */ + +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 *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; + + 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, 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_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); + 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); + 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); + 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) + { + /* 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 = build3_v (OMP_SECTIONS, stmt, omp_clauses, NULL); + 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) +{ + /* XXX */ + 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 (); + } +} |