diff options
Diffstat (limited to 'gcc-4.9/gcc/fortran/trans-openmp.c')
| -rw-r--r-- | gcc-4.9/gcc/fortran/trans-openmp.c | 2696 |
1 files changed, 2395 insertions, 301 deletions
diff --git a/gcc-4.9/gcc/fortran/trans-openmp.c b/gcc-4.9/gcc/fortran/trans-openmp.c index 41020a836..da01a9034 100644 --- a/gcc-4.9/gcc/fortran/trans-openmp.c +++ b/gcc-4.9/gcc/fortran/trans-openmp.c @@ -53,9 +53,13 @@ gfc_omp_privatize_by_reference (const_tree decl) if (TREE_CODE (type) == POINTER_TYPE) { /* Array POINTER/ALLOCATABLE have aggregate types, all user variables - that have POINTER_TYPE type and don't have GFC_POINTER_TYPE_P - set are supposed to be privatized by reference. */ - if (GFC_POINTER_TYPE_P (type)) + that have POINTER_TYPE type and aren't scalar pointers, scalar + allocatables, Cray pointees or C pointers are supposed to be + privatized by reference. */ + if (GFC_DECL_GET_SCALAR_POINTER (decl) + || GFC_DECL_GET_SCALAR_ALLOCATABLE (decl) + || GFC_DECL_CRAY_POINTEE (decl) + || VOID_TYPE_P (TREE_TYPE (TREE_TYPE (decl)))) return false; if (!DECL_ARTIFICIAL (decl) @@ -77,6 +81,19 @@ gfc_omp_privatize_by_reference (const_tree decl) enum omp_clause_default_kind gfc_omp_predetermined_sharing (tree decl) { + /* Associate names preserve the association established during ASSOCIATE. + As they are implemented either as pointers to the selector or array + descriptor and shouldn't really change in the ASSOCIATE region, + this decl can be either shared or firstprivate. If it is a pointer, + use firstprivate, as it is cheaper that way, otherwise make it shared. */ + if (GFC_DECL_ASSOCIATE_VAR_P (decl)) + { + if (TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE) + return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE; + else + return OMP_CLAUSE_DEFAULT_SHARED; + } + if (DECL_ARTIFICIAL (decl) && ! GFC_DECL_RESULT (decl) && ! (DECL_LANG_SPECIFIC (decl) @@ -135,6 +152,41 @@ gfc_omp_report_decl (tree decl) return decl; } +/* Return true if TYPE has any allocatable components. */ + +static bool +gfc_has_alloc_comps (tree type, tree decl) +{ + tree field, ftype; + + if (POINTER_TYPE_P (type)) + { + if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)) + type = TREE_TYPE (type); + else if (GFC_DECL_GET_SCALAR_POINTER (decl)) + return false; + } + + while (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type)) + type = gfc_get_element_type (type); + + if (TREE_CODE (type) != RECORD_TYPE) + return false; + + for (field = TYPE_FIELDS (type); field; field = DECL_CHAIN (field)) + { + ftype = TREE_TYPE (field); + if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field)) + return true; + if (GFC_DESCRIPTOR_TYPE_P (ftype) + && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE) + return true; + if (gfc_has_alloc_comps (ftype, field)) + return true; + } + return false; +} + /* Return true if DECL in private clause needs OMP_CLAUSE_PRIVATE_OUTER_REF on the private clause. */ bool @@ -146,68 +198,335 @@ gfc_omp_private_outer_ref (tree decl) && GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE) return true; + if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)) + return true; + + if (gfc_omp_privatize_by_reference (decl)) + type = TREE_TYPE (type); + + if (gfc_has_alloc_comps (type, decl)) + return true; + return false; } +/* Callback for gfc_omp_unshare_expr. */ + +static tree +gfc_omp_unshare_expr_r (tree *tp, int *walk_subtrees, void *) +{ + tree t = *tp; + enum tree_code code = TREE_CODE (t); + + /* Stop at types, decls, constants like copy_tree_r. */ + if (TREE_CODE_CLASS (code) == tcc_type + || TREE_CODE_CLASS (code) == tcc_declaration + || TREE_CODE_CLASS (code) == tcc_constant + || code == BLOCK) + *walk_subtrees = 0; + else if (handled_component_p (t) + || TREE_CODE (t) == MEM_REF) + { + *tp = unshare_expr (t); + *walk_subtrees = 0; + } + + return NULL_TREE; +} + +/* Unshare in expr anything that the FE which normally doesn't + care much about tree sharing (because during gimplification + everything is unshared) could cause problems with tree sharing + at omp-low.c time. */ + +static tree +gfc_omp_unshare_expr (tree expr) +{ + walk_tree (&expr, gfc_omp_unshare_expr_r, NULL, NULL); + return expr; +} + +enum walk_alloc_comps +{ + WALK_ALLOC_COMPS_DTOR, + WALK_ALLOC_COMPS_DEFAULT_CTOR, + WALK_ALLOC_COMPS_COPY_CTOR +}; + +/* Handle allocatable components in OpenMP clauses. */ + +static tree +gfc_walk_alloc_comps (tree decl, tree dest, tree var, + enum walk_alloc_comps kind) +{ + stmtblock_t block, tmpblock; + tree type = TREE_TYPE (decl), then_b, tem, field; + gfc_init_block (&block); + + if (GFC_ARRAY_TYPE_P (type) || GFC_DESCRIPTOR_TYPE_P (type)) + { + if (GFC_DESCRIPTOR_TYPE_P (type)) + { + gfc_init_block (&tmpblock); + tem = gfc_full_array_size (&tmpblock, decl, + GFC_TYPE_ARRAY_RANK (type)); + then_b = gfc_finish_block (&tmpblock); + gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (then_b)); + tem = gfc_omp_unshare_expr (tem); + tem = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, tem, + gfc_index_one_node); + } + else + { + if (!TYPE_DOMAIN (type) + || TYPE_MAX_VALUE (TYPE_DOMAIN (type)) == NULL_TREE + || TYPE_MIN_VALUE (TYPE_DOMAIN (type)) == error_mark_node + || TYPE_MAX_VALUE (TYPE_DOMAIN (type)) == error_mark_node) + { + tem = fold_build2 (EXACT_DIV_EXPR, sizetype, + TYPE_SIZE_UNIT (type), + TYPE_SIZE_UNIT (TREE_TYPE (type))); + tem = size_binop (MINUS_EXPR, tem, size_one_node); + } + else + tem = array_type_nelts (type); + tem = fold_convert (gfc_array_index_type, tem); + } + + tree nelems = gfc_evaluate_now (tem, &block); + tree index = gfc_create_var (gfc_array_index_type, "S"); + + gfc_init_block (&tmpblock); + tem = gfc_conv_array_data (decl); + tree declvar = build_fold_indirect_ref_loc (input_location, tem); + tree declvref = gfc_build_array_ref (declvar, index, NULL); + tree destvar, destvref = NULL_TREE; + if (dest) + { + tem = gfc_conv_array_data (dest); + destvar = build_fold_indirect_ref_loc (input_location, tem); + destvref = gfc_build_array_ref (destvar, index, NULL); + } + gfc_add_expr_to_block (&tmpblock, + gfc_walk_alloc_comps (declvref, destvref, + var, kind)); + + gfc_loopinfo loop; + gfc_init_loopinfo (&loop); + loop.dimen = 1; + loop.from[0] = gfc_index_zero_node; + loop.loopvar[0] = index; + loop.to[0] = nelems; + gfc_trans_scalarizing_loops (&loop, &tmpblock); + gfc_add_block_to_block (&block, &loop.pre); + return gfc_finish_block (&block); + } + else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (var)) + { + decl = build_fold_indirect_ref_loc (input_location, decl); + if (dest) + dest = build_fold_indirect_ref_loc (input_location, dest); + type = TREE_TYPE (decl); + } + + gcc_assert (TREE_CODE (type) == RECORD_TYPE); + for (field = TYPE_FIELDS (type); field; field = DECL_CHAIN (field)) + { + tree ftype = TREE_TYPE (field); + tree declf, destf = NULL_TREE; + bool has_alloc_comps = gfc_has_alloc_comps (ftype, field); + if ((!GFC_DESCRIPTOR_TYPE_P (ftype) + || GFC_TYPE_ARRAY_AKIND (ftype) != GFC_ARRAY_ALLOCATABLE) + && !GFC_DECL_GET_SCALAR_ALLOCATABLE (field) + && !has_alloc_comps) + continue; + declf = fold_build3_loc (input_location, COMPONENT_REF, ftype, + decl, field, NULL_TREE); + if (dest) + destf = fold_build3_loc (input_location, COMPONENT_REF, ftype, + dest, field, NULL_TREE); + + tem = NULL_TREE; + switch (kind) + { + case WALK_ALLOC_COMPS_DTOR: + break; + case WALK_ALLOC_COMPS_DEFAULT_CTOR: + if (GFC_DESCRIPTOR_TYPE_P (ftype) + && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE) + { + gfc_add_modify (&block, unshare_expr (destf), + unshare_expr (declf)); + tem = gfc_duplicate_allocatable_nocopy + (destf, declf, ftype, + GFC_TYPE_ARRAY_RANK (ftype)); + } + else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field)) + tem = gfc_duplicate_allocatable_nocopy (destf, declf, ftype, 0); + break; + case WALK_ALLOC_COMPS_COPY_CTOR: + if (GFC_DESCRIPTOR_TYPE_P (ftype) + && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE) + tem = gfc_duplicate_allocatable (destf, declf, ftype, + GFC_TYPE_ARRAY_RANK (ftype)); + else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field)) + tem = gfc_duplicate_allocatable (destf, declf, ftype, 0); + break; + } + if (tem) + gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (tem)); + if (has_alloc_comps) + { + gfc_init_block (&tmpblock); + gfc_add_expr_to_block (&tmpblock, + gfc_walk_alloc_comps (declf, destf, + field, kind)); + then_b = gfc_finish_block (&tmpblock); + if (GFC_DESCRIPTOR_TYPE_P (ftype) + && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE) + tem = gfc_conv_descriptor_data_get (unshare_expr (declf)); + else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field)) + tem = unshare_expr (declf); + else + tem = NULL_TREE; + if (tem) + { + tem = fold_convert (pvoid_type_node, tem); + tem = fold_build2_loc (input_location, NE_EXPR, + boolean_type_node, tem, + null_pointer_node); + then_b = build3_loc (input_location, COND_EXPR, void_type_node, + tem, then_b, + build_empty_stmt (input_location)); + } + gfc_add_expr_to_block (&block, then_b); + } + if (kind == WALK_ALLOC_COMPS_DTOR) + { + if (GFC_DESCRIPTOR_TYPE_P (ftype) + && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE) + { + tem = gfc_trans_dealloc_allocated (unshare_expr (declf), + false, NULL); + gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (tem)); + } + else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field)) + { + tem = gfc_call_free (unshare_expr (declf)); + gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (tem)); + } + } + } + + return gfc_finish_block (&block); +} + /* Return code to initialize DECL with its default constructor, or NULL if there's nothing to do. */ 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; + tree type = TREE_TYPE (decl), size, 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 (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_PRIVATE + || OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LASTPRIVATE + || OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LINEAR + || OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_REDUCTION); - if (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_REDUCTION) - return NULL; + if ((! GFC_DESCRIPTOR_TYPE_P (type) + || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE) + && !GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause))) + { + if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) + { + gcc_assert (outer); + gfc_start_block (&block); + tree tem = gfc_walk_alloc_comps (outer, decl, + OMP_CLAUSE_DECL (clause), + WALK_ALLOC_COMPS_DEFAULT_CTOR); + gfc_add_expr_to_block (&block, tem); + return gfc_finish_block (&block); + } + return NULL_TREE; + } - gcc_assert (outer != NULL); - gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_PRIVATE - || OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LASTPRIVATE); + gcc_assert (outer != NULL_TREE); - /* Allocatable arrays in PRIVATE clauses need to be set to + /* Allocatable arrays and scalars 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_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_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_loc (input_location, MULT_EXPR, gfc_array_index_type, - size, esize); - size = gfc_evaluate_now (fold_convert (size_type_node, size), &cond_block); - + if (GFC_DESCRIPTOR_TYPE_P (type)) + { + gfc_add_modify (&cond_block, decl, outer); + tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1]; + size = gfc_conv_descriptor_ubound_get (decl, rank); + 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_loc (input_location, MULT_EXPR, + gfc_array_index_type, size, + gfc_conv_descriptor_stride_get (decl, rank)); + tree esize = fold_convert (gfc_array_index_type, + TYPE_SIZE_UNIT (gfc_get_element_type (type))); + size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + size, esize); + size = unshare_expr (size); + size = gfc_evaluate_now (fold_convert (size_type_node, size), + &cond_block); + } + else + size = fold_convert (size_type_node, TYPE_SIZE_UNIT (TREE_TYPE (type))); 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); - + if (GFC_DESCRIPTOR_TYPE_P (type)) + gfc_conv_descriptor_data_set (&cond_block, unshare_expr (decl), ptr); + else + gfc_add_modify (&cond_block, unshare_expr (decl), + fold_convert (TREE_TYPE (decl), ptr)); + if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) + { + tree tem = gfc_walk_alloc_comps (outer, decl, + OMP_CLAUSE_DECL (clause), + WALK_ALLOC_COMPS_DEFAULT_CTOR); + gfc_add_expr_to_block (&cond_block, tem); + } 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_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)); + /* Reduction clause requires allocated ALLOCATABLE. */ + if (OMP_CLAUSE_CODE (clause) != OMP_CLAUSE_REDUCTION) + { + gfc_init_block (&cond_block); + if (GFC_DESCRIPTOR_TYPE_P (type)) + gfc_conv_descriptor_data_set (&cond_block, unshare_expr (decl), + null_pointer_node); + else + gfc_add_modify (&cond_block, unshare_expr (decl), + build_zero_cst (TREE_TYPE (decl))); + else_b = gfc_finish_block (&cond_block); + + tree tem = fold_convert (pvoid_type_node, + GFC_DESCRIPTOR_TYPE_P (type) + ? gfc_conv_descriptor_data_get (outer) : outer); + tem = unshare_expr (tem); + cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + tem, null_pointer_node); + gfc_add_expr_to_block (&block, + build3_loc (input_location, COND_EXPR, + void_type_node, cond, then_b, + else_b)); + } + else + gfc_add_expr_to_block (&block, then_b); return gfc_finish_block (&block); } @@ -217,15 +536,29 @@ gfc_omp_clause_default_ctor (tree clause, tree decl, tree outer) tree gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src) { - tree type = TREE_TYPE (dest), ptr, size, esize, rank, call; + tree type = TREE_TYPE (dest), ptr, size, call; 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) - return build2_v (MODIFY_EXPR, dest, src); + gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_FIRSTPRIVATE + || OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LINEAR); - gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_FIRSTPRIVATE); + if ((! GFC_DESCRIPTOR_TYPE_P (type) + || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE) + && !GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause))) + { + if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) + { + gfc_start_block (&block); + gfc_add_modify (&block, dest, src); + tree tem = gfc_walk_alloc_comps (src, dest, OMP_CLAUSE_DECL (clause), + WALK_ALLOC_COMPS_COPY_CTOR); + gfc_add_expr_to_block (&block, tem); + return gfc_finish_block (&block); + } + else + return build2_v (MODIFY_EXPR, dest, src); + } /* Allocatable arrays in FIRSTPRIVATE clauses need to be allocated and copied from SRC. */ @@ -234,86 +567,389 @@ gfc_omp_clause_copy_ctor (tree clause, tree dest, tree 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_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_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_loc (input_location, MULT_EXPR, gfc_array_index_type, - size, esize); - size = gfc_evaluate_now (fold_convert (size_type_node, size), &cond_block); - + if (GFC_DESCRIPTOR_TYPE_P (type)) + { + tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1]; + size = gfc_conv_descriptor_ubound_get (dest, rank); + 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_loc (input_location, MULT_EXPR, + gfc_array_index_type, size, + gfc_conv_descriptor_stride_get (dest, rank)); + tree esize = fold_convert (gfc_array_index_type, + TYPE_SIZE_UNIT (gfc_get_element_type (type))); + size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + size, esize); + size = unshare_expr (size); + size = gfc_evaluate_now (fold_convert (size_type_node, size), + &cond_block); + } + else + size = fold_convert (size_type_node, TYPE_SIZE_UNIT (TREE_TYPE (type))); 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); + if (GFC_DESCRIPTOR_TYPE_P (type)) + gfc_conv_descriptor_data_set (&cond_block, unshare_expr (dest), ptr); + else + gfc_add_modify (&cond_block, unshare_expr (dest), + fold_convert (TREE_TYPE (dest), ptr)); + tree srcptr = GFC_DESCRIPTOR_TYPE_P (type) + ? gfc_conv_descriptor_data_get (src) : src; + srcptr = unshare_expr (srcptr); + srcptr = fold_convert (pvoid_type_node, srcptr); call = build_call_expr_loc (input_location, - builtin_decl_explicit (BUILT_IN_MEMCPY), - 3, ptr, - fold_convert (pvoid_type_node, - gfc_conv_descriptor_data_get (src)), - size); + builtin_decl_explicit (BUILT_IN_MEMCPY), 3, ptr, + srcptr, size); gfc_add_expr_to_block (&cond_block, fold_convert (void_type_node, call)); + if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) + { + tree tem = gfc_walk_alloc_comps (src, dest, + OMP_CLAUSE_DECL (clause), + WALK_ALLOC_COMPS_COPY_CTOR); + gfc_add_expr_to_block (&cond_block, tem); + } then_b = gfc_finish_block (&cond_block); gfc_init_block (&cond_block); - gfc_conv_descriptor_data_set (&cond_block, dest, null_pointer_node); + if (GFC_DESCRIPTOR_TYPE_P (type)) + gfc_conv_descriptor_data_set (&cond_block, unshare_expr (dest), + null_pointer_node); + else + gfc_add_modify (&cond_block, unshare_expr (dest), + build_zero_cst (TREE_TYPE (dest))); 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)); + unshare_expr (srcptr), 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); } -/* Similarly, except use an assignment operator instead. */ +/* Similarly, except use an intrinsic or pointer assignment operator + instead. */ tree -gfc_omp_clause_assign_op (tree clause ATTRIBUTE_UNUSED, tree dest, tree src) +gfc_omp_clause_assign_op (tree clause, tree dest, tree src) { - tree type = TREE_TYPE (dest), rank, size, esize, call; - stmtblock_t block; + tree type = TREE_TYPE (dest), ptr, size, call, nonalloc; + tree cond, then_b, else_b; + stmtblock_t block, cond_block, cond_block2, inner_block; - if (! GFC_DESCRIPTOR_TYPE_P (type) - || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE) - return build2_v (MODIFY_EXPR, dest, src); + if ((! GFC_DESCRIPTOR_TYPE_P (type) + || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE) + && !GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause))) + { + if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) + { + gfc_start_block (&block); + /* First dealloc any allocatable components in DEST. */ + tree tem = gfc_walk_alloc_comps (dest, NULL_TREE, + OMP_CLAUSE_DECL (clause), + WALK_ALLOC_COMPS_DTOR); + gfc_add_expr_to_block (&block, tem); + /* Then copy over toplevel data. */ + gfc_add_modify (&block, dest, src); + /* Finally allocate any allocatable components and copy. */ + tem = gfc_walk_alloc_comps (src, dest, OMP_CLAUSE_DECL (clause), + WALK_ALLOC_COMPS_COPY_CTOR); + gfc_add_expr_to_block (&block, tem); + return gfc_finish_block (&block); + } + else + 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_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_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_loc (input_location, MULT_EXPR, gfc_array_index_type, - size, esize); - size = gfc_evaluate_now (fold_convert (size_type_node, size), &block); + if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) + { + then_b = gfc_walk_alloc_comps (dest, NULL_TREE, OMP_CLAUSE_DECL (clause), + WALK_ALLOC_COMPS_DTOR); + tree tem = fold_convert (pvoid_type_node, + GFC_DESCRIPTOR_TYPE_P (type) + ? gfc_conv_descriptor_data_get (dest) : dest); + tem = unshare_expr (tem); + cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + tem, null_pointer_node); + tem = build3_loc (input_location, COND_EXPR, void_type_node, cond, + then_b, build_empty_stmt (input_location)); + gfc_add_expr_to_block (&block, tem); + } + + gfc_init_block (&cond_block); + + if (GFC_DESCRIPTOR_TYPE_P (type)) + { + tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1]; + size = gfc_conv_descriptor_ubound_get (src, rank); + size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + size, + gfc_conv_descriptor_lbound_get (src, 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_loc (input_location, MULT_EXPR, + gfc_array_index_type, size, + gfc_conv_descriptor_stride_get (src, rank)); + tree esize = fold_convert (gfc_array_index_type, + TYPE_SIZE_UNIT (gfc_get_element_type (type))); + size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + size, esize); + size = unshare_expr (size); + size = gfc_evaluate_now (fold_convert (size_type_node, size), + &cond_block); + } + else + size = fold_convert (size_type_node, TYPE_SIZE_UNIT (TREE_TYPE (type))); + ptr = gfc_create_var (pvoid_type_node, NULL); + + tree destptr = GFC_DESCRIPTOR_TYPE_P (type) + ? gfc_conv_descriptor_data_get (dest) : dest; + destptr = unshare_expr (destptr); + destptr = fold_convert (pvoid_type_node, destptr); + gfc_add_modify (&cond_block, ptr, destptr); + + nonalloc = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + destptr, null_pointer_node); + cond = nonalloc; + if (GFC_DESCRIPTOR_TYPE_P (type)) + { + int i; + for (i = 0; i < GFC_TYPE_ARRAY_RANK (type); i++) + { + tree rank = gfc_rank_cst[i]; + tree tem = gfc_conv_descriptor_ubound_get (src, rank); + tem = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, tem, + gfc_conv_descriptor_lbound_get (src, rank)); + tem = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, tem, + gfc_conv_descriptor_lbound_get (dest, rank)); + tem = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + tem, gfc_conv_descriptor_ubound_get (dest, + rank)); + cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR, + boolean_type_node, cond, tem); + } + } + + gfc_init_block (&cond_block2); + + if (GFC_DESCRIPTOR_TYPE_P (type)) + { + gfc_init_block (&inner_block); + gfc_allocate_using_malloc (&inner_block, ptr, size, NULL_TREE); + then_b = gfc_finish_block (&inner_block); + + gfc_init_block (&inner_block); + gfc_add_modify (&inner_block, ptr, + gfc_call_realloc (&inner_block, ptr, size)); + else_b = gfc_finish_block (&inner_block); + + gfc_add_expr_to_block (&cond_block2, + build3_loc (input_location, COND_EXPR, + void_type_node, + unshare_expr (nonalloc), + then_b, else_b)); + gfc_add_modify (&cond_block2, dest, src); + gfc_conv_descriptor_data_set (&cond_block2, unshare_expr (dest), ptr); + } + else + { + gfc_allocate_using_malloc (&cond_block2, ptr, size, NULL_TREE); + gfc_add_modify (&cond_block2, unshare_expr (dest), + fold_convert (type, ptr)); + } + then_b = gfc_finish_block (&cond_block2); + else_b = build_empty_stmt (input_location); + + gfc_add_expr_to_block (&cond_block, + build3_loc (input_location, COND_EXPR, + void_type_node, unshare_expr (cond), + then_b, else_b)); + + tree srcptr = GFC_DESCRIPTOR_TYPE_P (type) + ? gfc_conv_descriptor_data_get (src) : src; + srcptr = unshare_expr (srcptr); + srcptr = fold_convert (pvoid_type_node, srcptr); call = build_call_expr_loc (input_location, - builtin_decl_explicit (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)); + builtin_decl_explicit (BUILT_IN_MEMCPY), 3, ptr, + srcptr, size); + gfc_add_expr_to_block (&cond_block, fold_convert (void_type_node, call)); + if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) + { + tree tem = gfc_walk_alloc_comps (src, dest, + OMP_CLAUSE_DECL (clause), + WALK_ALLOC_COMPS_COPY_CTOR); + gfc_add_expr_to_block (&cond_block, tem); + } + then_b = gfc_finish_block (&cond_block); + + if (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_COPYIN) + { + gfc_init_block (&cond_block); + if (GFC_DESCRIPTOR_TYPE_P (type)) + gfc_add_expr_to_block (&cond_block, + gfc_trans_dealloc_allocated (unshare_expr (dest), + false, NULL)); + else + { + destptr = gfc_evaluate_now (destptr, &cond_block); + gfc_add_expr_to_block (&cond_block, gfc_call_free (destptr)); + gfc_add_modify (&cond_block, unshare_expr (dest), + build_zero_cst (TREE_TYPE (dest))); + } + else_b = gfc_finish_block (&cond_block); + + cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + unshare_expr (srcptr), null_pointer_node); + gfc_add_expr_to_block (&block, + build3_loc (input_location, COND_EXPR, + void_type_node, cond, + then_b, else_b)); + } + else + gfc_add_expr_to_block (&block, then_b); + + return gfc_finish_block (&block); +} + +static void +gfc_omp_linear_clause_add_loop (stmtblock_t *block, tree dest, tree src, + tree add, tree nelems) +{ + stmtblock_t tmpblock; + tree desta, srca, index = gfc_create_var (gfc_array_index_type, "S"); + nelems = gfc_evaluate_now (nelems, block); + + gfc_init_block (&tmpblock); + if (TREE_CODE (TREE_TYPE (dest)) == ARRAY_TYPE) + { + desta = gfc_build_array_ref (dest, index, NULL); + srca = gfc_build_array_ref (src, index, NULL); + } + else + { + gcc_assert (POINTER_TYPE_P (TREE_TYPE (dest))); + tree idx = fold_build2 (MULT_EXPR, sizetype, + fold_convert (sizetype, index), + TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (dest)))); + desta = build_fold_indirect_ref (fold_build2 (POINTER_PLUS_EXPR, + TREE_TYPE (dest), dest, + idx)); + srca = build_fold_indirect_ref (fold_build2 (POINTER_PLUS_EXPR, + TREE_TYPE (src), src, + idx)); + } + gfc_add_modify (&tmpblock, desta, + fold_build2 (PLUS_EXPR, TREE_TYPE (desta), + srca, add)); + + gfc_loopinfo loop; + gfc_init_loopinfo (&loop); + loop.dimen = 1; + loop.from[0] = gfc_index_zero_node; + loop.loopvar[0] = index; + loop.to[0] = nelems; + gfc_trans_scalarizing_loops (&loop, &tmpblock); + gfc_add_block_to_block (block, &loop.pre); +} + +/* Build and return code for a constructor of DEST that initializes + it to SRC plus ADD (ADD is scalar integer). */ + +tree +gfc_omp_clause_linear_ctor (tree clause, tree dest, tree src, tree add) +{ + tree type = TREE_TYPE (dest), ptr, size, nelems = NULL_TREE; + stmtblock_t block; + + gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LINEAR); + gfc_start_block (&block); + add = gfc_evaluate_now (add, &block); + + if ((! GFC_DESCRIPTOR_TYPE_P (type) + || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE) + && !GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause))) + { + gcc_assert (TREE_CODE (type) == ARRAY_TYPE); + if (!TYPE_DOMAIN (type) + || TYPE_MAX_VALUE (TYPE_DOMAIN (type)) == NULL_TREE + || TYPE_MIN_VALUE (TYPE_DOMAIN (type)) == error_mark_node + || TYPE_MAX_VALUE (TYPE_DOMAIN (type)) == error_mark_node) + { + nelems = fold_build2 (EXACT_DIV_EXPR, sizetype, + TYPE_SIZE_UNIT (type), + TYPE_SIZE_UNIT (TREE_TYPE (type))); + nelems = size_binop (MINUS_EXPR, nelems, size_one_node); + } + else + nelems = array_type_nelts (type); + nelems = fold_convert (gfc_array_index_type, nelems); + + gfc_omp_linear_clause_add_loop (&block, dest, src, add, nelems); + return gfc_finish_block (&block); + } + + /* Allocatable arrays in LINEAR clauses need to be allocated + and copied from SRC. */ + gfc_add_modify (&block, dest, src); + if (GFC_DESCRIPTOR_TYPE_P (type)) + { + tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1]; + size = gfc_conv_descriptor_ubound_get (dest, rank); + 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_loc (input_location, MULT_EXPR, + gfc_array_index_type, size, + gfc_conv_descriptor_stride_get (dest, rank)); + tree esize = fold_convert (gfc_array_index_type, + TYPE_SIZE_UNIT (gfc_get_element_type (type))); + nelems = gfc_evaluate_now (unshare_expr (size), &block); + size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + nelems, unshare_expr (esize)); + size = gfc_evaluate_now (fold_convert (size_type_node, size), + &block); + nelems = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, nelems, + gfc_index_one_node); + } + else + size = fold_convert (size_type_node, TYPE_SIZE_UNIT (TREE_TYPE (type))); + ptr = gfc_create_var (pvoid_type_node, NULL); + gfc_allocate_using_malloc (&block, ptr, size, NULL_TREE); + if (GFC_DESCRIPTOR_TYPE_P (type)) + { + gfc_conv_descriptor_data_set (&block, unshare_expr (dest), ptr); + tree etype = gfc_get_element_type (type); + ptr = fold_convert (build_pointer_type (etype), ptr); + tree srcptr = gfc_conv_descriptor_data_get (unshare_expr (src)); + srcptr = fold_convert (build_pointer_type (etype), srcptr); + gfc_omp_linear_clause_add_loop (&block, ptr, srcptr, add, nelems); + } + else + { + gfc_add_modify (&block, unshare_expr (dest), + fold_convert (TREE_TYPE (dest), ptr)); + ptr = fold_convert (TREE_TYPE (dest), ptr); + tree dstm = build_fold_indirect_ref (ptr); + tree srcm = build_fold_indirect_ref (unshare_expr (src)); + gfc_add_modify (&block, dstm, + fold_build2 (PLUS_EXPR, TREE_TYPE (add), srcm, add)); + } return gfc_finish_block (&block); } @@ -321,20 +957,161 @@ gfc_omp_clause_assign_op (tree clause ATTRIBUTE_UNUSED, tree dest, tree src) to be done. */ tree -gfc_omp_clause_dtor (tree clause ATTRIBUTE_UNUSED, tree decl) +gfc_omp_clause_dtor (tree clause, tree decl) { - tree type = TREE_TYPE (decl); + tree type = TREE_TYPE (decl), tem; + + if ((! GFC_DESCRIPTOR_TYPE_P (type) + || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE) + && !GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause))) + { + if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) + return gfc_walk_alloc_comps (decl, NULL_TREE, + OMP_CLAUSE_DECL (clause), + WALK_ALLOC_COMPS_DTOR); + return NULL_TREE; + } - if (! GFC_DESCRIPTOR_TYPE_P (type) - || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE) - return NULL; + if (GFC_DESCRIPTOR_TYPE_P (type)) + /* Allocatable arrays in FIRSTPRIVATE/LASTPRIVATE etc. clauses need + to be deallocated if they were allocated. */ + tem = gfc_trans_dealloc_allocated (decl, false, NULL); + else + tem = gfc_call_free (decl); + tem = gfc_omp_unshare_expr (tem); - if (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_REDUCTION) - return NULL; + if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) + { + stmtblock_t block; + tree then_b; + + gfc_init_block (&block); + gfc_add_expr_to_block (&block, + gfc_walk_alloc_comps (decl, NULL_TREE, + OMP_CLAUSE_DECL (clause), + WALK_ALLOC_COMPS_DTOR)); + gfc_add_expr_to_block (&block, tem); + then_b = gfc_finish_block (&block); + + tem = fold_convert (pvoid_type_node, + GFC_DESCRIPTOR_TYPE_P (type) + ? gfc_conv_descriptor_data_get (decl) : decl); + tem = unshare_expr (tem); + tree cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + tem, null_pointer_node); + tem = build3_loc (input_location, COND_EXPR, void_type_node, cond, + then_b, build_empty_stmt (input_location)); + } + return tem; +} - /* Allocatable arrays in FIRSTPRIVATE/LASTPRIVATE etc. clauses need - to be deallocated if they were allocated. */ - return gfc_trans_dealloc_allocated (decl, false, NULL); + +void +gfc_omp_finish_clause (tree c, gimple_seq *pre_p) +{ + if (OMP_CLAUSE_CODE (c) != OMP_CLAUSE_MAP) + return; + + tree decl = OMP_CLAUSE_DECL (c); + tree c2 = NULL_TREE, c3 = NULL_TREE, c4 = NULL_TREE; + if (POINTER_TYPE_P (TREE_TYPE (decl))) + { + if (!gfc_omp_privatize_by_reference (decl) + && !GFC_DECL_GET_SCALAR_POINTER (decl) + && !GFC_DECL_GET_SCALAR_ALLOCATABLE (decl) + && !GFC_DECL_CRAY_POINTEE (decl) + && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (decl)))) + return; + c4 = build_omp_clause (OMP_CLAUSE_LOCATION (c), OMP_CLAUSE_MAP); + OMP_CLAUSE_MAP_KIND (c4) = OMP_CLAUSE_MAP_POINTER; + OMP_CLAUSE_DECL (c4) = decl; + OMP_CLAUSE_SIZE (c4) = size_int (0); + decl = build_fold_indirect_ref (decl); + OMP_CLAUSE_DECL (c) = decl; + OMP_CLAUSE_SIZE (c) = NULL_TREE; + } + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) + { + stmtblock_t block; + gfc_start_block (&block); + tree type = TREE_TYPE (decl); + tree ptr = gfc_conv_descriptor_data_get (decl); + ptr = fold_convert (build_pointer_type (char_type_node), ptr); + ptr = build_fold_indirect_ref (ptr); + OMP_CLAUSE_DECL (c) = ptr; + c2 = build_omp_clause (input_location, OMP_CLAUSE_MAP); + OMP_CLAUSE_MAP_KIND (c2) = OMP_CLAUSE_MAP_TO_PSET; + OMP_CLAUSE_DECL (c2) = decl; + OMP_CLAUSE_SIZE (c2) = TYPE_SIZE_UNIT (type); + c3 = build_omp_clause (OMP_CLAUSE_LOCATION (c), OMP_CLAUSE_MAP); + OMP_CLAUSE_MAP_KIND (c3) = OMP_CLAUSE_MAP_POINTER; + OMP_CLAUSE_DECL (c3) = gfc_conv_descriptor_data_get (decl); + OMP_CLAUSE_SIZE (c3) = size_int (0); + tree size = create_tmp_var (gfc_array_index_type, NULL); + tree elemsz = TYPE_SIZE_UNIT (gfc_get_element_type (type)); + elemsz = fold_convert (gfc_array_index_type, elemsz); + if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER + || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT) + { + stmtblock_t cond_block; + tree tem, then_b, else_b, zero, cond; + + gfc_init_block (&cond_block); + tem = gfc_full_array_size (&cond_block, decl, + GFC_TYPE_ARRAY_RANK (type)); + gfc_add_modify (&cond_block, size, tem); + gfc_add_modify (&cond_block, size, + fold_build2 (MULT_EXPR, gfc_array_index_type, + size, elemsz)); + then_b = gfc_finish_block (&cond_block); + gfc_init_block (&cond_block); + zero = build_int_cst (gfc_array_index_type, 0); + gfc_add_modify (&cond_block, size, zero); + else_b = gfc_finish_block (&cond_block); + tem = gfc_conv_descriptor_data_get (decl); + tem = fold_convert (pvoid_type_node, tem); + cond = fold_build2_loc (input_location, NE_EXPR, + boolean_type_node, tem, null_pointer_node); + gfc_add_expr_to_block (&block, build3_loc (input_location, COND_EXPR, + void_type_node, cond, + then_b, else_b)); + } + else + { + gfc_add_modify (&block, size, + gfc_full_array_size (&block, decl, + GFC_TYPE_ARRAY_RANK (type))); + gfc_add_modify (&block, size, + fold_build2 (MULT_EXPR, gfc_array_index_type, + size, elemsz)); + } + OMP_CLAUSE_SIZE (c) = size; + tree stmt = gfc_finish_block (&block); + gimplify_and_add (stmt, pre_p); + } + tree last = c; + if (OMP_CLAUSE_SIZE (c) == NULL_TREE) + OMP_CLAUSE_SIZE (c) + = DECL_P (decl) ? DECL_SIZE_UNIT (decl) + : TYPE_SIZE_UNIT (TREE_TYPE (decl)); + if (c2) + { + OMP_CLAUSE_CHAIN (c2) = OMP_CLAUSE_CHAIN (last); + OMP_CLAUSE_CHAIN (last) = c2; + last = c2; + } + if (c3) + { + OMP_CLAUSE_CHAIN (c3) = OMP_CLAUSE_CHAIN (last); + OMP_CLAUSE_CHAIN (last) = c3; + last = c3; + } + if (c4) + { + OMP_CLAUSE_CHAIN (c4) = OMP_CLAUSE_CHAIN (last); + OMP_CLAUSE_CHAIN (last) = c4; + last = c4; + } } @@ -427,8 +1204,33 @@ gfc_trans_add_clause (tree node, tree tail) } static tree -gfc_trans_omp_variable (gfc_symbol *sym) +gfc_trans_omp_variable (gfc_symbol *sym, bool declare_simd) { + if (declare_simd) + { + int cnt = 0; + gfc_symbol *proc_sym; + gfc_formal_arglist *f; + + gcc_assert (sym->attr.dummy); + proc_sym = sym->ns->proc_name; + if (proc_sym->attr.entry_master) + ++cnt; + if (gfc_return_by_reference (proc_sym)) + { + ++cnt; + if (proc_sym->ts.type == BT_CHARACTER) + ++cnt; + } + for (f = gfc_sym_get_dummy_args (proc_sym); f; f = f->next) + if (f->sym == sym) + break; + else if (f->sym) + ++cnt; + gcc_assert (f); + return build_int_cst (integer_type_node, cnt); + } + tree t = gfc_get_symbol_decl (sym); tree parent_decl; int parent_flag; @@ -442,7 +1244,8 @@ gfc_trans_omp_variable (gfc_symbol *sym) entry_master = sym->attr.result && sym->ns->proc_name->attr.entry_master && !gfc_return_by_reference (sym->ns->proc_name); - parent_decl = DECL_CONTEXT (current_function_decl); + parent_decl = current_function_decl + ? DECL_CONTEXT (current_function_decl) : NULL_TREE; if ((t == parent_decl && return_value) || (sym->ns && sym->ns->proc_name @@ -481,13 +1284,14 @@ gfc_trans_omp_variable (gfc_symbol *sym) } static tree -gfc_trans_omp_variable_list (enum omp_clause_code code, gfc_namelist *namelist, - tree list) +gfc_trans_omp_variable_list (enum omp_clause_code code, + gfc_omp_namelist *namelist, tree list, + bool declare_simd) { for (; namelist != NULL; namelist = namelist->next) - if (namelist->sym->attr.referenced) + if (namelist->sym->attr.referenced || declare_simd) { - tree t = gfc_trans_omp_variable (namelist->sym); + tree t = gfc_trans_omp_variable (namelist->sym, declare_simd); if (t != error_mark_node) { tree node = build_omp_clause (input_location, code); @@ -498,18 +1302,39 @@ gfc_trans_omp_variable_list (enum omp_clause_code code, gfc_namelist *namelist, return list; } +struct omp_udr_find_orig_data +{ + gfc_omp_udr *omp_udr; + bool omp_orig_seen; +}; + +static int +omp_udr_find_orig (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, + void *data) +{ + struct omp_udr_find_orig_data *cd = (struct omp_udr_find_orig_data *) data; + if ((*e)->expr_type == EXPR_VARIABLE + && (*e)->symtree->n.sym == cd->omp_udr->omp_orig) + cd->omp_orig_seen = true; + + return 0; +} + static void -gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where) +gfc_trans_omp_array_reduction_or_udr (tree c, gfc_omp_namelist *n, locus where) { + gfc_symbol *sym = n->sym; 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_symbol omp_var_copy[4]; gfc_expr *e1, *e2, *e3, *e4; gfc_ref *ref; tree decl, backend_decl, stmt, type, outer_decl; locus old_loc = gfc_current_locus; const char *iname; bool t; + gfc_omp_udr *udr = n->udr ? n->udr->udr : NULL; decl = OMP_CLAUSE_DECL (c); gfc_current_locus = where; @@ -532,12 +1357,29 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where) init_val_sym.attr.referenced = 1; init_val_sym.declared_at = where; init_val_sym.attr.flavor = FL_VARIABLE; - backend_decl = omp_reduction_init (c, gfc_sym_type (&init_val_sym)); + if (OMP_CLAUSE_REDUCTION_CODE (c) != ERROR_MARK) + backend_decl = omp_reduction_init (c, gfc_sym_type (&init_val_sym)); + else if (udr->initializer_ns) + backend_decl = NULL; + else + switch (sym->ts.type) + { + case BT_LOGICAL: + case BT_INTEGER: + case BT_REAL: + case BT_COMPLEX: + backend_decl = build_zero_cst (gfc_sym_type (&init_val_sym)); + break; + default: + backend_decl = NULL_TREE; + break; + } 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); + if (sym->as) + outer_sym.as = gfc_copy_array_spec (sym->as); outer_sym.attr.dummy = 0; outer_sym.attr.result = 0; outer_sym.attr.flavor = FL_VARIABLE; @@ -558,28 +1400,75 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where) symtree3->n.sym = &outer_sym; gcc_assert (symtree3 == root3); + memset (omp_var_copy, 0, sizeof omp_var_copy); + if (udr) + { + omp_var_copy[0] = *udr->omp_out; + omp_var_copy[1] = *udr->omp_in; + *udr->omp_out = outer_sym; + *udr->omp_in = *sym; + if (udr->initializer_ns) + { + omp_var_copy[2] = *udr->omp_priv; + omp_var_copy[3] = *udr->omp_orig; + *udr->omp_priv = *sym; + *udr->omp_orig = outer_sym; + } + } + /* 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->type = REF_ARRAY; - ref->u.ar.where = where; - ref->u.ar.as = sym->as; - ref->u.ar.type = AR_FULL; - ref->u.ar.dimen = 0; + if (sym->attr.dimension) + { + e1->ref = ref = gfc_get_ref (); + ref->type = REF_ARRAY; + 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); - 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); + e2 = NULL; + if (backend_decl != NULL_TREE) + { + 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); + } + else if (udr->initializer_ns == NULL) + { + gcc_assert (sym->ts.type == BT_DERIVED); + e2 = gfc_default_initializer (&sym->ts); + gcc_assert (e2); + t = gfc_resolve_expr (e2); + gcc_assert (t); + } + else if (n->udr->initializer->op == EXEC_ASSIGN) + { + e2 = gfc_copy_expr (n->udr->initializer->expr2); + t = gfc_resolve_expr (e2); + gcc_assert (t); + } + if (udr && udr->initializer_ns) + { + struct omp_udr_find_orig_data cd; + cd.omp_udr = udr; + cd.omp_orig_seen = false; + gfc_code_walker (&n->udr->initializer, + gfc_dummy_code_callback, omp_udr_find_orig, &cd); + if (cd.omp_orig_seen) + OMP_CLAUSE_REDUCTION_OMP_ORIG_REF (c) = 1; + } e3 = gfc_copy_expr (e1); e3->symtree = symtree3; @@ -587,6 +1476,7 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where) gcc_assert (t); iname = NULL; + e4 = NULL; switch (OMP_CLAUSE_REDUCTION_CODE (c)) { case PLUS_EXPR: @@ -623,6 +1513,18 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where) case BIT_XOR_EXPR: iname = "ieor"; break; + case ERROR_MARK: + if (n->udr->combiner->op == EXEC_ASSIGN) + { + gfc_free_expr (e3); + e3 = gfc_copy_expr (n->udr->combiner->expr1); + e4 = gfc_copy_expr (n->udr->combiner->expr2); + t = gfc_resolve_expr (e3); + gcc_assert (t); + t = gfc_resolve_expr (e4); + gcc_assert (t); + } + break; default: gcc_unreachable (); } @@ -646,58 +1548,27 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where) 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); + if (OMP_CLAUSE_REDUCTION_CODE (c) != ERROR_MARK) + { + /* 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); + } /* Create the init statement list. */ pushlevel (); - 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 rank, size, esize, ptr; - stmtblock_t block; - - gfc_start_block (&block); - - 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_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_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_loc (input_location, MULT_EXPR, gfc_array_index_type, - size, esize); - size = gfc_evaluate_now (fold_convert (size_type_node, size), &block); - - 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, - false)); - stmt = gfc_finish_block (&block); - } - else + if (e2) stmt = gfc_trans_assignment (e1, e2, false, false); + else + stmt = gfc_trans_call (n->udr->initializer, false, + NULL_TREE, NULL_TREE, false); if (TREE_CODE (stmt) != BIND_EXPR) stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); else @@ -706,22 +1577,11 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where) /* Create the merge statement list. */ pushlevel (); - 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, - true)); - gfc_add_expr_to_block (&block, gfc_trans_dealloc_allocated (decl, false, - NULL)); - stmt = gfc_finish_block (&block); - } - else + if (e4) stmt = gfc_trans_assignment (e3, e4, false, true); + else + stmt = gfc_trans_call (n->udr->combiner, false, + NULL_TREE, NULL_TREE, false); if (TREE_CODE (stmt) != BIND_EXPR) stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); else @@ -734,32 +1594,91 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where) gfc_current_locus = old_loc; gfc_free_expr (e1); - gfc_free_expr (e2); + if (e2) + gfc_free_expr (e2); gfc_free_expr (e3); - gfc_free_expr (e4); + if (e4) + gfc_free_expr (e4); free (symtree1); free (symtree2); free (symtree3); free (symtree4); - gfc_free_array_spec (outer_sym.as); + if (outer_sym.as) + gfc_free_array_spec (outer_sym.as); + + if (udr) + { + *udr->omp_out = omp_var_copy[0]; + *udr->omp_in = omp_var_copy[1]; + if (udr->initializer_ns) + { + *udr->omp_priv = omp_var_copy[2]; + *udr->omp_orig = omp_var_copy[3]; + } + } } static tree -gfc_trans_omp_reduction_list (gfc_namelist *namelist, tree list, - enum tree_code reduction_code, locus where) +gfc_trans_omp_reduction_list (gfc_omp_namelist *namelist, tree list, + locus where) { for (; namelist != NULL; namelist = namelist->next) if (namelist->sym->attr.referenced) { - tree t = gfc_trans_omp_variable (namelist->sym); + tree t = gfc_trans_omp_variable (namelist->sym, false); if (t != error_mark_node) { tree node = build_omp_clause (where.lb->location, 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); + switch (namelist->u.reduction_op) + { + case OMP_REDUCTION_PLUS: + OMP_CLAUSE_REDUCTION_CODE (node) = PLUS_EXPR; + break; + case OMP_REDUCTION_MINUS: + OMP_CLAUSE_REDUCTION_CODE (node) = MINUS_EXPR; + break; + case OMP_REDUCTION_TIMES: + OMP_CLAUSE_REDUCTION_CODE (node) = MULT_EXPR; + break; + case OMP_REDUCTION_AND: + OMP_CLAUSE_REDUCTION_CODE (node) = TRUTH_ANDIF_EXPR; + break; + case OMP_REDUCTION_OR: + OMP_CLAUSE_REDUCTION_CODE (node) = TRUTH_ORIF_EXPR; + break; + case OMP_REDUCTION_EQV: + OMP_CLAUSE_REDUCTION_CODE (node) = EQ_EXPR; + break; + case OMP_REDUCTION_NEQV: + OMP_CLAUSE_REDUCTION_CODE (node) = NE_EXPR; + break; + case OMP_REDUCTION_MAX: + OMP_CLAUSE_REDUCTION_CODE (node) = MAX_EXPR; + break; + case OMP_REDUCTION_MIN: + OMP_CLAUSE_REDUCTION_CODE (node) = MIN_EXPR; + break; + case OMP_REDUCTION_IAND: + OMP_CLAUSE_REDUCTION_CODE (node) = BIT_AND_EXPR; + break; + case OMP_REDUCTION_IOR: + OMP_CLAUSE_REDUCTION_CODE (node) = BIT_IOR_EXPR; + break; + case OMP_REDUCTION_IEOR: + OMP_CLAUSE_REDUCTION_CODE (node) = BIT_XOR_EXPR; + break; + case OMP_REDUCTION_USER: + OMP_CLAUSE_REDUCTION_CODE (node) = ERROR_MARK; + break; + default: + gcc_unreachable (); + } + if (namelist->sym->attr.dimension + || namelist->u.reduction_op == OMP_REDUCTION_USER + || namelist->sym->attr.allocatable) + gfc_trans_omp_array_reduction_or_udr (node, namelist, where); list = gfc_trans_add_clause (node, list); } } @@ -768,7 +1687,7 @@ gfc_trans_omp_reduction_list (gfc_namelist *namelist, tree list, static tree gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, - locus where) + locus where, bool declare_simd = false) { tree omp_clauses = NULL_TREE, chunk_size, c; int list; @@ -780,62 +1699,15 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, for (list = 0; list < OMP_LIST_NUM; list++) { - gfc_namelist *n = clauses->lists[list]; + gfc_omp_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 (); - } - omp_clauses - = gfc_trans_omp_reduction_list (n, omp_clauses, reduction_code, - where); - continue; - } switch (list) { + case OMP_LIST_REDUCTION: + omp_clauses = gfc_trans_omp_reduction_list (n, omp_clauses, where); + break; case OMP_LIST_PRIVATE: clause_code = OMP_CLAUSE_PRIVATE; goto add_clause; @@ -853,10 +1725,411 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, goto add_clause; case OMP_LIST_COPYPRIVATE: clause_code = OMP_CLAUSE_COPYPRIVATE; + goto add_clause; + case OMP_LIST_UNIFORM: + clause_code = OMP_CLAUSE_UNIFORM; /* FALLTHROUGH */ add_clause: omp_clauses - = gfc_trans_omp_variable_list (clause_code, n, omp_clauses); + = gfc_trans_omp_variable_list (clause_code, n, omp_clauses, + declare_simd); + break; + case OMP_LIST_ALIGNED: + for (; n != NULL; n = n->next) + if (n->sym->attr.referenced || declare_simd) + { + tree t = gfc_trans_omp_variable (n->sym, declare_simd); + if (t != error_mark_node) + { + tree node = build_omp_clause (input_location, + OMP_CLAUSE_ALIGNED); + OMP_CLAUSE_DECL (node) = t; + if (n->expr) + { + tree alignment_var; + + if (block == NULL) + alignment_var = gfc_conv_constant_to_tree (n->expr); + else + { + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, n->expr); + gfc_add_block_to_block (block, &se.pre); + alignment_var = gfc_evaluate_now (se.expr, block); + gfc_add_block_to_block (block, &se.post); + } + OMP_CLAUSE_ALIGNED_ALIGNMENT (node) = alignment_var; + } + omp_clauses = gfc_trans_add_clause (node, omp_clauses); + } + } + break; + case OMP_LIST_LINEAR: + { + gfc_expr *last_step_expr = NULL; + tree last_step = NULL_TREE; + + for (; n != NULL; n = n->next) + { + if (n->expr) + { + last_step_expr = n->expr; + last_step = NULL_TREE; + } + if (n->sym->attr.referenced || declare_simd) + { + tree t = gfc_trans_omp_variable (n->sym, declare_simd); + if (t != error_mark_node) + { + tree node = build_omp_clause (input_location, + OMP_CLAUSE_LINEAR); + OMP_CLAUSE_DECL (node) = t; + if (last_step_expr && last_step == NULL_TREE) + { + if (block == NULL) + last_step + = gfc_conv_constant_to_tree (last_step_expr); + else + { + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, last_step_expr); + gfc_add_block_to_block (block, &se.pre); + last_step = gfc_evaluate_now (se.expr, block); + gfc_add_block_to_block (block, &se.post); + } + } + OMP_CLAUSE_LINEAR_STEP (node) + = fold_convert (gfc_typenode_for_spec (&n->sym->ts), + last_step); + if (n->sym->attr.dimension || n->sym->attr.allocatable) + OMP_CLAUSE_LINEAR_ARRAY (node) = 1; + omp_clauses = gfc_trans_add_clause (node, omp_clauses); + } + } + } + } + break; + case OMP_LIST_DEPEND: + for (; n != NULL; n = n->next) + { + if (!n->sym->attr.referenced) + continue; + + tree node = build_omp_clause (input_location, OMP_CLAUSE_DEPEND); + if (n->expr == NULL || n->expr->ref->u.ar.type == AR_FULL) + { + tree decl = gfc_get_symbol_decl (n->sym); + if (gfc_omp_privatize_by_reference (decl)) + decl = build_fold_indirect_ref (decl); + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) + { + decl = gfc_conv_descriptor_data_get (decl); + decl = fold_convert (build_pointer_type (char_type_node), + decl); + decl = build_fold_indirect_ref (decl); + } + else if (DECL_P (decl)) + TREE_ADDRESSABLE (decl) = 1; + OMP_CLAUSE_DECL (node) = decl; + } + else + { + tree ptr; + gfc_init_se (&se, NULL); + if (n->expr->ref->u.ar.type == AR_ELEMENT) + { + gfc_conv_expr_reference (&se, n->expr); + ptr = se.expr; + } + else + { + gfc_conv_expr_descriptor (&se, n->expr); + ptr = gfc_conv_array_data (se.expr); + } + gfc_add_block_to_block (block, &se.pre); + gfc_add_block_to_block (block, &se.post); + ptr = fold_convert (build_pointer_type (char_type_node), + ptr); + OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr); + } + switch (n->u.depend_op) + { + case OMP_DEPEND_IN: + OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_IN; + break; + case OMP_DEPEND_OUT: + OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_OUT; + break; + case OMP_DEPEND_INOUT: + OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_INOUT; + break; + default: + gcc_unreachable (); + } + omp_clauses = gfc_trans_add_clause (node, omp_clauses); + } + break; + case OMP_LIST_MAP: + for (; n != NULL; n = n->next) + { + if (!n->sym->attr.referenced) + continue; + + tree node = build_omp_clause (input_location, OMP_CLAUSE_MAP); + tree node2 = NULL_TREE; + tree node3 = NULL_TREE; + tree node4 = NULL_TREE; + tree decl = gfc_get_symbol_decl (n->sym); + if (DECL_P (decl)) + TREE_ADDRESSABLE (decl) = 1; + if (n->expr == NULL || n->expr->ref->u.ar.type == AR_FULL) + { + if (POINTER_TYPE_P (TREE_TYPE (decl))) + { + node4 = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + OMP_CLAUSE_MAP_KIND (node4) = OMP_CLAUSE_MAP_POINTER; + OMP_CLAUSE_DECL (node4) = decl; + OMP_CLAUSE_SIZE (node4) = size_int (0); + decl = build_fold_indirect_ref (decl); + } + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) + { + tree type = TREE_TYPE (decl); + tree ptr = gfc_conv_descriptor_data_get (decl); + ptr = fold_convert (build_pointer_type (char_type_node), + ptr); + ptr = build_fold_indirect_ref (ptr); + OMP_CLAUSE_DECL (node) = ptr; + node2 = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + OMP_CLAUSE_MAP_KIND (node2) = OMP_CLAUSE_MAP_TO_PSET; + OMP_CLAUSE_DECL (node2) = decl; + OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type); + node3 = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + OMP_CLAUSE_MAP_KIND (node3) = OMP_CLAUSE_MAP_POINTER; + OMP_CLAUSE_DECL (node3) + = gfc_conv_descriptor_data_get (decl); + OMP_CLAUSE_SIZE (node3) = size_int (0); + if (n->sym->attr.pointer) + { + stmtblock_t cond_block; + tree size + = gfc_create_var (gfc_array_index_type, NULL); + tree tem, then_b, else_b, zero, cond; + + gfc_init_block (&cond_block); + tem + = gfc_full_array_size (&cond_block, decl, + GFC_TYPE_ARRAY_RANK (type)); + gfc_add_modify (&cond_block, size, tem); + then_b = gfc_finish_block (&cond_block); + gfc_init_block (&cond_block); + zero = build_int_cst (gfc_array_index_type, 0); + gfc_add_modify (&cond_block, size, zero); + else_b = gfc_finish_block (&cond_block); + tem = gfc_conv_descriptor_data_get (decl); + tem = fold_convert (pvoid_type_node, tem); + cond = fold_build2_loc (input_location, NE_EXPR, + boolean_type_node, + tem, null_pointer_node); + gfc_add_expr_to_block (block, + build3_loc (input_location, + COND_EXPR, + void_type_node, + cond, then_b, + else_b)); + OMP_CLAUSE_SIZE (node) = size; + } + else + OMP_CLAUSE_SIZE (node) + = gfc_full_array_size (block, decl, + GFC_TYPE_ARRAY_RANK (type)); + tree elemsz + = TYPE_SIZE_UNIT (gfc_get_element_type (type)); + elemsz = fold_convert (gfc_array_index_type, elemsz); + OMP_CLAUSE_SIZE (node) + = fold_build2 (MULT_EXPR, gfc_array_index_type, + OMP_CLAUSE_SIZE (node), elemsz); + } + else + OMP_CLAUSE_DECL (node) = decl; + } + else + { + tree ptr, ptr2; + gfc_init_se (&se, NULL); + if (n->expr->ref->u.ar.type == AR_ELEMENT) + { + gfc_conv_expr_reference (&se, n->expr); + gfc_add_block_to_block (block, &se.pre); + ptr = se.expr; + OMP_CLAUSE_SIZE (node) + = TYPE_SIZE_UNIT (TREE_TYPE (ptr)); + } + else + { + gfc_conv_expr_descriptor (&se, n->expr); + ptr = gfc_conv_array_data (se.expr); + tree type = TREE_TYPE (se.expr); + gfc_add_block_to_block (block, &se.pre); + OMP_CLAUSE_SIZE (node) + = gfc_full_array_size (block, se.expr, + GFC_TYPE_ARRAY_RANK (type)); + tree elemsz + = TYPE_SIZE_UNIT (gfc_get_element_type (type)); + elemsz = fold_convert (gfc_array_index_type, elemsz); + OMP_CLAUSE_SIZE (node) + = fold_build2 (MULT_EXPR, gfc_array_index_type, + OMP_CLAUSE_SIZE (node), elemsz); + } + gfc_add_block_to_block (block, &se.post); + ptr = fold_convert (build_pointer_type (char_type_node), + ptr); + OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr); + + if (POINTER_TYPE_P (TREE_TYPE (decl)) + && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (decl)))) + { + node4 = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + OMP_CLAUSE_MAP_KIND (node4) = OMP_CLAUSE_MAP_POINTER; + OMP_CLAUSE_DECL (node4) = decl; + OMP_CLAUSE_SIZE (node4) = size_int (0); + decl = build_fold_indirect_ref (decl); + } + ptr = fold_convert (sizetype, ptr); + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) + { + tree type = TREE_TYPE (decl); + ptr2 = gfc_conv_descriptor_data_get (decl); + node2 = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + OMP_CLAUSE_MAP_KIND (node2) = OMP_CLAUSE_MAP_TO_PSET; + OMP_CLAUSE_DECL (node2) = decl; + OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type); + node3 = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + OMP_CLAUSE_MAP_KIND (node3) = OMP_CLAUSE_MAP_POINTER; + OMP_CLAUSE_DECL (node3) + = gfc_conv_descriptor_data_get (decl); + } + else + { + if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE) + ptr2 = build_fold_addr_expr (decl); + else + { + gcc_assert (POINTER_TYPE_P (TREE_TYPE (decl))); + ptr2 = decl; + } + node3 = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + OMP_CLAUSE_MAP_KIND (node3) = OMP_CLAUSE_MAP_POINTER; + OMP_CLAUSE_DECL (node3) = decl; + } + ptr2 = fold_convert (sizetype, ptr2); + OMP_CLAUSE_SIZE (node3) + = fold_build2 (MINUS_EXPR, sizetype, ptr, ptr2); + } + switch (n->u.map_op) + { + case OMP_MAP_ALLOC: + OMP_CLAUSE_MAP_KIND (node) = OMP_CLAUSE_MAP_ALLOC; + break; + case OMP_MAP_TO: + OMP_CLAUSE_MAP_KIND (node) = OMP_CLAUSE_MAP_TO; + break; + case OMP_MAP_FROM: + OMP_CLAUSE_MAP_KIND (node) = OMP_CLAUSE_MAP_FROM; + break; + case OMP_MAP_TOFROM: + OMP_CLAUSE_MAP_KIND (node) = OMP_CLAUSE_MAP_TOFROM; + break; + default: + gcc_unreachable (); + } + omp_clauses = gfc_trans_add_clause (node, omp_clauses); + if (node2) + omp_clauses = gfc_trans_add_clause (node2, omp_clauses); + if (node3) + omp_clauses = gfc_trans_add_clause (node3, omp_clauses); + if (node4) + omp_clauses = gfc_trans_add_clause (node4, omp_clauses); + } + break; + case OMP_LIST_TO: + case OMP_LIST_FROM: + for (; n != NULL; n = n->next) + { + if (!n->sym->attr.referenced) + continue; + + tree node = build_omp_clause (input_location, + list == OMP_LIST_TO + ? OMP_CLAUSE_TO : OMP_CLAUSE_FROM); + if (n->expr == NULL || n->expr->ref->u.ar.type == AR_FULL) + { + tree decl = gfc_get_symbol_decl (n->sym); + if (gfc_omp_privatize_by_reference (decl)) + decl = build_fold_indirect_ref (decl); + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) + { + tree type = TREE_TYPE (decl); + tree ptr = gfc_conv_descriptor_data_get (decl); + ptr = fold_convert (build_pointer_type (char_type_node), + ptr); + ptr = build_fold_indirect_ref (ptr); + OMP_CLAUSE_DECL (node) = ptr; + OMP_CLAUSE_SIZE (node) + = gfc_full_array_size (block, decl, + GFC_TYPE_ARRAY_RANK (type)); + tree elemsz + = TYPE_SIZE_UNIT (gfc_get_element_type (type)); + elemsz = fold_convert (gfc_array_index_type, elemsz); + OMP_CLAUSE_SIZE (node) + = fold_build2 (MULT_EXPR, gfc_array_index_type, + OMP_CLAUSE_SIZE (node), elemsz); + } + else + OMP_CLAUSE_DECL (node) = decl; + } + else + { + tree ptr; + gfc_init_se (&se, NULL); + if (n->expr->ref->u.ar.type == AR_ELEMENT) + { + gfc_conv_expr_reference (&se, n->expr); + ptr = se.expr; + gfc_add_block_to_block (block, &se.pre); + OMP_CLAUSE_SIZE (node) + = TYPE_SIZE_UNIT (TREE_TYPE (ptr)); + } + else + { + gfc_conv_expr_descriptor (&se, n->expr); + ptr = gfc_conv_array_data (se.expr); + tree type = TREE_TYPE (se.expr); + gfc_add_block_to_block (block, &se.pre); + OMP_CLAUSE_SIZE (node) + = gfc_full_array_size (block, se.expr, + GFC_TYPE_ARRAY_RANK (type)); + tree elemsz + = TYPE_SIZE_UNIT (gfc_get_element_type (type)); + elemsz = fold_convert (gfc_array_index_type, elemsz); + OMP_CLAUSE_SIZE (node) + = fold_build2 (MULT_EXPR, gfc_array_index_type, + OMP_CLAUSE_SIZE (node), elemsz); + } + gfc_add_block_to_block (block, &se.post); + ptr = fold_convert (build_pointer_type (char_type_node), + ptr); + OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr); + } + omp_clauses = gfc_trans_add_clause (node, omp_clauses); + } break; default: break; @@ -1000,7 +2273,146 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, omp_clauses = gfc_trans_add_clause (c, omp_clauses); } - return omp_clauses; + if (clauses->inbranch) + { + c = build_omp_clause (where.lb->location, OMP_CLAUSE_INBRANCH); + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + + if (clauses->notinbranch) + { + c = build_omp_clause (where.lb->location, OMP_CLAUSE_NOTINBRANCH); + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + + switch (clauses->cancel) + { + case OMP_CANCEL_UNKNOWN: + break; + case OMP_CANCEL_PARALLEL: + c = build_omp_clause (where.lb->location, OMP_CLAUSE_PARALLEL); + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + break; + case OMP_CANCEL_SECTIONS: + c = build_omp_clause (where.lb->location, OMP_CLAUSE_SECTIONS); + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + break; + case OMP_CANCEL_DO: + c = build_omp_clause (where.lb->location, OMP_CLAUSE_FOR); + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + break; + case OMP_CANCEL_TASKGROUP: + c = build_omp_clause (where.lb->location, OMP_CLAUSE_TASKGROUP); + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + break; + } + + if (clauses->proc_bind != OMP_PROC_BIND_UNKNOWN) + { + c = build_omp_clause (where.lb->location, OMP_CLAUSE_PROC_BIND); + switch (clauses->proc_bind) + { + case OMP_PROC_BIND_MASTER: + OMP_CLAUSE_PROC_BIND_KIND (c) = OMP_CLAUSE_PROC_BIND_MASTER; + break; + case OMP_PROC_BIND_SPREAD: + OMP_CLAUSE_PROC_BIND_KIND (c) = OMP_CLAUSE_PROC_BIND_SPREAD; + break; + case OMP_PROC_BIND_CLOSE: + OMP_CLAUSE_PROC_BIND_KIND (c) = OMP_CLAUSE_PROC_BIND_CLOSE; + break; + default: + gcc_unreachable (); + } + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + + if (clauses->safelen_expr) + { + tree safelen_var; + + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, clauses->safelen_expr); + gfc_add_block_to_block (block, &se.pre); + safelen_var = gfc_evaluate_now (se.expr, block); + gfc_add_block_to_block (block, &se.post); + + c = build_omp_clause (where.lb->location, OMP_CLAUSE_SAFELEN); + OMP_CLAUSE_SAFELEN_EXPR (c) = safelen_var; + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + + if (clauses->simdlen_expr) + { + c = build_omp_clause (where.lb->location, OMP_CLAUSE_SIMDLEN); + OMP_CLAUSE_SIMDLEN_EXPR (c) + = gfc_conv_constant_to_tree (clauses->simdlen_expr); + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + + if (clauses->num_teams) + { + tree num_teams; + + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, clauses->num_teams); + gfc_add_block_to_block (block, &se.pre); + num_teams = gfc_evaluate_now (se.expr, block); + gfc_add_block_to_block (block, &se.post); + + c = build_omp_clause (where.lb->location, OMP_CLAUSE_NUM_TEAMS); + OMP_CLAUSE_NUM_TEAMS_EXPR (c) = num_teams; + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + + if (clauses->device) + { + tree device; + + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, clauses->device); + gfc_add_block_to_block (block, &se.pre); + device = gfc_evaluate_now (se.expr, block); + gfc_add_block_to_block (block, &se.post); + + c = build_omp_clause (where.lb->location, OMP_CLAUSE_DEVICE); + OMP_CLAUSE_DEVICE_ID (c) = device; + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + + if (clauses->thread_limit) + { + tree thread_limit; + + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, clauses->thread_limit); + gfc_add_block_to_block (block, &se.pre); + thread_limit = gfc_evaluate_now (se.expr, block); + gfc_add_block_to_block (block, &se.post); + + c = build_omp_clause (where.lb->location, OMP_CLAUSE_THREAD_LIMIT); + OMP_CLAUSE_THREAD_LIMIT_EXPR (c) = thread_limit; + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + + chunk_size = NULL_TREE; + if (clauses->dist_chunk_size) + { + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, clauses->dist_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->dist_sched_kind != OMP_SCHED_NONE) + { + c = build_omp_clause (where.lb->location, OMP_CLAUSE_DIST_SCHEDULE); + OMP_CLAUSE_DIST_SCHEDULE_CHUNK_EXPR (c) = chunk_size; + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + + return nreverse (omp_clauses); } /* Like gfc_trans_code, but force creation of a BIND_EXPR around it. */ @@ -1045,6 +2457,7 @@ gfc_trans_omp_atomic (gfc_code *code) enum tree_code op = ERROR_MARK; enum tree_code aop = OMP_ATOMIC; bool var_on_left = false; + bool seq_cst = (atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_SEQ_CST) != 0; code = code->block->next; gcc_assert (code->op == EXEC_ASSIGN); @@ -1060,7 +2473,7 @@ gfc_trans_omp_atomic (gfc_code *code) && expr2->value.function.isym->id == GFC_ISYM_CONVERSION) expr2 = expr2->value.function.actual->expr; - switch (atomic_code->ext.omp_atomic) + switch (atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_MASK) { case GFC_OMP_ATOMIC_READ: gfc_conv_expr (&vse, code->expr1); @@ -1072,6 +2485,7 @@ gfc_trans_omp_atomic (gfc_code *code) lhsaddr = gfc_build_addr_expr (NULL, lse.expr); x = build1 (OMP_ATOMIC_READ, type, lhsaddr); + OMP_ATOMIC_SEQ_CST (x) = seq_cst; x = convert (TREE_TYPE (vse.expr), x); gfc_add_modify (&block, vse.expr, x); @@ -1107,7 +2521,9 @@ gfc_trans_omp_atomic (gfc_code *code) type = TREE_TYPE (lse.expr); lhsaddr = gfc_build_addr_expr (NULL, lse.expr); - if (atomic_code->ext.omp_atomic == GFC_OMP_ATOMIC_WRITE) + if (((atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_MASK) + == GFC_OMP_ATOMIC_WRITE) + || (atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_SWAP)) { gfc_conv_expr (&rse, expr2); gfc_add_block_to_block (&block, &rse.pre); @@ -1229,7 +2645,9 @@ gfc_trans_omp_atomic (gfc_code *code) lhsaddr = save_expr (lhsaddr); rhs = gfc_evaluate_now (rse.expr, &block); - if (atomic_code->ext.omp_atomic == GFC_OMP_ATOMIC_WRITE) + if (((atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_MASK) + == GFC_OMP_ATOMIC_WRITE) + || (atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_SWAP)) x = rhs; else { @@ -1252,6 +2670,7 @@ gfc_trans_omp_atomic (gfc_code *code) if (aop == OMP_ATOMIC) { x = build2_v (OMP_ATOMIC, lhsaddr, convert (type, x)); + OMP_ATOMIC_SEQ_CST (x) = seq_cst; gfc_add_expr_to_block (&block, x); } else @@ -1273,6 +2692,7 @@ gfc_trans_omp_atomic (gfc_code *code) gfc_add_block_to_block (&block, &lse.pre); } x = build2 (aop, type, lhsaddr, convert (type, x)); + OMP_ATOMIC_SEQ_CST (x) = seq_cst; x = convert (TREE_TYPE (vse.expr), x); gfc_add_modify (&block, vse.expr, x); } @@ -1288,6 +2708,63 @@ gfc_trans_omp_barrier (void) } static tree +gfc_trans_omp_cancel (gfc_code *code) +{ + int mask = 0; + tree ifc = boolean_true_node; + stmtblock_t block; + switch (code->ext.omp_clauses->cancel) + { + case OMP_CANCEL_PARALLEL: mask = 1; break; + case OMP_CANCEL_DO: mask = 2; break; + case OMP_CANCEL_SECTIONS: mask = 4; break; + case OMP_CANCEL_TASKGROUP: mask = 8; break; + default: gcc_unreachable (); + } + gfc_start_block (&block); + if (code->ext.omp_clauses->if_expr) + { + gfc_se se; + tree if_var; + + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, code->ext.omp_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); + tree type = TREE_TYPE (if_var); + ifc = fold_build2_loc (input_location, NE_EXPR, + boolean_type_node, if_var, + build_zero_cst (type)); + } + tree decl = builtin_decl_explicit (BUILT_IN_GOMP_CANCEL); + tree c_bool_type = TREE_TYPE (TREE_TYPE (decl)); + ifc = fold_convert (c_bool_type, ifc); + gfc_add_expr_to_block (&block, + build_call_expr_loc (input_location, decl, 2, + build_int_cst (integer_type_node, + mask), ifc)); + return gfc_finish_block (&block); +} + +static tree +gfc_trans_omp_cancellation_point (gfc_code *code) +{ + int mask = 0; + switch (code->ext.omp_clauses->cancel) + { + case OMP_CANCEL_PARALLEL: mask = 1; break; + case OMP_CANCEL_DO: mask = 2; break; + case OMP_CANCEL_SECTIONS: mask = 4; break; + case OMP_CANCEL_TASKGROUP: mask = 8; break; + default: gcc_unreachable (); + } + tree decl = builtin_decl_explicit (BUILT_IN_GOMP_CANCELLATION_POINT); + return build_call_expr_loc (input_location, decl, 1, + build_int_cst (integer_type_node, mask)); +} + +static tree gfc_trans_omp_critical (gfc_code *code) { tree name = NULL_TREE, stmt; @@ -1304,7 +2781,7 @@ typedef struct dovar_init_d { static tree -gfc_trans_omp_do (gfc_code *code, stmtblock_t *pblock, +gfc_trans_omp_do (gfc_code *code, gfc_exec_op op, stmtblock_t *pblock, gfc_omp_clauses *do_clauses, tree par_clauses) { gfc_se se; @@ -1344,14 +2821,16 @@ gfc_trans_omp_do (gfc_code *code, stmtblock_t *pblock, 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; + gfc_omp_namelist *n = NULL; + if (op != EXEC_OMP_DISTRIBUTE) + for (n = clauses->lists[(op == EXEC_OMP_SIMD && collapse == 1) + ? OMP_LIST_LINEAR : 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) + else if (n == NULL && op != EXEC_OMP_SIMD) for (n = clauses->lists[OMP_LIST_PRIVATE]; n != NULL; n = n->next) if (code->ext.iterator->var->symtree->n.sym == n->sym) break; @@ -1393,7 +2872,8 @@ gfc_trans_omp_do (gfc_code *code, stmtblock_t *pblock, } else dovar_decl - = gfc_trans_omp_variable (code->ext.iterator->var->symtree->n.sym); + = gfc_trans_omp_variable (code->ext.iterator->var->symtree->n.sym, + false); /* Loop body. */ if (simple) @@ -1447,11 +2927,24 @@ gfc_trans_omp_do (gfc_code *code, stmtblock_t *pblock, if (!dovar_found) { - tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE); + if (op == EXEC_OMP_SIMD) + { + if (collapse == 1) + { + tmp = build_omp_clause (input_location, OMP_CLAUSE_LINEAR); + OMP_CLAUSE_LINEAR_STEP (tmp) = step; + } + else + tmp = build_omp_clause (input_location, OMP_CLAUSE_LASTPRIVATE); + if (!simple) + dovar_found = 2; + } + else + 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) + if (dovar_found == 2) { tree c = NULL; @@ -1475,8 +2968,14 @@ gfc_trans_omp_do (gfc_code *code, stmtblock_t *pblock, OMP_CLAUSE_LASTPRIVATE_STMT (c) = tmp; break; } + else if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LINEAR + && OMP_CLAUSE_DECL (c) == dovar_decl) + { + OMP_CLAUSE_LINEAR_STMT (c) = tmp; + break; + } } - if (c == NULL && par_clauses != NULL) + if (c == NULL && op == EXEC_OMP_DO && par_clauses != NULL) { for (c = par_clauses; c ; c = OMP_CLAUSE_CHAIN (c)) if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LASTPRIVATE @@ -1496,7 +2995,17 @@ gfc_trans_omp_do (gfc_code *code, stmtblock_t *pblock, } if (!simple) { - tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE); + if (op != EXEC_OMP_SIMD) + tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE); + else if (collapse == 1) + { + tmp = build_omp_clause (input_location, OMP_CLAUSE_LINEAR); + OMP_CLAUSE_LINEAR_STEP (tmp) = step; + OMP_CLAUSE_LINEAR_NO_COPYIN (tmp) = 1; + OMP_CLAUSE_LINEAR_NO_COPYOUT (tmp) = 1; + } + else + tmp = build_omp_clause (input_location, OMP_CLAUSE_LASTPRIVATE); OMP_CLAUSE_DECL (tmp) = count; omp_clauses = gfc_trans_add_clause (tmp, omp_clauses); } @@ -1538,7 +3047,13 @@ gfc_trans_omp_do (gfc_code *code, stmtblock_t *pblock, } /* End of loop body. */ - stmt = make_node (OMP_FOR); + switch (op) + { + case EXEC_OMP_SIMD: stmt = make_node (OMP_SIMD); break; + case EXEC_OMP_DO: stmt = make_node (OMP_FOR); break; + case EXEC_OMP_DISTRIBUTE: stmt = make_node (OMP_DISTRIBUTE); break; + default: gcc_unreachable (); + } TREE_TYPE (stmt) = void_type_node; OMP_FOR_BODY (stmt) = gfc_finish_block (&body); @@ -1589,41 +3104,352 @@ gfc_trans_omp_parallel (gfc_code *code) return gfc_finish_block (&block); } +enum +{ + GFC_OMP_SPLIT_SIMD, + GFC_OMP_SPLIT_DO, + GFC_OMP_SPLIT_PARALLEL, + GFC_OMP_SPLIT_DISTRIBUTE, + GFC_OMP_SPLIT_TEAMS, + GFC_OMP_SPLIT_TARGET, + GFC_OMP_SPLIT_NUM +}; + +enum +{ + GFC_OMP_MASK_SIMD = (1 << GFC_OMP_SPLIT_SIMD), + GFC_OMP_MASK_DO = (1 << GFC_OMP_SPLIT_DO), + GFC_OMP_MASK_PARALLEL = (1 << GFC_OMP_SPLIT_PARALLEL), + GFC_OMP_MASK_DISTRIBUTE = (1 << GFC_OMP_SPLIT_DISTRIBUTE), + GFC_OMP_MASK_TEAMS = (1 << GFC_OMP_SPLIT_TEAMS), + GFC_OMP_MASK_TARGET = (1 << GFC_OMP_SPLIT_TARGET) +}; + +static void +gfc_split_omp_clauses (gfc_code *code, + gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM]) +{ + int mask = 0, innermost = 0; + memset (clausesa, 0, GFC_OMP_SPLIT_NUM * sizeof (gfc_omp_clauses)); + switch (code->op) + { + case EXEC_OMP_DISTRIBUTE: + innermost = GFC_OMP_SPLIT_DISTRIBUTE; + break; + case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: + mask = GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO; + innermost = GFC_OMP_SPLIT_DO; + break; + case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: + mask = GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_PARALLEL + | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD; + innermost = GFC_OMP_SPLIT_SIMD; + break; + case EXEC_OMP_DISTRIBUTE_SIMD: + mask = GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_SIMD; + innermost = GFC_OMP_SPLIT_SIMD; + break; + case EXEC_OMP_DO: + innermost = GFC_OMP_SPLIT_DO; + break; + case EXEC_OMP_DO_SIMD: + mask = GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD; + innermost = GFC_OMP_SPLIT_SIMD; + break; + case EXEC_OMP_PARALLEL: + innermost = GFC_OMP_SPLIT_PARALLEL; + break; + case EXEC_OMP_PARALLEL_DO: + mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO; + innermost = GFC_OMP_SPLIT_DO; + break; + case EXEC_OMP_PARALLEL_DO_SIMD: + mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD; + innermost = GFC_OMP_SPLIT_SIMD; + break; + case EXEC_OMP_SIMD: + innermost = GFC_OMP_SPLIT_SIMD; + break; + case EXEC_OMP_TARGET: + innermost = GFC_OMP_SPLIT_TARGET; + break; + case EXEC_OMP_TARGET_TEAMS: + mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS; + innermost = GFC_OMP_SPLIT_TEAMS; + break; + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: + mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS + | GFC_OMP_MASK_DISTRIBUTE; + innermost = GFC_OMP_SPLIT_DISTRIBUTE; + break; + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: + mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE + | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO; + innermost = GFC_OMP_SPLIT_DO; + break; + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE + | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD; + innermost = GFC_OMP_SPLIT_SIMD; + break; + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: + mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS + | GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_SIMD; + innermost = GFC_OMP_SPLIT_SIMD; + break; + case EXEC_OMP_TEAMS: + innermost = GFC_OMP_SPLIT_TEAMS; + break; + case EXEC_OMP_TEAMS_DISTRIBUTE: + mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE; + innermost = GFC_OMP_SPLIT_DISTRIBUTE; + break; + case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: + mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE + | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO; + innermost = GFC_OMP_SPLIT_DO; + break; + case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE + | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD; + innermost = GFC_OMP_SPLIT_SIMD; + break; + case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: + mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_SIMD; + innermost = GFC_OMP_SPLIT_SIMD; + break; + default: + gcc_unreachable (); + } + if (mask == 0) + { + clausesa[innermost] = *code->ext.omp_clauses; + return; + } + if (code->ext.omp_clauses != NULL) + { + if (mask & GFC_OMP_MASK_TARGET) + { + /* First the clauses that are unique to some constructs. */ + clausesa[GFC_OMP_SPLIT_TARGET].lists[OMP_LIST_MAP] + = code->ext.omp_clauses->lists[OMP_LIST_MAP]; + clausesa[GFC_OMP_SPLIT_TARGET].device + = code->ext.omp_clauses->device; + } + if (mask & GFC_OMP_MASK_TEAMS) + { + /* First the clauses that are unique to some constructs. */ + clausesa[GFC_OMP_SPLIT_TEAMS].num_teams + = code->ext.omp_clauses->num_teams; + clausesa[GFC_OMP_SPLIT_TEAMS].thread_limit + = code->ext.omp_clauses->thread_limit; + /* Shared and default clauses are allowed on parallel and teams. */ + clausesa[GFC_OMP_SPLIT_TEAMS].lists[OMP_LIST_SHARED] + = code->ext.omp_clauses->lists[OMP_LIST_SHARED]; + clausesa[GFC_OMP_SPLIT_TEAMS].default_sharing + = code->ext.omp_clauses->default_sharing; + } + if (mask & GFC_OMP_MASK_DISTRIBUTE) + { + /* First the clauses that are unique to some constructs. */ + clausesa[GFC_OMP_SPLIT_DISTRIBUTE].dist_sched_kind + = code->ext.omp_clauses->dist_sched_kind; + clausesa[GFC_OMP_SPLIT_DISTRIBUTE].dist_chunk_size + = code->ext.omp_clauses->dist_chunk_size; + /* Duplicate collapse. */ + clausesa[GFC_OMP_SPLIT_DISTRIBUTE].collapse + = code->ext.omp_clauses->collapse; + } + if (mask & GFC_OMP_MASK_PARALLEL) + { + /* First the clauses that are unique to some constructs. */ + clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_COPYIN] + = code->ext.omp_clauses->lists[OMP_LIST_COPYIN]; + clausesa[GFC_OMP_SPLIT_PARALLEL].num_threads + = code->ext.omp_clauses->num_threads; + clausesa[GFC_OMP_SPLIT_PARALLEL].proc_bind + = code->ext.omp_clauses->proc_bind; + /* Shared and default clauses are allowed on parallel and teams. */ + clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_SHARED] + = code->ext.omp_clauses->lists[OMP_LIST_SHARED]; + clausesa[GFC_OMP_SPLIT_PARALLEL].default_sharing + = code->ext.omp_clauses->default_sharing; + } + if (mask & GFC_OMP_MASK_DO) + { + /* First the clauses that are unique to some constructs. */ + clausesa[GFC_OMP_SPLIT_DO].ordered + = code->ext.omp_clauses->ordered; + clausesa[GFC_OMP_SPLIT_DO].sched_kind + = code->ext.omp_clauses->sched_kind; + clausesa[GFC_OMP_SPLIT_DO].chunk_size + = code->ext.omp_clauses->chunk_size; + clausesa[GFC_OMP_SPLIT_DO].nowait + = code->ext.omp_clauses->nowait; + /* Duplicate collapse. */ + clausesa[GFC_OMP_SPLIT_DO].collapse + = code->ext.omp_clauses->collapse; + } + if (mask & GFC_OMP_MASK_SIMD) + { + clausesa[GFC_OMP_SPLIT_SIMD].safelen_expr + = code->ext.omp_clauses->safelen_expr; + clausesa[GFC_OMP_SPLIT_SIMD].lists[OMP_LIST_LINEAR] + = code->ext.omp_clauses->lists[OMP_LIST_LINEAR]; + clausesa[GFC_OMP_SPLIT_SIMD].lists[OMP_LIST_ALIGNED] + = code->ext.omp_clauses->lists[OMP_LIST_ALIGNED]; + /* Duplicate collapse. */ + clausesa[GFC_OMP_SPLIT_SIMD].collapse + = code->ext.omp_clauses->collapse; + } + /* Private clause is supported on all constructs but target, + it is enough to put it on the innermost one. For + !$ omp do put it on parallel though, + as that's what we did for OpenMP 3.1. */ + clausesa[innermost == GFC_OMP_SPLIT_DO + ? (int) GFC_OMP_SPLIT_PARALLEL + : innermost].lists[OMP_LIST_PRIVATE] + = code->ext.omp_clauses->lists[OMP_LIST_PRIVATE]; + /* Firstprivate clause is supported on all constructs but + target and simd. Put it on the outermost of those and + duplicate on parallel. */ + if (mask & GFC_OMP_MASK_TEAMS) + clausesa[GFC_OMP_SPLIT_TEAMS].lists[OMP_LIST_FIRSTPRIVATE] + = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; + else if (mask & GFC_OMP_MASK_DISTRIBUTE) + clausesa[GFC_OMP_SPLIT_DISTRIBUTE].lists[OMP_LIST_FIRSTPRIVATE] + = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; + if (mask & GFC_OMP_MASK_PARALLEL) + clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_FIRSTPRIVATE] + = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; + else if (mask & GFC_OMP_MASK_DO) + clausesa[GFC_OMP_SPLIT_DO].lists[OMP_LIST_FIRSTPRIVATE] + = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; + /* Lastprivate is allowed on do and simd. In + parallel do{, simd} we actually want to put it on + parallel rather than do. */ + if (mask & GFC_OMP_MASK_PARALLEL) + clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_LASTPRIVATE] + = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE]; + else if (mask & GFC_OMP_MASK_DO) + clausesa[GFC_OMP_SPLIT_DO].lists[OMP_LIST_LASTPRIVATE] + = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE]; + if (mask & GFC_OMP_MASK_SIMD) + clausesa[GFC_OMP_SPLIT_SIMD].lists[OMP_LIST_LASTPRIVATE] + = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE]; + /* Reduction is allowed on simd, do, parallel and teams. + Duplicate it on all of them, but omit on do if + parallel is present. */ + if (mask & GFC_OMP_MASK_TEAMS) + clausesa[GFC_OMP_SPLIT_TEAMS].lists[OMP_LIST_REDUCTION] + = code->ext.omp_clauses->lists[OMP_LIST_REDUCTION]; + if (mask & GFC_OMP_MASK_PARALLEL) + clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_REDUCTION] + = code->ext.omp_clauses->lists[OMP_LIST_REDUCTION]; + else if (mask & GFC_OMP_MASK_DO) + clausesa[GFC_OMP_SPLIT_DO].lists[OMP_LIST_REDUCTION] + = code->ext.omp_clauses->lists[OMP_LIST_REDUCTION]; + if (mask & GFC_OMP_MASK_SIMD) + clausesa[GFC_OMP_SPLIT_SIMD].lists[OMP_LIST_REDUCTION] + = code->ext.omp_clauses->lists[OMP_LIST_REDUCTION]; + /* FIXME: This is currently being discussed. */ + if (mask & GFC_OMP_MASK_PARALLEL) + clausesa[GFC_OMP_SPLIT_PARALLEL].if_expr + = code->ext.omp_clauses->if_expr; + else + clausesa[GFC_OMP_SPLIT_TARGET].if_expr + = code->ext.omp_clauses->if_expr; + } + if ((mask & (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO)) + == (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO)) + clausesa[GFC_OMP_SPLIT_DO].nowait = true; +} + static tree -gfc_trans_omp_parallel_do (gfc_code *code) +gfc_trans_omp_do_simd (gfc_code *code, stmtblock_t *pblock, + gfc_omp_clauses *clausesa, tree omp_clauses) { - stmtblock_t block, *pblock = NULL; - gfc_omp_clauses parallel_clauses, do_clauses; - tree stmt, omp_clauses = NULL_TREE; + stmtblock_t block; + gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM]; + tree stmt, body, omp_do_clauses = NULL_TREE; - gfc_start_block (&block); + if (pblock == NULL) + gfc_start_block (&block); + else + gfc_init_block (&block); - memset (&do_clauses, 0, sizeof (do_clauses)); - if (code->ext.omp_clauses != NULL) + if (clausesa == NULL) + { + clausesa = clausesa_buf; + gfc_split_omp_clauses (code, clausesa); + } + if (gfc_option.gfc_flag_openmp) + omp_do_clauses + = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_DO], code->loc); + body = gfc_trans_omp_do (code, EXEC_OMP_SIMD, pblock ? pblock : &block, + &clausesa[GFC_OMP_SPLIT_SIMD], omp_clauses); + if (pblock == NULL) + { + if (TREE_CODE (body) != BIND_EXPR) + body = build3_v (BIND_EXPR, NULL, body, poplevel (1, 0)); + else + poplevel (0, 0); + } + else if (TREE_CODE (body) != BIND_EXPR) + body = build3_v (BIND_EXPR, NULL, body, NULL_TREE); + if (gfc_option.gfc_flag_openmp) { - 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; - do_clauses.collapse = parallel_clauses.collapse; - parallel_clauses.sched_kind = OMP_SCHED_NONE; - parallel_clauses.chunk_size = NULL; - parallel_clauses.ordered = false; - parallel_clauses.collapse = 0; - 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 = █ + stmt = make_node (OMP_FOR); + TREE_TYPE (stmt) = void_type_node; + OMP_FOR_BODY (stmt) = body; + OMP_FOR_CLAUSES (stmt) = omp_do_clauses; + } else - pushlevel (); - stmt = gfc_trans_omp_do (code, pblock, &do_clauses, omp_clauses); - if (TREE_CODE (stmt) != BIND_EXPR) - stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); + stmt = body; + gfc_add_expr_to_block (&block, stmt); + return gfc_finish_block (&block); +} + +static tree +gfc_trans_omp_parallel_do (gfc_code *code, stmtblock_t *pblock, + gfc_omp_clauses *clausesa) +{ + stmtblock_t block, *new_pblock = pblock; + gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM]; + tree stmt, omp_clauses = NULL_TREE; + + if (pblock == NULL) + gfc_start_block (&block); else - poplevel (0, 0); + gfc_init_block (&block); + + if (clausesa == NULL) + { + clausesa = clausesa_buf; + gfc_split_omp_clauses (code, clausesa); + } + omp_clauses + = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_PARALLEL], + code->loc); + if (pblock == NULL) + { + if (!clausesa[GFC_OMP_SPLIT_DO].ordered + && clausesa[GFC_OMP_SPLIT_DO].sched_kind != OMP_SCHED_STATIC) + new_pblock = █ + else + pushlevel (); + } + stmt = gfc_trans_omp_do (code, EXEC_OMP_DO, new_pblock, + &clausesa[GFC_OMP_SPLIT_DO], omp_clauses); + if (pblock == NULL) + { + if (TREE_CODE (stmt) != BIND_EXPR) + stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); + else + poplevel (0, 0); + } + else if (TREE_CODE (stmt) != BIND_EXPR) + stmt = build3_v (BIND_EXPR, NULL, stmt, NULL_TREE); stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt, omp_clauses); OMP_PARALLEL_COMBINED (stmt) = 1; @@ -1632,6 +3458,50 @@ gfc_trans_omp_parallel_do (gfc_code *code) } static tree +gfc_trans_omp_parallel_do_simd (gfc_code *code, stmtblock_t *pblock, + gfc_omp_clauses *clausesa) +{ + stmtblock_t block; + gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM]; + tree stmt, omp_clauses = NULL_TREE; + + if (pblock == NULL) + gfc_start_block (&block); + else + gfc_init_block (&block); + + if (clausesa == NULL) + { + clausesa = clausesa_buf; + gfc_split_omp_clauses (code, clausesa); + } + if (gfc_option.gfc_flag_openmp) + omp_clauses + = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_PARALLEL], + code->loc); + if (pblock == NULL) + pushlevel (); + stmt = gfc_trans_omp_do_simd (code, pblock, clausesa, omp_clauses); + if (pblock == NULL) + { + if (TREE_CODE (stmt) != BIND_EXPR) + stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); + else + poplevel (0, 0); + } + else if (TREE_CODE (stmt) != BIND_EXPR) + stmt = build3_v (BIND_EXPR, NULL, stmt, NULL_TREE); + if (gfc_option.gfc_flag_openmp) + { + 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); +} + +static tree gfc_trans_omp_parallel_sections (gfc_code *code) { stmtblock_t block; @@ -1743,6 +3613,13 @@ gfc_trans_omp_task (gfc_code *code) } static tree +gfc_trans_omp_taskgroup (gfc_code *code) +{ + tree stmt = gfc_trans_code (code->block->next); + return build1_loc (input_location, OMP_TASKGROUP, void_type_node, stmt); +} + +static tree gfc_trans_omp_taskwait (void) { tree decl = builtin_decl_explicit (BUILT_IN_GOMP_TASKWAIT); @@ -1757,6 +3634,170 @@ gfc_trans_omp_taskyield (void) } static tree +gfc_trans_omp_distribute (gfc_code *code, gfc_omp_clauses *clausesa) +{ + stmtblock_t block; + gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM]; + tree stmt, omp_clauses = NULL_TREE; + + gfc_start_block (&block); + if (clausesa == NULL) + { + clausesa = clausesa_buf; + gfc_split_omp_clauses (code, clausesa); + } + if (gfc_option.gfc_flag_openmp) + omp_clauses + = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_DISTRIBUTE], + code->loc); + switch (code->op) + { + case EXEC_OMP_DISTRIBUTE: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: + case EXEC_OMP_TEAMS_DISTRIBUTE: + /* This is handled in gfc_trans_omp_do. */ + gcc_unreachable (); + break; + case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: + case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: + stmt = gfc_trans_omp_parallel_do (code, &block, clausesa); + if (TREE_CODE (stmt) != BIND_EXPR) + stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); + else + poplevel (0, 0); + break; + case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + stmt = gfc_trans_omp_parallel_do_simd (code, &block, clausesa); + if (TREE_CODE (stmt) != BIND_EXPR) + stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); + else + poplevel (0, 0); + break; + case EXEC_OMP_DISTRIBUTE_SIMD: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: + case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: + stmt = gfc_trans_omp_do (code, EXEC_OMP_SIMD, &block, + &clausesa[GFC_OMP_SPLIT_SIMD], NULL_TREE); + if (TREE_CODE (stmt) != BIND_EXPR) + stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); + else + poplevel (0, 0); + break; + default: + gcc_unreachable (); + } + if (gfc_option.gfc_flag_openmp) + { + tree distribute = make_node (OMP_DISTRIBUTE); + TREE_TYPE (distribute) = void_type_node; + OMP_FOR_BODY (distribute) = stmt; + OMP_FOR_CLAUSES (distribute) = omp_clauses; + stmt = distribute; + } + gfc_add_expr_to_block (&block, stmt); + return gfc_finish_block (&block); +} + +static tree +gfc_trans_omp_teams (gfc_code *code, gfc_omp_clauses *clausesa) +{ + stmtblock_t block; + gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM]; + tree stmt, omp_clauses = NULL_TREE; + + gfc_start_block (&block); + if (clausesa == NULL) + { + clausesa = clausesa_buf; + gfc_split_omp_clauses (code, clausesa); + } + if (gfc_option.gfc_flag_openmp) + omp_clauses + = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_TEAMS], + code->loc); + switch (code->op) + { + case EXEC_OMP_TARGET_TEAMS: + case EXEC_OMP_TEAMS: + stmt = gfc_trans_omp_code (code->block->next, true); + break; + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: + case EXEC_OMP_TEAMS_DISTRIBUTE: + stmt = gfc_trans_omp_do (code, EXEC_OMP_DISTRIBUTE, NULL, + &clausesa[GFC_OMP_SPLIT_DISTRIBUTE], + NULL); + break; + default: + stmt = gfc_trans_omp_distribute (code, clausesa); + break; + } + stmt = build2_loc (input_location, OMP_TEAMS, void_type_node, stmt, + omp_clauses); + gfc_add_expr_to_block (&block, stmt); + return gfc_finish_block (&block); +} + +static tree +gfc_trans_omp_target (gfc_code *code) +{ + stmtblock_t block; + gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM]; + tree stmt, omp_clauses = NULL_TREE; + + gfc_start_block (&block); + gfc_split_omp_clauses (code, clausesa); + if (gfc_option.gfc_flag_openmp) + omp_clauses + = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_TARGET], + code->loc); + if (code->op == EXEC_OMP_TARGET) + stmt = gfc_trans_omp_code (code->block->next, true); + else + stmt = gfc_trans_omp_teams (code, clausesa); + if (TREE_CODE (stmt) != BIND_EXPR) + stmt = build3_v (BIND_EXPR, NULL, stmt, NULL_TREE); + if (gfc_option.gfc_flag_openmp) + stmt = build2_loc (input_location, OMP_TARGET, void_type_node, stmt, + omp_clauses); + gfc_add_expr_to_block (&block, stmt); + return gfc_finish_block (&block); +} + +static tree +gfc_trans_omp_target_data (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 = build2_loc (input_location, OMP_TARGET_DATA, void_type_node, stmt, + omp_clauses); + gfc_add_expr_to_block (&block, stmt); + return gfc_finish_block (&block); +} + +static tree +gfc_trans_omp_target_update (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 = build1_loc (input_location, OMP_TARGET_UPDATE, void_type_node, + omp_clauses); + gfc_add_expr_to_block (&block, stmt); + return gfc_finish_block (&block); +} + +static tree gfc_trans_omp_workshare (gfc_code *code, gfc_omp_clauses *clauses) { tree res, tmp, stmt; @@ -1923,10 +3964,23 @@ gfc_trans_omp_directive (gfc_code *code) return gfc_trans_omp_atomic (code); case EXEC_OMP_BARRIER: return gfc_trans_omp_barrier (); + case EXEC_OMP_CANCEL: + return gfc_trans_omp_cancel (code); + case EXEC_OMP_CANCELLATION_POINT: + return gfc_trans_omp_cancellation_point (code); case EXEC_OMP_CRITICAL: return gfc_trans_omp_critical (code); + case EXEC_OMP_DISTRIBUTE: case EXEC_OMP_DO: - return gfc_trans_omp_do (code, NULL, code->ext.omp_clauses, NULL); + case EXEC_OMP_SIMD: + return gfc_trans_omp_do (code, code->op, NULL, code->ext.omp_clauses, + NULL); + case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: + case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: + case EXEC_OMP_DISTRIBUTE_SIMD: + return gfc_trans_omp_distribute (code, NULL); + case EXEC_OMP_DO_SIMD: + return gfc_trans_omp_do_simd (code, NULL, NULL, NULL_TREE); case EXEC_OMP_FLUSH: return gfc_trans_omp_flush (); case EXEC_OMP_MASTER: @@ -1936,7 +3990,9 @@ gfc_trans_omp_directive (gfc_code *code) case EXEC_OMP_PARALLEL: return gfc_trans_omp_parallel (code); case EXEC_OMP_PARALLEL_DO: - return gfc_trans_omp_parallel_do (code); + return gfc_trans_omp_parallel_do (code, NULL, NULL); + case EXEC_OMP_PARALLEL_DO_SIMD: + return gfc_trans_omp_parallel_do_simd (code, NULL, NULL); case EXEC_OMP_PARALLEL_SECTIONS: return gfc_trans_omp_parallel_sections (code); case EXEC_OMP_PARALLEL_WORKSHARE: @@ -1945,15 +4001,53 @@ gfc_trans_omp_directive (gfc_code *code) 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_TARGET: + case EXEC_OMP_TARGET_TEAMS: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: + return gfc_trans_omp_target (code); + case EXEC_OMP_TARGET_DATA: + return gfc_trans_omp_target_data (code); + case EXEC_OMP_TARGET_UPDATE: + return gfc_trans_omp_target_update (code); case EXEC_OMP_TASK: return gfc_trans_omp_task (code); + case EXEC_OMP_TASKGROUP: + return gfc_trans_omp_taskgroup (code); case EXEC_OMP_TASKWAIT: return gfc_trans_omp_taskwait (); case EXEC_OMP_TASKYIELD: return gfc_trans_omp_taskyield (); + case EXEC_OMP_TEAMS: + case EXEC_OMP_TEAMS_DISTRIBUTE: + case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: + case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: + return gfc_trans_omp_teams (code, NULL); case EXEC_OMP_WORKSHARE: return gfc_trans_omp_workshare (code, code->ext.omp_clauses); default: gcc_unreachable (); } } + +void +gfc_trans_omp_declare_simd (gfc_namespace *ns) +{ + if (ns->entries) + return; + + gfc_omp_declare_simd *ods; + for (ods = ns->omp_declare_simd; ods; ods = ods->next) + { + tree c = gfc_trans_omp_clauses (NULL, ods->clauses, ods->where, true); + tree fndecl = ns->proc_name->backend_decl; + if (c != NULL_TREE) + c = tree_cons (NULL_TREE, c, NULL_TREE); + c = build_tree_list (get_identifier ("omp declare simd"), c); + TREE_CHAIN (c) = DECL_ATTRIBUTES (fndecl); + DECL_ATTRIBUTES (fndecl) = c; + } +} |