X-Git-Url: http://git.sourceforge.jp/view?p=pf3gnuchains%2Fgcc-fork.git;a=blobdiff_plain;f=gcc%2Ffortran%2Ftrans-openmp.c;h=b1f8e09a1b96a71d93abb70da1c2f566247736af;hp=4d461cfa488b3390f41478d15e207e580a781e7b;hb=2169f33bdc9db9199850a22ce70730c68227b2db;hpb=1b013d97b21e27f9ce50324503d1115c272e19e2 diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c index 4d461cfa488..b1f8e09a1b9 100644 --- a/gcc/fortran/trans-openmp.c +++ b/gcc/fortran/trans-openmp.c @@ -1,5 +1,6 @@ /* OpenMP directive translation -- generate GCC trees from gfc_code. - Copyright (C) 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc. + Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010, 2011 + Free Software Foundation, Inc. Contributed by Jakub Jelinek This file is part of GCC. @@ -23,10 +24,8 @@ along with GCC; see the file COPYING3. If not see #include "system.h" #include "coretypes.h" #include "tree.h" -#include "gimple.h" -#include "ggc.h" -#include "toplev.h" -#include "real.h" +#include "gimple.h" /* For create_tmp_var_raw. */ +#include "diagnostic-core.h" /* For internal_error. */ #include "gfortran.h" #include "trans.h" #include "trans-stmt.h" @@ -57,7 +56,8 @@ gfc_omp_privatize_by_reference (const_tree decl) if (GFC_POINTER_TYPE_P (type)) return false; - if (!DECL_ARTIFICIAL (decl)) + if (!DECL_ARTIFICIAL (decl) + && TREE_CODE (TREE_TYPE (type)) != FUNCTION_TYPE) return true; /* Some arrays are expanded as DECL_ARTIFICIAL pointers @@ -75,7 +75,10 @@ gfc_omp_privatize_by_reference (const_tree decl) enum omp_clause_default_kind gfc_omp_predetermined_sharing (tree decl) { - if (DECL_ARTIFICIAL (decl) && ! GFC_DECL_RESULT (decl)) + if (DECL_ARTIFICIAL (decl) + && ! GFC_DECL_RESULT (decl) + && ! (DECL_LANG_SPECIFIC (decl) + && GFC_DECL_SAVED_DESCRIPTOR (decl))) return OMP_CLAUSE_DEFAULT_SHARED; /* Cray pointees shouldn't be listed in any clauses and should be @@ -85,9 +88,7 @@ gfc_omp_predetermined_sharing (tree decl) if (GFC_DECL_CRAY_POINTEE (decl)) return OMP_CLAUSE_DEFAULT_PRIVATE; - /* Assumed-size arrays are predetermined to inherit sharing - attributes of the associated actual argument, which is shared - for all we care. */ + /* Assumed-size arrays are predetermined shared. */ if (TREE_CODE (decl) == PARM_DECL && GFC_ARRAY_TYPE_P (TREE_TYPE (decl)) && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl)) == GFC_ARRAY_UNKNOWN @@ -96,6 +97,15 @@ gfc_omp_predetermined_sharing (tree decl) == NULL) return OMP_CLAUSE_DEFAULT_SHARED; + /* Dummy procedures aren't considered variables by OpenMP, thus are + disallowed in OpenMP clauses. They are represented as PARM_DECLs + in the middle-end, so return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE here + to avoid complaining about their uses with default(none). */ + if (TREE_CODE (decl) == PARM_DECL + && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE + && TREE_CODE (TREE_TYPE (TREE_TYPE (decl))) == FUNCTION_TYPE) + return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE; + /* 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 @@ -109,6 +119,19 @@ gfc_omp_predetermined_sharing (tree decl) return OMP_CLAUSE_DEFAULT_UNSPECIFIED; } +/* Return decl that should be used when reporting DEFAULT(NONE) + diagnostics. */ + +tree +gfc_omp_report_decl (tree decl) +{ + if (DECL_ARTIFICIAL (decl) + && DECL_LANG_SPECIFIC (decl) + && GFC_DECL_SAVED_DESCRIPTOR (decl)) + return GFC_DECL_SAVED_DESCRIPTOR (decl); + + return decl; +} /* Return true if DECL in private clause needs OMP_CLAUSE_PRIVATE_OUTER_REF on the private clause. */ @@ -151,33 +174,35 @@ gfc_omp_clause_default_ctor (tree clause, tree decl, tree outer) 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); + size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + size, gfc_conv_descriptor_lbound_get (decl, rank)); + size = fold_build2_loc (input_location, 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)); + size = fold_build2_loc (input_location, 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 = fold_build2_loc (input_location, 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); + + ptr = gfc_create_var (pvoid_type_node, NULL); + gfc_allocate_using_malloc (&cond_block, ptr, size, NULL_TREE); 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)); + cond = fold_build2_loc (input_location, 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_loc (input_location, COND_EXPR, + void_type_node, cond, then_b, else_b)); return gfc_finish_block (&block); } @@ -188,7 +213,8 @@ 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; + tree cond, then_b, else_b; + stmtblock_t block, cond_block; if (! GFC_DESCRIPTOR_TYPE_P (type) || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE) @@ -200,30 +226,46 @@ gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src) and copied from SRC. */ gfc_start_block (&block); - gfc_add_modify (&block, dest, src); + gfc_init_block (&cond_block); + + gfc_add_modify (&cond_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); + size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + size, gfc_conv_descriptor_lbound_get (dest, rank)); + size = fold_build2_loc (input_location, 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)); + size = fold_build2_loc (input_location, 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); + size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + size, esize); + size = gfc_evaluate_now (fold_convert (size_type_node, size), &cond_block); + + ptr = gfc_create_var (pvoid_type_node, NULL); + gfc_allocate_using_malloc (&cond_block, ptr, size, NULL_TREE); + gfc_conv_descriptor_data_set (&cond_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)); + gfc_add_expr_to_block (&cond_block, fold_convert (void_type_node, call)); + then_b = gfc_finish_block (&cond_block); + + gfc_init_block (&cond_block); + gfc_conv_descriptor_data_set (&cond_block, dest, null_pointer_node); + else_b = gfc_finish_block (&cond_block); + + cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + fold_convert (pvoid_type_node, + gfc_conv_descriptor_data_get (src)), + null_pointer_node); + gfc_add_expr_to_block (&block, build3_loc (input_location, COND_EXPR, + void_type_node, cond, then_b, else_b)); return gfc_finish_block (&block); } @@ -245,16 +287,17 @@ gfc_omp_clause_assign_op (tree clause ATTRIBUTE_UNUSED, tree dest, tree 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); + size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + size, gfc_conv_descriptor_lbound_get (dest, rank)); + size = fold_build2_loc (input_location, 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)); + size = fold_build2_loc (input_location, 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 = fold_build2_loc (input_location, 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, @@ -454,13 +497,23 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where) gfc_symbol init_val_sym, outer_sym, intrinsic_sym; gfc_expr *e1, *e2, *e3, *e4; gfc_ref *ref; - tree decl, backend_decl, stmt; + tree decl, backend_decl, stmt, type, outer_decl; locus old_loc = gfc_current_locus; const char *iname; gfc_try t; decl = OMP_CLAUSE_DECL (c); gfc_current_locus = where; + type = TREE_TYPE (decl); + outer_decl = create_tmp_var_raw (type, NULL); + if (TREE_CODE (decl) == PARM_DECL + && TREE_CODE (type) == REFERENCE_TYPE + && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)) + && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (type)) == GFC_ARRAY_ALLOCATABLE) + { + decl = build_fold_indirect_ref (decl); + type = TREE_TYPE (type); + } /* Create a fake symbol for init value. */ memset (&init_val_sym, 0, sizeof (init_val_sym)); @@ -479,7 +532,9 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where) 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); + outer_sym.backend_decl = outer_decl; + if (decl != OMP_CLAUSE_DECL (c)) + outer_sym.backend_decl = build_fold_indirect_ref (outer_decl); /* Create fake symtrees for it. */ symtree1 = gfc_new_symtree (&root1, sym->name); @@ -596,12 +651,12 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where) /* Create the init statement list. */ pushlevel (0); - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)) - && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl)) == GFC_ARRAY_ALLOCATABLE) + if (GFC_DESCRIPTOR_TYPE_P (type) + && GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE) { /* If decl is an allocatable array, it needs to be allocated with the same bounds as the outer var. */ - tree type = TREE_TYPE (decl), rank, size, esize, ptr; + tree rank, size, esize, ptr; stmtblock_t block; gfc_start_block (&block); @@ -609,26 +664,31 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where) gfc_add_modify (&block, decl, outer_sym.backend_decl); 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); + size = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, size, + gfc_conv_descriptor_lbound_get (decl, rank)); + size = fold_build2_loc (input_location, 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)); + size = fold_build2_loc (input_location, 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 = fold_build2_loc (input_location, 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); + + ptr = gfc_create_var (pvoid_type_node, NULL); + gfc_allocate_using_malloc (&block, ptr, size, NULL_TREE); gfc_conv_descriptor_data_set (&block, decl, ptr); - gfc_add_expr_to_block (&block, gfc_trans_assignment (e1, e2, false)); + + gfc_add_expr_to_block (&block, gfc_trans_assignment (e1, e2, false, + false)); stmt = gfc_finish_block (&block); } else - stmt = gfc_trans_assignment (e1, e2, false); + stmt = gfc_trans_assignment (e1, e2, false, false); if (TREE_CODE (stmt) != BIND_EXPR) stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0)); else @@ -637,20 +697,21 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where) /* Create the merge statement list. */ pushlevel (0); - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)) - && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl)) == GFC_ARRAY_ALLOCATABLE) + if (GFC_DESCRIPTOR_TYPE_P (type) + && GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE) { /* If decl is an allocatable array, it needs to be deallocated afterwards. */ stmtblock_t block; gfc_start_block (&block); - gfc_add_expr_to_block (&block, gfc_trans_assignment (e3, e4, false)); + gfc_add_expr_to_block (&block, gfc_trans_assignment (e3, e4, false, + true)); gfc_add_expr_to_block (&block, gfc_trans_dealloc_allocated (decl)); stmt = gfc_finish_block (&block); } else - stmt = gfc_trans_assignment (e3, e4, false); + stmt = gfc_trans_assignment (e3, e4, false, true); if (TREE_CODE (stmt) != BIND_EXPR) stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0)); else @@ -658,7 +719,7 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where) OMP_CLAUSE_REDUCTION_MERGE (c) = stmt; /* And stick the placeholder VAR_DECL into the clause as well. */ - OMP_CLAUSE_REDUCTION_PLACEHOLDER (c) = outer_sym.backend_decl; + OMP_CLAUSE_REDUCTION_PLACEHOLDER (c) = outer_decl; gfc_current_locus = old_loc; @@ -666,11 +727,10 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where) 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); + free (symtree1); + free (symtree2); + free (symtree3); + free (symtree4); gfc_free_array_spec (outer_sym.as); } @@ -700,7 +760,7 @@ 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; + tree omp_clauses = NULL_TREE, chunk_size, c; int list; enum omp_clause_code clause_code; gfc_se se; @@ -759,7 +819,6 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, default: gcc_unreachable (); } - old_clauses = omp_clauses; omp_clauses = gfc_trans_omp_reduction_list (n, omp_clauses, reduction_code, where); @@ -809,6 +868,21 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, omp_clauses = gfc_trans_add_clause (c, omp_clauses); } + if (clauses->final_expr) + { + tree final_var; + + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, clauses->final_expr); + gfc_add_block_to_block (block, &se.pre); + final_var = gfc_evaluate_now (se.expr, block); + gfc_add_block_to_block (block, &se.post); + + c = build_omp_clause (where.lb->location, OMP_CLAUSE_FINAL); + OMP_CLAUSE_FINAL_EXPR (c) = final_var; + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + if (clauses->num_threads) { tree num_threads; @@ -902,10 +976,17 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, omp_clauses = gfc_trans_add_clause (c, omp_clauses); } + if (clauses->mergeable) + { + c = build_omp_clause (where.lb->location, OMP_CLAUSE_MERGEABLE); + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + if (clauses->collapse) { c = build_omp_clause (where.lb->location, OMP_CLAUSE_COLLAPSE); - OMP_CLAUSE_COLLAPSE_EXPR (c) = build_int_cst (NULL, clauses->collapse); + OMP_CLAUSE_COLLAPSE_EXPR (c) + = build_int_cst (integer_type_node, clauses->collapse); omp_clauses = gfc_trans_add_clause (c, omp_clauses); } @@ -943,35 +1024,85 @@ static tree gfc_trans_omp_workshare (gfc_code *, gfc_omp_clauses *); static tree gfc_trans_omp_atomic (gfc_code *code) { + gfc_code *atomic_code = code; gfc_se lse; gfc_se rse; + gfc_se vse; gfc_expr *expr2, *e; gfc_symbol *var; stmtblock_t block; tree lhsaddr, type, rhs, x; enum tree_code op = ERROR_MARK; + enum tree_code aop = OMP_ATOMIC; bool var_on_left = false; code = code->block->next; gcc_assert (code->op == EXEC_ASSIGN); - gcc_assert (code->next == NULL); var = code->expr1->symtree->n.sym; gfc_init_se (&lse, NULL); gfc_init_se (&rse, NULL); + gfc_init_se (&vse, NULL); gfc_start_block (&block); - gfc_conv_expr (&lse, code->expr1); - 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->id == GFC_ISYM_CONVERSION) expr2 = expr2->value.function.actual->expr; - if (expr2->expr_type == EXPR_OP) + switch (atomic_code->ext.omp_atomic) + { + case GFC_OMP_ATOMIC_READ: + gfc_conv_expr (&vse, code->expr1); + gfc_add_block_to_block (&block, &vse.pre); + + gfc_conv_expr (&lse, expr2); + gfc_add_block_to_block (&block, &lse.pre); + type = TREE_TYPE (lse.expr); + lhsaddr = gfc_build_addr_expr (NULL, lse.expr); + + x = build1 (OMP_ATOMIC_READ, type, lhsaddr); + x = convert (TREE_TYPE (vse.expr), x); + gfc_add_modify (&block, vse.expr, x); + + gfc_add_block_to_block (&block, &lse.pre); + gfc_add_block_to_block (&block, &rse.pre); + + return gfc_finish_block (&block); + case GFC_OMP_ATOMIC_CAPTURE: + aop = OMP_ATOMIC_CAPTURE_NEW; + if (expr2->expr_type == EXPR_VARIABLE) + { + aop = OMP_ATOMIC_CAPTURE_OLD; + gfc_conv_expr (&vse, code->expr1); + gfc_add_block_to_block (&block, &vse.pre); + + gfc_conv_expr (&lse, expr2); + gfc_add_block_to_block (&block, &lse.pre); + gfc_init_se (&lse, NULL); + code = code->next; + var = code->expr1->symtree->n.sym; + expr2 = code->expr2; + if (expr2->expr_type == EXPR_FUNCTION + && expr2->value.function.isym->id == GFC_ISYM_CONVERSION) + expr2 = expr2->value.function.actual->expr; + } + break; + default: + break; + } + + gfc_conv_expr (&lse, code->expr1); + gfc_add_block_to_block (&block, &lse.pre); + type = TREE_TYPE (lse.expr); + lhsaddr = gfc_build_addr_expr (NULL, lse.expr); + + if (atomic_code->ext.omp_atomic == GFC_OMP_ATOMIC_WRITE) + { + gfc_conv_expr (&rse, expr2); + gfc_add_block_to_block (&block, &rse.pre); + } + else if (expr2->expr_type == EXPR_OP) { gfc_expr *e; switch (expr2->value.op.op) @@ -1074,7 +1205,8 @@ gfc_trans_omp_atomic (gfc_code *code) 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); + x = fold_build2_loc (input_location, op, TREE_TYPE (accum), + accum, rse.expr); gfc_add_modify (&block, accum, x); } @@ -1086,24 +1218,55 @@ gfc_trans_omp_atomic (gfc_code *code) lhsaddr = save_expr (lhsaddr); rhs = gfc_evaluate_now (rse.expr, &block); - x = convert (TREE_TYPE (rhs), build_fold_indirect_ref_loc (input_location, - lhsaddr)); - if (var_on_left) - x = fold_build2 (op, TREE_TYPE (rhs), x, rhs); + if (atomic_code->ext.omp_atomic == GFC_OMP_ATOMIC_WRITE) + x = rhs; else - x = fold_build2 (op, TREE_TYPE (rhs), rhs, x); + { + x = convert (TREE_TYPE (rhs), + build_fold_indirect_ref_loc (input_location, lhsaddr)); + if (var_on_left) + x = fold_build2_loc (input_location, op, TREE_TYPE (rhs), x, rhs); + else + x = fold_build2_loc (input_location, op, TREE_TYPE (rhs), rhs, x); + } if (TREE_CODE (TREE_TYPE (rhs)) == COMPLEX_TYPE && TREE_CODE (type) != COMPLEX_TYPE) - x = fold_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); + x = fold_build1_loc (input_location, REALPART_EXPR, + TREE_TYPE (TREE_TYPE (rhs)), x); gfc_add_block_to_block (&block, &lse.pre); gfc_add_block_to_block (&block, &rse.pre); + if (aop == OMP_ATOMIC) + { + x = build2_v (OMP_ATOMIC, lhsaddr, convert (type, x)); + gfc_add_expr_to_block (&block, x); + } + else + { + if (aop == OMP_ATOMIC_CAPTURE_NEW) + { + code = code->next; + expr2 = code->expr2; + if (expr2->expr_type == EXPR_FUNCTION + && expr2->value.function.isym->id == GFC_ISYM_CONVERSION) + expr2 = expr2->value.function.actual->expr; + + gcc_assert (expr2->expr_type == EXPR_VARIABLE); + gfc_conv_expr (&vse, code->expr1); + gfc_add_block_to_block (&block, &vse.pre); + + gfc_init_se (&lse, NULL); + gfc_conv_expr (&lse, expr2); + gfc_add_block_to_block (&block, &lse.pre); + } + x = build2 (aop, type, lhsaddr, convert (type, x)); + x = convert (TREE_TYPE (vse.expr), x); + gfc_add_modify (&block, vse.expr, x); + } + return gfc_finish_block (&block); } @@ -1121,9 +1284,17 @@ gfc_trans_omp_critical (gfc_code *code) if (code->ext.omp_name != NULL) name = get_identifier (code->ext.omp_name); stmt = gfc_trans_code (code->block->next); - return build2 (OMP_CRITICAL, void_type_node, stmt, name); + return build2_loc (input_location, OMP_CRITICAL, void_type_node, stmt, name); } +typedef struct dovar_init_d { + tree var; + tree init; +} dovar_init; + +DEF_VEC_O(dovar_init); +DEF_VEC_ALLOC_O(dovar_init,heap); + static tree gfc_trans_omp_do (gfc_code *code, stmtblock_t *pblock, gfc_omp_clauses *do_clauses, tree par_clauses) @@ -1134,14 +1305,15 @@ gfc_trans_omp_do (gfc_code *code, stmtblock_t *pblock, stmtblock_t block; stmtblock_t body; gfc_omp_clauses *clauses = code->ext.omp_clauses; - gfc_code *outermost; int i, collapse = clauses->collapse; - tree dovar_init = NULL_TREE; + VEC(dovar_init,heap) *inits = NULL; + dovar_init *di; + unsigned ix; if (collapse <= 0) collapse = 1; - outermost = code = code->block->next; + code = code->block->next; gcc_assert (code->op == EXEC_DO); init = make_tree_vec (collapse); @@ -1160,6 +1332,7 @@ gfc_trans_omp_do (gfc_code *code, stmtblock_t *pblock, { int simple = 0; int dovar_found = 0; + tree dovar_decl; if (clauses) { @@ -1200,22 +1373,34 @@ gfc_trans_omp_do (gfc_code *code, stmtblock_t *pblock, 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 (integer_onep (step)) - simple = 1; - else if (tree_int_cst_equal (step, integer_minus_one_node)) - simple = -1; + 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)); + /* The condition should not be folded. */ + TREE_VEC_ELT (cond, i) = build2_loc (input_location, simple > 0 + ? LE_EXPR : GE_EXPR, + boolean_type_node, dovar, to); + TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location, PLUS_EXPR, + type, dovar, step); + TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location, + MODIFY_EXPR, + type, dovar, + TREE_VEC_ELT (incr, i)); } else { @@ -1226,30 +1411,37 @@ gfc_trans_omp_do (gfc_code *code, stmtblock_t *pblock, 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 = fold_build2_loc (input_location, MINUS_EXPR, type, step, from); + tmp = fold_build2_loc (input_location, PLUS_EXPR, type, to, tmp); + tmp = fold_build2_loc (input_location, 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)); + /* The condition should not be folded. */ + TREE_VEC_ELT (cond, i) = build2_loc (input_location, LT_EXPR, + boolean_type_node, + count, tmp); + TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location, PLUS_EXPR, + type, count, + build_int_cst (type, 1)); + TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location, + 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); + tmp = fold_build2_loc (input_location, MULT_EXPR, type, count, step); + tmp = fold_build2_loc (input_location, PLUS_EXPR, type, from, tmp); + di = VEC_safe_push (dovar_init, heap, inits, NULL); + di->var = dovar; + di->init = tmp; } if (!dovar_found) { tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE); - OMP_CLAUSE_DECL (tmp) = dovar; + OMP_CLAUSE_DECL (tmp) = dovar_decl; omp_clauses = gfc_trans_add_clause (tmp, omp_clauses); } else if (dovar_found == 2) @@ -1265,11 +1457,13 @@ gfc_trans_omp_do (gfc_code *code, stmtblock_t *pblock, 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); + tmp = fold_build2_loc (input_location, PLUS_EXPR, type, dovar, + tmp); + tmp = fold_build2_loc (input_location, 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) + && OMP_CLAUSE_DECL (c) == dovar_decl) { OMP_CLAUSE_LASTPRIVATE_STMT (c) = tmp; break; @@ -1279,11 +1473,11 @@ gfc_trans_omp_do (gfc_code *code, stmtblock_t *pblock, { for (c = par_clauses; c ; c = OMP_CLAUSE_CHAIN (c)) if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LASTPRIVATE - && OMP_CLAUSE_DECL (c) == dovar) + && OMP_CLAUSE_DECL (c) == dovar_decl) { tree l = build_omp_clause (input_location, OMP_CLAUSE_LASTPRIVATE); - OMP_CLAUSE_DECL (l) = dovar; + OMP_CLAUSE_DECL (l) = dovar_decl; OMP_CLAUSE_CHAIN (l) = omp_clauses; OMP_CLAUSE_LASTPRIVATE_STMT (l) = tmp; omp_clauses = l; @@ -1312,24 +1506,18 @@ gfc_trans_omp_do (gfc_code *code, stmtblock_t *pblock, 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); - } + FOR_EACH_VEC_ELT (dovar_init, inits, ix, di) + gfc_add_modify (&body, di->var, di->init); + VEC_free (dovar_init, heap, inits); /* 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). */ + /* Put these labels where they can be found later. */ - code->block->backend_decl = tree_cons (cycle_label, NULL, NULL); + code->cycle_label = cycle_label; + code->exit_label = NULL_TREE; /* Main loop body. */ tmp = gfc_trans_omp_code (code->block->next, true); @@ -1359,7 +1547,7 @@ gfc_trans_omp_do (gfc_code *code, stmtblock_t *pblock, static tree gfc_trans_omp_flush (void) { - tree decl = built_in_decls [BUILT_IN_SYNCHRONIZE]; + tree decl = built_in_decls [BUILT_IN_SYNC_SYNCHRONIZE]; return build_call_expr_loc (input_location, decl, 0); } @@ -1388,7 +1576,8 @@ gfc_trans_omp_parallel (gfc_code *code) omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, code->loc); stmt = gfc_trans_omp_code (code->block->next, true); - stmt = build2 (OMP_PARALLEL, void_type_node, stmt, omp_clauses); + stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt, + omp_clauses); gfc_add_expr_to_block (&block, stmt); return gfc_finish_block (&block); } @@ -1428,7 +1617,8 @@ gfc_trans_omp_parallel_do (gfc_code *code) stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0)); else poplevel (0, 0, 0); - stmt = build2 (OMP_PARALLEL, void_type_node, stmt, omp_clauses); + stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt, + omp_clauses); OMP_PARALLEL_COMBINED (stmt) = 1; gfc_add_expr_to_block (&block, stmt); return gfc_finish_block (&block); @@ -1453,7 +1643,8 @@ gfc_trans_omp_parallel_sections (gfc_code *code) stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0)); else poplevel (0, 0, 0); - stmt = build2 (OMP_PARALLEL, void_type_node, stmt, omp_clauses); + stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt, + omp_clauses); OMP_PARALLEL_COMBINED (stmt) = 1; gfc_add_expr_to_block (&block, stmt); return gfc_finish_block (&block); @@ -1478,7 +1669,8 @@ gfc_trans_omp_parallel_workshare (gfc_code *code) stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0)); else poplevel (0, 0, 0); - stmt = build2 (OMP_PARALLEL, void_type_node, stmt, omp_clauses); + stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt, + omp_clauses); OMP_PARALLEL_COMBINED (stmt) = 1; gfc_add_expr_to_block (&block, stmt); return gfc_finish_block (&block); @@ -1510,7 +1702,8 @@ gfc_trans_omp_sections (gfc_code *code, gfc_omp_clauses *clauses) } stmt = gfc_finish_block (&body); - stmt = build2 (OMP_SECTIONS, void_type_node, stmt, omp_clauses); + stmt = build2_loc (input_location, OMP_SECTIONS, void_type_node, stmt, + omp_clauses); gfc_add_expr_to_block (&block, stmt); return gfc_finish_block (&block); @@ -1521,7 +1714,8 @@ 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 (OMP_SINGLE, void_type_node, stmt, omp_clauses); + stmt = build2_loc (input_location, OMP_SINGLE, void_type_node, stmt, + omp_clauses); return stmt; } @@ -1535,7 +1729,8 @@ gfc_trans_omp_task (gfc_code *code) omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, code->loc); stmt = gfc_trans_omp_code (code->block->next, true); - stmt = build2 (OMP_TASK, void_type_node, stmt, omp_clauses); + stmt = build2_loc (input_location, OMP_TASK, void_type_node, stmt, + omp_clauses); gfc_add_expr_to_block (&block, stmt); return gfc_finish_block (&block); } @@ -1548,6 +1743,13 @@ gfc_trans_omp_taskwait (void) } static tree +gfc_trans_omp_taskyield (void) +{ + tree decl = built_in_decls [BUILT_IN_GOMP_TASKYIELD]; + return build_call_expr_loc (input_location, decl, 0); +} + +static tree gfc_trans_omp_workshare (gfc_code *code, gfc_omp_clauses *clauses) { tree res, tmp, stmt; @@ -1650,7 +1852,8 @@ gfc_trans_omp_workshare (gfc_code *code, gfc_omp_clauses *clauses) { /* Finish single block and add it to pblock. */ tmp = gfc_finish_block (&singleblock); - tmp = build2 (OMP_SINGLE, void_type_node, tmp, NULL_TREE); + tmp = build2_loc (input_location, 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); @@ -1679,10 +1882,10 @@ gfc_trans_omp_workshare (gfc_code *code, gfc_omp_clauses *clauses) { /* 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); + tmp = build2_loc (input_location, 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); } @@ -1739,6 +1942,8 @@ gfc_trans_omp_directive (gfc_code *code) return gfc_trans_omp_task (code); case EXEC_OMP_TASKWAIT: return gfc_trans_omp_taskwait (); + case EXEC_OMP_TASKYIELD: + return gfc_trans_omp_taskyield (); case EXEC_OMP_WORKSHARE: return gfc_trans_omp_workshare (code, code->ext.omp_clauses); default: