Mercurial > hg > CbC > CbC_gcc
diff gcc/fortran/trans-openmp.c @ 145:1830386684a0
gcc-9.2.0
| author | anatofuz |
|---|---|
| date | Thu, 13 Feb 2020 11:34:05 +0900 |
| parents | 84e7813d76e9 |
| children |
line wrap: on
line diff
--- a/gcc/fortran/trans-openmp.c Thu Oct 25 07:37:49 2018 +0900 +++ b/gcc/fortran/trans-openmp.c Thu Feb 13 11:34:05 2020 +0900 @@ -1,5 +1,5 @@ /* OpenMP directive translation -- generate GCC trees from gfc_code. - Copyright (C) 2005-2018 Free Software Foundation, Inc. + Copyright (C) 2005-2020 Free Software Foundation, Inc. Contributed by Jakub Jelinek <jakub@redhat.com> This file is part of GCC. @@ -43,9 +43,141 @@ #include "diagnostic-core.h" #undef GCC_DIAG_STYLE #define GCC_DIAG_STYLE __gcc_gfc__ +#include "attribs.h" int ompws_flags; +/* True if OpenMP should regard this DECL as being a scalar which has Fortran's + allocatable or pointer attribute. */ + +bool +gfc_omp_is_allocatable_or_ptr (const_tree decl) +{ + return (DECL_P (decl) + && (GFC_DECL_GET_SCALAR_POINTER (decl) + || GFC_DECL_GET_SCALAR_ALLOCATABLE (decl))); +} + +/* True if the argument is an optional argument; except that false is also + returned for arguments with the value attribute (nonpointers) and for + assumed-shape variables (decl is a local variable containing arg->data). + Note that pvoid_type_node is for 'type(c_ptr), value. */ + +static bool +gfc_omp_is_optional_argument (const_tree decl) +{ + return (TREE_CODE (decl) == PARM_DECL + && DECL_LANG_SPECIFIC (decl) + && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE + && !VOID_TYPE_P (TREE_TYPE (TREE_TYPE (decl))) + && GFC_DECL_OPTIONAL_ARGUMENT (decl)); +} + +/* Check whether this DECL belongs to a Fortran optional argument. + With 'for_present_check' set to false, decls which are optional parameters + themselve are returned as tree - or a NULL_TREE otherwise. Those decls are + always pointers. With 'for_present_check' set to true, the decl for checking + whether an argument is present is returned; for arguments with value + attribute this is the hidden argument and of BOOLEAN_TYPE. If the decl is + unrelated to optional arguments, NULL_TREE is returned. */ + +tree +gfc_omp_check_optional_argument (tree decl, bool for_present_check) +{ + if (!for_present_check) + return gfc_omp_is_optional_argument (decl) ? decl : NULL_TREE; + + if (!DECL_LANG_SPECIFIC (decl)) + return NULL_TREE; + + bool is_array_type = false; + + /* For assumed-shape arrays, a local decl with arg->data is used. */ + if (TREE_CODE (decl) != PARM_DECL + && (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)) + || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)))) + { + is_array_type = true; + decl = GFC_DECL_SAVED_DESCRIPTOR (decl); + } + + if (decl == NULL_TREE + || TREE_CODE (decl) != PARM_DECL + || !DECL_LANG_SPECIFIC (decl) + || !GFC_DECL_OPTIONAL_ARGUMENT (decl)) + return NULL_TREE; + + /* Scalars with VALUE attribute which are passed by value use a hidden + argument to denote the present status. They are passed as nonpointer type + with one exception: 'type(c_ptr), value' as 'void*'. */ + /* Cf. trans-expr.c's gfc_conv_expr_present. */ + if (TREE_CODE (TREE_TYPE (decl)) != POINTER_TYPE + || VOID_TYPE_P (TREE_TYPE (TREE_TYPE (decl)))) + { + char name[GFC_MAX_SYMBOL_LEN + 2]; + tree tree_name; + + name[0] = '_'; + strcpy (&name[1], IDENTIFIER_POINTER (DECL_NAME (decl))); + tree_name = get_identifier (name); + + /* Walk function argument list to find the hidden arg. */ + decl = DECL_ARGUMENTS (DECL_CONTEXT (decl)); + for ( ; decl != NULL_TREE; decl = TREE_CHAIN (decl)) + if (DECL_NAME (decl) == tree_name + && DECL_ARTIFICIAL (decl)) + break; + + gcc_assert (decl); + return decl; + } + + tree cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + decl, null_pointer_node); + + /* Fortran regards unallocated allocatables/disassociated pointer which + are passed to a nonallocatable, nonpointer argument as not associated; + cf. F2018, 15.5.2.12, Paragraph 1. */ + if (is_array_type) + { + tree cond2 = build_fold_indirect_ref_loc (input_location, decl); + cond2 = gfc_conv_array_data (cond2); + cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + cond2, null_pointer_node); + cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, + boolean_type_node, cond, cond2); + } + + return cond; +} + + +/* Returns tree with NULL if it is not an array descriptor and with the tree to + access the 'data' component otherwise. With type_only = true, it returns the + TREE_TYPE without creating a new tree. */ + +tree +gfc_omp_array_data (tree decl, bool type_only) +{ + tree type = TREE_TYPE (decl); + + if (POINTER_TYPE_P (type)) + type = TREE_TYPE (type); + + if (!GFC_DESCRIPTOR_TYPE_P (type)) + return NULL_TREE; + + if (type_only) + return GFC_TYPE_ARRAY_DATAPTR_TYPE (type); + + if (POINTER_TYPE_P (TREE_TYPE (decl))) + decl = build_fold_indirect_ref (decl); + + decl = gfc_conv_descriptor_data_get (decl); + STRIP_NOPS (decl); + return decl; +} + /* True if OpenMP should privatize what this DECL points to rather than the DECL itself. */ @@ -58,8 +190,15 @@ && (!DECL_ARTIFICIAL (decl) || TREE_CODE (decl) == PARM_DECL)) return true; + if (TREE_CODE (type) == POINTER_TYPE + && gfc_omp_is_optional_argument (decl)) + return true; + if (TREE_CODE (type) == POINTER_TYPE) { + while (TREE_CODE (decl) == COMPONENT_REF) + decl = TREE_OPERAND (decl, 1); + /* Array POINTER/ALLOCATABLE have aggregate types, all user variables that have POINTER_TYPE type and aren't scalar pointers, scalar allocatables, Cray pointees or C pointers are supposed to be @@ -149,7 +288,8 @@ variables at all (they can't be redefined), but they can nevertheless appear in parallel/task regions and for default(none) purposes treat them as shared. For vtables likely the same handling is desirable. */ - if (VAR_P (decl) && TREE_READONLY (decl) && TREE_STATIC (decl)) + if (VAR_P (decl) && TREE_READONLY (decl) + && (TREE_STATIC (decl) || DECL_EXTERNAL (decl))) return OMP_CLAUSE_DEFAULT_SHARED; return OMP_CLAUSE_DEFAULT_UNSPECIFIED; @@ -296,10 +436,19 @@ } else { + bool compute_nelts = false; 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) + compute_nelts = true; + else if (VAR_P (TYPE_MAX_VALUE (TYPE_DOMAIN (type)))) + { + tree a = DECL_ATTRIBUTES (TYPE_MAX_VALUE (TYPE_DOMAIN (type))); + if (lookup_attribute ("omp dummy var", a)) + compute_nelts = true; + } + if (compute_nelts) { tem = fold_build2 (EXACT_DIV_EXPR, sizetype, TYPE_SIZE_UNIT (type), @@ -460,7 +609,8 @@ if ((! GFC_DESCRIPTOR_TYPE_P (type) || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE) - && !GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause))) + && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause)) + || !POINTER_TYPE_P (type))) { if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) { @@ -546,6 +696,9 @@ build3_loc (input_location, COND_EXPR, void_type_node, cond, then_b, else_b)); + /* Avoid -W*uninitialized warnings. */ + if (DECL_P (decl)) + TREE_NO_WARNING (decl) = 1; } else gfc_add_expr_to_block (&block, then_b); @@ -567,7 +720,8 @@ if ((! GFC_DESCRIPTOR_TYPE_P (type) || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE) - && !GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause))) + && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause)) + || !POINTER_TYPE_P (type))) { if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) { @@ -651,6 +805,9 @@ gfc_add_expr_to_block (&block, build3_loc (input_location, COND_EXPR, void_type_node, cond, then_b, else_b)); + /* Avoid -W*uninitialized warnings. */ + if (DECL_P (dest)) + TREE_NO_WARNING (dest) = 1; return gfc_finish_block (&block); } @@ -667,7 +824,8 @@ if ((! GFC_DESCRIPTOR_TYPE_P (type) || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE) - && !GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause))) + && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause)) + || !POINTER_TYPE_P (type))) { if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) { @@ -905,13 +1063,23 @@ if ((! GFC_DESCRIPTOR_TYPE_P (type) || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE) - && !GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause))) + && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause)) + || !POINTER_TYPE_P (type))) { + bool compute_nelts = false; 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) + compute_nelts = true; + else if (VAR_P (TYPE_MAX_VALUE (TYPE_DOMAIN (type)))) + { + tree a = DECL_ATTRIBUTES (TYPE_MAX_VALUE (TYPE_DOMAIN (type))); + if (lookup_attribute ("omp dummy var", a)) + compute_nelts = true; + } + if (compute_nelts) { nelems = fold_build2 (EXACT_DIV_EXPR, sizetype, TYPE_SIZE_UNIT (type), @@ -989,7 +1157,8 @@ if ((! GFC_DESCRIPTOR_TYPE_P (type) || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE) - && !GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause))) + && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause)) + || !POINTER_TYPE_P (type))) { if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) return gfc_walk_alloc_comps (decl, NULL_TREE, @@ -1036,6 +1205,53 @@ return tem; } +/* Build a conditional expression in BLOCK. If COND_VAL is not + null, then the block THEN_B is executed, otherwise ELSE_VAL + is assigned to VAL. */ + +static void +gfc_build_cond_assign (stmtblock_t *block, tree val, tree cond_val, + tree then_b, tree else_val) +{ + stmtblock_t cond_block; + tree else_b = NULL_TREE; + tree val_ty = TREE_TYPE (val); + + if (else_val) + { + gfc_init_block (&cond_block); + gfc_add_modify (&cond_block, val, fold_convert (val_ty, else_val)); + else_b = gfc_finish_block (&cond_block); + } + gfc_add_expr_to_block (block, + build3_loc (input_location, COND_EXPR, void_type_node, + cond_val, then_b, else_b)); +} + +/* Build a conditional expression in BLOCK, returning a temporary + variable containing the result. If COND_VAL is not null, then + THEN_VAL will be assigned to the variable, otherwise ELSE_VAL + is assigned. + */ + +static tree +gfc_build_cond_assign_expr (stmtblock_t *block, tree cond_val, + tree then_val, tree else_val) +{ + tree val; + tree val_ty = TREE_TYPE (then_val); + stmtblock_t cond_block; + + val = create_tmp_var (val_ty); + + gfc_init_block (&cond_block); + gfc_add_modify (&cond_block, val, then_val); + tree then_b = gfc_finish_block (&cond_block); + + gfc_build_cond_assign (block, val, cond_val, then_b, else_val); + + return val; +} void gfc_omp_finish_clause (tree c, gimple_seq *pre_p) @@ -1060,6 +1276,7 @@ } tree c2 = NULL_TREE, c3 = NULL_TREE, c4 = NULL_TREE; + tree present = gfc_omp_check_optional_argument (decl, true); if (POINTER_TYPE_P (TREE_TYPE (decl))) { if (!gfc_omp_privatize_by_reference (decl) @@ -1069,13 +1286,52 @@ && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (decl)))) return; tree orig_decl = decl; + + /* For nonallocatable, nonpointer arrays, a temporary variable is + generated, but this one is only defined if the variable is present; + hence, we now set it to NULL to avoid accessing undefined variables. + We cannot use a temporary variable here as otherwise the replacement + of the variables in omp-low.c will not work. */ + if (present && GFC_ARRAY_TYPE_P (TREE_TYPE (decl))) + { + tree tmp = fold_build2_loc (input_location, MODIFY_EXPR, + void_type_node, decl, null_pointer_node); + tree cond = fold_build1_loc (input_location, TRUTH_NOT_EXPR, + boolean_type_node, present); + tmp = build3_loc (input_location, COND_EXPR, void_type_node, + cond, tmp, NULL_TREE); + gimplify_and_add (tmp, pre_p); + } + c4 = build_omp_clause (OMP_CLAUSE_LOCATION (c), OMP_CLAUSE_MAP); OMP_CLAUSE_SET_MAP_KIND (c4, GOMP_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 (present + && (GFC_DECL_GET_SCALAR_POINTER (orig_decl) + || GFC_DECL_GET_SCALAR_ALLOCATABLE (orig_decl))) + { + c2 = build_omp_clause (input_location, OMP_CLAUSE_MAP); + OMP_CLAUSE_SET_MAP_KIND (c2, GOMP_MAP_POINTER); + OMP_CLAUSE_DECL (c2) = decl; + OMP_CLAUSE_SIZE (c2) = size_int (0); + + stmtblock_t block; + gfc_start_block (&block); + tree ptr = decl; + ptr = gfc_build_cond_assign_expr (&block, present, decl, + null_pointer_node); + gimplify_and_add (gfc_finish_block (&block), pre_p); + ptr = build_fold_indirect_ref (ptr); + OMP_CLAUSE_DECL (c) = ptr; + OMP_CLAUSE_SIZE (c) = TYPE_SIZE_UNIT (TREE_TYPE (ptr)); + } + else + { + OMP_CLAUSE_DECL (c) = decl; + OMP_CLAUSE_SIZE (c) = NULL_TREE; + } if (TREE_CODE (TREE_TYPE (orig_decl)) == REFERENCE_TYPE && (GFC_DECL_GET_SCALAR_POINTER (orig_decl) || GFC_DECL_GET_SCALAR_ALLOCATABLE (orig_decl))) @@ -1094,16 +1350,38 @@ gfc_start_block (&block); tree type = TREE_TYPE (decl); tree ptr = gfc_conv_descriptor_data_get (decl); + + if (present) + ptr = gfc_build_cond_assign_expr (&block, present, ptr, + null_pointer_node); 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_SET_MAP_KIND (c2, GOMP_MAP_TO_PSET); - OMP_CLAUSE_DECL (c2) = decl; + if (present) + { + ptr = create_tmp_var (TREE_TYPE (TREE_OPERAND (decl, 0))); + gfc_add_modify (&block, ptr, TREE_OPERAND (decl, 0)); + + OMP_CLAUSE_DECL (c2) = build_fold_indirect_ref (ptr); + } + else + 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_SET_MAP_KIND (c3, GOMP_MAP_POINTER); - OMP_CLAUSE_DECL (c3) = gfc_conv_descriptor_data_get (decl); + if (present) + { + ptr = gfc_conv_descriptor_data_get (decl); + ptr = gfc_build_addr_expr (NULL, ptr); + ptr = gfc_build_cond_assign_expr (&block, present, + ptr, null_pointer_node); + ptr = build_fold_indirect_ref (ptr); + OMP_CLAUSE_DECL (c3) = ptr; + } + else + 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); tree elemsz = TYPE_SIZE_UNIT (gfc_get_element_type (type)); @@ -1129,11 +1407,33 @@ tem = gfc_conv_descriptor_data_get (decl); tem = fold_convert (pvoid_type_node, tem); cond = fold_build2_loc (input_location, NE_EXPR, - logical_type_node, tem, null_pointer_node); + boolean_type_node, tem, null_pointer_node); + if (present) + { + cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, + boolean_type_node, present, cond); + } gfc_add_expr_to_block (&block, build3_loc (input_location, COND_EXPR, void_type_node, cond, then_b, else_b)); } + else if (present) + { + stmtblock_t cond_block; + tree then_b; + + gfc_init_block (&cond_block); + gfc_add_modify (&cond_block, size, + gfc_full_array_size (&cond_block, decl, + GFC_TYPE_ARRAY_RANK (type))); + gfc_add_modify (&cond_block, size, + fold_build2 (MULT_EXPR, gfc_array_index_type, + size, elemsz)); + then_b = gfc_finish_block (&cond_block); + + gfc_build_cond_assign (&block, size, present, then_b, + build_int_cst (gfc_array_index_type, 0)); + } else { gfc_add_modify (&block, size, @@ -1168,7 +1468,6 @@ { OMP_CLAUSE_CHAIN (c4) = OMP_CLAUSE_CHAIN (last); OMP_CLAUSE_CHAIN (last) = c4; - last = c4; } } @@ -1191,7 +1490,8 @@ || GFC_CLASS_TYPE_P (type)) return false; } - if (TYPE_STRING_FLAG (type)) + if ((TREE_CODE (type) == ARRAY_TYPE || TREE_CODE (type) == INTEGER_TYPE) + && TYPE_STRING_FLAG (type)) return false; if (INTEGRAL_TYPE_P (type) || SCALAR_FLOAT_TYPE_P (type) @@ -1715,7 +2015,7 @@ tree t = gfc_trans_omp_variable (namelist->sym, false); if (t != error_mark_node) { - tree node = build_omp_clause (where.lb->location, + tree node = build_omp_clause (gfc_get_location (&namelist->where), OMP_CLAUSE_REDUCTION); OMP_CLAUSE_DECL (node) = t; if (mark_addressable) @@ -1791,6 +2091,91 @@ static vec<tree, va_heap, vl_embed> *doacross_steps; + +/* Translate an array section or array element. */ + +static void +gfc_trans_omp_array_section (stmtblock_t *block, gfc_omp_namelist *n, + tree decl, bool element, gomp_map_kind ptr_kind, + tree node, tree &node2, tree &node3, tree &node4) +{ + gfc_se se; + tree ptr, ptr2; + + gfc_init_se (&se, NULL); + + if (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))) + && ptr_kind == GOMP_MAP_POINTER) + { + node4 = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + OMP_CLAUSE_SET_MAP_KIND (node4, GOMP_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_SET_MAP_KIND (node2, GOMP_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_SET_MAP_KIND (node3, ptr_kind); + OMP_CLAUSE_DECL (node3) + = gfc_conv_descriptor_data_get (decl); + if (ptr_kind == GOMP_MAP_ATTACH_DETACH) + STRIP_NOPS (OMP_CLAUSE_DECL (node3)); + } + 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_SET_MAP_KIND (node3, ptr_kind); + OMP_CLAUSE_DECL (node3) = decl; + } + ptr2 = fold_convert (sizetype, ptr2); + OMP_CLAUSE_SIZE (node3) + = fold_build2 (MINUS_EXPR, sizetype, ptr, ptr2); +} + static tree gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, locus where, bool declare_simd = false) @@ -1842,6 +2227,9 @@ case OMP_LIST_USE_DEVICE_PTR: clause_code = OMP_CLAUSE_USE_DEVICE_PTR; goto add_clause; + case OMP_LIST_USE_DEVICE_ADDR: + clause_code = OMP_CLAUSE_USE_DEVICE_ADDR; + goto add_clause; case OMP_LIST_IS_DEVICE_PTR: clause_code = OMP_CLAUSE_IS_DEVICE_PTR; goto add_clause; @@ -2044,7 +2432,7 @@ 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); + tree decl = gfc_trans_omp_variable (n->sym, false); if (gfc_omp_privatize_by_reference (decl)) decl = build_fold_indirect_ref (decl); if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) @@ -2105,27 +2493,84 @@ tree node2 = NULL_TREE; tree node3 = NULL_TREE; tree node4 = NULL_TREE; - tree decl = gfc_get_symbol_decl (n->sym); + tree decl = gfc_trans_omp_variable (n->sym, false); if (DECL_P (decl)) TREE_ADDRESSABLE (decl) = 1; - if (n->expr == NULL || n->expr->ref->u.ar.type == AR_FULL) + if (n->expr == NULL + || (n->expr->ref->type == REF_ARRAY + && n->expr->ref->u.ar.type == AR_FULL)) { - if (POINTER_TYPE_P (TREE_TYPE (decl)) - && (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))))) + tree present = gfc_omp_check_optional_argument (decl, true); + if (n->sym->ts.type == BT_CLASS) + { + tree type = TREE_TYPE (decl); + if (n->sym->attr.optional) + sorry ("optional class parameter"); + if (POINTER_TYPE_P (type)) + { + node4 = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + OMP_CLAUSE_SET_MAP_KIND (node4, GOMP_MAP_POINTER); + OMP_CLAUSE_DECL (node4) = decl; + OMP_CLAUSE_SIZE (node4) = size_int (0); + decl = build_fold_indirect_ref (decl); + } + tree ptr = gfc_class_data_get (decl); + ptr = build_fold_indirect_ref (ptr); + OMP_CLAUSE_DECL (node) = ptr; + OMP_CLAUSE_SIZE (node) = gfc_class_vtab_size_get (decl); + node2 = build_omp_clause (input_location, OMP_CLAUSE_MAP); + OMP_CLAUSE_SET_MAP_KIND (node2, GOMP_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_SET_MAP_KIND (node3, GOMP_MAP_ATTACH_DETACH); + OMP_CLAUSE_DECL (node3) = gfc_class_data_get (decl); + OMP_CLAUSE_SIZE (node3) = size_int (0); + goto finalize_map_clause; + } + else if (POINTER_TYPE_P (TREE_TYPE (decl)) + && (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))) + || n->sym->ts.type == BT_DERIVED)) { tree orig_decl = decl; + + /* For nonallocatable, nonpointer arrays, a temporary + variable is generated, but this one is only defined if + the variable is present; hence, we now set it to NULL + to avoid accessing undefined variables. We cannot use + a temporary variable here as otherwise the replacement + of the variables in omp-low.c will not work. */ + if (present && GFC_ARRAY_TYPE_P (TREE_TYPE (decl))) + { + tree tmp = fold_build2_loc (input_location, + MODIFY_EXPR, + void_type_node, decl, + null_pointer_node); + tree cond = fold_build1_loc (input_location, + TRUTH_NOT_EXPR, + boolean_type_node, + present); + gfc_add_expr_to_block (block, + build3_loc (input_location, + COND_EXPR, + void_type_node, + cond, tmp, + NULL_TREE)); + } node4 = build_omp_clause (input_location, OMP_CLAUSE_MAP); OMP_CLAUSE_SET_MAP_KIND (node4, GOMP_MAP_POINTER); OMP_CLAUSE_DECL (node4) = decl; OMP_CLAUSE_SIZE (node4) = size_int (0); decl = build_fold_indirect_ref (decl); - if (TREE_CODE (TREE_TYPE (orig_decl)) == REFERENCE_TYPE + if ((TREE_CODE (TREE_TYPE (orig_decl)) == REFERENCE_TYPE + || gfc_omp_is_optional_argument (orig_decl)) && (GFC_DECL_GET_SCALAR_POINTER (orig_decl) || GFC_DECL_GET_SCALAR_ALLOCATABLE (orig_decl))) { @@ -2137,10 +2582,15 @@ decl = build_fold_indirect_ref (decl); } } - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)) + && n->u.map_op != OMP_MAP_ATTACH + && n->u.map_op != OMP_MAP_DETACH) { tree type = TREE_TYPE (decl); tree ptr = gfc_conv_descriptor_data_get (decl); + if (present) + ptr = gfc_build_cond_assign_expr (block, present, ptr, + null_pointer_node); ptr = fold_convert (build_pointer_type (char_type_node), ptr); ptr = build_fold_indirect_ref (ptr); @@ -2153,8 +2603,18 @@ node3 = build_omp_clause (input_location, OMP_CLAUSE_MAP); OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_POINTER); - OMP_CLAUSE_DECL (node3) - = gfc_conv_descriptor_data_get (decl); + if (present) + { + ptr = gfc_conv_descriptor_data_get (decl); + ptr = gfc_build_addr_expr (NULL, ptr); + ptr = gfc_build_cond_assign_expr (block, present, ptr, + null_pointer_node); + ptr = build_fold_indirect_ref (ptr); + OMP_CLAUSE_DECL (node3) = ptr; + } + else + OMP_CLAUSE_DECL (node3) + = gfc_conv_descriptor_data_get (decl); OMP_CLAUSE_SIZE (node3) = size_int (0); /* We have to check for n->sym->attr.dimension because @@ -2179,8 +2639,13 @@ tem = gfc_conv_descriptor_data_get (decl); tem = fold_convert (pvoid_type_node, tem); cond = fold_build2_loc (input_location, NE_EXPR, - logical_type_node, + boolean_type_node, tem, null_pointer_node); + if (present) + cond = fold_build2_loc (input_location, + TRUTH_ANDIF_EXPR, + boolean_type_node, + present, cond); gfc_add_expr_to_block (block, build3_loc (input_location, COND_EXPR, @@ -2190,9 +2655,29 @@ OMP_CLAUSE_SIZE (node) = size; } else if (n->sym->attr.dimension) - OMP_CLAUSE_SIZE (node) - = gfc_full_array_size (block, decl, - GFC_TYPE_ARRAY_RANK (type)); + { + stmtblock_t cond_block; + gfc_init_block (&cond_block); + tree size = gfc_full_array_size (&cond_block, decl, + GFC_TYPE_ARRAY_RANK (type)); + if (present) + { + tree var = gfc_create_var (gfc_array_index_type, + NULL); + gfc_add_modify (&cond_block, var, size); + tree cond_body = gfc_finish_block (&cond_block); + tree cond = build3_loc (input_location, COND_EXPR, + void_type_node, present, + cond_body, NULL_TREE); + gfc_add_expr_to_block (block, cond); + OMP_CLAUSE_SIZE (node) = var; + } + else + { + gfc_add_block_to_block (block, &cond_block); + OMP_CLAUSE_SIZE (node) = size; + } + } if (n->sym->attr.dimension) { tree elemsz @@ -2203,91 +2688,185 @@ OMP_CLAUSE_SIZE (node), elemsz); } } + else if (present + && TREE_CODE (decl) == INDIRECT_REF + && (TREE_CODE (TREE_OPERAND (decl, 0)) + == INDIRECT_REF)) + { + /* A single indirectref is handled by the middle end. */ + gcc_assert (!POINTER_TYPE_P (TREE_TYPE (decl))); + decl = TREE_OPERAND (decl, 0); + decl = gfc_build_cond_assign_expr (block, present, decl, + null_pointer_node); + OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (decl); + } else OMP_CLAUSE_DECL (node) = decl; } - else + else if (n->expr + && n->expr->expr_type == EXPR_VARIABLE + && n->expr->ref->type == REF_COMPONENT) { - tree ptr, ptr2; + gfc_ref *lastcomp; + + for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT) + lastcomp = ref; + + symbol_attribute sym_attr; + + if (lastcomp->u.c.component->ts.type == BT_CLASS) + sym_attr = CLASS_DATA (lastcomp->u.c.component)->attr; + else + sym_attr = lastcomp->u.c.component->attr; + 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 + + if (!sym_attr.dimension + && lastcomp->u.c.component->ts.type != BT_CLASS + && lastcomp->u.c.component->ts.type != BT_DERIVED) { - gfc_conv_expr_descriptor (&se, n->expr); - ptr = gfc_conv_array_data (se.expr); - tree type = TREE_TYPE (se.expr); + /* Last component is a scalar. */ + gfc_conv_expr (&se, n->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); + OMP_CLAUSE_DECL (node) = se.expr; + gfc_add_block_to_block (block, &se.post); + goto finalize_map_clause; } - 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)))) + + se.expr = gfc_maybe_dereference_var (n->sym, decl); + + for (gfc_ref *ref = n->expr->ref; + ref && ref != lastcomp->next; + ref = ref->next) { - node4 = build_omp_clause (input_location, - OMP_CLAUSE_MAP); - OMP_CLAUSE_SET_MAP_KIND (node4, GOMP_MAP_POINTER); - OMP_CLAUSE_DECL (node4) = decl; - OMP_CLAUSE_SIZE (node4) = size_int (0); - decl = build_fold_indirect_ref (decl); + if (ref->type == REF_COMPONENT) + { + if (ref->u.c.sym->attr.extension) + conv_parent_component_references (&se, ref); + + gfc_conv_component_ref (&se, ref); + } + else + sorry ("unhandled derived-type component"); } - ptr = fold_convert (sizetype, ptr); - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) + + tree inner = se.expr; + + /* Last component is a derived type or class pointer. */ + if (lastcomp->u.c.component->ts.type == BT_DERIVED + || lastcomp->u.c.component->ts.type == BT_CLASS) { - tree type = TREE_TYPE (decl); - ptr2 = gfc_conv_descriptor_data_get (decl); - node2 = build_omp_clause (input_location, - OMP_CLAUSE_MAP); - OMP_CLAUSE_SET_MAP_KIND (node2, GOMP_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_SET_MAP_KIND (node3, GOMP_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); + if (sym_attr.allocatable || sym_attr.pointer) + { + tree data, size; + + if (lastcomp->u.c.component->ts.type == BT_CLASS) + { + data = gfc_class_data_get (inner); + size = gfc_class_vtab_size_get (inner); + } + else /* BT_DERIVED. */ + { + data = inner; + size = TYPE_SIZE_UNIT (TREE_TYPE (inner)); + } + + OMP_CLAUSE_DECL (node) + = build_fold_indirect_ref (data); + OMP_CLAUSE_SIZE (node) = size; + node2 = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + OMP_CLAUSE_SET_MAP_KIND (node2, + GOMP_MAP_ATTACH_DETACH); + OMP_CLAUSE_DECL (node2) = data; + OMP_CLAUSE_SIZE (node2) = size_int (0); + } else { - gcc_assert (POINTER_TYPE_P (TREE_TYPE (decl))); - ptr2 = decl; + OMP_CLAUSE_DECL (node) = decl; + OMP_CLAUSE_SIZE (node) + = TYPE_SIZE_UNIT (TREE_TYPE (decl)); + } + } + else if (lastcomp->next + && lastcomp->next->type == REF_ARRAY + && lastcomp->next->u.ar.type == AR_FULL) + { + /* Just pass the (auto-dereferenced) decl through for + bare attach and detach clauses. */ + if (n->u.map_op == OMP_MAP_ATTACH + || n->u.map_op == OMP_MAP_DETACH) + { + OMP_CLAUSE_DECL (node) = inner; + OMP_CLAUSE_SIZE (node) = size_zero_node; + goto finalize_map_clause; } - node3 = build_omp_clause (input_location, - OMP_CLAUSE_MAP); - OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_POINTER); - OMP_CLAUSE_DECL (node3) = decl; + + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (inner))) + { + tree type = TREE_TYPE (inner); + tree ptr = gfc_conv_descriptor_data_get (inner); + ptr = build_fold_indirect_ref (ptr); + OMP_CLAUSE_DECL (node) = ptr; + node2 = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + OMP_CLAUSE_SET_MAP_KIND (node2, GOMP_MAP_TO_PSET); + OMP_CLAUSE_DECL (node2) = inner; + OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type); + node3 = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + OMP_CLAUSE_SET_MAP_KIND (node3, + GOMP_MAP_ATTACH_DETACH); + OMP_CLAUSE_DECL (node3) + = gfc_conv_descriptor_data_get (inner); + STRIP_NOPS (OMP_CLAUSE_DECL (node3)); + OMP_CLAUSE_SIZE (node3) = size_int (0); + int rank = GFC_TYPE_ARRAY_RANK (type); + OMP_CLAUSE_SIZE (node) + = gfc_full_array_size (block, inner, rank); + 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) = inner; } - ptr2 = fold_convert (sizetype, ptr2); - OMP_CLAUSE_SIZE (node3) - = fold_build2 (MINUS_EXPR, sizetype, ptr, ptr2); + else /* An array element or section. */ + { + bool element + = (lastcomp->next + && lastcomp->next->type == REF_ARRAY + && lastcomp->next->u.ar.type == AR_ELEMENT); + + gfc_trans_omp_array_section (block, n, inner, element, + GOMP_MAP_ATTACH_DETACH, + node, node2, node3, node4); + } } + else /* An array element or array section. */ + { + bool element = n->expr->ref->u.ar.type == AR_ELEMENT; + gfc_trans_omp_array_section (block, n, decl, element, + GOMP_MAP_POINTER, node, node2, + node3, node4); + } + + finalize_map_clause: switch (n->u.map_op) { case OMP_MAP_ALLOC: OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALLOC); break; + case OMP_MAP_IF_PRESENT: + OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_IF_PRESENT); + break; + case OMP_MAP_ATTACH: + OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ATTACH); + break; case OMP_MAP_TO: OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_TO); break; @@ -2312,6 +2891,9 @@ case OMP_MAP_DELETE: OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_DELETE); break; + case OMP_MAP_DETACH: + OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_DETACH); + break; case OMP_MAP_FORCE_ALLOC: OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_ALLOC); break; @@ -2367,9 +2949,13 @@ tree node = build_omp_clause (input_location, clause_code); if (n->expr == NULL || n->expr->ref->u.ar.type == AR_FULL) { - tree decl = gfc_get_symbol_decl (n->sym); + tree decl = gfc_trans_omp_variable (n->sym, false); if (gfc_omp_privatize_by_reference (decl)) - decl = build_fold_indirect_ref (decl); + { + if (gfc_omp_is_allocatable_or_ptr (decl)) + decl = build_fold_indirect_ref (decl); + decl = build_fold_indirect_ref (decl); + } else if (DECL_P (decl)) TREE_ADDRESSABLE (decl) = 1; if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) @@ -2391,7 +2977,12 @@ OMP_CLAUSE_SIZE (node), elemsz); } else - OMP_CLAUSE_DECL (node) = decl; + { + OMP_CLAUSE_DECL (node) = decl; + if (gfc_omp_is_allocatable_or_ptr (decl)) + OMP_CLAUSE_SIZE (node) + = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (decl))); + } } else { @@ -2444,7 +3035,7 @@ if_var = gfc_evaluate_now (se.expr, block); gfc_add_block_to_block (block, &se.post); - c = build_omp_clause (where.lb->location, OMP_CLAUSE_IF); + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_IF); OMP_CLAUSE_IF_MODIFIER (c) = ERROR_MARK; OMP_CLAUSE_IF_EXPR (c) = if_var; omp_clauses = gfc_trans_add_clause (c, omp_clauses); @@ -2460,7 +3051,7 @@ if_var = gfc_evaluate_now (se.expr, block); gfc_add_block_to_block (block, &se.post); - c = build_omp_clause (where.lb->location, OMP_CLAUSE_IF); + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_IF); switch (ifc) { case OMP_IF_PARALLEL: @@ -2504,7 +3095,7 @@ final_var = gfc_evaluate_now (se.expr, block); gfc_add_block_to_block (block, &se.post); - c = build_omp_clause (where.lb->location, OMP_CLAUSE_FINAL); + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_FINAL); OMP_CLAUSE_FINAL_EXPR (c) = final_var; omp_clauses = gfc_trans_add_clause (c, omp_clauses); } @@ -2519,7 +3110,7 @@ num_threads = gfc_evaluate_now (se.expr, block); gfc_add_block_to_block (block, &se.post); - c = build_omp_clause (where.lb->location, OMP_CLAUSE_NUM_THREADS); + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NUM_THREADS); OMP_CLAUSE_NUM_THREADS_EXPR (c) = num_threads; omp_clauses = gfc_trans_add_clause (c, omp_clauses); } @@ -2536,7 +3127,7 @@ if (clauses->sched_kind != OMP_SCHED_NONE) { - c = build_omp_clause (where.lb->location, OMP_CLAUSE_SCHEDULE); + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SCHEDULE); OMP_CLAUSE_SCHEDULE_CHUNK_EXPR (c) = chunk_size; switch (clauses->sched_kind) { @@ -2573,7 +3164,7 @@ if (clauses->default_sharing != OMP_DEFAULT_UNKNOWN) { - c = build_omp_clause (where.lb->location, OMP_CLAUSE_DEFAULT); + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_DEFAULT); switch (clauses->default_sharing) { case OMP_DEFAULT_NONE: @@ -2599,13 +3190,13 @@ if (clauses->nowait) { - c = build_omp_clause (where.lb->location, OMP_CLAUSE_NOWAIT); + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NOWAIT); omp_clauses = gfc_trans_add_clause (c, omp_clauses); } if (clauses->ordered) { - c = build_omp_clause (where.lb->location, OMP_CLAUSE_ORDERED); + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_ORDERED); OMP_CLAUSE_ORDERED_EXPR (c) = clauses->orderedc ? build_int_cst (integer_type_node, clauses->orderedc) : NULL_TREE; @@ -2614,19 +3205,19 @@ if (clauses->untied) { - c = build_omp_clause (where.lb->location, OMP_CLAUSE_UNTIED); + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_UNTIED); omp_clauses = gfc_trans_add_clause (c, omp_clauses); } if (clauses->mergeable) { - c = build_omp_clause (where.lb->location, OMP_CLAUSE_MERGEABLE); + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_MERGEABLE); omp_clauses = gfc_trans_add_clause (c, omp_clauses); } if (clauses->collapse) { - c = build_omp_clause (where.lb->location, OMP_CLAUSE_COLLAPSE); + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_COLLAPSE); OMP_CLAUSE_COLLAPSE_EXPR (c) = build_int_cst (integer_type_node, clauses->collapse); omp_clauses = gfc_trans_add_clause (c, omp_clauses); @@ -2634,13 +3225,13 @@ if (clauses->inbranch) { - c = build_omp_clause (where.lb->location, OMP_CLAUSE_INBRANCH); + c = build_omp_clause (gfc_get_location (&where), 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); + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NOTINBRANCH); omp_clauses = gfc_trans_add_clause (c, omp_clauses); } @@ -2649,26 +3240,26 @@ case OMP_CANCEL_UNKNOWN: break; case OMP_CANCEL_PARALLEL: - c = build_omp_clause (where.lb->location, OMP_CLAUSE_PARALLEL); + c = build_omp_clause (gfc_get_location (&where), 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); + c = build_omp_clause (gfc_get_location (&where), 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); + c = build_omp_clause (gfc_get_location (&where), 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); + c = build_omp_clause (gfc_get_location (&where), 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); + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_PROC_BIND); switch (clauses->proc_bind) { case OMP_PROC_BIND_MASTER: @@ -2696,7 +3287,7 @@ 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); + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SAFELEN); OMP_CLAUSE_SAFELEN_EXPR (c) = safelen_var; omp_clauses = gfc_trans_add_clause (c, omp_clauses); } @@ -2705,7 +3296,7 @@ { if (declare_simd) { - c = build_omp_clause (where.lb->location, OMP_CLAUSE_SIMDLEN); + c = build_omp_clause (gfc_get_location (&where), 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); @@ -2720,7 +3311,7 @@ simdlen_var = gfc_evaluate_now (se.expr, block); gfc_add_block_to_block (block, &se.post); - c = build_omp_clause (where.lb->location, OMP_CLAUSE_SIMDLEN); + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SIMDLEN); OMP_CLAUSE_SIMDLEN_EXPR (c) = simdlen_var; omp_clauses = gfc_trans_add_clause (c, omp_clauses); } @@ -2736,7 +3327,7 @@ 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); + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NUM_TEAMS); OMP_CLAUSE_NUM_TEAMS_EXPR (c) = num_teams; omp_clauses = gfc_trans_add_clause (c, omp_clauses); } @@ -2751,7 +3342,7 @@ 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); + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_DEVICE); OMP_CLAUSE_DEVICE_ID (c) = device; omp_clauses = gfc_trans_add_clause (c, omp_clauses); } @@ -2766,7 +3357,7 @@ 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); + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_THREAD_LIMIT); OMP_CLAUSE_THREAD_LIMIT_EXPR (c) = thread_limit; omp_clauses = gfc_trans_add_clause (c, omp_clauses); } @@ -2783,7 +3374,8 @@ if (clauses->dist_sched_kind != OMP_SCHED_NONE) { - c = build_omp_clause (where.lb->location, OMP_CLAUSE_DIST_SCHEDULE); + c = build_omp_clause (gfc_get_location (&where), + OMP_CLAUSE_DIST_SCHEDULE); OMP_CLAUSE_DIST_SCHEDULE_CHUNK_EXPR (c) = chunk_size; omp_clauses = gfc_trans_add_clause (c, omp_clauses); } @@ -2798,7 +3390,7 @@ grainsize = gfc_evaluate_now (se.expr, block); gfc_add_block_to_block (block, &se.post); - c = build_omp_clause (where.lb->location, OMP_CLAUSE_GRAINSIZE); + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_GRAINSIZE); OMP_CLAUSE_GRAINSIZE_EXPR (c) = grainsize; omp_clauses = gfc_trans_add_clause (c, omp_clauses); } @@ -2813,7 +3405,7 @@ num_tasks = gfc_evaluate_now (se.expr, block); gfc_add_block_to_block (block, &se.post); - c = build_omp_clause (where.lb->location, OMP_CLAUSE_NUM_TASKS); + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NUM_TASKS); OMP_CLAUSE_NUM_TASKS_EXPR (c) = num_tasks; omp_clauses = gfc_trans_add_clause (c, omp_clauses); } @@ -2828,7 +3420,7 @@ priority = gfc_evaluate_now (se.expr, block); gfc_add_block_to_block (block, &se.post); - c = build_omp_clause (where.lb->location, OMP_CLAUSE_PRIORITY); + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_PRIORITY); OMP_CLAUSE_PRIORITY_EXPR (c) = priority; omp_clauses = gfc_trans_add_clause (c, omp_clauses); } @@ -2843,41 +3435,43 @@ hint = gfc_evaluate_now (se.expr, block); gfc_add_block_to_block (block, &se.post); - c = build_omp_clause (where.lb->location, OMP_CLAUSE_HINT); + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_HINT); OMP_CLAUSE_HINT_EXPR (c) = hint; omp_clauses = gfc_trans_add_clause (c, omp_clauses); } if (clauses->simd) { - c = build_omp_clause (where.lb->location, OMP_CLAUSE_SIMD); + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SIMD); omp_clauses = gfc_trans_add_clause (c, omp_clauses); } if (clauses->threads) { - c = build_omp_clause (where.lb->location, OMP_CLAUSE_THREADS); + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_THREADS); omp_clauses = gfc_trans_add_clause (c, omp_clauses); } if (clauses->nogroup) { - c = build_omp_clause (where.lb->location, OMP_CLAUSE_NOGROUP); + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NOGROUP); omp_clauses = gfc_trans_add_clause (c, omp_clauses); } if (clauses->defaultmap) { - c = build_omp_clause (where.lb->location, OMP_CLAUSE_DEFAULTMAP); + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_DEFAULTMAP); + OMP_CLAUSE_DEFAULTMAP_SET_KIND (c, OMP_CLAUSE_DEFAULTMAP_TOFROM, + OMP_CLAUSE_DEFAULTMAP_CATEGORY_SCALAR); omp_clauses = gfc_trans_add_clause (c, omp_clauses); } if (clauses->depend_source) { - c = build_omp_clause (where.lb->location, OMP_CLAUSE_DEPEND); + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_DEPEND); OMP_CLAUSE_DEPEND_KIND (c) = OMP_CLAUSE_DEPEND_SOURCE; omp_clauses = gfc_trans_add_clause (c, omp_clauses); } if (clauses->async) { - c = build_omp_clause (where.lb->location, OMP_CLAUSE_ASYNC); + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_ASYNC); if (clauses->async_expr) OMP_CLAUSE_ASYNC_EXPR (c) = gfc_convert_expr_to_tree (block, clauses->async_expr); @@ -2887,27 +3481,27 @@ } if (clauses->seq) { - c = build_omp_clause (where.lb->location, OMP_CLAUSE_SEQ); + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SEQ); omp_clauses = gfc_trans_add_clause (c, omp_clauses); } if (clauses->par_auto) { - c = build_omp_clause (where.lb->location, OMP_CLAUSE_AUTO); + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_AUTO); omp_clauses = gfc_trans_add_clause (c, omp_clauses); } if (clauses->if_present) { - c = build_omp_clause (where.lb->location, OMP_CLAUSE_IF_PRESENT); + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_IF_PRESENT); omp_clauses = gfc_trans_add_clause (c, omp_clauses); } if (clauses->finalize) { - c = build_omp_clause (where.lb->location, OMP_CLAUSE_FINALIZE); + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_FINALIZE); omp_clauses = gfc_trans_add_clause (c, omp_clauses); } if (clauses->independent) { - c = build_omp_clause (where.lb->location, OMP_CLAUSE_INDEPENDENT); + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_INDEPENDENT); omp_clauses = gfc_trans_add_clause (c, omp_clauses); } if (clauses->wait_list) @@ -2916,7 +3510,7 @@ for (el = clauses->wait_list; el; el = el->next) { - c = build_omp_clause (where.lb->location, OMP_CLAUSE_WAIT); + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_WAIT); OMP_CLAUSE_DECL (c) = gfc_convert_expr_to_tree (block, el->expr); OMP_CLAUSE_CHAIN (c) = omp_clauses; omp_clauses = c; @@ -2926,7 +3520,7 @@ { tree num_gangs_var = gfc_convert_expr_to_tree (block, clauses->num_gangs_expr); - c = build_omp_clause (where.lb->location, OMP_CLAUSE_NUM_GANGS); + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NUM_GANGS); OMP_CLAUSE_NUM_GANGS_EXPR (c) = num_gangs_var; omp_clauses = gfc_trans_add_clause (c, omp_clauses); } @@ -2934,7 +3528,7 @@ { tree num_workers_var = gfc_convert_expr_to_tree (block, clauses->num_workers_expr); - c = build_omp_clause (where.lb->location, OMP_CLAUSE_NUM_WORKERS); + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NUM_WORKERS); OMP_CLAUSE_NUM_WORKERS_EXPR (c) = num_workers_var; omp_clauses = gfc_trans_add_clause (c, omp_clauses); } @@ -2942,7 +3536,7 @@ { tree vector_length_var = gfc_convert_expr_to_tree (block, clauses->vector_length_expr); - c = build_omp_clause (where.lb->location, OMP_CLAUSE_VECTOR_LENGTH); + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_VECTOR_LENGTH); OMP_CLAUSE_VECTOR_LENGTH_EXPR (c) = vector_length_var; omp_clauses = gfc_trans_add_clause (c, omp_clauses); } @@ -2956,7 +3550,7 @@ for (el = clauses->tile_list; el; el = el->next) vec_safe_push (tvec, gfc_convert_expr_to_tree (block, el->expr)); - c = build_omp_clause (where.lb->location, OMP_CLAUSE_TILE); + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_TILE); OMP_CLAUSE_TILE_LIST (c) = build_tree_list_vec (tvec); omp_clauses = gfc_trans_add_clause (c, omp_clauses); tvec->truncate (0); @@ -2967,13 +3561,13 @@ { tree vector_var = gfc_convert_expr_to_tree (block, clauses->vector_expr); - c = build_omp_clause (where.lb->location, OMP_CLAUSE_VECTOR); + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_VECTOR); OMP_CLAUSE_VECTOR_EXPR (c) = vector_var; omp_clauses = gfc_trans_add_clause (c, omp_clauses); } else { - c = build_omp_clause (where.lb->location, OMP_CLAUSE_VECTOR); + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_VECTOR); omp_clauses = gfc_trans_add_clause (c, omp_clauses); } } @@ -2983,20 +3577,20 @@ { tree worker_var = gfc_convert_expr_to_tree (block, clauses->worker_expr); - c = build_omp_clause (where.lb->location, OMP_CLAUSE_WORKER); + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_WORKER); OMP_CLAUSE_WORKER_EXPR (c) = worker_var; omp_clauses = gfc_trans_add_clause (c, omp_clauses); } else { - c = build_omp_clause (where.lb->location, OMP_CLAUSE_WORKER); + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_WORKER); omp_clauses = gfc_trans_add_clause (c, omp_clauses); } } if (clauses->gang) { tree arg; - c = build_omp_clause (where.lb->location, OMP_CLAUSE_GANG); + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_GANG); omp_clauses = gfc_trans_add_clause (c, omp_clauses); if (clauses->gang_num_expr) { @@ -3039,8 +3633,9 @@ return stmt; } -/* Trans OpenACC directives. */ -/* parallel, kernels, data and host_data. */ +/* Translate OpenACC 'parallel', 'kernels', 'serial', 'data', 'host_data' + construct. */ + static tree gfc_trans_oacc_construct (gfc_code *code) { @@ -3056,6 +3651,9 @@ case EXEC_OACC_KERNELS: construct_code = OACC_KERNELS; break; + case EXEC_OACC_SERIAL: + construct_code = OACC_SERIAL; + break; case EXEC_OACC_DATA: construct_code = OACC_DATA; break; @@ -3166,7 +3764,9 @@ 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; + enum omp_memory_order mo + = ((atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_SEQ_CST) + ? OMP_MEMORY_ORDER_SEQ_CST : OMP_MEMORY_ORDER_RELAXED); code = code->block->next; gcc_assert (code->op == EXEC_ASSIGN); @@ -3180,7 +3780,6 @@ expr2 = code->expr2; if (((atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_MASK) != GFC_OMP_ATOMIC_WRITE) - && (atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_SWAP) == 0 && expr2->expr_type == EXPR_FUNCTION && expr2->value.function.isym && expr2->value.function.isym->id == GFC_ISYM_CONVERSION) @@ -3198,7 +3797,7 @@ lhsaddr = gfc_build_addr_expr (NULL, lse.expr); x = build1 (OMP_ATOMIC_READ, type, lhsaddr); - OMP_ATOMIC_SEQ_CST (x) = seq_cst; + OMP_ATOMIC_MEMORY_ORDER (x) = mo; x = convert (TREE_TYPE (vse.expr), x); gfc_add_modify (&block, vse.expr, x); @@ -3398,7 +3997,7 @@ if (aop == OMP_ATOMIC) { x = build2_v (OMP_ATOMIC, lhsaddr, convert (type, x)); - OMP_ATOMIC_SEQ_CST (x) = seq_cst; + OMP_ATOMIC_MEMORY_ORDER (x) = mo; gfc_add_expr_to_block (&block, x); } else @@ -3421,7 +4020,7 @@ gfc_add_block_to_block (&block, &lse.pre); } x = build2 (aop, type, lhsaddr, convert (type, x)); - OMP_ATOMIC_SEQ_CST (x) = seq_cst; + OMP_ATOMIC_MEMORY_ORDER (x) = mo; x = convert (TREE_TYPE (vse.expr), x); gfc_add_modify (&block, vse.expr, x); } @@ -3861,7 +4460,9 @@ return gfc_finish_block (&block); } -/* parallel loop and kernels loop. */ +/* Translate combined OpenACC 'parallel loop', 'kernels loop', 'serial loop' + construct. */ + static tree gfc_trans_oacc_combined_directive (gfc_code *code) { @@ -3869,6 +4470,7 @@ gfc_omp_clauses construct_clauses, loop_clauses; tree stmt, oacc_clauses = NULL_TREE; enum tree_code construct_code; + location_t loc = input_location; switch (code->op) { @@ -3878,6 +4480,9 @@ case EXEC_OACC_KERNELS_LOOP: construct_code = OACC_KERNELS; break; + case EXEC_OACC_SERIAL_LOOP: + construct_code = OACC_SERIAL; + break; default: gcc_unreachable (); } @@ -3930,12 +4535,12 @@ else pushlevel (); stmt = gfc_trans_omp_do (code, EXEC_OACC_LOOP, pblock, &loop_clauses, NULL); + protected_set_expr_location (stmt, loc); if (TREE_CODE (stmt) != BIND_EXPR) stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); else poplevel (0, 0); - stmt = build2_loc (input_location, construct_code, void_type_node, stmt, - oacc_clauses); + stmt = build2_loc (loc, construct_code, void_type_node, stmt, oacc_clauses); gfc_add_expr_to_block (&block, stmt); return gfc_finish_block (&block); } @@ -4586,8 +5191,12 @@ 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); + tree body = gfc_trans_code (code->block->next); + tree stmt = make_node (OMP_TASKGROUP); + TREE_TYPE (stmt) = void_type_node; + OMP_TASKGROUP_BODY (stmt) = body; + OMP_TASKGROUP_CLAUSES (stmt) = NULL_TREE; + return stmt; } static tree @@ -4688,10 +5297,14 @@ gfc_split_omp_clauses (code, clausesa); } if (flag_openmp) - omp_clauses - = chainon (omp_clauses, - gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_TEAMS], - code->loc)); + { + omp_clauses + = chainon (omp_clauses, + gfc_trans_omp_clauses (&block, + &clausesa[GFC_OMP_SPLIT_TEAMS], + code->loc)); + pushlevel (); + } switch (code->op) { case EXEC_OMP_TARGET_TEAMS: @@ -4711,6 +5324,7 @@ } if (flag_openmp) { + stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); stmt = build2_loc (input_location, OMP_TEAMS, void_type_node, stmt, omp_clauses); if (combined) @@ -4744,6 +5358,7 @@ { stmtblock_t iblock; + pushlevel (); gfc_start_block (&iblock); tree inner_clauses = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_PARALLEL], @@ -5106,9 +5721,11 @@ { case EXEC_OACC_PARALLEL_LOOP: case EXEC_OACC_KERNELS_LOOP: + case EXEC_OACC_SERIAL_LOOP: return gfc_trans_oacc_combined_directive (code); case EXEC_OACC_PARALLEL: case EXEC_OACC_KERNELS: + case EXEC_OACC_SERIAL: case EXEC_OACC_DATA: case EXEC_OACC_HOST_DATA: return gfc_trans_oacc_construct (code);