mirror of
https://github.com/autc04/Retro68.git
synced 2024-06-03 00:29:47 +00:00
7762 lines
241 KiB
C++
7762 lines
241 KiB
C++
/* OpenMP directive translation -- generate GCC trees from gfc_code.
|
||
Copyright (C) 2005-2022 Free Software Foundation, Inc.
|
||
Contributed by Jakub Jelinek <jakub@redhat.com>
|
||
|
||
This file is part of GCC.
|
||
|
||
GCC is free software; you can redistribute it and/or modify it under
|
||
the terms of the GNU General Public License as published by the Free
|
||
Software Foundation; either version 3, or (at your option) any later
|
||
version.
|
||
|
||
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
|
||
WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
||
FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
|
||
for more details.
|
||
|
||
You should have received a copy of the GNU General Public License
|
||
along with GCC; see the file COPYING3. If not see
|
||
<http://www.gnu.org/licenses/>. */
|
||
|
||
|
||
#include "config.h"
|
||
#include "system.h"
|
||
#include "coretypes.h"
|
||
#include "options.h"
|
||
#include "tree.h"
|
||
#include "gfortran.h"
|
||
#include "gimple-expr.h"
|
||
#include "trans.h"
|
||
#include "stringpool.h"
|
||
#include "fold-const.h"
|
||
#include "gimplify.h" /* For create_tmp_var_raw. */
|
||
#include "trans-stmt.h"
|
||
#include "trans-types.h"
|
||
#include "trans-array.h"
|
||
#include "trans-const.h"
|
||
#include "arith.h"
|
||
#include "constructor.h"
|
||
#include "gomp-constants.h"
|
||
#include "omp-general.h"
|
||
#include "omp-low.h"
|
||
#include "memmodel.h" /* For MEMMODEL_ enums. */
|
||
|
||
#undef GCC_DIAG_STYLE
|
||
#define GCC_DIAG_STYLE __gcc_tdiag__
|
||
#include "diagnostic-core.h"
|
||
#undef GCC_DIAG_STYLE
|
||
#define GCC_DIAG_STYLE __gcc_gfc__
|
||
#include "attribs.h"
|
||
#include "function.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 for 'procedure(), optional' the value false is used as that's
|
||
always a pointer and no additional indirection is used.
|
||
Note that pvoid_type_node is for 'type(c_ptr), value' (and c_funloc). */
|
||
|
||
static bool
|
||
gfc_omp_is_optional_argument (const_tree decl)
|
||
{
|
||
/* Note: VAR_DECL can occur with BIND(C) and array descriptors. */
|
||
return ((TREE_CODE (decl) == PARM_DECL || TREE_CODE (decl) == VAR_DECL)
|
||
&& DECL_LANG_SPECIFIC (decl)
|
||
&& TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE
|
||
&& !VOID_TYPE_P (TREE_TYPE (TREE_TYPE (decl)))
|
||
&& TREE_CODE (TREE_TYPE (TREE_TYPE (decl))) != FUNCTION_TYPE
|
||
&& 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;
|
||
|
||
tree orig_decl = decl;
|
||
|
||
/* 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))))
|
||
decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
|
||
|
||
/* Note: With BIND(C), array descriptors are converted to a VAR_DECL. */
|
||
if (decl == NULL_TREE
|
||
|| (TREE_CODE (decl) != PARM_DECL && TREE_CODE (decl) != VAR_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.cc'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;
|
||
}
|
||
|
||
return fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
|
||
orig_decl, null_pointer_node);
|
||
}
|
||
|
||
|
||
/* 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. */
|
||
|
||
bool
|
||
gfc_omp_privatize_by_reference (const_tree decl)
|
||
{
|
||
tree type = TREE_TYPE (decl);
|
||
|
||
if (TREE_CODE (type) == REFERENCE_TYPE
|
||
&& (!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
|
||
privatized by reference. */
|
||
if (GFC_DECL_GET_SCALAR_POINTER (decl)
|
||
|| GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)
|
||
|| GFC_DECL_CRAY_POINTEE (decl)
|
||
|| GFC_DECL_ASSOCIATE_VAR_P (decl)
|
||
|| VOID_TYPE_P (TREE_TYPE (TREE_TYPE (decl))))
|
||
return false;
|
||
|
||
if (!DECL_ARTIFICIAL (decl)
|
||
&& TREE_CODE (TREE_TYPE (type)) != FUNCTION_TYPE)
|
||
return true;
|
||
|
||
/* Some arrays are expanded as DECL_ARTIFICIAL pointers
|
||
by the frontend. */
|
||
if (DECL_LANG_SPECIFIC (decl)
|
||
&& GFC_DECL_SAVED_DESCRIPTOR (decl))
|
||
return true;
|
||
}
|
||
|
||
return false;
|
||
}
|
||
|
||
/* OMP_CLAUSE_DEFAULT_UNSPECIFIED unless OpenMP sharing attribute
|
||
of DECL is predetermined. */
|
||
|
||
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)
|
||
&& GFC_DECL_SAVED_DESCRIPTOR (decl)))
|
||
return OMP_CLAUSE_DEFAULT_SHARED;
|
||
|
||
/* Cray pointees shouldn't be listed in any clauses and should be
|
||
gimplified to dereference of the corresponding Cray pointer.
|
||
Make them all private, so that they are emitted in the debug
|
||
information. */
|
||
if (GFC_DECL_CRAY_POINTEE (decl))
|
||
return OMP_CLAUSE_DEFAULT_PRIVATE;
|
||
|
||
/* Assumed-size arrays are predetermined shared. */
|
||
if (TREE_CODE (decl) == PARM_DECL
|
||
&& GFC_ARRAY_TYPE_P (TREE_TYPE (decl))
|
||
&& GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl)) == GFC_ARRAY_UNKNOWN
|
||
&& GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (decl),
|
||
GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl)) - 1)
|
||
== NULL)
|
||
return OMP_CLAUSE_DEFAULT_SHARED;
|
||
|
||
/* Dummy procedures aren't considered variables by OpenMP, thus are
|
||
disallowed in OpenMP clauses. They are represented as PARM_DECLs
|
||
in the middle-end, so return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE here
|
||
to avoid complaining about their uses with default(none). */
|
||
if (TREE_CODE (decl) == PARM_DECL
|
||
&& TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE
|
||
&& TREE_CODE (TREE_TYPE (TREE_TYPE (decl))) == FUNCTION_TYPE)
|
||
return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE;
|
||
|
||
/* COMMON and EQUIVALENCE decls are shared. They
|
||
are only referenced through DECL_VALUE_EXPR of the variables
|
||
contained in them. If those are privatized, they will not be
|
||
gimplified to the COMMON or EQUIVALENCE decls. */
|
||
if (GFC_DECL_COMMON_OR_EQUIV (decl) && ! DECL_HAS_VALUE_EXPR_P (decl))
|
||
return OMP_CLAUSE_DEFAULT_SHARED;
|
||
|
||
if (GFC_DECL_RESULT (decl) && ! DECL_HAS_VALUE_EXPR_P (decl))
|
||
return OMP_CLAUSE_DEFAULT_SHARED;
|
||
|
||
/* These are either array or derived parameters, or vtables.
|
||
In the former cases, the OpenMP standard doesn't consider them to be
|
||
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) || DECL_EXTERNAL (decl)))
|
||
return OMP_CLAUSE_DEFAULT_SHARED;
|
||
|
||
return OMP_CLAUSE_DEFAULT_UNSPECIFIED;
|
||
}
|
||
|
||
|
||
/* OMP_CLAUSE_DEFAULTMAP_CATEGORY_UNSPECIFIED unless OpenMP mapping attribute
|
||
of DECL is predetermined. */
|
||
|
||
enum omp_clause_defaultmap_kind
|
||
gfc_omp_predetermined_mapping (tree decl)
|
||
{
|
||
if (DECL_ARTIFICIAL (decl)
|
||
&& ! GFC_DECL_RESULT (decl)
|
||
&& ! (DECL_LANG_SPECIFIC (decl)
|
||
&& GFC_DECL_SAVED_DESCRIPTOR (decl)))
|
||
return OMP_CLAUSE_DEFAULTMAP_TO;
|
||
|
||
/* These are either array or derived parameters, or vtables. */
|
||
if (VAR_P (decl) && TREE_READONLY (decl)
|
||
&& (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
|
||
return OMP_CLAUSE_DEFAULTMAP_TO;
|
||
|
||
return OMP_CLAUSE_DEFAULTMAP_CATEGORY_UNSPECIFIED;
|
||
}
|
||
|
||
|
||
/* Return decl that should be used when reporting DEFAULT(NONE)
|
||
diagnostics. */
|
||
|
||
tree
|
||
gfc_omp_report_decl (tree decl)
|
||
{
|
||
if (DECL_ARTIFICIAL (decl)
|
||
&& DECL_LANG_SPECIFIC (decl)
|
||
&& GFC_DECL_SAVED_DESCRIPTOR (decl))
|
||
return GFC_DECL_SAVED_DESCRIPTOR (decl);
|
||
|
||
return decl;
|
||
}
|
||
|
||
/* Return true if 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;
|
||
}
|
||
|
||
if (GFC_DESCRIPTOR_TYPE_P (type)
|
||
&& (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER
|
||
|| GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT))
|
||
return false;
|
||
|
||
if (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 TYPE is polymorphic but not with pointer attribute. */
|
||
|
||
static bool
|
||
gfc_is_polymorphic_nonptr (tree type)
|
||
{
|
||
if (POINTER_TYPE_P (type))
|
||
type = TREE_TYPE (type);
|
||
return GFC_CLASS_TYPE_P (type);
|
||
}
|
||
|
||
/* Return true if TYPE is unlimited polymorphic but not with pointer attribute;
|
||
unlimited means also intrinsic types are handled and _len is used. */
|
||
|
||
static bool
|
||
gfc_is_unlimited_polymorphic_nonptr (tree type)
|
||
{
|
||
if (POINTER_TYPE_P (type))
|
||
type = TREE_TYPE (type);
|
||
if (!GFC_CLASS_TYPE_P (type))
|
||
return false;
|
||
|
||
tree field = TYPE_FIELDS (type); /* _data */
|
||
gcc_assert (field);
|
||
field = DECL_CHAIN (field); /* _vptr */
|
||
gcc_assert (field);
|
||
field = DECL_CHAIN (field);
|
||
if (!field)
|
||
return false;
|
||
gcc_assert (strcmp ("_len", IDENTIFIER_POINTER (DECL_NAME (field))) == 0);
|
||
return true;
|
||
}
|
||
|
||
/* Return true if the DECL is for an allocatable array or scalar. */
|
||
|
||
bool
|
||
gfc_omp_allocatable_p (tree decl)
|
||
{
|
||
if (!DECL_P (decl))
|
||
return false;
|
||
|
||
if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl))
|
||
return true;
|
||
|
||
tree type = TREE_TYPE (decl);
|
||
if (gfc_omp_privatize_by_reference (decl))
|
||
type = TREE_TYPE (type);
|
||
|
||
if (GFC_DESCRIPTOR_TYPE_P (type)
|
||
&& GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
|
||
return true;
|
||
|
||
return false;
|
||
}
|
||
|
||
|
||
/* Return true if DECL in private clause needs
|
||
OMP_CLAUSE_PRIVATE_OUTER_REF on the private clause. */
|
||
bool
|
||
gfc_omp_private_outer_ref (tree decl)
|
||
{
|
||
tree type = TREE_TYPE (decl);
|
||
|
||
if (gfc_omp_privatize_by_reference (decl))
|
||
type = TREE_TYPE (type);
|
||
|
||
if (GFC_DESCRIPTOR_TYPE_P (type)
|
||
&& GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
|
||
return true;
|
||
|
||
if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl))
|
||
return true;
|
||
|
||
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.cc 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
|
||
{
|
||
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),
|
||
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),
|
||
NULL_TREE);
|
||
else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field))
|
||
tem = gfc_duplicate_allocatable (destf, declf, ftype, 0,
|
||
NULL_TREE);
|
||
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,
|
||
logical_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_conv_descriptor_data_get (unshare_expr (declf));
|
||
tem = gfc_deallocate_with_status (tem, NULL_TREE, NULL_TREE,
|
||
NULL_TREE, NULL_TREE, true,
|
||
NULL,
|
||
GFC_CAF_COARRAY_NOCOARRAY);
|
||
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), size, ptr, cond, then_b, else_b;
|
||
stmtblock_t block, cond_block;
|
||
|
||
switch (OMP_CLAUSE_CODE (clause))
|
||
{
|
||
case OMP_CLAUSE__LOOPTEMP_:
|
||
case OMP_CLAUSE__REDUCTEMP_:
|
||
case OMP_CLAUSE__CONDTEMP_:
|
||
case OMP_CLAUSE__SCANTEMP_:
|
||
return NULL;
|
||
case OMP_CLAUSE_PRIVATE:
|
||
case OMP_CLAUSE_LASTPRIVATE:
|
||
case OMP_CLAUSE_LINEAR:
|
||
case OMP_CLAUSE_REDUCTION:
|
||
case OMP_CLAUSE_IN_REDUCTION:
|
||
case OMP_CLAUSE_TASK_REDUCTION:
|
||
break;
|
||
default:
|
||
gcc_unreachable ();
|
||
}
|
||
|
||
if ((! GFC_DESCRIPTOR_TYPE_P (type)
|
||
|| GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
|
||
&& (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause))
|
||
|| !POINTER_TYPE_P (type)))
|
||
{
|
||
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_TREE);
|
||
|
||
/* 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);
|
||
|
||
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);
|
||
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);
|
||
|
||
/* Reduction clause requires allocated ALLOCATABLE. */
|
||
if (OMP_CLAUSE_CODE (clause) != OMP_CLAUSE_REDUCTION
|
||
&& OMP_CLAUSE_CODE (clause) != OMP_CLAUSE_IN_REDUCTION
|
||
&& OMP_CLAUSE_CODE (clause) != OMP_CLAUSE_TASK_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, logical_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));
|
||
/* Avoid -W*uninitialized warnings. */
|
||
if (DECL_P (decl))
|
||
suppress_warning (decl, OPT_Wuninitialized);
|
||
}
|
||
else
|
||
gfc_add_expr_to_block (&block, then_b);
|
||
|
||
return gfc_finish_block (&block);
|
||
}
|
||
|
||
/* Build and return code for a copy constructor from SRC to DEST. */
|
||
|
||
tree
|
||
gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src)
|
||
{
|
||
tree type = TREE_TYPE (dest), ptr, size, call;
|
||
tree decl_type = TREE_TYPE (OMP_CLAUSE_DECL (clause));
|
||
tree cond, then_b, else_b;
|
||
stmtblock_t block, cond_block;
|
||
|
||
gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_FIRSTPRIVATE
|
||
|| OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LINEAR);
|
||
|
||
/* Privatize pointer, only; cf. gfc_omp_predetermined_sharing. */
|
||
if (DECL_P (OMP_CLAUSE_DECL (clause))
|
||
&& GFC_DECL_ASSOCIATE_VAR_P (OMP_CLAUSE_DECL (clause)))
|
||
return build2 (MODIFY_EXPR, TREE_TYPE (dest), dest, src);
|
||
|
||
if (DECL_ARTIFICIAL (OMP_CLAUSE_DECL (clause))
|
||
&& DECL_LANG_SPECIFIC (OMP_CLAUSE_DECL (clause))
|
||
&& GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_DECL (clause)))
|
||
decl_type
|
||
= TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_DECL (clause)));
|
||
|
||
if (gfc_is_polymorphic_nonptr (decl_type))
|
||
{
|
||
if (POINTER_TYPE_P (decl_type))
|
||
decl_type = TREE_TYPE (decl_type);
|
||
decl_type = TREE_TYPE (TYPE_FIELDS (decl_type));
|
||
if (GFC_DESCRIPTOR_TYPE_P (decl_type) || GFC_ARRAY_TYPE_P (decl_type))
|
||
fatal_error (input_location,
|
||
"Sorry, polymorphic arrays not yet supported for "
|
||
"firstprivate");
|
||
tree src_len;
|
||
tree nelems = build_int_cst (size_type_node, 1); /* Scalar. */
|
||
tree src_data = gfc_class_data_get (unshare_expr (src));
|
||
tree dest_data = gfc_class_data_get (unshare_expr (dest));
|
||
bool unlimited = gfc_is_unlimited_polymorphic_nonptr (type);
|
||
|
||
gfc_start_block (&block);
|
||
gfc_add_modify (&block, gfc_class_vptr_get (dest),
|
||
gfc_class_vptr_get (src));
|
||
gfc_init_block (&cond_block);
|
||
|
||
if (unlimited)
|
||
{
|
||
src_len = gfc_class_len_get (src);
|
||
gfc_add_modify (&cond_block, gfc_class_len_get (unshare_expr (dest)), src_len);
|
||
}
|
||
|
||
/* Use: size = class._vtab._size * (class._len > 0 ? class._len : 1). */
|
||
size = fold_convert (size_type_node, gfc_class_vtab_size_get (src));
|
||
if (unlimited)
|
||
{
|
||
cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
|
||
unshare_expr (src_len),
|
||
build_zero_cst (TREE_TYPE (src_len)));
|
||
cond = build3_loc (input_location, COND_EXPR, size_type_node, cond,
|
||
fold_convert (size_type_node,
|
||
unshare_expr (src_len)),
|
||
build_int_cst (size_type_node, 1));
|
||
size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
|
||
size, cond);
|
||
}
|
||
|
||
/* Malloc memory + call class->_vpt->_copy. */
|
||
call = builtin_decl_explicit (BUILT_IN_MALLOC);
|
||
call = build_call_expr_loc (input_location, call, 1, size);
|
||
gfc_add_modify (&cond_block, dest_data,
|
||
fold_convert (TREE_TYPE (dest_data), call));
|
||
gfc_add_expr_to_block (&cond_block,
|
||
gfc_copy_class_to_class (src, dest, nelems,
|
||
unlimited));
|
||
|
||
gcc_assert (TREE_CODE (dest_data) == COMPONENT_REF);
|
||
if (!GFC_DECL_GET_SCALAR_ALLOCATABLE (TREE_OPERAND (dest_data, 1)))
|
||
{
|
||
gfc_add_block_to_block (&block, &cond_block);
|
||
}
|
||
else
|
||
{
|
||
/* Create: if (class._data != 0) <cond_block> else class._data = NULL; */
|
||
cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
|
||
src_data, null_pointer_node);
|
||
gfc_add_expr_to_block (&block, build3_loc (input_location, COND_EXPR,
|
||
void_type_node, cond,
|
||
gfc_finish_block (&cond_block),
|
||
fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
|
||
unshare_expr (dest_data), null_pointer_node)));
|
||
}
|
||
return gfc_finish_block (&block);
|
||
}
|
||
|
||
if ((! GFC_DESCRIPTOR_TYPE_P (type)
|
||
|| GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
|
||
&& (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause))
|
||
|| !POINTER_TYPE_P (type)))
|
||
{
|
||
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. */
|
||
gfc_start_block (&block);
|
||
|
||
gfc_init_block (&cond_block);
|
||
|
||
gfc_add_modify (&cond_block, dest, fold_convert (TREE_TYPE (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)));
|
||
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);
|
||
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,
|
||
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);
|
||
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, logical_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));
|
||
/* Avoid -W*uninitialized warnings. */
|
||
if (DECL_P (dest))
|
||
suppress_warning (dest, OPT_Wuninitialized);
|
||
|
||
return gfc_finish_block (&block);
|
||
}
|
||
|
||
/* Similarly, except use an intrinsic or pointer assignment operator
|
||
instead. */
|
||
|
||
tree
|
||
gfc_omp_clause_assign_op (tree clause, tree dest, tree src)
|
||
{
|
||
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)
|
||
&& (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause))
|
||
|| !POINTER_TYPE_P (type)))
|
||
{
|
||
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);
|
||
}
|
||
|
||
gfc_start_block (&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, logical_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, logical_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, logical_type_node,
|
||
tem, gfc_conv_descriptor_ubound_get (dest,
|
||
rank));
|
||
cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
|
||
logical_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, 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))
|
||
{
|
||
tree tmp = gfc_conv_descriptor_data_get (unshare_expr (dest));
|
||
tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
|
||
NULL_TREE, NULL_TREE, true, NULL,
|
||
GFC_CAF_COARRAY_NOCOARRAY);
|
||
gfc_add_expr_to_block (&cond_block, tmp);
|
||
}
|
||
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, logical_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))
|
||
|| !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),
|
||
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);
|
||
}
|
||
|
||
/* Build and return code destructing DECL. Return NULL if nothing
|
||
to be done. */
|
||
|
||
tree
|
||
gfc_omp_clause_dtor (tree clause, tree decl)
|
||
{
|
||
tree type = TREE_TYPE (decl), tem;
|
||
tree decl_type = TREE_TYPE (OMP_CLAUSE_DECL (clause));
|
||
|
||
/* Only pointer was privatized; cf. gfc_omp_clause_copy_ctor. */
|
||
if (DECL_P (OMP_CLAUSE_DECL (clause))
|
||
&& GFC_DECL_ASSOCIATE_VAR_P (OMP_CLAUSE_DECL (clause)))
|
||
return NULL_TREE;
|
||
|
||
if (DECL_ARTIFICIAL (OMP_CLAUSE_DECL (clause))
|
||
&& DECL_LANG_SPECIFIC (OMP_CLAUSE_DECL (clause))
|
||
&& GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_DECL (clause)))
|
||
decl_type
|
||
= TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_DECL (clause)));
|
||
if (gfc_is_polymorphic_nonptr (decl_type))
|
||
{
|
||
if (POINTER_TYPE_P (decl_type))
|
||
decl_type = TREE_TYPE (decl_type);
|
||
decl_type = TREE_TYPE (TYPE_FIELDS (decl_type));
|
||
if (GFC_DESCRIPTOR_TYPE_P (decl_type) || GFC_ARRAY_TYPE_P (decl_type))
|
||
fatal_error (input_location,
|
||
"Sorry, polymorphic arrays not yet supported for "
|
||
"firstprivate");
|
||
stmtblock_t block, cond_block;
|
||
gfc_start_block (&block);
|
||
gfc_init_block (&cond_block);
|
||
tree final = gfc_class_vtab_final_get (decl);
|
||
tree size = fold_convert (size_type_node, gfc_class_vtab_size_get (decl));
|
||
gfc_se se;
|
||
gfc_init_se (&se, NULL);
|
||
symbol_attribute attr = {};
|
||
tree data = gfc_class_data_get (decl);
|
||
tree desc = gfc_conv_scalar_to_descriptor (&se, data, attr);
|
||
|
||
/* Call class->_vpt->_finalize + free. */
|
||
tree call = build_fold_indirect_ref (final);
|
||
call = build_call_expr_loc (input_location, call, 3,
|
||
gfc_build_addr_expr (NULL, desc),
|
||
size, boolean_false_node);
|
||
gfc_add_block_to_block (&cond_block, &se.pre);
|
||
gfc_add_expr_to_block (&cond_block, fold_convert (void_type_node, call));
|
||
gfc_add_block_to_block (&cond_block, &se.post);
|
||
/* Create: if (_vtab && _final) <cond_block> */
|
||
tree cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
|
||
gfc_class_vptr_get (decl),
|
||
null_pointer_node);
|
||
tree cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
|
||
final, null_pointer_node);
|
||
cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
|
||
boolean_type_node, cond, cond2);
|
||
gfc_add_expr_to_block (&block, build3_loc (input_location, COND_EXPR,
|
||
void_type_node, cond,
|
||
gfc_finish_block (&cond_block), NULL_TREE));
|
||
call = builtin_decl_explicit (BUILT_IN_FREE);
|
||
call = build_call_expr_loc (input_location, call, 1, data);
|
||
gfc_add_expr_to_block (&block, fold_convert (void_type_node, call));
|
||
return gfc_finish_block (&block);
|
||
}
|
||
|
||
if ((! GFC_DESCRIPTOR_TYPE_P (type)
|
||
|| GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
|
||
&& (!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,
|
||
OMP_CLAUSE_DECL (clause),
|
||
WALK_ALLOC_COMPS_DTOR);
|
||
return NULL_TREE;
|
||
}
|
||
|
||
if (GFC_DESCRIPTOR_TYPE_P (type))
|
||
{
|
||
/* Allocatable arrays in FIRSTPRIVATE/LASTPRIVATE etc. clauses need
|
||
to be deallocated if they were allocated. */
|
||
tem = gfc_conv_descriptor_data_get (decl);
|
||
tem = gfc_deallocate_with_status (tem, NULL_TREE, NULL_TREE, NULL_TREE,
|
||
NULL_TREE, true, NULL,
|
||
GFC_CAF_COARRAY_NOCOARRAY);
|
||
}
|
||
else
|
||
tem = gfc_call_free (decl);
|
||
tem = gfc_omp_unshare_expr (tem);
|
||
|
||
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, logical_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;
|
||
}
|
||
|
||
/* 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, bool openacc)
|
||
{
|
||
if (OMP_CLAUSE_CODE (c) != OMP_CLAUSE_MAP)
|
||
return;
|
||
|
||
tree decl = OMP_CLAUSE_DECL (c);
|
||
|
||
/* Assumed-size arrays can't be mapped implicitly, they have to be
|
||
mapped explicitly using array sections. */
|
||
if (TREE_CODE (decl) == PARM_DECL
|
||
&& GFC_ARRAY_TYPE_P (TREE_TYPE (decl))
|
||
&& GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl)) == GFC_ARRAY_UNKNOWN
|
||
&& GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (decl),
|
||
GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl)) - 1)
|
||
== NULL)
|
||
{
|
||
error_at (OMP_CLAUSE_LOCATION (c),
|
||
"implicit mapping of assumed size array %qD", decl);
|
||
return;
|
||
}
|
||
|
||
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)
|
||
&& !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;
|
||
tree orig_decl = decl;
|
||
|
||
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);
|
||
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)))
|
||
{
|
||
c3 = build_omp_clause (OMP_CLAUSE_LOCATION (c), OMP_CLAUSE_MAP);
|
||
OMP_CLAUSE_SET_MAP_KIND (c3, GOMP_MAP_POINTER);
|
||
OMP_CLAUSE_DECL (c3) = unshare_expr (decl);
|
||
OMP_CLAUSE_SIZE (c3) = size_int (0);
|
||
decl = build_fold_indirect_ref (decl);
|
||
OMP_CLAUSE_DECL (c) = decl;
|
||
}
|
||
}
|
||
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);
|
||
|
||
/* OpenMP: automatically map pointer targets with the pointer;
|
||
hence, always update the descriptor/pointer itself.
|
||
NOTE: This also remaps the pointer for allocatable arrays with
|
||
'target' attribute which also don't have the 'restrict' qualifier. */
|
||
bool always_modifier = false;
|
||
|
||
if (!openacc
|
||
&& !(TYPE_QUALS (TREE_TYPE (ptr)) & TYPE_QUAL_RESTRICT))
|
||
always_modifier = true;
|
||
|
||
if (present)
|
||
ptr = gfc_build_cond_assign_expr (&block, present, ptr,
|
||
null_pointer_node);
|
||
gcc_assert (POINTER_TYPE_P (TREE_TYPE (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);
|
||
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, always_modifier ? GOMP_MAP_ALWAYS_POINTER
|
||
: GOMP_MAP_POINTER);
|
||
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));
|
||
elemsz = fold_convert (gfc_array_index_type, elemsz);
|
||
if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE
|
||
|| 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);
|
||
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,
|
||
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 (gimplify_expr (&OMP_CLAUSE_SIZE (c), pre_p,
|
||
NULL, is_gimple_val, fb_rvalue) == GS_ERROR)
|
||
OMP_CLAUSE_SIZE (c) = size_int (0);
|
||
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;
|
||
}
|
||
}
|
||
|
||
|
||
/* Return true if DECL is a scalar variable (for the purpose of
|
||
implicit firstprivatization/mapping). Only if 'ptr_alloc_ok.'
|
||
is true, allocatables and pointers are permitted. */
|
||
|
||
bool
|
||
gfc_omp_scalar_p (tree decl, bool ptr_alloc_ok)
|
||
{
|
||
tree type = TREE_TYPE (decl);
|
||
if (TREE_CODE (type) == REFERENCE_TYPE)
|
||
type = TREE_TYPE (type);
|
||
if (TREE_CODE (type) == POINTER_TYPE)
|
||
{
|
||
if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)
|
||
|| GFC_DECL_GET_SCALAR_POINTER (decl))
|
||
{
|
||
if (!ptr_alloc_ok)
|
||
return false;
|
||
type = TREE_TYPE (type);
|
||
}
|
||
if (GFC_ARRAY_TYPE_P (type)
|
||
|| GFC_CLASS_TYPE_P (type))
|
||
return false;
|
||
}
|
||
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)
|
||
|| COMPLEX_FLOAT_TYPE_P (type))
|
||
return true;
|
||
return false;
|
||
}
|
||
|
||
|
||
/* Return true if DECL is a scalar with target attribute but does not have the
|
||
allocatable (or pointer) attribute (for the purpose of implicit mapping). */
|
||
|
||
bool
|
||
gfc_omp_scalar_target_p (tree decl)
|
||
{
|
||
return (DECL_P (decl) && GFC_DECL_GET_SCALAR_TARGET (decl)
|
||
&& gfc_omp_scalar_p (decl, false));
|
||
}
|
||
|
||
|
||
/* Return true if DECL's DECL_VALUE_EXPR (if any) should be
|
||
disregarded in OpenMP construct, because it is going to be
|
||
remapped during OpenMP lowering. SHARED is true if DECL
|
||
is going to be shared, false if it is going to be privatized. */
|
||
|
||
bool
|
||
gfc_omp_disregard_value_expr (tree decl, bool shared)
|
||
{
|
||
if (GFC_DECL_COMMON_OR_EQUIV (decl)
|
||
&& DECL_HAS_VALUE_EXPR_P (decl))
|
||
{
|
||
tree value = DECL_VALUE_EXPR (decl);
|
||
|
||
if (TREE_CODE (value) == COMPONENT_REF
|
||
&& VAR_P (TREE_OPERAND (value, 0))
|
||
&& GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value, 0)))
|
||
{
|
||
/* If variable in COMMON or EQUIVALENCE is privatized, return
|
||
true, as just that variable is supposed to be privatized,
|
||
not the whole COMMON or whole EQUIVALENCE.
|
||
For shared variables in COMMON or EQUIVALENCE, let them be
|
||
gimplified to DECL_VALUE_EXPR, so that for multiple shared vars
|
||
from the same COMMON or EQUIVALENCE just one sharing of the
|
||
whole COMMON or EQUIVALENCE is enough. */
|
||
return ! shared;
|
||
}
|
||
}
|
||
|
||
if (GFC_DECL_RESULT (decl) && DECL_HAS_VALUE_EXPR_P (decl))
|
||
return ! shared;
|
||
|
||
return false;
|
||
}
|
||
|
||
/* Return true if DECL that is shared iff SHARED is true should
|
||
be put into OMP_CLAUSE_PRIVATE with OMP_CLAUSE_PRIVATE_DEBUG
|
||
flag set. */
|
||
|
||
bool
|
||
gfc_omp_private_debug_clause (tree decl, bool shared)
|
||
{
|
||
if (GFC_DECL_CRAY_POINTEE (decl))
|
||
return true;
|
||
|
||
if (GFC_DECL_COMMON_OR_EQUIV (decl)
|
||
&& DECL_HAS_VALUE_EXPR_P (decl))
|
||
{
|
||
tree value = DECL_VALUE_EXPR (decl);
|
||
|
||
if (TREE_CODE (value) == COMPONENT_REF
|
||
&& VAR_P (TREE_OPERAND (value, 0))
|
||
&& GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value, 0)))
|
||
return shared;
|
||
}
|
||
|
||
return false;
|
||
}
|
||
|
||
/* Register language specific type size variables as potentially OpenMP
|
||
firstprivate variables. */
|
||
|
||
void
|
||
gfc_omp_firstprivatize_type_sizes (struct gimplify_omp_ctx *ctx, tree type)
|
||
{
|
||
if (GFC_ARRAY_TYPE_P (type) || GFC_DESCRIPTOR_TYPE_P (type))
|
||
{
|
||
int r;
|
||
|
||
gcc_assert (TYPE_LANG_SPECIFIC (type) != NULL);
|
||
for (r = 0; r < GFC_TYPE_ARRAY_RANK (type); r++)
|
||
{
|
||
omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_LBOUND (type, r));
|
||
omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_UBOUND (type, r));
|
||
omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_STRIDE (type, r));
|
||
}
|
||
omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_SIZE (type));
|
||
omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_OFFSET (type));
|
||
}
|
||
}
|
||
|
||
|
||
static inline tree
|
||
gfc_trans_add_clause (tree node, tree tail)
|
||
{
|
||
OMP_CLAUSE_CHAIN (node) = tail;
|
||
return node;
|
||
}
|
||
|
||
static tree
|
||
gfc_trans_omp_variable (gfc_symbol *sym, 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;
|
||
bool return_value;
|
||
bool alternate_entry;
|
||
bool entry_master;
|
||
|
||
return_value = sym->attr.function && sym->result == sym;
|
||
alternate_entry = sym->attr.function && sym->attr.entry
|
||
&& sym->result == sym;
|
||
entry_master = sym->attr.result
|
||
&& sym->ns->proc_name->attr.entry_master
|
||
&& !gfc_return_by_reference (sym->ns->proc_name);
|
||
parent_decl = current_function_decl
|
||
? DECL_CONTEXT (current_function_decl) : NULL_TREE;
|
||
|
||
if ((t == parent_decl && return_value)
|
||
|| (sym->ns && sym->ns->proc_name
|
||
&& sym->ns->proc_name->backend_decl == parent_decl
|
||
&& (alternate_entry || entry_master)))
|
||
parent_flag = 1;
|
||
else
|
||
parent_flag = 0;
|
||
|
||
/* Special case for assigning the return value of a function.
|
||
Self recursive functions must have an explicit return value. */
|
||
if (return_value && (t == current_function_decl || parent_flag))
|
||
t = gfc_get_fake_result_decl (sym, parent_flag);
|
||
|
||
/* Similarly for alternate entry points. */
|
||
else if (alternate_entry
|
||
&& (sym->ns->proc_name->backend_decl == current_function_decl
|
||
|| parent_flag))
|
||
{
|
||
gfc_entry_list *el = NULL;
|
||
|
||
for (el = sym->ns->entries; el; el = el->next)
|
||
if (sym == el->sym)
|
||
{
|
||
t = gfc_get_fake_result_decl (sym, parent_flag);
|
||
break;
|
||
}
|
||
}
|
||
|
||
else if (entry_master
|
||
&& (sym->ns->proc_name->backend_decl == current_function_decl
|
||
|| parent_flag))
|
||
t = gfc_get_fake_result_decl (sym, parent_flag);
|
||
|
||
return t;
|
||
}
|
||
|
||
static tree
|
||
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 || declare_simd)
|
||
{
|
||
tree t = gfc_trans_omp_variable (namelist->sym, declare_simd);
|
||
if (t != error_mark_node)
|
||
{
|
||
tree node;
|
||
/* For HAS_DEVICE_ADDR of an array descriptor, firstprivatize the
|
||
descriptor such that the bounds are available; its data component
|
||
is unmodified; it is handled as device address inside target. */
|
||
if (code == OMP_CLAUSE_HAS_DEVICE_ADDR
|
||
&& (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (t))
|
||
|| (POINTER_TYPE_P (TREE_TYPE (t))
|
||
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (t))))))
|
||
node = build_omp_clause (input_location, OMP_CLAUSE_FIRSTPRIVATE);
|
||
else
|
||
node = build_omp_clause (input_location, code);
|
||
OMP_CLAUSE_DECL (node) = t;
|
||
list = gfc_trans_add_clause (node, list);
|
||
|
||
if (code == OMP_CLAUSE_LASTPRIVATE
|
||
&& namelist->u.lastprivate_conditional)
|
||
OMP_CLAUSE_LASTPRIVATE_CONDITIONAL (node) = 1;
|
||
}
|
||
}
|
||
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_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->u2.udr ? n->u2.udr->udr : NULL;
|
||
|
||
decl = OMP_CLAUSE_DECL (c);
|
||
gfc_current_locus = where;
|
||
type = TREE_TYPE (decl);
|
||
outer_decl = create_tmp_var_raw (type);
|
||
if (TREE_CODE (decl) == PARM_DECL
|
||
&& TREE_CODE (type) == REFERENCE_TYPE
|
||
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type))
|
||
&& GFC_TYPE_ARRAY_AKIND (TREE_TYPE (type)) == GFC_ARRAY_ALLOCATABLE)
|
||
{
|
||
decl = build_fold_indirect_ref (decl);
|
||
type = TREE_TYPE (type);
|
||
}
|
||
|
||
/* Create a fake symbol for init value. */
|
||
memset (&init_val_sym, 0, sizeof (init_val_sym));
|
||
init_val_sym.ns = sym->ns;
|
||
init_val_sym.name = sym->name;
|
||
init_val_sym.ts = sym->ts;
|
||
init_val_sym.attr.referenced = 1;
|
||
init_val_sym.declared_at = where;
|
||
init_val_sym.attr.flavor = FL_VARIABLE;
|
||
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;
|
||
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;
|
||
outer_sym.backend_decl = outer_decl;
|
||
if (decl != OMP_CLAUSE_DECL (c))
|
||
outer_sym.backend_decl = build_fold_indirect_ref (outer_decl);
|
||
|
||
/* Create fake symtrees for it. */
|
||
symtree1 = gfc_new_symtree (&root1, sym->name);
|
||
symtree1->n.sym = sym;
|
||
gcc_assert (symtree1 == root1);
|
||
|
||
symtree2 = gfc_new_symtree (&root2, sym->name);
|
||
symtree2->n.sym = &init_val_sym;
|
||
gcc_assert (symtree2 == root2);
|
||
|
||
symtree3 = gfc_new_symtree (&root3, sym->name);
|
||
symtree3->n.sym = &outer_sym;
|
||
gcc_assert (symtree3 == root3);
|
||
|
||
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;
|
||
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 = 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->u2.udr->initializer->op == EXEC_ASSIGN)
|
||
{
|
||
e2 = gfc_copy_expr (n->u2.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->u2.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;
|
||
t = gfc_resolve_expr (e3);
|
||
gcc_assert (t);
|
||
|
||
iname = NULL;
|
||
e4 = NULL;
|
||
switch (OMP_CLAUSE_REDUCTION_CODE (c))
|
||
{
|
||
case PLUS_EXPR:
|
||
case MINUS_EXPR:
|
||
e4 = gfc_add (e3, e1);
|
||
break;
|
||
case MULT_EXPR:
|
||
e4 = gfc_multiply (e3, e1);
|
||
break;
|
||
case TRUTH_ANDIF_EXPR:
|
||
e4 = gfc_and (e3, e1);
|
||
break;
|
||
case TRUTH_ORIF_EXPR:
|
||
e4 = gfc_or (e3, e1);
|
||
break;
|
||
case EQ_EXPR:
|
||
e4 = gfc_eqv (e3, e1);
|
||
break;
|
||
case NE_EXPR:
|
||
e4 = gfc_neqv (e3, e1);
|
||
break;
|
||
case MIN_EXPR:
|
||
iname = "min";
|
||
break;
|
||
case MAX_EXPR:
|
||
iname = "max";
|
||
break;
|
||
case BIT_AND_EXPR:
|
||
iname = "iand";
|
||
break;
|
||
case BIT_IOR_EXPR:
|
||
iname = "ior";
|
||
break;
|
||
case BIT_XOR_EXPR:
|
||
iname = "ieor";
|
||
break;
|
||
case ERROR_MARK:
|
||
if (n->u2.udr->combiner->op == EXEC_ASSIGN)
|
||
{
|
||
gfc_free_expr (e3);
|
||
e3 = gfc_copy_expr (n->u2.udr->combiner->expr1);
|
||
e4 = gfc_copy_expr (n->u2.udr->combiner->expr2);
|
||
t = gfc_resolve_expr (e3);
|
||
gcc_assert (t);
|
||
t = gfc_resolve_expr (e4);
|
||
gcc_assert (t);
|
||
}
|
||
break;
|
||
default:
|
||
gcc_unreachable ();
|
||
}
|
||
if (iname != NULL)
|
||
{
|
||
memset (&intrinsic_sym, 0, sizeof (intrinsic_sym));
|
||
intrinsic_sym.ns = sym->ns;
|
||
intrinsic_sym.name = iname;
|
||
intrinsic_sym.ts = sym->ts;
|
||
intrinsic_sym.attr.referenced = 1;
|
||
intrinsic_sym.attr.intrinsic = 1;
|
||
intrinsic_sym.attr.function = 1;
|
||
intrinsic_sym.attr.implicit_type = 1;
|
||
intrinsic_sym.result = &intrinsic_sym;
|
||
intrinsic_sym.declared_at = where;
|
||
|
||
symtree4 = gfc_new_symtree (&root4, iname);
|
||
symtree4->n.sym = &intrinsic_sym;
|
||
gcc_assert (symtree4 == root4);
|
||
|
||
e4 = gfc_get_expr ();
|
||
e4->expr_type = EXPR_FUNCTION;
|
||
e4->where = where;
|
||
e4->symtree = symtree4;
|
||
e4->value.function.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;
|
||
}
|
||
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 (e2)
|
||
stmt = gfc_trans_assignment (e1, e2, false, false);
|
||
else
|
||
stmt = gfc_trans_call (n->u2.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
|
||
poplevel (0, 0);
|
||
OMP_CLAUSE_REDUCTION_INIT (c) = stmt;
|
||
|
||
/* Create the merge statement list. */
|
||
pushlevel ();
|
||
if (e4)
|
||
stmt = gfc_trans_assignment (e3, e4, false, true);
|
||
else
|
||
stmt = gfc_trans_call (n->u2.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
|
||
poplevel (0, 0);
|
||
OMP_CLAUSE_REDUCTION_MERGE (c) = stmt;
|
||
|
||
/* And stick the placeholder VAR_DECL into the clause as well. */
|
||
OMP_CLAUSE_REDUCTION_PLACEHOLDER (c) = outer_decl;
|
||
|
||
gfc_current_locus = old_loc;
|
||
|
||
gfc_free_expr (e1);
|
||
if (e2)
|
||
gfc_free_expr (e2);
|
||
gfc_free_expr (e3);
|
||
if (e4)
|
||
gfc_free_expr (e4);
|
||
free (symtree1);
|
||
free (symtree2);
|
||
free (symtree3);
|
||
free (symtree4);
|
||
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 (int kind, gfc_omp_namelist *namelist, tree list,
|
||
locus where, bool mark_addressable)
|
||
{
|
||
omp_clause_code clause = OMP_CLAUSE_REDUCTION;
|
||
switch (kind)
|
||
{
|
||
case OMP_LIST_REDUCTION:
|
||
case OMP_LIST_REDUCTION_INSCAN:
|
||
case OMP_LIST_REDUCTION_TASK:
|
||
break;
|
||
case OMP_LIST_IN_REDUCTION:
|
||
clause = OMP_CLAUSE_IN_REDUCTION;
|
||
break;
|
||
case OMP_LIST_TASK_REDUCTION:
|
||
clause = OMP_CLAUSE_TASK_REDUCTION;
|
||
break;
|
||
default:
|
||
gcc_unreachable ();
|
||
}
|
||
for (; namelist != NULL; namelist = namelist->next)
|
||
if (namelist->sym->attr.referenced)
|
||
{
|
||
tree t = gfc_trans_omp_variable (namelist->sym, false);
|
||
if (t != error_mark_node)
|
||
{
|
||
tree node = build_omp_clause (gfc_get_location (&namelist->where),
|
||
clause);
|
||
OMP_CLAUSE_DECL (node) = t;
|
||
if (mark_addressable)
|
||
TREE_ADDRESSABLE (t) = 1;
|
||
if (kind == OMP_LIST_REDUCTION_INSCAN)
|
||
OMP_CLAUSE_REDUCTION_INSCAN (node) = 1;
|
||
if (kind == OMP_LIST_REDUCTION_TASK)
|
||
OMP_CLAUSE_REDUCTION_TASK (node) = 1;
|
||
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);
|
||
}
|
||
}
|
||
return list;
|
||
}
|
||
|
||
static inline tree
|
||
gfc_convert_expr_to_tree (stmtblock_t *block, gfc_expr *expr)
|
||
{
|
||
gfc_se se;
|
||
tree result;
|
||
|
||
gfc_init_se (&se, NULL );
|
||
gfc_conv_expr (&se, expr);
|
||
gfc_add_block_to_block (block, &se.pre);
|
||
result = gfc_evaluate_now (se.expr, block);
|
||
gfc_add_block_to_block (block, &se.post);
|
||
|
||
return result;
|
||
}
|
||
|
||
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;
|
||
tree elemsz = NULL_TREE;
|
||
|
||
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 (TREE_TYPE (ptr)));
|
||
elemsz = OMP_CLAUSE_SIZE (node);
|
||
}
|
||
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));
|
||
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);
|
||
}
|
||
gcc_assert (se.post.head == NULL_TREE);
|
||
gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr)));
|
||
OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr);
|
||
ptr = fold_convert (ptrdiff_type_node, 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);
|
||
}
|
||
else if (ptr_kind == GOMP_MAP_ALWAYS_POINTER
|
||
&& n->expr->ts.type == BT_CHARACTER
|
||
&& n->expr->ts.deferred)
|
||
{
|
||
gomp_map_kind map_kind;
|
||
if (GOMP_MAP_COPY_TO_P (OMP_CLAUSE_MAP_KIND (node)))
|
||
map_kind = GOMP_MAP_TO;
|
||
else if (OMP_CLAUSE_MAP_KIND (node) == GOMP_MAP_RELEASE
|
||
|| OMP_CLAUSE_MAP_KIND (node) == GOMP_MAP_DELETE)
|
||
map_kind = OMP_CLAUSE_MAP_KIND (node);
|
||
else
|
||
map_kind = GOMP_MAP_ALLOC;
|
||
gcc_assert (se.string_length);
|
||
node4 = build_omp_clause (input_location, OMP_CLAUSE_MAP);
|
||
OMP_CLAUSE_SET_MAP_KIND (node4, map_kind);
|
||
OMP_CLAUSE_DECL (node4) = se.string_length;
|
||
OMP_CLAUSE_SIZE (node4) = TYPE_SIZE_UNIT (gfc_charlen_type_node);
|
||
}
|
||
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
|
||
{
|
||
tree desc_node;
|
||
tree type = TREE_TYPE (decl);
|
||
ptr2 = gfc_conv_descriptor_data_get (decl);
|
||
desc_node = build_omp_clause (input_location, OMP_CLAUSE_MAP);
|
||
OMP_CLAUSE_DECL (desc_node) = decl;
|
||
OMP_CLAUSE_SIZE (desc_node) = TYPE_SIZE_UNIT (type);
|
||
if (ptr_kind == GOMP_MAP_ALWAYS_POINTER)
|
||
{
|
||
OMP_CLAUSE_SET_MAP_KIND (desc_node, GOMP_MAP_TO);
|
||
node2 = node;
|
||
node = desc_node; /* Needs to come first. */
|
||
}
|
||
else
|
||
{
|
||
OMP_CLAUSE_SET_MAP_KIND (desc_node, GOMP_MAP_TO_PSET);
|
||
node2 = desc_node;
|
||
}
|
||
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);
|
||
/* This purposely does not include GOMP_MAP_ALWAYS_POINTER. The extra
|
||
cast prevents gimplify.cc from recognising it as being part of the
|
||
struct – and adding an 'alloc: for the 'desc.data' pointer, which
|
||
would break as the 'desc' (the descriptor) is also mapped
|
||
(see node4 above). */
|
||
if (ptr_kind == GOMP_MAP_ATTACH_DETACH)
|
||
STRIP_NOPS (OMP_CLAUSE_DECL (node3));
|
||
}
|
||
else
|
||
{
|
||
if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE)
|
||
{
|
||
tree offset;
|
||
ptr2 = build_fold_addr_expr (decl);
|
||
offset = fold_build2 (MINUS_EXPR, ptrdiff_type_node, ptr,
|
||
fold_convert (ptrdiff_type_node, ptr2));
|
||
offset = build2 (TRUNC_DIV_EXPR, ptrdiff_type_node,
|
||
offset, fold_convert (ptrdiff_type_node, elemsz));
|
||
offset = build4_loc (input_location, ARRAY_REF,
|
||
TREE_TYPE (TREE_TYPE (decl)),
|
||
decl, offset, NULL_TREE, NULL_TREE);
|
||
OMP_CLAUSE_DECL (node) = offset;
|
||
|
||
if (ptr_kind == GOMP_MAP_ALWAYS_POINTER)
|
||
return;
|
||
}
|
||
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 (ptrdiff_type_node, ptr2);
|
||
OMP_CLAUSE_SIZE (node3) = fold_build2 (MINUS_EXPR, ptrdiff_type_node,
|
||
ptr, ptr2);
|
||
}
|
||
|
||
static tree
|
||
handle_iterator (gfc_namespace *ns, stmtblock_t *iter_block, tree block)
|
||
{
|
||
tree list = NULL_TREE;
|
||
for (gfc_symbol *sym = ns->omp_affinity_iterators; sym; sym = sym->tlink)
|
||
{
|
||
gfc_constructor *c;
|
||
gfc_se se;
|
||
|
||
tree last = make_tree_vec (6);
|
||
tree iter_var = gfc_get_symbol_decl (sym);
|
||
tree type = TREE_TYPE (iter_var);
|
||
TREE_VEC_ELT (last, 0) = iter_var;
|
||
DECL_CHAIN (iter_var) = BLOCK_VARS (block);
|
||
BLOCK_VARS (block) = iter_var;
|
||
|
||
/* begin */
|
||
c = gfc_constructor_first (sym->value->value.constructor);
|
||
gfc_init_se (&se, NULL);
|
||
gfc_conv_expr (&se, c->expr);
|
||
gfc_add_block_to_block (iter_block, &se.pre);
|
||
gfc_add_block_to_block (iter_block, &se.post);
|
||
TREE_VEC_ELT (last, 1) = fold_convert (type,
|
||
gfc_evaluate_now (se.expr,
|
||
iter_block));
|
||
/* end */
|
||
c = gfc_constructor_next (c);
|
||
gfc_init_se (&se, NULL);
|
||
gfc_conv_expr (&se, c->expr);
|
||
gfc_add_block_to_block (iter_block, &se.pre);
|
||
gfc_add_block_to_block (iter_block, &se.post);
|
||
TREE_VEC_ELT (last, 2) = fold_convert (type,
|
||
gfc_evaluate_now (se.expr,
|
||
iter_block));
|
||
/* step */
|
||
c = gfc_constructor_next (c);
|
||
tree step;
|
||
if (c)
|
||
{
|
||
gfc_init_se (&se, NULL);
|
||
gfc_conv_expr (&se, c->expr);
|
||
gfc_add_block_to_block (iter_block, &se.pre);
|
||
gfc_add_block_to_block (iter_block, &se.post);
|
||
gfc_conv_expr (&se, c->expr);
|
||
step = fold_convert (type,
|
||
gfc_evaluate_now (se.expr,
|
||
iter_block));
|
||
}
|
||
else
|
||
step = build_int_cst (type, 1);
|
||
TREE_VEC_ELT (last, 3) = step;
|
||
/* orig_step */
|
||
TREE_VEC_ELT (last, 4) = save_expr (step);
|
||
TREE_CHAIN (last) = list;
|
||
list = last;
|
||
}
|
||
return list;
|
||
}
|
||
|
||
static tree
|
||
gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
|
||
locus where, bool declare_simd = false,
|
||
bool openacc = false)
|
||
{
|
||
tree omp_clauses = NULL_TREE, prev_clauses, chunk_size, c;
|
||
tree iterator = NULL_TREE;
|
||
tree tree_block = NULL_TREE;
|
||
stmtblock_t iter_block;
|
||
int list, ifc;
|
||
enum omp_clause_code clause_code;
|
||
gfc_omp_namelist *prev = NULL;
|
||
gfc_se se;
|
||
|
||
if (clauses == NULL)
|
||
return NULL_TREE;
|
||
|
||
for (list = 0; list < OMP_LIST_NUM; list++)
|
||
{
|
||
gfc_omp_namelist *n = clauses->lists[list];
|
||
|
||
if (n == NULL)
|
||
continue;
|
||
switch (list)
|
||
{
|
||
case OMP_LIST_REDUCTION:
|
||
case OMP_LIST_REDUCTION_INSCAN:
|
||
case OMP_LIST_REDUCTION_TASK:
|
||
case OMP_LIST_IN_REDUCTION:
|
||
case OMP_LIST_TASK_REDUCTION:
|
||
/* An OpenACC async clause indicates the need to set reduction
|
||
arguments addressable, to allow asynchronous copy-out. */
|
||
omp_clauses = gfc_trans_omp_reduction_list (list, n, omp_clauses,
|
||
where, clauses->async);
|
||
break;
|
||
case OMP_LIST_PRIVATE:
|
||
clause_code = OMP_CLAUSE_PRIVATE;
|
||
goto add_clause;
|
||
case OMP_LIST_SHARED:
|
||
clause_code = OMP_CLAUSE_SHARED;
|
||
goto add_clause;
|
||
case OMP_LIST_FIRSTPRIVATE:
|
||
clause_code = OMP_CLAUSE_FIRSTPRIVATE;
|
||
goto add_clause;
|
||
case OMP_LIST_LASTPRIVATE:
|
||
clause_code = OMP_CLAUSE_LASTPRIVATE;
|
||
goto add_clause;
|
||
case OMP_LIST_COPYIN:
|
||
clause_code = OMP_CLAUSE_COPYIN;
|
||
goto add_clause;
|
||
case OMP_LIST_COPYPRIVATE:
|
||
clause_code = OMP_CLAUSE_COPYPRIVATE;
|
||
goto add_clause;
|
||
case OMP_LIST_UNIFORM:
|
||
clause_code = OMP_CLAUSE_UNIFORM;
|
||
goto add_clause;
|
||
case OMP_LIST_USE_DEVICE:
|
||
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;
|
||
case OMP_LIST_HAS_DEVICE_ADDR:
|
||
clause_code = OMP_CLAUSE_HAS_DEVICE_ADDR;
|
||
goto add_clause;
|
||
case OMP_LIST_NONTEMPORAL:
|
||
clause_code = OMP_CLAUSE_NONTEMPORAL;
|
||
goto add_clause;
|
||
case OMP_LIST_SCAN_IN:
|
||
clause_code = OMP_CLAUSE_INCLUSIVE;
|
||
goto add_clause;
|
||
case OMP_LIST_SCAN_EX:
|
||
clause_code = OMP_CLAUSE_EXCLUSIVE;
|
||
goto add_clause;
|
||
|
||
add_clause:
|
||
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 (declare_simd)
|
||
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_ALLOCATE:
|
||
for (; n != NULL; n = n->next)
|
||
if (n->sym->attr.referenced)
|
||
{
|
||
tree t = gfc_trans_omp_variable (n->sym, false);
|
||
if (t != error_mark_node)
|
||
{
|
||
tree node = build_omp_clause (input_location,
|
||
OMP_CLAUSE_ALLOCATE);
|
||
OMP_CLAUSE_DECL (node) = t;
|
||
if (n->expr)
|
||
{
|
||
tree allocator_;
|
||
gfc_init_se (&se, NULL);
|
||
gfc_conv_expr (&se, n->expr);
|
||
allocator_ = gfc_evaluate_now (se.expr, block);
|
||
OMP_CLAUSE_ALLOCATE_ALLOCATOR (node) = allocator_;
|
||
}
|
||
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;
|
||
bool last_step_parm = false;
|
||
|
||
for (; n != NULL; n = n->next)
|
||
{
|
||
if (n->expr)
|
||
{
|
||
last_step_expr = n->expr;
|
||
last_step = NULL_TREE;
|
||
last_step_parm = false;
|
||
}
|
||
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;
|
||
omp_clause_linear_kind kind;
|
||
switch (n->u.linear_op)
|
||
{
|
||
case OMP_LINEAR_DEFAULT:
|
||
kind = OMP_CLAUSE_LINEAR_DEFAULT;
|
||
break;
|
||
case OMP_LINEAR_REF:
|
||
kind = OMP_CLAUSE_LINEAR_REF;
|
||
break;
|
||
case OMP_LINEAR_VAL:
|
||
kind = OMP_CLAUSE_LINEAR_VAL;
|
||
break;
|
||
case OMP_LINEAR_UVAL:
|
||
kind = OMP_CLAUSE_LINEAR_UVAL;
|
||
break;
|
||
default:
|
||
gcc_unreachable ();
|
||
}
|
||
OMP_CLAUSE_LINEAR_KIND (node) = kind;
|
||
if (last_step_expr && last_step == NULL_TREE)
|
||
{
|
||
if (!declare_simd)
|
||
{
|
||
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);
|
||
}
|
||
else if (last_step_expr->expr_type == EXPR_VARIABLE)
|
||
{
|
||
gfc_symbol *s = last_step_expr->symtree->n.sym;
|
||
last_step = gfc_trans_omp_variable (s, true);
|
||
last_step_parm = true;
|
||
}
|
||
else
|
||
last_step
|
||
= gfc_conv_constant_to_tree (last_step_expr);
|
||
}
|
||
if (last_step_parm)
|
||
{
|
||
OMP_CLAUSE_LINEAR_VARIABLE_STRIDE (node) = 1;
|
||
OMP_CLAUSE_LINEAR_STEP (node) = last_step;
|
||
}
|
||
else
|
||
{
|
||
if (kind == OMP_CLAUSE_LINEAR_REF)
|
||
{
|
||
tree type;
|
||
if (n->sym->attr.flavor == FL_PROCEDURE)
|
||
{
|
||
type = gfc_get_function_type (n->sym);
|
||
type = build_pointer_type (type);
|
||
}
|
||
else
|
||
type = gfc_sym_type (n->sym);
|
||
if (POINTER_TYPE_P (type))
|
||
type = TREE_TYPE (type);
|
||
/* Otherwise to be determined what exactly
|
||
should be done. */
|
||
tree t = fold_convert (sizetype, last_step);
|
||
t = size_binop (MULT_EXPR, t,
|
||
TYPE_SIZE_UNIT (type));
|
||
OMP_CLAUSE_LINEAR_STEP (node) = t;
|
||
}
|
||
else
|
||
{
|
||
tree type
|
||
= gfc_typenode_for_spec (&n->sym->ts);
|
||
OMP_CLAUSE_LINEAR_STEP (node)
|
||
= fold_convert (type, 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_AFFINITY:
|
||
case OMP_LIST_DEPEND:
|
||
iterator = NULL_TREE;
|
||
prev = NULL;
|
||
prev_clauses = omp_clauses;
|
||
for (; n != NULL; n = n->next)
|
||
{
|
||
if (iterator && prev->u2.ns != n->u2.ns)
|
||
{
|
||
BLOCK_SUBBLOCKS (tree_block) = gfc_finish_block (&iter_block);
|
||
TREE_VEC_ELT (iterator, 5) = tree_block;
|
||
for (tree c = omp_clauses; c != prev_clauses;
|
||
c = OMP_CLAUSE_CHAIN (c))
|
||
OMP_CLAUSE_DECL (c) = build_tree_list (iterator,
|
||
OMP_CLAUSE_DECL (c));
|
||
prev_clauses = omp_clauses;
|
||
iterator = NULL_TREE;
|
||
}
|
||
if (n->u2.ns && (!prev || prev->u2.ns != n->u2.ns))
|
||
{
|
||
gfc_init_block (&iter_block);
|
||
tree_block = make_node (BLOCK);
|
||
TREE_USED (tree_block) = 1;
|
||
BLOCK_VARS (tree_block) = NULL_TREE;
|
||
iterator = handle_iterator (n->u2.ns, block,
|
||
tree_block);
|
||
}
|
||
if (!iterator)
|
||
gfc_init_block (&iter_block);
|
||
prev = n;
|
||
if (list == OMP_LIST_DEPEND
|
||
&& n->u.depend_op == OMP_DEPEND_SINK_FIRST)
|
||
{
|
||
tree vec = NULL_TREE;
|
||
unsigned int i;
|
||
for (i = 0; ; i++)
|
||
{
|
||
tree addend = integer_zero_node, t;
|
||
bool neg = false;
|
||
if (n->expr)
|
||
{
|
||
addend = gfc_conv_constant_to_tree (n->expr);
|
||
if (TREE_CODE (addend) == INTEGER_CST
|
||
&& tree_int_cst_sgn (addend) == -1)
|
||
{
|
||
neg = true;
|
||
addend = const_unop (NEGATE_EXPR,
|
||
TREE_TYPE (addend), addend);
|
||
}
|
||
}
|
||
t = gfc_trans_omp_variable (n->sym, false);
|
||
if (t != error_mark_node)
|
||
{
|
||
if (i < vec_safe_length (doacross_steps)
|
||
&& !integer_zerop (addend)
|
||
&& (*doacross_steps)[i])
|
||
{
|
||
tree step = (*doacross_steps)[i];
|
||
addend = fold_convert (TREE_TYPE (step), addend);
|
||
addend = build2 (TRUNC_DIV_EXPR,
|
||
TREE_TYPE (step), addend, step);
|
||
}
|
||
vec = tree_cons (addend, t, vec);
|
||
if (neg)
|
||
OMP_CLAUSE_DEPEND_SINK_NEGATIVE (vec) = 1;
|
||
}
|
||
if (n->next == NULL
|
||
|| n->next->u.depend_op != OMP_DEPEND_SINK)
|
||
break;
|
||
n = n->next;
|
||
}
|
||
if (vec == NULL_TREE)
|
||
continue;
|
||
|
||
tree node = build_omp_clause (input_location,
|
||
OMP_CLAUSE_DEPEND);
|
||
OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_SINK;
|
||
OMP_CLAUSE_DECL (node) = nreverse (vec);
|
||
omp_clauses = gfc_trans_add_clause (node, omp_clauses);
|
||
continue;
|
||
}
|
||
|
||
if (!n->sym->attr.referenced)
|
||
continue;
|
||
|
||
tree node = build_omp_clause (input_location,
|
||
list == OMP_LIST_DEPEND
|
||
? OMP_CLAUSE_DEPEND
|
||
: OMP_CLAUSE_AFFINITY);
|
||
if (n->expr == NULL || n->expr->ref->u.ar.type == AR_FULL)
|
||
{
|
||
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)))
|
||
{
|
||
decl = gfc_conv_descriptor_data_get (decl);
|
||
gcc_assert (POINTER_TYPE_P (TREE_TYPE (decl)));
|
||
decl = build_fold_indirect_ref (decl);
|
||
}
|
||
else if (n->sym->attr.allocatable || n->sym->attr.pointer)
|
||
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 (&iter_block, &se.pre);
|
||
gfc_add_block_to_block (&iter_block, &se.post);
|
||
gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr)));
|
||
OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr);
|
||
}
|
||
if (list == OMP_LIST_DEPEND)
|
||
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;
|
||
case OMP_DEPEND_MUTEXINOUTSET:
|
||
OMP_CLAUSE_DEPEND_KIND (node)
|
||
= OMP_CLAUSE_DEPEND_MUTEXINOUTSET;
|
||
break;
|
||
case OMP_DEPEND_DEPOBJ:
|
||
OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_DEPOBJ;
|
||
break;
|
||
default:
|
||
gcc_unreachable ();
|
||
}
|
||
if (!iterator)
|
||
gfc_add_block_to_block (block, &iter_block);
|
||
omp_clauses = gfc_trans_add_clause (node, omp_clauses);
|
||
}
|
||
if (iterator)
|
||
{
|
||
BLOCK_SUBBLOCKS (tree_block) = gfc_finish_block (&iter_block);
|
||
TREE_VEC_ELT (iterator, 5) = tree_block;
|
||
for (tree c = omp_clauses; c != prev_clauses;
|
||
c = OMP_CLAUSE_CHAIN (c))
|
||
OMP_CLAUSE_DECL (c) = build_tree_list (iterator,
|
||
OMP_CLAUSE_DECL (c));
|
||
}
|
||
break;
|
||
case OMP_LIST_MAP:
|
||
for (; n != NULL; n = n->next)
|
||
{
|
||
if (!n->sym->attr.referenced)
|
||
continue;
|
||
|
||
bool always_modifier = false;
|
||
tree node = build_omp_clause (input_location, OMP_CLAUSE_MAP);
|
||
tree node2 = NULL_TREE;
|
||
tree node3 = NULL_TREE;
|
||
tree node4 = NULL_TREE;
|
||
|
||
/* OpenMP: automatically map pointer targets with the pointer;
|
||
hence, always update the descriptor/pointer itself. */
|
||
if (!openacc
|
||
&& ((n->expr == NULL && n->sym->attr.pointer)
|
||
|| (n->expr && gfc_expr_attr (n->expr).pointer)))
|
||
always_modifier = true;
|
||
|
||
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;
|
||
case OMP_MAP_FROM:
|
||
OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FROM);
|
||
break;
|
||
case OMP_MAP_TOFROM:
|
||
OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_TOFROM);
|
||
break;
|
||
case OMP_MAP_ALWAYS_TO:
|
||
always_modifier = true;
|
||
OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_TO);
|
||
break;
|
||
case OMP_MAP_ALWAYS_FROM:
|
||
always_modifier = true;
|
||
OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_FROM);
|
||
break;
|
||
case OMP_MAP_ALWAYS_TOFROM:
|
||
always_modifier = true;
|
||
OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_TOFROM);
|
||
break;
|
||
case OMP_MAP_RELEASE:
|
||
OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_RELEASE);
|
||
break;
|
||
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;
|
||
case OMP_MAP_FORCE_TO:
|
||
OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_TO);
|
||
break;
|
||
case OMP_MAP_FORCE_FROM:
|
||
OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_FROM);
|
||
break;
|
||
case OMP_MAP_FORCE_TOFROM:
|
||
OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_TOFROM);
|
||
break;
|
||
case OMP_MAP_FORCE_PRESENT:
|
||
OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_PRESENT);
|
||
break;
|
||
case OMP_MAP_FORCE_DEVICEPTR:
|
||
OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_DEVICEPTR);
|
||
break;
|
||
default:
|
||
gcc_unreachable ();
|
||
}
|
||
|
||
tree decl = gfc_trans_omp_variable (n->sym, false);
|
||
if (DECL_P (decl))
|
||
TREE_ADDRESSABLE (decl) = 1;
|
||
|
||
gfc_ref *lastref = NULL;
|
||
|
||
if (n->expr)
|
||
for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next)
|
||
if (ref->type == REF_COMPONENT || ref->type == REF_ARRAY)
|
||
lastref = ref;
|
||
|
||
bool allocatable = false, pointer = false;
|
||
|
||
if (lastref && lastref->type == REF_COMPONENT)
|
||
{
|
||
gfc_component *c = lastref->u.c.component;
|
||
|
||
if (c->ts.type == BT_CLASS)
|
||
{
|
||
pointer = CLASS_DATA (c)->attr.class_pointer;
|
||
allocatable = CLASS_DATA (c)->attr.allocatable;
|
||
}
|
||
else
|
||
{
|
||
pointer = c->attr.pointer;
|
||
allocatable = c->attr.allocatable;
|
||
}
|
||
}
|
||
|
||
if (n->expr == NULL
|
||
|| (n->expr->ref->type == REF_ARRAY
|
||
&& n->expr->ref->u.ar.type == AR_FULL))
|
||
{
|
||
tree present = gfc_omp_check_optional_argument (decl, true);
|
||
if (openacc && 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.cc 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
|
||
|| gfc_omp_is_optional_argument (orig_decl))
|
||
&& (GFC_DECL_GET_SCALAR_POINTER (orig_decl)
|
||
|| GFC_DECL_GET_SCALAR_ALLOCATABLE (orig_decl)))
|
||
{
|
||
node3 = build_omp_clause (input_location,
|
||
OMP_CLAUSE_MAP);
|
||
OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_POINTER);
|
||
OMP_CLAUSE_DECL (node3) = decl;
|
||
OMP_CLAUSE_SIZE (node3) = 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);
|
||
if (present)
|
||
ptr = gfc_build_cond_assign_expr (block, present, ptr,
|
||
null_pointer_node);
|
||
gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr)));
|
||
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) = decl;
|
||
OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type);
|
||
node3 = build_omp_clause (input_location,
|
||
OMP_CLAUSE_MAP);
|
||
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);
|
||
if (n->u.map_op == OMP_MAP_ATTACH)
|
||
{
|
||
/* Standalone attach clauses used with arrays with
|
||
descriptors must copy the descriptor to the target,
|
||
else they won't have anything to perform the
|
||
attachment onto (see OpenACC 2.6, "2.6.3. Data
|
||
Structures with Pointers"). */
|
||
OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_ATTACH);
|
||
/* We don't want to map PTR at all in this case, so
|
||
delete its node and shuffle the others down. */
|
||
node = node2;
|
||
node2 = node3;
|
||
node3 = NULL;
|
||
goto finalize_map_clause;
|
||
}
|
||
else if (n->u.map_op == OMP_MAP_DETACH)
|
||
{
|
||
OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_DETACH);
|
||
/* Similarly to above, we don't want to unmap PTR
|
||
here. */
|
||
node = node2;
|
||
node2 = node3;
|
||
node3 = NULL;
|
||
goto finalize_map_clause;
|
||
}
|
||
else
|
||
OMP_CLAUSE_SET_MAP_KIND (node3,
|
||
always_modifier
|
||
? GOMP_MAP_ALWAYS_POINTER
|
||
: GOMP_MAP_POINTER);
|
||
|
||
/* We have to check for n->sym->attr.dimension because
|
||
of scalar coarrays. */
|
||
if ((n->sym->attr.pointer || n->sym->attr.allocatable)
|
||
&& n->sym->attr.dimension)
|
||
{
|
||
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);
|
||
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));
|
||
OMP_CLAUSE_SIZE (node) = size;
|
||
}
|
||
else if (n->sym->attr.dimension)
|
||
{
|
||
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
|
||
= 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 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 if (n->expr
|
||
&& n->expr->expr_type == EXPR_VARIABLE
|
||
&& n->expr->ref->type == REF_ARRAY
|
||
&& !n->expr->ref->next)
|
||
{
|
||
/* An array element or array section which is not part of a
|
||
derived type, etc. */
|
||
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);
|
||
}
|
||
else if (n->expr
|
||
&& n->expr->expr_type == EXPR_VARIABLE
|
||
&& (n->expr->ref->type == REF_COMPONENT
|
||
|| n->expr->ref->type == REF_ARRAY)
|
||
&& lastref
|
||
&& lastref->type == REF_COMPONENT
|
||
&& lastref->u.c.component->ts.type != BT_CLASS
|
||
&& lastref->u.c.component->ts.type != BT_DERIVED
|
||
&& !lastref->u.c.component->attr.dimension)
|
||
{
|
||
/* Derived type access with last component being a scalar. */
|
||
gfc_init_se (&se, NULL);
|
||
|
||
gfc_conv_expr (&se, n->expr);
|
||
gfc_add_block_to_block (block, &se.pre);
|
||
/* For BT_CHARACTER a pointer is returned. */
|
||
OMP_CLAUSE_DECL (node)
|
||
= POINTER_TYPE_P (TREE_TYPE (se.expr))
|
||
? build_fold_indirect_ref (se.expr) : se.expr;
|
||
gfc_add_block_to_block (block, &se.post);
|
||
if (pointer || allocatable)
|
||
{
|
||
node2 = build_omp_clause (input_location,
|
||
OMP_CLAUSE_MAP);
|
||
gomp_map_kind kind
|
||
= (openacc ? GOMP_MAP_ATTACH_DETACH
|
||
: GOMP_MAP_ALWAYS_POINTER);
|
||
OMP_CLAUSE_SET_MAP_KIND (node2, kind);
|
||
OMP_CLAUSE_DECL (node2)
|
||
= POINTER_TYPE_P (TREE_TYPE (se.expr))
|
||
? se.expr
|
||
: gfc_build_addr_expr (NULL, se.expr);
|
||
OMP_CLAUSE_SIZE (node2) = size_int (0);
|
||
if (!openacc
|
||
&& n->expr->ts.type == BT_CHARACTER
|
||
&& n->expr->ts.deferred)
|
||
{
|
||
gcc_assert (se.string_length);
|
||
tree tmp
|
||
= gfc_get_char_type (n->expr->ts.kind);
|
||
OMP_CLAUSE_SIZE (node)
|
||
= fold_build2 (MULT_EXPR, size_type_node,
|
||
fold_convert (size_type_node,
|
||
se.string_length),
|
||
TYPE_SIZE_UNIT (tmp));
|
||
node3 = build_omp_clause (input_location,
|
||
OMP_CLAUSE_MAP);
|
||
OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_TO);
|
||
OMP_CLAUSE_DECL (node3) = se.string_length;
|
||
OMP_CLAUSE_SIZE (node3)
|
||
= TYPE_SIZE_UNIT (gfc_charlen_type_node);
|
||
}
|
||
}
|
||
}
|
||
else if (n->expr
|
||
&& n->expr->expr_type == EXPR_VARIABLE
|
||
&& (n->expr->ref->type == REF_COMPONENT
|
||
|| n->expr->ref->type == REF_ARRAY))
|
||
{
|
||
gfc_init_se (&se, NULL);
|
||
se.expr = gfc_maybe_dereference_var (n->sym, decl);
|
||
|
||
for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next)
|
||
{
|
||
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 if (ref->type == REF_ARRAY)
|
||
{
|
||
if (ref->u.ar.type == AR_ELEMENT && ref->next)
|
||
gfc_conv_array_ref (&se, &ref->u.ar, n->expr,
|
||
&n->expr->where);
|
||
else
|
||
gcc_assert (!ref->next);
|
||
}
|
||
else
|
||
sorry ("unhandled expression type");
|
||
}
|
||
|
||
tree inner = se.expr;
|
||
|
||
/* Last component is a derived type or class pointer. */
|
||
if (lastref->type == REF_COMPONENT
|
||
&& (lastref->u.c.component->ts.type == BT_DERIVED
|
||
|| lastref->u.c.component->ts.type == BT_CLASS))
|
||
{
|
||
if (pointer || (openacc && allocatable))
|
||
{
|
||
tree data, size;
|
||
|
||
if (lastref->u.c.component->ts.type == BT_CLASS)
|
||
{
|
||
data = gfc_class_data_get (inner);
|
||
gcc_assert (POINTER_TYPE_P (TREE_TYPE (data)));
|
||
data = build_fold_indirect_ref (data);
|
||
size = gfc_class_vtab_size_get (inner);
|
||
}
|
||
else /* BT_DERIVED. */
|
||
{
|
||
data = inner;
|
||
size = TYPE_SIZE_UNIT (TREE_TYPE (inner));
|
||
}
|
||
|
||
OMP_CLAUSE_DECL (node) = data;
|
||
OMP_CLAUSE_SIZE (node) = size;
|
||
node2 = build_omp_clause (input_location,
|
||
OMP_CLAUSE_MAP);
|
||
OMP_CLAUSE_SET_MAP_KIND (node2,
|
||
openacc
|
||
? GOMP_MAP_ATTACH_DETACH
|
||
: GOMP_MAP_ALWAYS_POINTER);
|
||
OMP_CLAUSE_DECL (node2) = build_fold_addr_expr (data);
|
||
OMP_CLAUSE_SIZE (node2) = size_int (0);
|
||
}
|
||
else
|
||
{
|
||
OMP_CLAUSE_DECL (node) = inner;
|
||
OMP_CLAUSE_SIZE (node)
|
||
= TYPE_SIZE_UNIT (TREE_TYPE (inner));
|
||
}
|
||
}
|
||
else if (lastref->type == REF_ARRAY
|
||
&& lastref->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;
|
||
}
|
||
|
||
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (inner)))
|
||
{
|
||
gomp_map_kind map_kind;
|
||
tree desc_node;
|
||
tree type = TREE_TYPE (inner);
|
||
tree ptr = gfc_conv_descriptor_data_get (inner);
|
||
ptr = build_fold_indirect_ref (ptr);
|
||
OMP_CLAUSE_DECL (node) = ptr;
|
||
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));
|
||
if (GOMP_MAP_COPY_TO_P (OMP_CLAUSE_MAP_KIND (node)))
|
||
map_kind = GOMP_MAP_TO;
|
||
else if (n->u.map_op == OMP_MAP_RELEASE
|
||
|| n->u.map_op == OMP_MAP_DELETE)
|
||
map_kind = OMP_CLAUSE_MAP_KIND (node);
|
||
else
|
||
map_kind = GOMP_MAP_ALLOC;
|
||
if (!openacc
|
||
&& n->expr->ts.type == BT_CHARACTER
|
||
&& n->expr->ts.deferred)
|
||
{
|
||
gcc_assert (se.string_length);
|
||
tree len = fold_convert (size_type_node,
|
||
se.string_length);
|
||
elemsz = gfc_get_char_type (n->expr->ts.kind);
|
||
elemsz = TYPE_SIZE_UNIT (elemsz);
|
||
elemsz = fold_build2 (MULT_EXPR, size_type_node,
|
||
len, elemsz);
|
||
node4 = build_omp_clause (input_location,
|
||
OMP_CLAUSE_MAP);
|
||
OMP_CLAUSE_SET_MAP_KIND (node4, map_kind);
|
||
OMP_CLAUSE_DECL (node4) = se.string_length;
|
||
OMP_CLAUSE_SIZE (node4)
|
||
= TYPE_SIZE_UNIT (gfc_charlen_type_node);
|
||
}
|
||
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);
|
||
desc_node = build_omp_clause (input_location,
|
||
OMP_CLAUSE_MAP);
|
||
if (openacc)
|
||
OMP_CLAUSE_SET_MAP_KIND (desc_node,
|
||
GOMP_MAP_TO_PSET);
|
||
else
|
||
OMP_CLAUSE_SET_MAP_KIND (desc_node, map_kind);
|
||
OMP_CLAUSE_DECL (desc_node) = inner;
|
||
OMP_CLAUSE_SIZE (desc_node) = TYPE_SIZE_UNIT (type);
|
||
if (openacc)
|
||
node2 = desc_node;
|
||
else
|
||
{
|
||
node2 = node;
|
||
node = desc_node; /* Put first. */
|
||
}
|
||
node3 = build_omp_clause (input_location,
|
||
OMP_CLAUSE_MAP);
|
||
OMP_CLAUSE_SET_MAP_KIND (node3,
|
||
openacc
|
||
? GOMP_MAP_ATTACH_DETACH
|
||
: GOMP_MAP_ALWAYS_POINTER);
|
||
OMP_CLAUSE_DECL (node3)
|
||
= gfc_conv_descriptor_data_get (inner);
|
||
/* Similar to gfc_trans_omp_array_section (details
|
||
there), we add/keep the cast for OpenMP to prevent
|
||
that an 'alloc:' gets added for node3 ('desc.data')
|
||
as that is part of the whole descriptor (node3).
|
||
TODO: Remove once the ME handles this properly. */
|
||
if (!openacc)
|
||
OMP_CLAUSE_DECL (node3)
|
||
= fold_convert (TREE_TYPE (TREE_OPERAND(ptr, 0)),
|
||
OMP_CLAUSE_DECL (node3));
|
||
else
|
||
STRIP_NOPS (OMP_CLAUSE_DECL (node3));
|
||
OMP_CLAUSE_SIZE (node3) = size_int (0);
|
||
}
|
||
else
|
||
OMP_CLAUSE_DECL (node) = inner;
|
||
}
|
||
else if (lastref->type == REF_ARRAY)
|
||
{
|
||
/* An array element or section. */
|
||
bool element = lastref->u.ar.type == AR_ELEMENT;
|
||
gomp_map_kind kind = (openacc ? GOMP_MAP_ATTACH_DETACH
|
||
: GOMP_MAP_ALWAYS_POINTER);
|
||
gfc_trans_omp_array_section (block, n, inner, element,
|
||
kind, node, node2, node3,
|
||
node4);
|
||
}
|
||
else
|
||
gcc_unreachable ();
|
||
}
|
||
else
|
||
sorry ("unhandled expression");
|
||
|
||
finalize_map_clause:
|
||
|
||
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:
|
||
case OMP_LIST_CACHE:
|
||
for (; n != NULL; n = n->next)
|
||
{
|
||
if (!n->sym->attr.referenced)
|
||
continue;
|
||
|
||
switch (list)
|
||
{
|
||
case OMP_LIST_TO:
|
||
clause_code = OMP_CLAUSE_TO;
|
||
break;
|
||
case OMP_LIST_FROM:
|
||
clause_code = OMP_CLAUSE_FROM;
|
||
break;
|
||
case OMP_LIST_CACHE:
|
||
clause_code = OMP_CLAUSE__CACHE_;
|
||
break;
|
||
default:
|
||
gcc_unreachable ();
|
||
}
|
||
tree node = build_omp_clause (input_location, clause_code);
|
||
if (n->expr == NULL || n->expr->ref->u.ar.type == AR_FULL)
|
||
{
|
||
tree decl = gfc_trans_omp_variable (n->sym, false);
|
||
if (gfc_omp_privatize_by_reference (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)))
|
||
{
|
||
tree type = TREE_TYPE (decl);
|
||
tree ptr = gfc_conv_descriptor_data_get (decl);
|
||
gcc_assert (POINTER_TYPE_P (TREE_TYPE (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;
|
||
if (gfc_omp_is_allocatable_or_ptr (decl))
|
||
OMP_CLAUSE_SIZE (node)
|
||
= TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (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);
|
||
gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr)));
|
||
OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr);
|
||
}
|
||
omp_clauses = gfc_trans_add_clause (node, omp_clauses);
|
||
}
|
||
break;
|
||
default:
|
||
break;
|
||
}
|
||
}
|
||
|
||
if (clauses->if_expr)
|
||
{
|
||
tree if_var;
|
||
|
||
gfc_init_se (&se, NULL);
|
||
gfc_conv_expr (&se, clauses->if_expr);
|
||
gfc_add_block_to_block (block, &se.pre);
|
||
if_var = gfc_evaluate_now (se.expr, block);
|
||
gfc_add_block_to_block (block, &se.post);
|
||
|
||
c = build_omp_clause (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);
|
||
}
|
||
for (ifc = 0; ifc < OMP_IF_LAST; ifc++)
|
||
if (clauses->if_exprs[ifc])
|
||
{
|
||
tree if_var;
|
||
|
||
gfc_init_se (&se, NULL);
|
||
gfc_conv_expr (&se, clauses->if_exprs[ifc]);
|
||
gfc_add_block_to_block (block, &se.pre);
|
||
if_var = gfc_evaluate_now (se.expr, block);
|
||
gfc_add_block_to_block (block, &se.post);
|
||
|
||
c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_IF);
|
||
switch (ifc)
|
||
{
|
||
case OMP_IF_CANCEL:
|
||
OMP_CLAUSE_IF_MODIFIER (c) = VOID_CST;
|
||
break;
|
||
case OMP_IF_PARALLEL:
|
||
OMP_CLAUSE_IF_MODIFIER (c) = OMP_PARALLEL;
|
||
break;
|
||
case OMP_IF_SIMD:
|
||
OMP_CLAUSE_IF_MODIFIER (c) = OMP_SIMD;
|
||
break;
|
||
case OMP_IF_TASK:
|
||
OMP_CLAUSE_IF_MODIFIER (c) = OMP_TASK;
|
||
break;
|
||
case OMP_IF_TASKLOOP:
|
||
OMP_CLAUSE_IF_MODIFIER (c) = OMP_TASKLOOP;
|
||
break;
|
||
case OMP_IF_TARGET:
|
||
OMP_CLAUSE_IF_MODIFIER (c) = OMP_TARGET;
|
||
break;
|
||
case OMP_IF_TARGET_DATA:
|
||
OMP_CLAUSE_IF_MODIFIER (c) = OMP_TARGET_DATA;
|
||
break;
|
||
case OMP_IF_TARGET_UPDATE:
|
||
OMP_CLAUSE_IF_MODIFIER (c) = OMP_TARGET_UPDATE;
|
||
break;
|
||
case OMP_IF_TARGET_ENTER_DATA:
|
||
OMP_CLAUSE_IF_MODIFIER (c) = OMP_TARGET_ENTER_DATA;
|
||
break;
|
||
case OMP_IF_TARGET_EXIT_DATA:
|
||
OMP_CLAUSE_IF_MODIFIER (c) = OMP_TARGET_EXIT_DATA;
|
||
break;
|
||
default:
|
||
gcc_unreachable ();
|
||
}
|
||
OMP_CLAUSE_IF_EXPR (c) = if_var;
|
||
omp_clauses = gfc_trans_add_clause (c, omp_clauses);
|
||
}
|
||
|
||
if (clauses->final_expr)
|
||
{
|
||
tree final_var;
|
||
|
||
gfc_init_se (&se, NULL);
|
||
gfc_conv_expr (&se, clauses->final_expr);
|
||
gfc_add_block_to_block (block, &se.pre);
|
||
final_var = gfc_evaluate_now (se.expr, block);
|
||
gfc_add_block_to_block (block, &se.post);
|
||
|
||
c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_FINAL);
|
||
OMP_CLAUSE_FINAL_EXPR (c) = final_var;
|
||
omp_clauses = gfc_trans_add_clause (c, omp_clauses);
|
||
}
|
||
|
||
if (clauses->num_threads)
|
||
{
|
||
tree num_threads;
|
||
|
||
gfc_init_se (&se, NULL);
|
||
gfc_conv_expr (&se, clauses->num_threads);
|
||
gfc_add_block_to_block (block, &se.pre);
|
||
num_threads = gfc_evaluate_now (se.expr, block);
|
||
gfc_add_block_to_block (block, &se.post);
|
||
|
||
c = build_omp_clause (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);
|
||
}
|
||
|
||
chunk_size = NULL_TREE;
|
||
if (clauses->chunk_size)
|
||
{
|
||
gfc_init_se (&se, NULL);
|
||
gfc_conv_expr (&se, clauses->chunk_size);
|
||
gfc_add_block_to_block (block, &se.pre);
|
||
chunk_size = gfc_evaluate_now (se.expr, block);
|
||
gfc_add_block_to_block (block, &se.post);
|
||
}
|
||
|
||
if (clauses->sched_kind != OMP_SCHED_NONE)
|
||
{
|
||
c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SCHEDULE);
|
||
OMP_CLAUSE_SCHEDULE_CHUNK_EXPR (c) = chunk_size;
|
||
switch (clauses->sched_kind)
|
||
{
|
||
case OMP_SCHED_STATIC:
|
||
OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_STATIC;
|
||
break;
|
||
case OMP_SCHED_DYNAMIC:
|
||
OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_DYNAMIC;
|
||
break;
|
||
case OMP_SCHED_GUIDED:
|
||
OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_GUIDED;
|
||
break;
|
||
case OMP_SCHED_RUNTIME:
|
||
OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_RUNTIME;
|
||
break;
|
||
case OMP_SCHED_AUTO:
|
||
OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_AUTO;
|
||
break;
|
||
default:
|
||
gcc_unreachable ();
|
||
}
|
||
if (clauses->sched_monotonic)
|
||
OMP_CLAUSE_SCHEDULE_KIND (c)
|
||
= (omp_clause_schedule_kind) (OMP_CLAUSE_SCHEDULE_KIND (c)
|
||
| OMP_CLAUSE_SCHEDULE_MONOTONIC);
|
||
else if (clauses->sched_nonmonotonic)
|
||
OMP_CLAUSE_SCHEDULE_KIND (c)
|
||
= (omp_clause_schedule_kind) (OMP_CLAUSE_SCHEDULE_KIND (c)
|
||
| OMP_CLAUSE_SCHEDULE_NONMONOTONIC);
|
||
if (clauses->sched_simd)
|
||
OMP_CLAUSE_SCHEDULE_SIMD (c) = 1;
|
||
omp_clauses = gfc_trans_add_clause (c, omp_clauses);
|
||
}
|
||
|
||
if (clauses->default_sharing != OMP_DEFAULT_UNKNOWN)
|
||
{
|
||
c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_DEFAULT);
|
||
switch (clauses->default_sharing)
|
||
{
|
||
case OMP_DEFAULT_NONE:
|
||
OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_NONE;
|
||
break;
|
||
case OMP_DEFAULT_SHARED:
|
||
OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_SHARED;
|
||
break;
|
||
case OMP_DEFAULT_PRIVATE:
|
||
OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_PRIVATE;
|
||
break;
|
||
case OMP_DEFAULT_FIRSTPRIVATE:
|
||
OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_FIRSTPRIVATE;
|
||
break;
|
||
case OMP_DEFAULT_PRESENT:
|
||
OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_PRESENT;
|
||
break;
|
||
default:
|
||
gcc_unreachable ();
|
||
}
|
||
omp_clauses = gfc_trans_add_clause (c, omp_clauses);
|
||
}
|
||
|
||
if (clauses->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 (gfc_get_location (&where), OMP_CLAUSE_ORDERED);
|
||
OMP_CLAUSE_ORDERED_EXPR (c)
|
||
= clauses->orderedc ? build_int_cst (integer_type_node,
|
||
clauses->orderedc) : NULL_TREE;
|
||
omp_clauses = gfc_trans_add_clause (c, omp_clauses);
|
||
}
|
||
|
||
if (clauses->order_concurrent)
|
||
{
|
||
c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_ORDER);
|
||
OMP_CLAUSE_ORDER_UNCONSTRAINED (c) = clauses->order_unconstrained;
|
||
OMP_CLAUSE_ORDER_REPRODUCIBLE (c) = clauses->order_reproducible;
|
||
omp_clauses = gfc_trans_add_clause (c, omp_clauses);
|
||
}
|
||
|
||
if (clauses->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 (gfc_get_location (&where), OMP_CLAUSE_MERGEABLE);
|
||
omp_clauses = gfc_trans_add_clause (c, omp_clauses);
|
||
}
|
||
|
||
if (clauses->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);
|
||
}
|
||
|
||
if (clauses->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 (gfc_get_location (&where), 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 (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 (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 (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 (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 (gfc_get_location (&where), OMP_CLAUSE_PROC_BIND);
|
||
switch (clauses->proc_bind)
|
||
{
|
||
case OMP_PROC_BIND_PRIMARY:
|
||
OMP_CLAUSE_PROC_BIND_KIND (c) = OMP_CLAUSE_PROC_BIND_PRIMARY;
|
||
break;
|
||
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 (gfc_get_location (&where), OMP_CLAUSE_SAFELEN);
|
||
OMP_CLAUSE_SAFELEN_EXPR (c) = safelen_var;
|
||
omp_clauses = gfc_trans_add_clause (c, omp_clauses);
|
||
}
|
||
|
||
if (clauses->simdlen_expr)
|
||
{
|
||
if (declare_simd)
|
||
{
|
||
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);
|
||
}
|
||
else
|
||
{
|
||
tree simdlen_var;
|
||
|
||
gfc_init_se (&se, NULL);
|
||
gfc_conv_expr (&se, clauses->simdlen_expr);
|
||
gfc_add_block_to_block (block, &se.pre);
|
||
simdlen_var = gfc_evaluate_now (se.expr, block);
|
||
gfc_add_block_to_block (block, &se.post);
|
||
|
||
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);
|
||
}
|
||
}
|
||
|
||
if (clauses->num_teams_upper)
|
||
{
|
||
tree num_teams_lower = NULL_TREE, num_teams_upper;
|
||
|
||
gfc_init_se (&se, NULL);
|
||
gfc_conv_expr (&se, clauses->num_teams_upper);
|
||
gfc_add_block_to_block (block, &se.pre);
|
||
num_teams_upper = gfc_evaluate_now (se.expr, block);
|
||
gfc_add_block_to_block (block, &se.post);
|
||
|
||
if (clauses->num_teams_lower)
|
||
{
|
||
gfc_init_se (&se, NULL);
|
||
gfc_conv_expr (&se, clauses->num_teams_lower);
|
||
gfc_add_block_to_block (block, &se.pre);
|
||
num_teams_lower = gfc_evaluate_now (se.expr, block);
|
||
gfc_add_block_to_block (block, &se.post);
|
||
}
|
||
c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NUM_TEAMS);
|
||
OMP_CLAUSE_NUM_TEAMS_LOWER_EXPR (c) = num_teams_lower;
|
||
OMP_CLAUSE_NUM_TEAMS_UPPER_EXPR (c) = num_teams_upper;
|
||
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 (gfc_get_location (&where), OMP_CLAUSE_DEVICE);
|
||
OMP_CLAUSE_DEVICE_ID (c) = device;
|
||
|
||
if (clauses->ancestor)
|
||
OMP_CLAUSE_DEVICE_ANCESTOR (c) = 1;
|
||
|
||
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 (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);
|
||
}
|
||
|
||
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 (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);
|
||
}
|
||
|
||
if (clauses->grainsize)
|
||
{
|
||
tree grainsize;
|
||
|
||
gfc_init_se (&se, NULL);
|
||
gfc_conv_expr (&se, clauses->grainsize);
|
||
gfc_add_block_to_block (block, &se.pre);
|
||
grainsize = gfc_evaluate_now (se.expr, block);
|
||
gfc_add_block_to_block (block, &se.post);
|
||
|
||
c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_GRAINSIZE);
|
||
OMP_CLAUSE_GRAINSIZE_EXPR (c) = grainsize;
|
||
if (clauses->grainsize_strict)
|
||
OMP_CLAUSE_GRAINSIZE_STRICT (c) = 1;
|
||
omp_clauses = gfc_trans_add_clause (c, omp_clauses);
|
||
}
|
||
|
||
if (clauses->num_tasks)
|
||
{
|
||
tree num_tasks;
|
||
|
||
gfc_init_se (&se, NULL);
|
||
gfc_conv_expr (&se, clauses->num_tasks);
|
||
gfc_add_block_to_block (block, &se.pre);
|
||
num_tasks = gfc_evaluate_now (se.expr, block);
|
||
gfc_add_block_to_block (block, &se.post);
|
||
|
||
c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NUM_TASKS);
|
||
OMP_CLAUSE_NUM_TASKS_EXPR (c) = num_tasks;
|
||
if (clauses->num_tasks_strict)
|
||
OMP_CLAUSE_NUM_TASKS_STRICT (c) = 1;
|
||
omp_clauses = gfc_trans_add_clause (c, omp_clauses);
|
||
}
|
||
|
||
if (clauses->priority)
|
||
{
|
||
tree priority;
|
||
|
||
gfc_init_se (&se, NULL);
|
||
gfc_conv_expr (&se, clauses->priority);
|
||
gfc_add_block_to_block (block, &se.pre);
|
||
priority = gfc_evaluate_now (se.expr, block);
|
||
gfc_add_block_to_block (block, &se.post);
|
||
|
||
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);
|
||
}
|
||
|
||
if (clauses->detach)
|
||
{
|
||
tree detach;
|
||
|
||
gfc_init_se (&se, NULL);
|
||
gfc_conv_expr (&se, clauses->detach);
|
||
gfc_add_block_to_block (block, &se.pre);
|
||
detach = se.expr;
|
||
gfc_add_block_to_block (block, &se.post);
|
||
|
||
c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_DETACH);
|
||
TREE_ADDRESSABLE (detach) = 1;
|
||
OMP_CLAUSE_DECL (c) = detach;
|
||
omp_clauses = gfc_trans_add_clause (c, omp_clauses);
|
||
}
|
||
|
||
if (clauses->filter)
|
||
{
|
||
tree filter;
|
||
|
||
gfc_init_se (&se, NULL);
|
||
gfc_conv_expr (&se, clauses->filter);
|
||
gfc_add_block_to_block (block, &se.pre);
|
||
filter = gfc_evaluate_now (se.expr, block);
|
||
gfc_add_block_to_block (block, &se.post);
|
||
|
||
c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_FILTER);
|
||
OMP_CLAUSE_FILTER_EXPR (c) = filter;
|
||
omp_clauses = gfc_trans_add_clause (c, omp_clauses);
|
||
}
|
||
|
||
if (clauses->hint)
|
||
{
|
||
tree hint;
|
||
|
||
gfc_init_se (&se, NULL);
|
||
gfc_conv_expr (&se, clauses->hint);
|
||
gfc_add_block_to_block (block, &se.pre);
|
||
hint = gfc_evaluate_now (se.expr, block);
|
||
gfc_add_block_to_block (block, &se.post);
|
||
|
||
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 (gfc_get_location (&where), OMP_CLAUSE_SIMD);
|
||
omp_clauses = gfc_trans_add_clause (c, omp_clauses);
|
||
}
|
||
if (clauses->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 (gfc_get_location (&where), OMP_CLAUSE_NOGROUP);
|
||
omp_clauses = gfc_trans_add_clause (c, omp_clauses);
|
||
}
|
||
|
||
for (int i = 0; i < OMP_DEFAULTMAP_CAT_NUM; i++)
|
||
{
|
||
if (clauses->defaultmap[i] == OMP_DEFAULTMAP_UNSET)
|
||
continue;
|
||
enum omp_clause_defaultmap_kind behavior, category;
|
||
switch ((gfc_omp_defaultmap_category) i)
|
||
{
|
||
case OMP_DEFAULTMAP_CAT_UNCATEGORIZED:
|
||
category = OMP_CLAUSE_DEFAULTMAP_CATEGORY_UNSPECIFIED;
|
||
break;
|
||
case OMP_DEFAULTMAP_CAT_SCALAR:
|
||
category = OMP_CLAUSE_DEFAULTMAP_CATEGORY_SCALAR;
|
||
break;
|
||
case OMP_DEFAULTMAP_CAT_AGGREGATE:
|
||
category = OMP_CLAUSE_DEFAULTMAP_CATEGORY_AGGREGATE;
|
||
break;
|
||
case OMP_DEFAULTMAP_CAT_ALLOCATABLE:
|
||
category = OMP_CLAUSE_DEFAULTMAP_CATEGORY_ALLOCATABLE;
|
||
break;
|
||
case OMP_DEFAULTMAP_CAT_POINTER:
|
||
category = OMP_CLAUSE_DEFAULTMAP_CATEGORY_POINTER;
|
||
break;
|
||
default: gcc_unreachable ();
|
||
}
|
||
switch (clauses->defaultmap[i])
|
||
{
|
||
case OMP_DEFAULTMAP_ALLOC:
|
||
behavior = OMP_CLAUSE_DEFAULTMAP_ALLOC;
|
||
break;
|
||
case OMP_DEFAULTMAP_TO: behavior = OMP_CLAUSE_DEFAULTMAP_TO; break;
|
||
case OMP_DEFAULTMAP_FROM: behavior = OMP_CLAUSE_DEFAULTMAP_FROM; break;
|
||
case OMP_DEFAULTMAP_TOFROM:
|
||
behavior = OMP_CLAUSE_DEFAULTMAP_TOFROM;
|
||
break;
|
||
case OMP_DEFAULTMAP_FIRSTPRIVATE:
|
||
behavior = OMP_CLAUSE_DEFAULTMAP_FIRSTPRIVATE;
|
||
break;
|
||
case OMP_DEFAULTMAP_NONE: behavior = OMP_CLAUSE_DEFAULTMAP_NONE; break;
|
||
case OMP_DEFAULTMAP_DEFAULT:
|
||
behavior = OMP_CLAUSE_DEFAULTMAP_DEFAULT;
|
||
break;
|
||
default: gcc_unreachable ();
|
||
}
|
||
c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_DEFAULTMAP);
|
||
OMP_CLAUSE_DEFAULTMAP_SET_KIND (c, behavior, category);
|
||
omp_clauses = gfc_trans_add_clause (c, omp_clauses);
|
||
}
|
||
|
||
if (clauses->depend_source)
|
||
{
|
||
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 (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);
|
||
else
|
||
OMP_CLAUSE_ASYNC_EXPR (c) = NULL;
|
||
omp_clauses = gfc_trans_add_clause (c, omp_clauses);
|
||
}
|
||
if (clauses->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 (gfc_get_location (&where), OMP_CLAUSE_AUTO);
|
||
omp_clauses = gfc_trans_add_clause (c, omp_clauses);
|
||
}
|
||
if (clauses->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 (gfc_get_location (&where), OMP_CLAUSE_FINALIZE);
|
||
omp_clauses = gfc_trans_add_clause (c, omp_clauses);
|
||
}
|
||
if (clauses->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)
|
||
{
|
||
gfc_expr_list *el;
|
||
|
||
for (el = clauses->wait_list; el; el = el->next)
|
||
{
|
||
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;
|
||
}
|
||
}
|
||
if (clauses->num_gangs_expr)
|
||
{
|
||
tree num_gangs_var
|
||
= gfc_convert_expr_to_tree (block, clauses->num_gangs_expr);
|
||
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);
|
||
}
|
||
if (clauses->num_workers_expr)
|
||
{
|
||
tree num_workers_var
|
||
= gfc_convert_expr_to_tree (block, clauses->num_workers_expr);
|
||
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);
|
||
}
|
||
if (clauses->vector_length_expr)
|
||
{
|
||
tree vector_length_var
|
||
= gfc_convert_expr_to_tree (block, clauses->vector_length_expr);
|
||
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);
|
||
}
|
||
if (clauses->tile_list)
|
||
{
|
||
vec<tree, va_gc> *tvec;
|
||
gfc_expr_list *el;
|
||
|
||
vec_alloc (tvec, 4);
|
||
|
||
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 (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);
|
||
}
|
||
if (clauses->vector)
|
||
{
|
||
c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_VECTOR);
|
||
omp_clauses = gfc_trans_add_clause (c, omp_clauses);
|
||
|
||
if (clauses->vector_expr)
|
||
{
|
||
tree vector_var
|
||
= gfc_convert_expr_to_tree (block, clauses->vector_expr);
|
||
OMP_CLAUSE_VECTOR_EXPR (c) = vector_var;
|
||
|
||
/* TODO: We're not capturing location information for individual
|
||
clauses. However, if we have an expression attached to the
|
||
clause, that one provides better location information. */
|
||
OMP_CLAUSE_LOCATION (c)
|
||
= gfc_get_location (&clauses->vector_expr->where);
|
||
}
|
||
}
|
||
if (clauses->worker)
|
||
{
|
||
c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_WORKER);
|
||
omp_clauses = gfc_trans_add_clause (c, omp_clauses);
|
||
|
||
if (clauses->worker_expr)
|
||
{
|
||
tree worker_var
|
||
= gfc_convert_expr_to_tree (block, clauses->worker_expr);
|
||
OMP_CLAUSE_WORKER_EXPR (c) = worker_var;
|
||
|
||
/* TODO: We're not capturing location information for individual
|
||
clauses. However, if we have an expression attached to the
|
||
clause, that one provides better location information. */
|
||
OMP_CLAUSE_LOCATION (c)
|
||
= gfc_get_location (&clauses->worker_expr->where);
|
||
}
|
||
}
|
||
if (clauses->gang)
|
||
{
|
||
tree arg;
|
||
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)
|
||
{
|
||
arg = gfc_convert_expr_to_tree (block, clauses->gang_num_expr);
|
||
OMP_CLAUSE_GANG_EXPR (c) = arg;
|
||
|
||
/* TODO: We're not capturing location information for individual
|
||
clauses. However, if we have an expression attached to the
|
||
clause, that one provides better location information. */
|
||
OMP_CLAUSE_LOCATION (c)
|
||
= gfc_get_location (&clauses->gang_num_expr->where);
|
||
}
|
||
|
||
if (clauses->gang_static)
|
||
{
|
||
arg = clauses->gang_static_expr
|
||
? gfc_convert_expr_to_tree (block, clauses->gang_static_expr)
|
||
: integer_minus_one_node;
|
||
OMP_CLAUSE_GANG_STATIC_EXPR (c) = arg;
|
||
}
|
||
}
|
||
if (clauses->bind != OMP_BIND_UNSET)
|
||
{
|
||
c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_BIND);
|
||
omp_clauses = gfc_trans_add_clause (c, omp_clauses);
|
||
switch (clauses->bind)
|
||
{
|
||
case OMP_BIND_TEAMS:
|
||
OMP_CLAUSE_BIND_KIND (c) = OMP_CLAUSE_BIND_TEAMS;
|
||
break;
|
||
case OMP_BIND_PARALLEL:
|
||
OMP_CLAUSE_BIND_KIND (c) = OMP_CLAUSE_BIND_PARALLEL;
|
||
break;
|
||
case OMP_BIND_THREAD:
|
||
OMP_CLAUSE_BIND_KIND (c) = OMP_CLAUSE_BIND_THREAD;
|
||
break;
|
||
default:
|
||
gcc_unreachable ();
|
||
}
|
||
}
|
||
/* OpenACC 'nohost' clauses cannot appear here. */
|
||
gcc_checking_assert (!clauses->nohost);
|
||
|
||
return nreverse (omp_clauses);
|
||
}
|
||
|
||
/* Like gfc_trans_code, but force creation of a BIND_EXPR around it. */
|
||
|
||
static tree
|
||
gfc_trans_omp_code (gfc_code *code, bool force_empty)
|
||
{
|
||
tree stmt;
|
||
|
||
pushlevel ();
|
||
stmt = gfc_trans_code (code);
|
||
if (TREE_CODE (stmt) != BIND_EXPR)
|
||
{
|
||
if (!IS_EMPTY_STMT (stmt) || force_empty)
|
||
{
|
||
tree block = poplevel (1, 0);
|
||
stmt = build3_v (BIND_EXPR, NULL, stmt, block);
|
||
}
|
||
else
|
||
poplevel (0, 0);
|
||
}
|
||
else
|
||
poplevel (0, 0);
|
||
return stmt;
|
||
}
|
||
|
||
/* Translate OpenACC 'parallel', 'kernels', 'serial', 'data', 'host_data'
|
||
construct. */
|
||
|
||
static tree
|
||
gfc_trans_oacc_construct (gfc_code *code)
|
||
{
|
||
stmtblock_t block;
|
||
tree stmt, oacc_clauses;
|
||
enum tree_code construct_code;
|
||
|
||
switch (code->op)
|
||
{
|
||
case EXEC_OACC_PARALLEL:
|
||
construct_code = OACC_PARALLEL;
|
||
break;
|
||
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;
|
||
case EXEC_OACC_HOST_DATA:
|
||
construct_code = OACC_HOST_DATA;
|
||
break;
|
||
default:
|
||
gcc_unreachable ();
|
||
}
|
||
|
||
gfc_start_block (&block);
|
||
oacc_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
|
||
code->loc, false, true);
|
||
pushlevel ();
|
||
stmt = gfc_trans_omp_code (code->block->next, true);
|
||
stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
|
||
stmt = build2_loc (gfc_get_location (&code->loc), construct_code,
|
||
void_type_node, stmt, oacc_clauses);
|
||
gfc_add_expr_to_block (&block, stmt);
|
||
return gfc_finish_block (&block);
|
||
}
|
||
|
||
/* update, enter_data, exit_data, cache. */
|
||
static tree
|
||
gfc_trans_oacc_executable_directive (gfc_code *code)
|
||
{
|
||
stmtblock_t block;
|
||
tree stmt, oacc_clauses;
|
||
enum tree_code construct_code;
|
||
|
||
switch (code->op)
|
||
{
|
||
case EXEC_OACC_UPDATE:
|
||
construct_code = OACC_UPDATE;
|
||
break;
|
||
case EXEC_OACC_ENTER_DATA:
|
||
construct_code = OACC_ENTER_DATA;
|
||
break;
|
||
case EXEC_OACC_EXIT_DATA:
|
||
construct_code = OACC_EXIT_DATA;
|
||
break;
|
||
case EXEC_OACC_CACHE:
|
||
construct_code = OACC_CACHE;
|
||
break;
|
||
default:
|
||
gcc_unreachable ();
|
||
}
|
||
|
||
gfc_start_block (&block);
|
||
oacc_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
|
||
code->loc, false, true);
|
||
stmt = build1_loc (input_location, construct_code, void_type_node,
|
||
oacc_clauses);
|
||
gfc_add_expr_to_block (&block, stmt);
|
||
return gfc_finish_block (&block);
|
||
}
|
||
|
||
static tree
|
||
gfc_trans_oacc_wait_directive (gfc_code *code)
|
||
{
|
||
stmtblock_t block;
|
||
tree stmt, t;
|
||
vec<tree, va_gc> *args;
|
||
int nparms = 0;
|
||
gfc_expr_list *el;
|
||
gfc_omp_clauses *clauses = code->ext.omp_clauses;
|
||
location_t loc = input_location;
|
||
|
||
for (el = clauses->wait_list; el; el = el->next)
|
||
nparms++;
|
||
|
||
vec_alloc (args, nparms + 2);
|
||
stmt = builtin_decl_explicit (BUILT_IN_GOACC_WAIT);
|
||
|
||
gfc_start_block (&block);
|
||
|
||
if (clauses->async_expr)
|
||
t = gfc_convert_expr_to_tree (&block, clauses->async_expr);
|
||
else
|
||
t = build_int_cst (integer_type_node, -2);
|
||
|
||
args->quick_push (t);
|
||
args->quick_push (build_int_cst (integer_type_node, nparms));
|
||
|
||
for (el = clauses->wait_list; el; el = el->next)
|
||
args->quick_push (gfc_convert_expr_to_tree (&block, el->expr));
|
||
|
||
stmt = build_call_expr_loc_vec (loc, stmt, args);
|
||
gfc_add_expr_to_block (&block, stmt);
|
||
|
||
vec_free (args);
|
||
|
||
return gfc_finish_block (&block);
|
||
}
|
||
|
||
static tree gfc_trans_omp_sections (gfc_code *, gfc_omp_clauses *);
|
||
static tree gfc_trans_omp_workshare (gfc_code *, gfc_omp_clauses *);
|
||
|
||
static tree
|
||
gfc_trans_omp_atomic (gfc_code *code)
|
||
{
|
||
gfc_code *atomic_code = code->block;
|
||
gfc_se lse;
|
||
gfc_se rse;
|
||
gfc_se vse;
|
||
gfc_expr *expr1, *expr2, *e, *capture_expr1 = NULL, *capture_expr2 = NULL;
|
||
gfc_symbol *var;
|
||
stmtblock_t block;
|
||
tree lhsaddr, type, rhs, x, compare = NULL_TREE, comp_tgt = NULL_TREE;
|
||
enum tree_code op = ERROR_MARK;
|
||
enum tree_code aop = OMP_ATOMIC;
|
||
bool var_on_left = false, else_branch = false;
|
||
enum omp_memory_order mo, fail_mo;
|
||
switch (atomic_code->ext.omp_clauses->memorder)
|
||
{
|
||
case OMP_MEMORDER_UNSET: mo = OMP_MEMORY_ORDER_UNSPECIFIED; break;
|
||
case OMP_MEMORDER_ACQ_REL: mo = OMP_MEMORY_ORDER_ACQ_REL; break;
|
||
case OMP_MEMORDER_ACQUIRE: mo = OMP_MEMORY_ORDER_ACQUIRE; break;
|
||
case OMP_MEMORDER_RELAXED: mo = OMP_MEMORY_ORDER_RELAXED; break;
|
||
case OMP_MEMORDER_RELEASE: mo = OMP_MEMORY_ORDER_RELEASE; break;
|
||
case OMP_MEMORDER_SEQ_CST: mo = OMP_MEMORY_ORDER_SEQ_CST; break;
|
||
default: gcc_unreachable ();
|
||
}
|
||
switch (atomic_code->ext.omp_clauses->fail)
|
||
{
|
||
case OMP_MEMORDER_UNSET: fail_mo = OMP_FAIL_MEMORY_ORDER_UNSPECIFIED; break;
|
||
case OMP_MEMORDER_ACQUIRE: fail_mo = OMP_FAIL_MEMORY_ORDER_ACQUIRE; break;
|
||
case OMP_MEMORDER_RELAXED: fail_mo = OMP_FAIL_MEMORY_ORDER_RELAXED; break;
|
||
case OMP_MEMORDER_SEQ_CST: fail_mo = OMP_FAIL_MEMORY_ORDER_SEQ_CST; break;
|
||
default: gcc_unreachable ();
|
||
}
|
||
mo = (omp_memory_order) (mo | fail_mo);
|
||
|
||
code = code->block->next;
|
||
if (atomic_code->ext.omp_clauses->compare)
|
||
{
|
||
gfc_expr *comp_expr;
|
||
if (code->op == EXEC_IF)
|
||
{
|
||
comp_expr = code->block->expr1;
|
||
gcc_assert (code->block->next->op == EXEC_ASSIGN);
|
||
expr1 = code->block->next->expr1;
|
||
expr2 = code->block->next->expr2;
|
||
if (code->block->block)
|
||
{
|
||
gcc_assert (atomic_code->ext.omp_clauses->capture
|
||
&& code->block->block->next->op == EXEC_ASSIGN);
|
||
else_branch = true;
|
||
aop = OMP_ATOMIC_CAPTURE_OLD;
|
||
capture_expr1 = code->block->block->next->expr1;
|
||
capture_expr2 = code->block->block->next->expr2;
|
||
}
|
||
else if (atomic_code->ext.omp_clauses->capture)
|
||
{
|
||
gcc_assert (code->next->op == EXEC_ASSIGN);
|
||
aop = OMP_ATOMIC_CAPTURE_NEW;
|
||
capture_expr1 = code->next->expr1;
|
||
capture_expr2 = code->next->expr2;
|
||
}
|
||
}
|
||
else
|
||
{
|
||
gcc_assert (atomic_code->ext.omp_clauses->capture
|
||
&& code->op == EXEC_ASSIGN
|
||
&& code->next->op == EXEC_IF);
|
||
aop = OMP_ATOMIC_CAPTURE_OLD;
|
||
capture_expr1 = code->expr1;
|
||
capture_expr2 = code->expr2;
|
||
expr1 = code->next->block->next->expr1;
|
||
expr2 = code->next->block->next->expr2;
|
||
comp_expr = code->next->block->expr1;
|
||
}
|
||
gfc_init_se (&lse, NULL);
|
||
gfc_conv_expr (&lse, comp_expr->value.op.op2);
|
||
gfc_add_block_to_block (&block, &lse.pre);
|
||
compare = lse.expr;
|
||
var = expr1->symtree->n.sym;
|
||
}
|
||
else
|
||
{
|
||
gcc_assert (code->op == EXEC_ASSIGN);
|
||
expr1 = code->expr1;
|
||
expr2 = code->expr2;
|
||
if (atomic_code->ext.omp_clauses->capture
|
||
&& (expr2->expr_type == EXPR_VARIABLE
|
||
|| (expr2->expr_type == EXPR_FUNCTION
|
||
&& expr2->value.function.isym
|
||
&& expr2->value.function.isym->id == GFC_ISYM_CONVERSION
|
||
&& (expr2->value.function.actual->expr->expr_type
|
||
== EXPR_VARIABLE))))
|
||
{
|
||
capture_expr1 = expr1;
|
||
capture_expr2 = expr2;
|
||
expr1 = code->next->expr1;
|
||
expr2 = code->next->expr2;
|
||
aop = OMP_ATOMIC_CAPTURE_OLD;
|
||
}
|
||
else if (atomic_code->ext.omp_clauses->capture)
|
||
{
|
||
aop = OMP_ATOMIC_CAPTURE_NEW;
|
||
capture_expr1 = code->next->expr1;
|
||
capture_expr2 = code->next->expr2;
|
||
}
|
||
var = expr1->symtree->n.sym;
|
||
}
|
||
|
||
gfc_init_se (&lse, NULL);
|
||
gfc_init_se (&rse, NULL);
|
||
gfc_init_se (&vse, NULL);
|
||
gfc_start_block (&block);
|
||
|
||
if (((atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_MASK)
|
||
!= GFC_OMP_ATOMIC_WRITE)
|
||
&& expr2->expr_type == EXPR_FUNCTION
|
||
&& expr2->value.function.isym
|
||
&& expr2->value.function.isym->id == GFC_ISYM_CONVERSION)
|
||
expr2 = expr2->value.function.actual->expr;
|
||
|
||
if ((atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_MASK)
|
||
== GFC_OMP_ATOMIC_READ)
|
||
{
|
||
gfc_conv_expr (&vse, expr1);
|
||
gfc_add_block_to_block (&block, &vse.pre);
|
||
|
||
gfc_conv_expr (&lse, expr2);
|
||
gfc_add_block_to_block (&block, &lse.pre);
|
||
type = TREE_TYPE (lse.expr);
|
||
lhsaddr = gfc_build_addr_expr (NULL, lse.expr);
|
||
|
||
x = build1 (OMP_ATOMIC_READ, type, lhsaddr);
|
||
OMP_ATOMIC_MEMORY_ORDER (x) = mo;
|
||
x = convert (TREE_TYPE (vse.expr), x);
|
||
gfc_add_modify (&block, vse.expr, x);
|
||
|
||
gfc_add_block_to_block (&block, &lse.pre);
|
||
gfc_add_block_to_block (&block, &rse.pre);
|
||
|
||
return gfc_finish_block (&block);
|
||
}
|
||
|
||
if (capture_expr2
|
||
&& capture_expr2->expr_type == EXPR_FUNCTION
|
||
&& capture_expr2->value.function.isym
|
||
&& capture_expr2->value.function.isym->id == GFC_ISYM_CONVERSION)
|
||
capture_expr2 = capture_expr2->value.function.actual->expr;
|
||
gcc_assert (!capture_expr2 || capture_expr2->expr_type == EXPR_VARIABLE);
|
||
|
||
if (aop == OMP_ATOMIC_CAPTURE_OLD)
|
||
{
|
||
gfc_conv_expr (&vse, capture_expr1);
|
||
gfc_add_block_to_block (&block, &vse.pre);
|
||
gfc_conv_expr (&lse, capture_expr2);
|
||
gfc_add_block_to_block (&block, &lse.pre);
|
||
gfc_init_se (&lse, NULL);
|
||
}
|
||
|
||
gfc_conv_expr (&lse, expr1);
|
||
gfc_add_block_to_block (&block, &lse.pre);
|
||
type = TREE_TYPE (lse.expr);
|
||
lhsaddr = gfc_build_addr_expr (NULL, lse.expr);
|
||
|
||
if (((atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_MASK)
|
||
== GFC_OMP_ATOMIC_WRITE)
|
||
|| (atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_SWAP)
|
||
|| compare)
|
||
{
|
||
gfc_conv_expr (&rse, expr2);
|
||
gfc_add_block_to_block (&block, &rse.pre);
|
||
}
|
||
else if (expr2->expr_type == EXPR_OP)
|
||
{
|
||
gfc_expr *e;
|
||
switch (expr2->value.op.op)
|
||
{
|
||
case INTRINSIC_PLUS:
|
||
op = PLUS_EXPR;
|
||
break;
|
||
case INTRINSIC_TIMES:
|
||
op = MULT_EXPR;
|
||
break;
|
||
case INTRINSIC_MINUS:
|
||
op = MINUS_EXPR;
|
||
break;
|
||
case INTRINSIC_DIVIDE:
|
||
if (expr2->ts.type == BT_INTEGER)
|
||
op = TRUNC_DIV_EXPR;
|
||
else
|
||
op = RDIV_EXPR;
|
||
break;
|
||
case INTRINSIC_AND:
|
||
op = TRUTH_ANDIF_EXPR;
|
||
break;
|
||
case INTRINSIC_OR:
|
||
op = TRUTH_ORIF_EXPR;
|
||
break;
|
||
case INTRINSIC_EQV:
|
||
op = EQ_EXPR;
|
||
break;
|
||
case INTRINSIC_NEQV:
|
||
op = NE_EXPR;
|
||
break;
|
||
default:
|
||
gcc_unreachable ();
|
||
}
|
||
e = expr2->value.op.op1;
|
||
if (e->expr_type == EXPR_FUNCTION
|
||
&& e->value.function.isym
|
||
&& e->value.function.isym->id == GFC_ISYM_CONVERSION)
|
||
e = e->value.function.actual->expr;
|
||
if (e->expr_type == EXPR_VARIABLE
|
||
&& e->symtree != NULL
|
||
&& e->symtree->n.sym == var)
|
||
{
|
||
expr2 = expr2->value.op.op2;
|
||
var_on_left = true;
|
||
}
|
||
else
|
||
{
|
||
e = expr2->value.op.op2;
|
||
if (e->expr_type == EXPR_FUNCTION
|
||
&& e->value.function.isym
|
||
&& e->value.function.isym->id == GFC_ISYM_CONVERSION)
|
||
e = e->value.function.actual->expr;
|
||
gcc_assert (e->expr_type == EXPR_VARIABLE
|
||
&& e->symtree != NULL
|
||
&& e->symtree->n.sym == var);
|
||
expr2 = expr2->value.op.op1;
|
||
var_on_left = false;
|
||
}
|
||
gfc_conv_expr (&rse, expr2);
|
||
gfc_add_block_to_block (&block, &rse.pre);
|
||
}
|
||
else
|
||
{
|
||
gcc_assert (expr2->expr_type == EXPR_FUNCTION);
|
||
switch (expr2->value.function.isym->id)
|
||
{
|
||
case GFC_ISYM_MIN:
|
||
op = MIN_EXPR;
|
||
break;
|
||
case GFC_ISYM_MAX:
|
||
op = MAX_EXPR;
|
||
break;
|
||
case GFC_ISYM_IAND:
|
||
op = BIT_AND_EXPR;
|
||
break;
|
||
case GFC_ISYM_IOR:
|
||
op = BIT_IOR_EXPR;
|
||
break;
|
||
case GFC_ISYM_IEOR:
|
||
op = BIT_XOR_EXPR;
|
||
break;
|
||
default:
|
||
gcc_unreachable ();
|
||
}
|
||
e = expr2->value.function.actual->expr;
|
||
if (e->expr_type == EXPR_FUNCTION
|
||
&& e->value.function.isym
|
||
&& e->value.function.isym->id == GFC_ISYM_CONVERSION)
|
||
e = e->value.function.actual->expr;
|
||
gcc_assert (e->expr_type == EXPR_VARIABLE
|
||
&& e->symtree != NULL
|
||
&& e->symtree->n.sym == var);
|
||
|
||
gfc_conv_expr (&rse, expr2->value.function.actual->next->expr);
|
||
gfc_add_block_to_block (&block, &rse.pre);
|
||
if (expr2->value.function.actual->next->next != NULL)
|
||
{
|
||
tree accum = gfc_create_var (TREE_TYPE (rse.expr), NULL);
|
||
gfc_actual_arglist *arg;
|
||
|
||
gfc_add_modify (&block, accum, rse.expr);
|
||
for (arg = expr2->value.function.actual->next->next; arg;
|
||
arg = arg->next)
|
||
{
|
||
gfc_init_block (&rse.pre);
|
||
gfc_conv_expr (&rse, arg->expr);
|
||
gfc_add_block_to_block (&block, &rse.pre);
|
||
x = fold_build2_loc (input_location, op, TREE_TYPE (accum),
|
||
accum, rse.expr);
|
||
gfc_add_modify (&block, accum, x);
|
||
}
|
||
|
||
rse.expr = accum;
|
||
}
|
||
|
||
expr2 = expr2->value.function.actual->next->expr;
|
||
}
|
||
|
||
lhsaddr = save_expr (lhsaddr);
|
||
if (TREE_CODE (lhsaddr) != SAVE_EXPR
|
||
&& (TREE_CODE (lhsaddr) != ADDR_EXPR
|
||
|| !VAR_P (TREE_OPERAND (lhsaddr, 0))))
|
||
{
|
||
/* Make sure LHS is simple enough so that goa_lhs_expr_p can recognize
|
||
it even after unsharing function body. */
|
||
tree var = create_tmp_var_raw (TREE_TYPE (lhsaddr));
|
||
DECL_CONTEXT (var) = current_function_decl;
|
||
lhsaddr = build4 (TARGET_EXPR, TREE_TYPE (lhsaddr), var, lhsaddr,
|
||
NULL_TREE, NULL_TREE);
|
||
}
|
||
|
||
if (compare)
|
||
{
|
||
tree var = create_tmp_var_raw (TREE_TYPE (lhsaddr));
|
||
DECL_CONTEXT (var) = current_function_decl;
|
||
lhsaddr = build4 (TARGET_EXPR, TREE_TYPE (lhsaddr), var, lhsaddr, NULL,
|
||
NULL);
|
||
lse.expr = build_fold_indirect_ref_loc (input_location, lhsaddr);
|
||
compare = convert (TREE_TYPE (lse.expr), compare);
|
||
compare = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
|
||
lse.expr, compare);
|
||
}
|
||
|
||
if (expr2->expr_type == EXPR_VARIABLE || compare)
|
||
rhs = rse.expr;
|
||
else
|
||
rhs = gfc_evaluate_now (rse.expr, &block);
|
||
|
||
if (((atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_MASK)
|
||
== GFC_OMP_ATOMIC_WRITE)
|
||
|| (atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_SWAP)
|
||
|| compare)
|
||
x = rhs;
|
||
else
|
||
{
|
||
x = convert (TREE_TYPE (rhs),
|
||
build_fold_indirect_ref_loc (input_location, lhsaddr));
|
||
if (var_on_left)
|
||
x = fold_build2_loc (input_location, op, TREE_TYPE (rhs), x, rhs);
|
||
else
|
||
x = fold_build2_loc (input_location, op, TREE_TYPE (rhs), rhs, x);
|
||
}
|
||
|
||
if (TREE_CODE (TREE_TYPE (rhs)) == COMPLEX_TYPE
|
||
&& TREE_CODE (type) != COMPLEX_TYPE)
|
||
x = fold_build1_loc (input_location, REALPART_EXPR,
|
||
TREE_TYPE (TREE_TYPE (rhs)), x);
|
||
|
||
gfc_add_block_to_block (&block, &lse.pre);
|
||
gfc_add_block_to_block (&block, &rse.pre);
|
||
|
||
if (aop == OMP_ATOMIC_CAPTURE_NEW)
|
||
{
|
||
gfc_conv_expr (&vse, capture_expr1);
|
||
gfc_add_block_to_block (&block, &vse.pre);
|
||
gfc_add_block_to_block (&block, &lse.pre);
|
||
}
|
||
|
||
if (compare && else_branch)
|
||
{
|
||
tree var2 = create_tmp_var_raw (boolean_type_node);
|
||
DECL_CONTEXT (var2) = current_function_decl;
|
||
comp_tgt = build4 (TARGET_EXPR, boolean_type_node, var2,
|
||
boolean_false_node, NULL, NULL);
|
||
compare = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (var2),
|
||
var2, compare);
|
||
TREE_OPERAND (compare, 0) = comp_tgt;
|
||
compare = omit_one_operand_loc (input_location, boolean_type_node,
|
||
compare, comp_tgt);
|
||
}
|
||
|
||
if (compare)
|
||
x = build3_loc (input_location, COND_EXPR, type, compare,
|
||
convert (type, x), lse.expr);
|
||
|
||
if (aop == OMP_ATOMIC)
|
||
{
|
||
x = build2_v (OMP_ATOMIC, lhsaddr, convert (type, x));
|
||
OMP_ATOMIC_MEMORY_ORDER (x) = mo;
|
||
OMP_ATOMIC_WEAK (x) = atomic_code->ext.omp_clauses->weak;
|
||
gfc_add_expr_to_block (&block, x);
|
||
}
|
||
else
|
||
{
|
||
x = build2 (aop, type, lhsaddr, convert (type, x));
|
||
OMP_ATOMIC_MEMORY_ORDER (x) = mo;
|
||
OMP_ATOMIC_WEAK (x) = atomic_code->ext.omp_clauses->weak;
|
||
if (compare && else_branch)
|
||
{
|
||
tree vtmp = create_tmp_var_raw (TREE_TYPE (x));
|
||
DECL_CONTEXT (vtmp) = current_function_decl;
|
||
x = fold_build2_loc (input_location, MODIFY_EXPR,
|
||
TREE_TYPE (vtmp), vtmp, x);
|
||
vtmp = build4 (TARGET_EXPR, TREE_TYPE (vtmp), vtmp,
|
||
build_zero_cst (TREE_TYPE (vtmp)), NULL, NULL);
|
||
TREE_OPERAND (x, 0) = vtmp;
|
||
tree x2 = convert (TREE_TYPE (vse.expr), vtmp);
|
||
x2 = fold_build2_loc (input_location, MODIFY_EXPR,
|
||
TREE_TYPE (vse.expr), vse.expr, x2);
|
||
x2 = build3_loc (input_location, COND_EXPR, void_type_node, comp_tgt,
|
||
void_node, x2);
|
||
x = omit_one_operand_loc (input_location, TREE_TYPE (x2), x2, x);
|
||
gfc_add_expr_to_block (&block, x);
|
||
}
|
||
else
|
||
{
|
||
x = convert (TREE_TYPE (vse.expr), x);
|
||
gfc_add_modify (&block, vse.expr, x);
|
||
}
|
||
}
|
||
|
||
return gfc_finish_block (&block);
|
||
}
|
||
|
||
static tree
|
||
gfc_trans_omp_barrier (void)
|
||
{
|
||
tree decl = builtin_decl_explicit (BUILT_IN_GOMP_BARRIER);
|
||
return build_call_expr_loc (input_location, decl, 0);
|
||
}
|
||
|
||
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
|
||
|| code->ext.omp_clauses->if_exprs[OMP_IF_CANCEL])
|
||
{
|
||
gfc_se se;
|
||
tree if_var;
|
||
|
||
gcc_assert ((code->ext.omp_clauses->if_expr == NULL)
|
||
^ (code->ext.omp_clauses->if_exprs[OMP_IF_CANCEL] == NULL));
|
||
gfc_init_se (&se, NULL);
|
||
gfc_conv_expr (&se, code->ext.omp_clauses->if_expr != NULL
|
||
? code->ext.omp_clauses->if_expr
|
||
: code->ext.omp_clauses->if_exprs[OMP_IF_CANCEL]);
|
||
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)
|
||
{
|
||
stmtblock_t block;
|
||
tree stmt, name = NULL_TREE;
|
||
if (code->ext.omp_clauses->critical_name != NULL)
|
||
name = get_identifier (code->ext.omp_clauses->critical_name);
|
||
gfc_start_block (&block);
|
||
stmt = make_node (OMP_CRITICAL);
|
||
TREE_TYPE (stmt) = void_type_node;
|
||
OMP_CRITICAL_BODY (stmt) = gfc_trans_code (code->block->next);
|
||
OMP_CRITICAL_NAME (stmt) = name;
|
||
OMP_CRITICAL_CLAUSES (stmt) = gfc_trans_omp_clauses (&block,
|
||
code->ext.omp_clauses,
|
||
code->loc);
|
||
gfc_add_expr_to_block (&block, stmt);
|
||
return gfc_finish_block (&block);
|
||
}
|
||
|
||
typedef struct dovar_init_d {
|
||
tree var;
|
||
tree init;
|
||
} dovar_init;
|
||
|
||
|
||
static tree
|
||
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;
|
||
tree dovar, stmt, from, to, step, type, init, cond, incr, orig_decls;
|
||
tree count = NULL_TREE, cycle_label, tmp, omp_clauses;
|
||
stmtblock_t block;
|
||
stmtblock_t body;
|
||
gfc_omp_clauses *clauses = code->ext.omp_clauses;
|
||
int i, collapse = clauses->collapse;
|
||
vec<dovar_init> inits = vNULL;
|
||
dovar_init *di;
|
||
unsigned ix;
|
||
vec<tree, va_heap, vl_embed> *saved_doacross_steps = doacross_steps;
|
||
gfc_expr_list *tile = do_clauses ? do_clauses->tile_list : clauses->tile_list;
|
||
|
||
/* Both collapsed and tiled loops are lowered the same way. In
|
||
OpenACC, those clauses are not compatible, so prioritize the tile
|
||
clause, if present. */
|
||
if (tile)
|
||
{
|
||
collapse = 0;
|
||
for (gfc_expr_list *el = tile; el; el = el->next)
|
||
collapse++;
|
||
}
|
||
|
||
doacross_steps = NULL;
|
||
if (clauses->orderedc)
|
||
collapse = clauses->orderedc;
|
||
if (collapse <= 0)
|
||
collapse = 1;
|
||
|
||
code = code->block->next;
|
||
gcc_assert (code->op == EXEC_DO);
|
||
|
||
init = make_tree_vec (collapse);
|
||
cond = make_tree_vec (collapse);
|
||
incr = make_tree_vec (collapse);
|
||
orig_decls = clauses->orderedc ? make_tree_vec (collapse) : NULL_TREE;
|
||
|
||
if (pblock == NULL)
|
||
{
|
||
gfc_start_block (&block);
|
||
pblock = █
|
||
}
|
||
|
||
/* simd schedule modifier is only useful for composite do simd and other
|
||
constructs including that, where gfc_trans_omp_do is only called
|
||
on the simd construct and DO's clauses are translated elsewhere. */
|
||
do_clauses->sched_simd = false;
|
||
|
||
omp_clauses = gfc_trans_omp_clauses (pblock, do_clauses, code->loc);
|
||
|
||
for (i = 0; i < collapse; i++)
|
||
{
|
||
int simple = 0;
|
||
int dovar_found = 0;
|
||
tree dovar_decl;
|
||
|
||
if (clauses)
|
||
{
|
||
gfc_omp_namelist *n = NULL;
|
||
if (op == EXEC_OMP_SIMD && collapse == 1)
|
||
for (n = clauses->lists[OMP_LIST_LINEAR];
|
||
n != NULL; n = n->next)
|
||
if (code->ext.iterator->var->symtree->n.sym == n->sym)
|
||
{
|
||
dovar_found = 3;
|
||
break;
|
||
}
|
||
if (n == NULL && op != EXEC_OMP_DISTRIBUTE)
|
||
for (n = clauses->lists[OMP_LIST_LASTPRIVATE];
|
||
n != NULL; n = n->next)
|
||
if (code->ext.iterator->var->symtree->n.sym == n->sym)
|
||
{
|
||
dovar_found = 2;
|
||
break;
|
||
}
|
||
if (n == NULL)
|
||
for (n = clauses->lists[OMP_LIST_PRIVATE]; n != NULL; n = n->next)
|
||
if (code->ext.iterator->var->symtree->n.sym == n->sym)
|
||
{
|
||
dovar_found = 1;
|
||
break;
|
||
}
|
||
}
|
||
|
||
/* Evaluate all the expressions in the iterator. */
|
||
gfc_init_se (&se, NULL);
|
||
gfc_conv_expr_lhs (&se, code->ext.iterator->var);
|
||
gfc_add_block_to_block (pblock, &se.pre);
|
||
dovar = se.expr;
|
||
type = TREE_TYPE (dovar);
|
||
gcc_assert (TREE_CODE (type) == INTEGER_TYPE);
|
||
|
||
gfc_init_se (&se, NULL);
|
||
gfc_conv_expr_val (&se, code->ext.iterator->start);
|
||
gfc_add_block_to_block (pblock, &se.pre);
|
||
from = gfc_evaluate_now (se.expr, pblock);
|
||
|
||
gfc_init_se (&se, NULL);
|
||
gfc_conv_expr_val (&se, code->ext.iterator->end);
|
||
gfc_add_block_to_block (pblock, &se.pre);
|
||
to = gfc_evaluate_now (se.expr, pblock);
|
||
|
||
gfc_init_se (&se, NULL);
|
||
gfc_conv_expr_val (&se, code->ext.iterator->step);
|
||
gfc_add_block_to_block (pblock, &se.pre);
|
||
step = gfc_evaluate_now (se.expr, pblock);
|
||
dovar_decl = dovar;
|
||
|
||
/* Special case simple loops. */
|
||
if (VAR_P (dovar))
|
||
{
|
||
if (integer_onep (step))
|
||
simple = 1;
|
||
else if (tree_int_cst_equal (step, integer_minus_one_node))
|
||
simple = -1;
|
||
}
|
||
else
|
||
dovar_decl
|
||
= gfc_trans_omp_variable (code->ext.iterator->var->symtree->n.sym,
|
||
false);
|
||
|
||
/* Loop body. */
|
||
if (simple)
|
||
{
|
||
TREE_VEC_ELT (init, i) = build2_v (MODIFY_EXPR, dovar, from);
|
||
/* The condition should not be folded. */
|
||
TREE_VEC_ELT (cond, i) = build2_loc (input_location, simple > 0
|
||
? LE_EXPR : GE_EXPR,
|
||
logical_type_node, dovar, to);
|
||
TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location, PLUS_EXPR,
|
||
type, dovar, step);
|
||
TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location,
|
||
MODIFY_EXPR,
|
||
type, dovar,
|
||
TREE_VEC_ELT (incr, i));
|
||
}
|
||
else
|
||
{
|
||
/* STEP is not 1 or -1. Use:
|
||
for (count = 0; count < (to + step - from) / step; count++)
|
||
{
|
||
dovar = from + count * step;
|
||
body;
|
||
cycle_label:;
|
||
} */
|
||
tmp = fold_build2_loc (input_location, MINUS_EXPR, type, step, from);
|
||
tmp = fold_build2_loc (input_location, PLUS_EXPR, type, to, tmp);
|
||
tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, type, tmp,
|
||
step);
|
||
tmp = gfc_evaluate_now (tmp, pblock);
|
||
count = gfc_create_var (type, "count");
|
||
TREE_VEC_ELT (init, i) = build2_v (MODIFY_EXPR, count,
|
||
build_int_cst (type, 0));
|
||
/* The condition should not be folded. */
|
||
TREE_VEC_ELT (cond, i) = build2_loc (input_location, LT_EXPR,
|
||
logical_type_node,
|
||
count, tmp);
|
||
TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location, PLUS_EXPR,
|
||
type, count,
|
||
build_int_cst (type, 1));
|
||
TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location,
|
||
MODIFY_EXPR, type, count,
|
||
TREE_VEC_ELT (incr, i));
|
||
|
||
/* Initialize DOVAR. */
|
||
tmp = fold_build2_loc (input_location, MULT_EXPR, type, count, step);
|
||
tmp = fold_build2_loc (input_location, PLUS_EXPR, type, from, tmp);
|
||
dovar_init e = {dovar, tmp};
|
||
inits.safe_push (e);
|
||
if (clauses->orderedc)
|
||
{
|
||
if (doacross_steps == NULL)
|
||
vec_safe_grow_cleared (doacross_steps, clauses->orderedc, true);
|
||
(*doacross_steps)[i] = step;
|
||
}
|
||
}
|
||
if (orig_decls)
|
||
TREE_VEC_ELT (orig_decls, i) = dovar_decl;
|
||
|
||
if (dovar_found == 3
|
||
&& op == EXEC_OMP_SIMD
|
||
&& collapse == 1
|
||
&& !simple)
|
||
{
|
||
for (tmp = omp_clauses; tmp; tmp = OMP_CLAUSE_CHAIN (tmp))
|
||
if (OMP_CLAUSE_CODE (tmp) == OMP_CLAUSE_LINEAR
|
||
&& OMP_CLAUSE_DECL (tmp) == dovar)
|
||
{
|
||
OMP_CLAUSE_LINEAR_NO_COPYIN (tmp) = 1;
|
||
break;
|
||
}
|
||
}
|
||
if (!dovar_found && op == EXEC_OMP_SIMD)
|
||
{
|
||
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_DECL (tmp) = dovar_decl;
|
||
omp_clauses = gfc_trans_add_clause (tmp, omp_clauses);
|
||
}
|
||
if (!simple)
|
||
dovar_found = 3;
|
||
}
|
||
else if (!dovar_found && !simple)
|
||
{
|
||
tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE);
|
||
OMP_CLAUSE_DECL (tmp) = dovar_decl;
|
||
omp_clauses = gfc_trans_add_clause (tmp, omp_clauses);
|
||
}
|
||
if (dovar_found > 1)
|
||
{
|
||
tree c = NULL;
|
||
|
||
tmp = NULL;
|
||
if (!simple)
|
||
{
|
||
/* If dovar is lastprivate, but different counter is used,
|
||
dovar += step needs to be added to
|
||
OMP_CLAUSE_LASTPRIVATE_STMT, otherwise the copied dovar
|
||
will have the value on entry of the last loop, rather
|
||
than value after iterator increment. */
|
||
if (clauses->orderedc)
|
||
{
|
||
if (clauses->collapse <= 1 || i >= clauses->collapse)
|
||
tmp = count;
|
||
else
|
||
tmp = fold_build2_loc (input_location, PLUS_EXPR,
|
||
type, count, build_one_cst (type));
|
||
tmp = fold_build2_loc (input_location, MULT_EXPR, type,
|
||
tmp, step);
|
||
tmp = fold_build2_loc (input_location, PLUS_EXPR, type,
|
||
from, tmp);
|
||
}
|
||
else
|
||
{
|
||
tmp = gfc_evaluate_now (step, pblock);
|
||
tmp = fold_build2_loc (input_location, PLUS_EXPR, type,
|
||
dovar, tmp);
|
||
}
|
||
tmp = fold_build2_loc (input_location, MODIFY_EXPR, type,
|
||
dovar, tmp);
|
||
for (c = omp_clauses; c ; c = OMP_CLAUSE_CHAIN (c))
|
||
if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LASTPRIVATE
|
||
&& OMP_CLAUSE_DECL (c) == dovar_decl)
|
||
{
|
||
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 && 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
|
||
&& OMP_CLAUSE_DECL (c) == dovar_decl)
|
||
{
|
||
tree l = build_omp_clause (input_location,
|
||
OMP_CLAUSE_LASTPRIVATE);
|
||
if (OMP_CLAUSE_LASTPRIVATE_CONDITIONAL (c))
|
||
OMP_CLAUSE_LASTPRIVATE_CONDITIONAL (l) = 1;
|
||
OMP_CLAUSE_DECL (l) = dovar_decl;
|
||
OMP_CLAUSE_CHAIN (l) = omp_clauses;
|
||
OMP_CLAUSE_LASTPRIVATE_STMT (l) = tmp;
|
||
omp_clauses = l;
|
||
OMP_CLAUSE_SET_CODE (c, OMP_CLAUSE_SHARED);
|
||
break;
|
||
}
|
||
}
|
||
gcc_assert (simple || c != NULL);
|
||
}
|
||
if (!simple)
|
||
{
|
||
if (op != EXEC_OMP_SIMD || dovar_found == 1)
|
||
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) = build_int_cst (type, 1);
|
||
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);
|
||
}
|
||
|
||
if (i + 1 < collapse)
|
||
code = code->block->next;
|
||
}
|
||
|
||
if (pblock != &block)
|
||
{
|
||
pushlevel ();
|
||
gfc_start_block (&block);
|
||
}
|
||
|
||
gfc_start_block (&body);
|
||
|
||
FOR_EACH_VEC_ELT (inits, ix, di)
|
||
gfc_add_modify (&body, di->var, di->init);
|
||
inits.release ();
|
||
|
||
/* Cycle statement is implemented with a goto. Exit statement must not be
|
||
present for this loop. */
|
||
cycle_label = gfc_build_label_decl (NULL_TREE);
|
||
|
||
/* Put these labels where they can be found later. */
|
||
|
||
code->cycle_label = cycle_label;
|
||
code->exit_label = NULL_TREE;
|
||
|
||
/* Main loop body. */
|
||
if (clauses->lists[OMP_LIST_REDUCTION_INSCAN])
|
||
{
|
||
gcc_assert (code->block->next->next->op == EXEC_OMP_SCAN);
|
||
gcc_assert (code->block->next->next->next->next == NULL);
|
||
locus *cloc = &code->block->next->next->loc;
|
||
location_t loc = gfc_get_location (cloc);
|
||
|
||
gfc_code code2 = *code->block->next;
|
||
code2.next = NULL;
|
||
tmp = gfc_trans_code (&code2);
|
||
tmp = build2 (OMP_SCAN, void_type_node, tmp, NULL_TREE);
|
||
SET_EXPR_LOCATION (tmp, loc);
|
||
gfc_add_expr_to_block (&body, tmp);
|
||
input_location = loc;
|
||
tree c = gfc_trans_omp_clauses (&body,
|
||
code->block->next->next->ext.omp_clauses,
|
||
*cloc);
|
||
code2 = *code->block->next->next->next;
|
||
code2.next = NULL;
|
||
tmp = gfc_trans_code (&code2);
|
||
tmp = build2 (OMP_SCAN, void_type_node, tmp, c);
|
||
SET_EXPR_LOCATION (tmp, loc);
|
||
}
|
||
else
|
||
tmp = gfc_trans_omp_code (code->block->next, true);
|
||
gfc_add_expr_to_block (&body, tmp);
|
||
|
||
/* Label for cycle statements (if needed). */
|
||
if (TREE_USED (cycle_label))
|
||
{
|
||
tmp = build1_v (LABEL_EXPR, cycle_label);
|
||
gfc_add_expr_to_block (&body, tmp);
|
||
}
|
||
|
||
/* End of loop body. */
|
||
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;
|
||
case EXEC_OMP_LOOP: stmt = make_node (OMP_LOOP); break;
|
||
case EXEC_OMP_TASKLOOP: stmt = make_node (OMP_TASKLOOP); break;
|
||
case EXEC_OACC_LOOP: stmt = make_node (OACC_LOOP); break;
|
||
default: gcc_unreachable ();
|
||
}
|
||
|
||
TREE_TYPE (stmt) = void_type_node;
|
||
OMP_FOR_BODY (stmt) = gfc_finish_block (&body);
|
||
OMP_FOR_CLAUSES (stmt) = omp_clauses;
|
||
OMP_FOR_INIT (stmt) = init;
|
||
OMP_FOR_COND (stmt) = cond;
|
||
OMP_FOR_INCR (stmt) = incr;
|
||
if (orig_decls)
|
||
OMP_FOR_ORIG_DECLS (stmt) = orig_decls;
|
||
gfc_add_expr_to_block (&block, stmt);
|
||
|
||
vec_free (doacross_steps);
|
||
doacross_steps = saved_doacross_steps;
|
||
|
||
return gfc_finish_block (&block);
|
||
}
|
||
|
||
/* Translate combined OpenACC 'parallel loop', 'kernels loop', 'serial loop'
|
||
construct. */
|
||
|
||
static tree
|
||
gfc_trans_oacc_combined_directive (gfc_code *code)
|
||
{
|
||
stmtblock_t block, *pblock = NULL;
|
||
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)
|
||
{
|
||
case EXEC_OACC_PARALLEL_LOOP:
|
||
construct_code = OACC_PARALLEL;
|
||
break;
|
||
case EXEC_OACC_KERNELS_LOOP:
|
||
construct_code = OACC_KERNELS;
|
||
break;
|
||
case EXEC_OACC_SERIAL_LOOP:
|
||
construct_code = OACC_SERIAL;
|
||
break;
|
||
default:
|
||
gcc_unreachable ();
|
||
}
|
||
|
||
gfc_start_block (&block);
|
||
|
||
memset (&loop_clauses, 0, sizeof (loop_clauses));
|
||
if (code->ext.omp_clauses != NULL)
|
||
{
|
||
memcpy (&construct_clauses, code->ext.omp_clauses,
|
||
sizeof (construct_clauses));
|
||
loop_clauses.collapse = construct_clauses.collapse;
|
||
loop_clauses.gang = construct_clauses.gang;
|
||
loop_clauses.gang_static = construct_clauses.gang_static;
|
||
loop_clauses.gang_num_expr = construct_clauses.gang_num_expr;
|
||
loop_clauses.gang_static_expr = construct_clauses.gang_static_expr;
|
||
loop_clauses.vector = construct_clauses.vector;
|
||
loop_clauses.vector_expr = construct_clauses.vector_expr;
|
||
loop_clauses.worker = construct_clauses.worker;
|
||
loop_clauses.worker_expr = construct_clauses.worker_expr;
|
||
loop_clauses.seq = construct_clauses.seq;
|
||
loop_clauses.par_auto = construct_clauses.par_auto;
|
||
loop_clauses.independent = construct_clauses.independent;
|
||
loop_clauses.tile_list = construct_clauses.tile_list;
|
||
loop_clauses.lists[OMP_LIST_PRIVATE]
|
||
= construct_clauses.lists[OMP_LIST_PRIVATE];
|
||
loop_clauses.lists[OMP_LIST_REDUCTION]
|
||
= construct_clauses.lists[OMP_LIST_REDUCTION];
|
||
construct_clauses.gang = false;
|
||
construct_clauses.gang_static = false;
|
||
construct_clauses.gang_num_expr = NULL;
|
||
construct_clauses.gang_static_expr = NULL;
|
||
construct_clauses.vector = false;
|
||
construct_clauses.vector_expr = NULL;
|
||
construct_clauses.worker = false;
|
||
construct_clauses.worker_expr = NULL;
|
||
construct_clauses.seq = false;
|
||
construct_clauses.par_auto = false;
|
||
construct_clauses.independent = false;
|
||
construct_clauses.independent = false;
|
||
construct_clauses.tile_list = NULL;
|
||
construct_clauses.lists[OMP_LIST_PRIVATE] = NULL;
|
||
if (construct_code == OACC_KERNELS)
|
||
construct_clauses.lists[OMP_LIST_REDUCTION] = NULL;
|
||
oacc_clauses = gfc_trans_omp_clauses (&block, &construct_clauses,
|
||
code->loc, false, true);
|
||
}
|
||
if (!loop_clauses.seq)
|
||
pblock = █
|
||
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 (loc, construct_code, void_type_node, stmt, oacc_clauses);
|
||
gfc_add_expr_to_block (&block, stmt);
|
||
return gfc_finish_block (&block);
|
||
}
|
||
|
||
static tree
|
||
gfc_trans_omp_depobj (gfc_code *code)
|
||
{
|
||
stmtblock_t block;
|
||
gfc_se se;
|
||
gfc_init_se (&se, NULL);
|
||
gfc_init_block (&block);
|
||
gfc_conv_expr (&se, code->ext.omp_clauses->depobj);
|
||
gcc_assert (se.pre.head == NULL && se.post.head == NULL);
|
||
tree depobj = se.expr;
|
||
location_t loc = EXPR_LOCATION (depobj);
|
||
if (!POINTER_TYPE_P (TREE_TYPE (depobj)))
|
||
depobj = gfc_build_addr_expr (NULL, depobj);
|
||
depobj = fold_convert (build_pointer_type_for_mode (ptr_type_node,
|
||
TYPE_MODE (ptr_type_node),
|
||
true), depobj);
|
||
gfc_omp_namelist *n = code->ext.omp_clauses->lists[OMP_LIST_DEPEND];
|
||
if (n)
|
||
{
|
||
tree var;
|
||
if (n->expr && n->expr->ref->u.ar.type != AR_FULL)
|
||
{
|
||
gfc_init_se (&se, NULL);
|
||
if (n->expr->ref->u.ar.type == AR_ELEMENT)
|
||
{
|
||
gfc_conv_expr_reference (&se, n->expr);
|
||
var = se.expr;
|
||
}
|
||
else
|
||
{
|
||
gfc_conv_expr_descriptor (&se, n->expr);
|
||
var = gfc_conv_array_data (se.expr);
|
||
}
|
||
gfc_add_block_to_block (&block, &se.pre);
|
||
gfc_add_block_to_block (&block, &se.post);
|
||
gcc_assert (POINTER_TYPE_P (TREE_TYPE (var)));
|
||
}
|
||
else
|
||
{
|
||
var = gfc_get_symbol_decl (n->sym);
|
||
if (POINTER_TYPE_P (TREE_TYPE (var))
|
||
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (var))))
|
||
var = build_fold_indirect_ref (var);
|
||
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (var)))
|
||
{
|
||
var = gfc_conv_descriptor_data_get (var);
|
||
gcc_assert (POINTER_TYPE_P (TREE_TYPE (var)));
|
||
}
|
||
else if ((n->sym->attr.allocatable || n->sym->attr.pointer)
|
||
&& n->sym->attr.dummy)
|
||
var = build_fold_indirect_ref (var);
|
||
else if (!POINTER_TYPE_P (TREE_TYPE (var))
|
||
|| (n->sym->ts.f90_type == BT_VOID
|
||
&& !POINTER_TYPE_P (TREE_TYPE (TREE_TYPE (var)))
|
||
&& !GFC_ARRAY_TYPE_P (TREE_TYPE (TREE_TYPE (var)))))
|
||
{
|
||
TREE_ADDRESSABLE (var) = 1;
|
||
var = gfc_build_addr_expr (NULL, var);
|
||
}
|
||
}
|
||
depobj = save_expr (depobj);
|
||
tree r = build_fold_indirect_ref_loc (loc, depobj);
|
||
gfc_add_expr_to_block (&block,
|
||
build2 (MODIFY_EXPR, void_type_node, r, var));
|
||
}
|
||
|
||
/* Only one may be set. */
|
||
gcc_assert (((int)(n != NULL) + (int)(code->ext.omp_clauses->destroy)
|
||
+ (int)(code->ext.omp_clauses->depobj_update != OMP_DEPEND_UNSET))
|
||
== 1);
|
||
int k = -1; /* omp_clauses->destroy */
|
||
if (!code->ext.omp_clauses->destroy)
|
||
switch (code->ext.omp_clauses->depobj_update != OMP_DEPEND_UNSET
|
||
? code->ext.omp_clauses->depobj_update : n->u.depend_op)
|
||
{
|
||
case OMP_DEPEND_IN: k = GOMP_DEPEND_IN; break;
|
||
case OMP_DEPEND_OUT: k = GOMP_DEPEND_OUT; break;
|
||
case OMP_DEPEND_INOUT: k = GOMP_DEPEND_INOUT; break;
|
||
case OMP_DEPEND_MUTEXINOUTSET: k = GOMP_DEPEND_MUTEXINOUTSET; break;
|
||
default: gcc_unreachable ();
|
||
}
|
||
tree t = build_int_cst (ptr_type_node, k);
|
||
depobj = build2_loc (loc, POINTER_PLUS_EXPR, TREE_TYPE (depobj), depobj,
|
||
TYPE_SIZE_UNIT (ptr_type_node));
|
||
depobj = build_fold_indirect_ref_loc (loc, depobj);
|
||
gfc_add_expr_to_block (&block, build2 (MODIFY_EXPR, void_type_node, depobj, t));
|
||
|
||
return gfc_finish_block (&block);
|
||
}
|
||
|
||
static tree
|
||
gfc_trans_omp_error (gfc_code *code)
|
||
{
|
||
stmtblock_t block;
|
||
gfc_se se;
|
||
tree len, message;
|
||
bool fatal = code->ext.omp_clauses->severity == OMP_SEVERITY_FATAL;
|
||
tree fndecl = builtin_decl_explicit (fatal ? BUILT_IN_GOMP_ERROR
|
||
: BUILT_IN_GOMP_WARNING);
|
||
gfc_start_block (&block);
|
||
gfc_init_se (&se, NULL );
|
||
if (!code->ext.omp_clauses->message)
|
||
{
|
||
message = null_pointer_node;
|
||
len = build_int_cst (size_type_node, 0);
|
||
}
|
||
else
|
||
{
|
||
gfc_conv_expr (&se, code->ext.omp_clauses->message);
|
||
message = se.expr;
|
||
if (!POINTER_TYPE_P (TREE_TYPE (message)))
|
||
/* To ensure an ARRAY_TYPE is not passed as such. */
|
||
message = gfc_build_addr_expr (NULL, message);
|
||
len = se.string_length;
|
||
}
|
||
gfc_add_block_to_block (&block, &se.pre);
|
||
gfc_add_expr_to_block (&block, build_call_expr_loc (input_location, fndecl,
|
||
2, message, len));
|
||
gfc_add_block_to_block (&block, &se.post);
|
||
return gfc_finish_block (&block);
|
||
}
|
||
|
||
static tree
|
||
gfc_trans_omp_flush (gfc_code *code)
|
||
{
|
||
tree call;
|
||
if (!code->ext.omp_clauses
|
||
|| code->ext.omp_clauses->memorder == OMP_MEMORDER_UNSET
|
||
|| code->ext.omp_clauses->memorder == OMP_MEMORDER_SEQ_CST)
|
||
{
|
||
call = builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE);
|
||
call = build_call_expr_loc (input_location, call, 0);
|
||
}
|
||
else
|
||
{
|
||
enum memmodel mo = MEMMODEL_LAST;
|
||
switch (code->ext.omp_clauses->memorder)
|
||
{
|
||
case OMP_MEMORDER_ACQ_REL: mo = MEMMODEL_ACQ_REL; break;
|
||
case OMP_MEMORDER_RELEASE: mo = MEMMODEL_RELEASE; break;
|
||
case OMP_MEMORDER_ACQUIRE: mo = MEMMODEL_ACQUIRE; break;
|
||
default: gcc_unreachable (); break;
|
||
}
|
||
call = builtin_decl_explicit (BUILT_IN_ATOMIC_THREAD_FENCE);
|
||
call = build_call_expr_loc (input_location, call, 1,
|
||
build_int_cst (integer_type_node, mo));
|
||
}
|
||
return call;
|
||
}
|
||
|
||
static tree
|
||
gfc_trans_omp_master (gfc_code *code)
|
||
{
|
||
tree stmt = gfc_trans_code (code->block->next);
|
||
if (IS_EMPTY_STMT (stmt))
|
||
return stmt;
|
||
return build1_v (OMP_MASTER, stmt);
|
||
}
|
||
|
||
static tree
|
||
gfc_trans_omp_masked (gfc_code *code, gfc_omp_clauses *clauses)
|
||
{
|
||
stmtblock_t block;
|
||
tree body = gfc_trans_code (code->block->next);
|
||
if (IS_EMPTY_STMT (body))
|
||
return body;
|
||
if (!clauses)
|
||
clauses = code->ext.omp_clauses;
|
||
gfc_start_block (&block);
|
||
tree omp_clauses = gfc_trans_omp_clauses (&block, clauses, code->loc);
|
||
tree stmt = make_node (OMP_MASKED);
|
||
TREE_TYPE (stmt) = void_type_node;
|
||
OMP_MASKED_BODY (stmt) = body;
|
||
OMP_MASKED_CLAUSES (stmt) = omp_clauses;
|
||
gfc_add_expr_to_block (&block, stmt);
|
||
return gfc_finish_block (&block);
|
||
}
|
||
|
||
|
||
static tree
|
||
gfc_trans_omp_ordered (gfc_code *code)
|
||
{
|
||
if (!flag_openmp)
|
||
{
|
||
if (!code->ext.omp_clauses->simd)
|
||
return gfc_trans_code (code->block ? code->block->next : NULL);
|
||
code->ext.omp_clauses->threads = 0;
|
||
}
|
||
tree omp_clauses = gfc_trans_omp_clauses (NULL, code->ext.omp_clauses,
|
||
code->loc);
|
||
return build2_loc (input_location, OMP_ORDERED, void_type_node,
|
||
code->block ? gfc_trans_code (code->block->next)
|
||
: NULL_TREE, omp_clauses);
|
||
}
|
||
|
||
static tree
|
||
gfc_trans_omp_parallel (gfc_code *code)
|
||
{
|
||
stmtblock_t block;
|
||
tree stmt, omp_clauses;
|
||
|
||
gfc_start_block (&block);
|
||
omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
|
||
code->loc);
|
||
pushlevel ();
|
||
stmt = gfc_trans_omp_code (code->block->next, true);
|
||
stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
|
||
stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt,
|
||
omp_clauses);
|
||
gfc_add_expr_to_block (&block, stmt);
|
||
return gfc_finish_block (&block);
|
||
}
|
||
|
||
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_TASKLOOP,
|
||
GFC_OMP_SPLIT_MASKED,
|
||
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),
|
||
GFC_OMP_MASK_TASKLOOP = (1 << GFC_OMP_SPLIT_TASKLOOP),
|
||
GFC_OMP_MASK_MASKED = (1 << GFC_OMP_SPLIT_MASKED)
|
||
};
|
||
|
||
/* If a var is in lastprivate/firstprivate/reduction but not in a
|
||
data mapping/sharing clause, add it to 'map(tofrom:' if is_target
|
||
and to 'shared' otherwise. */
|
||
static void
|
||
gfc_add_clause_implicitly (gfc_omp_clauses *clauses_out,
|
||
gfc_omp_clauses *clauses_in,
|
||
bool is_target, bool is_parallel_do)
|
||
{
|
||
int clauselist_to_add = is_target ? OMP_LIST_MAP : OMP_LIST_SHARED;
|
||
gfc_omp_namelist *tail = NULL;
|
||
for (int i = 0; i < 5; ++i)
|
||
{
|
||
gfc_omp_namelist *n;
|
||
switch (i)
|
||
{
|
||
case 0: n = clauses_in->lists[OMP_LIST_FIRSTPRIVATE]; break;
|
||
case 1: n = clauses_in->lists[OMP_LIST_LASTPRIVATE]; break;
|
||
case 2: n = clauses_in->lists[OMP_LIST_REDUCTION]; break;
|
||
case 3: n = clauses_in->lists[OMP_LIST_REDUCTION_INSCAN]; break;
|
||
case 4: n = clauses_in->lists[OMP_LIST_REDUCTION_TASK]; break;
|
||
default: gcc_unreachable ();
|
||
}
|
||
for (; n != NULL; n = n->next)
|
||
{
|
||
gfc_omp_namelist *n2, **n_firstp = NULL, **n_lastp = NULL;
|
||
for (int j = 0; j < 6; ++j)
|
||
{
|
||
gfc_omp_namelist **n2ref = NULL, *prev2 = NULL;
|
||
switch (j)
|
||
{
|
||
case 0:
|
||
n2ref = &clauses_out->lists[clauselist_to_add];
|
||
break;
|
||
case 1:
|
||
n2ref = &clauses_out->lists[OMP_LIST_FIRSTPRIVATE];
|
||
break;
|
||
case 2:
|
||
if (is_target)
|
||
n2ref = &clauses_in->lists[OMP_LIST_LASTPRIVATE];
|
||
else
|
||
n2ref = &clauses_out->lists[OMP_LIST_LASTPRIVATE];
|
||
break;
|
||
case 3: n2ref = &clauses_out->lists[OMP_LIST_REDUCTION]; break;
|
||
case 4:
|
||
n2ref = &clauses_out->lists[OMP_LIST_REDUCTION_INSCAN];
|
||
break;
|
||
case 5:
|
||
n2ref = &clauses_out->lists[OMP_LIST_REDUCTION_TASK];
|
||
break;
|
||
default: gcc_unreachable ();
|
||
}
|
||
for (n2 = *n2ref; n2 != NULL; prev2 = n2, n2 = n2->next)
|
||
if (n2->sym == n->sym)
|
||
break;
|
||
if (n2)
|
||
{
|
||
if (j == 0 /* clauselist_to_add */)
|
||
break; /* Already present. */
|
||
if (j == 1 /* OMP_LIST_FIRSTPRIVATE */)
|
||
{
|
||
n_firstp = prev2 ? &prev2->next : n2ref;
|
||
continue;
|
||
}
|
||
if (j == 2 /* OMP_LIST_LASTPRIVATE */)
|
||
{
|
||
n_lastp = prev2 ? &prev2->next : n2ref;
|
||
continue;
|
||
}
|
||
break;
|
||
}
|
||
}
|
||
if (n_firstp && n_lastp)
|
||
{
|
||
/* For parallel do, GCC puts firstprivatee/lastprivate
|
||
on the parallel. */
|
||
if (is_parallel_do)
|
||
continue;
|
||
*n_firstp = (*n_firstp)->next;
|
||
if (!is_target)
|
||
*n_lastp = (*n_lastp)->next;
|
||
}
|
||
else if (is_target && n_lastp)
|
||
;
|
||
else if (n2 || n_firstp || n_lastp)
|
||
continue;
|
||
if (clauses_out->lists[clauselist_to_add]
|
||
&& (clauses_out->lists[clauselist_to_add]
|
||
== clauses_in->lists[clauselist_to_add]))
|
||
{
|
||
gfc_omp_namelist *p = NULL;
|
||
for (n2 = clauses_in->lists[clauselist_to_add]; n2; n2 = n2->next)
|
||
{
|
||
if (p)
|
||
{
|
||
p->next = gfc_get_omp_namelist ();
|
||
p = p->next;
|
||
}
|
||
else
|
||
{
|
||
p = gfc_get_omp_namelist ();
|
||
clauses_out->lists[clauselist_to_add] = p;
|
||
}
|
||
*p = *n2;
|
||
}
|
||
}
|
||
if (!tail)
|
||
{
|
||
tail = clauses_out->lists[clauselist_to_add];
|
||
for (; tail && tail->next; tail = tail->next)
|
||
;
|
||
}
|
||
n2 = gfc_get_omp_namelist ();
|
||
n2->where = n->where;
|
||
n2->sym = n->sym;
|
||
if (is_target)
|
||
n2->u.map_op = OMP_MAP_TOFROM;
|
||
if (tail)
|
||
{
|
||
tail->next = n2;
|
||
tail = n2;
|
||
}
|
||
else
|
||
clauses_out->lists[clauselist_to_add] = n2;
|
||
}
|
||
}
|
||
}
|
||
|
||
static void
|
||
gfc_free_split_omp_clauses (gfc_code *code, gfc_omp_clauses *clausesa)
|
||
{
|
||
for (int i = 0; i < GFC_OMP_SPLIT_NUM; ++i)
|
||
for (int j = 0; j < OMP_LIST_NUM; ++j)
|
||
if (clausesa[i].lists[j] && clausesa[i].lists[j] != code->ext.omp_clauses->lists[j])
|
||
for (gfc_omp_namelist *n = clausesa[i].lists[j]; n;)
|
||
{
|
||
gfc_omp_namelist *p = n;
|
||
n = n->next;
|
||
free (p);
|
||
}
|
||
}
|
||
|
||
static void
|
||
gfc_split_omp_clauses (gfc_code *code,
|
||
gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM])
|
||
{
|
||
int mask = 0, innermost = 0;
|
||
bool is_loop = false;
|
||
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:
|
||
case EXEC_OMP_LOOP:
|
||
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:
|
||
case EXEC_OMP_PARALLEL_LOOP:
|
||
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_PARALLEL_MASKED:
|
||
mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_MASKED;
|
||
innermost = GFC_OMP_SPLIT_MASKED;
|
||
break;
|
||
case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
|
||
mask = (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_MASKED
|
||
| GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD);
|
||
innermost = GFC_OMP_SPLIT_TASKLOOP;
|
||
break;
|
||
case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
|
||
mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD;
|
||
innermost = GFC_OMP_SPLIT_TASKLOOP;
|
||
break;
|
||
case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
|
||
mask = (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_MASKED
|
||
| GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD);
|
||
innermost = GFC_OMP_SPLIT_SIMD;
|
||
break;
|
||
case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
|
||
mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_TASKLOOP | 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_PARALLEL:
|
||
mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_PARALLEL;
|
||
innermost = GFC_OMP_SPLIT_PARALLEL;
|
||
break;
|
||
case EXEC_OMP_TARGET_PARALLEL_DO:
|
||
case EXEC_OMP_TARGET_PARALLEL_LOOP:
|
||
mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO;
|
||
innermost = GFC_OMP_SPLIT_DO;
|
||
break;
|
||
case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
|
||
mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO
|
||
| GFC_OMP_MASK_SIMD;
|
||
innermost = GFC_OMP_SPLIT_SIMD;
|
||
break;
|
||
case EXEC_OMP_TARGET_SIMD:
|
||
mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_SIMD;
|
||
innermost = GFC_OMP_SPLIT_SIMD;
|
||
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_TARGET_TEAMS_LOOP:
|
||
mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DO;
|
||
innermost = GFC_OMP_SPLIT_DO;
|
||
break;
|
||
case EXEC_OMP_MASKED_TASKLOOP:
|
||
mask = GFC_OMP_MASK_MASKED | GFC_OMP_MASK_TASKLOOP;
|
||
innermost = GFC_OMP_SPLIT_TASKLOOP;
|
||
break;
|
||
case EXEC_OMP_MASTER_TASKLOOP:
|
||
case EXEC_OMP_TASKLOOP:
|
||
innermost = GFC_OMP_SPLIT_TASKLOOP;
|
||
break;
|
||
case EXEC_OMP_MASKED_TASKLOOP_SIMD:
|
||
mask = GFC_OMP_MASK_MASKED | GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD;
|
||
innermost = GFC_OMP_SPLIT_SIMD;
|
||
break;
|
||
case EXEC_OMP_MASTER_TASKLOOP_SIMD:
|
||
case EXEC_OMP_TASKLOOP_SIMD:
|
||
mask = GFC_OMP_MASK_TASKLOOP | 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;
|
||
case EXEC_OMP_TEAMS_LOOP:
|
||
mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DO;
|
||
innermost = GFC_OMP_SPLIT_DO;
|
||
break;
|
||
default:
|
||
gcc_unreachable ();
|
||
}
|
||
if (mask == 0)
|
||
{
|
||
clausesa[innermost] = *code->ext.omp_clauses;
|
||
return;
|
||
}
|
||
/* Loops are similar to DO but still a bit different. */
|
||
switch (code->op)
|
||
{
|
||
case EXEC_OMP_LOOP:
|
||
case EXEC_OMP_PARALLEL_LOOP:
|
||
case EXEC_OMP_TEAMS_LOOP:
|
||
case EXEC_OMP_TARGET_PARALLEL_LOOP:
|
||
case EXEC_OMP_TARGET_TEAMS_LOOP:
|
||
is_loop = true;
|
||
default:
|
||
break;
|
||
}
|
||
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].lists[OMP_LIST_IS_DEVICE_PTR]
|
||
= code->ext.omp_clauses->lists[OMP_LIST_IS_DEVICE_PTR];
|
||
clausesa[GFC_OMP_SPLIT_TARGET].device
|
||
= code->ext.omp_clauses->device;
|
||
clausesa[GFC_OMP_SPLIT_TARGET].thread_limit
|
||
= code->ext.omp_clauses->thread_limit;
|
||
for (int i = 0; i < OMP_DEFAULTMAP_CAT_NUM; i++)
|
||
clausesa[GFC_OMP_SPLIT_TARGET].defaultmap[i]
|
||
= code->ext.omp_clauses->defaultmap[i];
|
||
clausesa[GFC_OMP_SPLIT_TARGET].if_exprs[OMP_IF_TARGET]
|
||
= code->ext.omp_clauses->if_exprs[OMP_IF_TARGET];
|
||
/* And this is copied to all. */
|
||
clausesa[GFC_OMP_SPLIT_TARGET].if_expr
|
||
= code->ext.omp_clauses->if_expr;
|
||
clausesa[GFC_OMP_SPLIT_TARGET].nowait
|
||
= code->ext.omp_clauses->nowait;
|
||
}
|
||
if (mask & GFC_OMP_MASK_TEAMS)
|
||
{
|
||
/* First the clauses that are unique to some constructs. */
|
||
clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_lower
|
||
= code->ext.omp_clauses->num_teams_lower;
|
||
clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_upper
|
||
= code->ext.omp_clauses->num_teams_upper;
|
||
clausesa[GFC_OMP_SPLIT_TEAMS].thread_limit
|
||
= code->ext.omp_clauses->thread_limit;
|
||
/* Shared and default clauses are allowed on parallel, teams
|
||
and taskloop. */
|
||
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;
|
||
clausesa[GFC_OMP_SPLIT_DISTRIBUTE].order_concurrent
|
||
= code->ext.omp_clauses->order_concurrent;
|
||
clausesa[GFC_OMP_SPLIT_DISTRIBUTE].order_unconstrained
|
||
= code->ext.omp_clauses->order_unconstrained;
|
||
clausesa[GFC_OMP_SPLIT_DISTRIBUTE].order_reproducible
|
||
= code->ext.omp_clauses->order_reproducible;
|
||
}
|
||
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, teams
|
||
and taskloop. */
|
||
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;
|
||
clausesa[GFC_OMP_SPLIT_PARALLEL].if_exprs[OMP_IF_PARALLEL]
|
||
= code->ext.omp_clauses->if_exprs[OMP_IF_PARALLEL];
|
||
/* And this is copied to all. */
|
||
clausesa[GFC_OMP_SPLIT_PARALLEL].if_expr
|
||
= code->ext.omp_clauses->if_expr;
|
||
}
|
||
if (mask & GFC_OMP_MASK_MASKED)
|
||
clausesa[GFC_OMP_SPLIT_MASKED].filter = code->ext.omp_clauses->filter;
|
||
if ((mask & GFC_OMP_MASK_DO) && !is_loop)
|
||
{
|
||
/* 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].orderedc
|
||
= code->ext.omp_clauses->orderedc;
|
||
clausesa[GFC_OMP_SPLIT_DO].sched_kind
|
||
= code->ext.omp_clauses->sched_kind;
|
||
if (innermost == GFC_OMP_SPLIT_SIMD)
|
||
clausesa[GFC_OMP_SPLIT_DO].sched_simd
|
||
= code->ext.omp_clauses->sched_simd;
|
||
clausesa[GFC_OMP_SPLIT_DO].sched_monotonic
|
||
= code->ext.omp_clauses->sched_monotonic;
|
||
clausesa[GFC_OMP_SPLIT_DO].sched_nonmonotonic
|
||
= code->ext.omp_clauses->sched_nonmonotonic;
|
||
clausesa[GFC_OMP_SPLIT_DO].chunk_size
|
||
= code->ext.omp_clauses->chunk_size;
|
||
clausesa[GFC_OMP_SPLIT_DO].nowait
|
||
= code->ext.omp_clauses->nowait;
|
||
}
|
||
if (mask & GFC_OMP_MASK_DO)
|
||
{
|
||
clausesa[GFC_OMP_SPLIT_DO].bind
|
||
= code->ext.omp_clauses->bind;
|
||
/* Duplicate collapse. */
|
||
clausesa[GFC_OMP_SPLIT_DO].collapse
|
||
= code->ext.omp_clauses->collapse;
|
||
clausesa[GFC_OMP_SPLIT_DO].order_concurrent
|
||
= code->ext.omp_clauses->order_concurrent;
|
||
clausesa[GFC_OMP_SPLIT_DO].order_unconstrained
|
||
= code->ext.omp_clauses->order_unconstrained;
|
||
clausesa[GFC_OMP_SPLIT_DO].order_reproducible
|
||
= code->ext.omp_clauses->order_reproducible;
|
||
}
|
||
if (mask & GFC_OMP_MASK_SIMD)
|
||
{
|
||
clausesa[GFC_OMP_SPLIT_SIMD].safelen_expr
|
||
= code->ext.omp_clauses->safelen_expr;
|
||
clausesa[GFC_OMP_SPLIT_SIMD].simdlen_expr
|
||
= code->ext.omp_clauses->simdlen_expr;
|
||
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;
|
||
clausesa[GFC_OMP_SPLIT_SIMD].if_exprs[OMP_IF_SIMD]
|
||
= code->ext.omp_clauses->if_exprs[OMP_IF_SIMD];
|
||
clausesa[GFC_OMP_SPLIT_SIMD].order_concurrent
|
||
= code->ext.omp_clauses->order_concurrent;
|
||
clausesa[GFC_OMP_SPLIT_SIMD].order_unconstrained
|
||
= code->ext.omp_clauses->order_unconstrained;
|
||
clausesa[GFC_OMP_SPLIT_SIMD].order_reproducible
|
||
= code->ext.omp_clauses->order_reproducible;
|
||
/* And this is copied to all. */
|
||
clausesa[GFC_OMP_SPLIT_SIMD].if_expr
|
||
= code->ext.omp_clauses->if_expr;
|
||
}
|
||
if (mask & GFC_OMP_MASK_TASKLOOP)
|
||
{
|
||
/* First the clauses that are unique to some constructs. */
|
||
clausesa[GFC_OMP_SPLIT_TASKLOOP].nogroup
|
||
= code->ext.omp_clauses->nogroup;
|
||
clausesa[GFC_OMP_SPLIT_TASKLOOP].grainsize
|
||
= code->ext.omp_clauses->grainsize;
|
||
clausesa[GFC_OMP_SPLIT_TASKLOOP].grainsize_strict
|
||
= code->ext.omp_clauses->grainsize_strict;
|
||
clausesa[GFC_OMP_SPLIT_TASKLOOP].num_tasks
|
||
= code->ext.omp_clauses->num_tasks;
|
||
clausesa[GFC_OMP_SPLIT_TASKLOOP].num_tasks_strict
|
||
= code->ext.omp_clauses->num_tasks_strict;
|
||
clausesa[GFC_OMP_SPLIT_TASKLOOP].priority
|
||
= code->ext.omp_clauses->priority;
|
||
clausesa[GFC_OMP_SPLIT_TASKLOOP].final_expr
|
||
= code->ext.omp_clauses->final_expr;
|
||
clausesa[GFC_OMP_SPLIT_TASKLOOP].untied
|
||
= code->ext.omp_clauses->untied;
|
||
clausesa[GFC_OMP_SPLIT_TASKLOOP].mergeable
|
||
= code->ext.omp_clauses->mergeable;
|
||
clausesa[GFC_OMP_SPLIT_TASKLOOP].if_exprs[OMP_IF_TASKLOOP]
|
||
= code->ext.omp_clauses->if_exprs[OMP_IF_TASKLOOP];
|
||
/* And this is copied to all. */
|
||
clausesa[GFC_OMP_SPLIT_TASKLOOP].if_expr
|
||
= code->ext.omp_clauses->if_expr;
|
||
/* Shared and default clauses are allowed on parallel, teams
|
||
and taskloop. */
|
||
clausesa[GFC_OMP_SPLIT_TASKLOOP].lists[OMP_LIST_SHARED]
|
||
= code->ext.omp_clauses->lists[OMP_LIST_SHARED];
|
||
clausesa[GFC_OMP_SPLIT_TASKLOOP].default_sharing
|
||
= code->ext.omp_clauses->default_sharing;
|
||
/* Duplicate collapse. */
|
||
clausesa[GFC_OMP_SPLIT_TASKLOOP].collapse
|
||
= code->ext.omp_clauses->collapse;
|
||
}
|
||
/* Private clause is supported on all constructs but master/masked,
|
||
it is enough to put it on the innermost one except for master/masked. For
|
||
!$ omp parallel do put it on parallel though,
|
||
as that's what we did for OpenMP 3.1. */
|
||
clausesa[((innermost == GFC_OMP_SPLIT_DO && !is_loop)
|
||
|| code->op == EXEC_OMP_PARALLEL_MASTER
|
||
|| code->op == EXEC_OMP_PARALLEL_MASKED)
|
||
? (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
|
||
simd and masked/master. Put it on the outermost of those and duplicate
|
||
on parallel and teams. */
|
||
if (mask & GFC_OMP_MASK_TARGET)
|
||
clausesa[GFC_OMP_SPLIT_TARGET].lists[OMP_LIST_FIRSTPRIVATE]
|
||
= code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE];
|
||
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_TASKLOOP)
|
||
clausesa[GFC_OMP_SPLIT_TASKLOOP].lists[OMP_LIST_FIRSTPRIVATE]
|
||
= code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE];
|
||
if ((mask & GFC_OMP_MASK_PARALLEL)
|
||
&& !(mask & GFC_OMP_MASK_TASKLOOP))
|
||
clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_FIRSTPRIVATE]
|
||
= code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE];
|
||
else if ((mask & GFC_OMP_MASK_DO) && !is_loop)
|
||
clausesa[GFC_OMP_SPLIT_DO].lists[OMP_LIST_FIRSTPRIVATE]
|
||
= code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE];
|
||
/* Lastprivate is allowed on distribute, do, simd, taskloop and loop.
|
||
In parallel do{, simd} we actually want to put it on
|
||
parallel rather than do. */
|
||
if (mask & GFC_OMP_MASK_DISTRIBUTE)
|
||
clausesa[GFC_OMP_SPLIT_DISTRIBUTE].lists[OMP_LIST_LASTPRIVATE]
|
||
= code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE];
|
||
if (mask & GFC_OMP_MASK_TASKLOOP)
|
||
clausesa[GFC_OMP_SPLIT_TASKLOOP].lists[OMP_LIST_LASTPRIVATE]
|
||
= code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE];
|
||
if ((mask & GFC_OMP_MASK_PARALLEL) && !is_loop
|
||
&& !(mask & GFC_OMP_MASK_TASKLOOP))
|
||
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, teams, taskloop, and loop.
|
||
Duplicate it on all of them, but
|
||
- omit on do if parallel is present;
|
||
- omit on task and parallel if loop is present;
|
||
additionally, inscan applies to do/simd only. */
|
||
for (int i = OMP_LIST_REDUCTION; i <= OMP_LIST_REDUCTION_TASK; i++)
|
||
{
|
||
if (mask & GFC_OMP_MASK_TASKLOOP
|
||
&& i != OMP_LIST_REDUCTION_INSCAN)
|
||
clausesa[GFC_OMP_SPLIT_TASKLOOP].lists[i]
|
||
= code->ext.omp_clauses->lists[i];
|
||
if (mask & GFC_OMP_MASK_TEAMS
|
||
&& i != OMP_LIST_REDUCTION_INSCAN
|
||
&& !is_loop)
|
||
clausesa[GFC_OMP_SPLIT_TEAMS].lists[i]
|
||
= code->ext.omp_clauses->lists[i];
|
||
if (mask & GFC_OMP_MASK_PARALLEL
|
||
&& i != OMP_LIST_REDUCTION_INSCAN
|
||
&& !(mask & GFC_OMP_MASK_TASKLOOP)
|
||
&& !is_loop)
|
||
clausesa[GFC_OMP_SPLIT_PARALLEL].lists[i]
|
||
= code->ext.omp_clauses->lists[i];
|
||
else if (mask & GFC_OMP_MASK_DO)
|
||
clausesa[GFC_OMP_SPLIT_DO].lists[i]
|
||
= code->ext.omp_clauses->lists[i];
|
||
if (mask & GFC_OMP_MASK_SIMD)
|
||
clausesa[GFC_OMP_SPLIT_SIMD].lists[i]
|
||
= code->ext.omp_clauses->lists[i];
|
||
}
|
||
if (mask & GFC_OMP_MASK_TARGET)
|
||
clausesa[GFC_OMP_SPLIT_TARGET].lists[OMP_LIST_IN_REDUCTION]
|
||
= code->ext.omp_clauses->lists[OMP_LIST_IN_REDUCTION];
|
||
if (mask & GFC_OMP_MASK_TASKLOOP)
|
||
clausesa[GFC_OMP_SPLIT_TASKLOOP].lists[OMP_LIST_IN_REDUCTION]
|
||
= code->ext.omp_clauses->lists[OMP_LIST_IN_REDUCTION];
|
||
/* Linear clause is supported on do and simd,
|
||
put it on the innermost one. */
|
||
clausesa[innermost].lists[OMP_LIST_LINEAR]
|
||
= code->ext.omp_clauses->lists[OMP_LIST_LINEAR];
|
||
}
|
||
/* Propagate firstprivate/lastprivate/reduction vars to
|
||
shared (parallel, teams) and map-tofrom (target). */
|
||
if (mask & GFC_OMP_MASK_TARGET)
|
||
gfc_add_clause_implicitly (&clausesa[GFC_OMP_SPLIT_TARGET],
|
||
code->ext.omp_clauses, true, false);
|
||
if ((mask & GFC_OMP_MASK_PARALLEL) && innermost != GFC_OMP_MASK_PARALLEL)
|
||
gfc_add_clause_implicitly (&clausesa[GFC_OMP_SPLIT_PARALLEL],
|
||
code->ext.omp_clauses, false,
|
||
mask & GFC_OMP_MASK_DO);
|
||
if (mask & GFC_OMP_MASK_TEAMS && innermost != GFC_OMP_MASK_TEAMS)
|
||
gfc_add_clause_implicitly (&clausesa[GFC_OMP_SPLIT_TEAMS],
|
||
code->ext.omp_clauses, false, false);
|
||
if (((mask & (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO))
|
||
== (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO))
|
||
&& !is_loop)
|
||
clausesa[GFC_OMP_SPLIT_DO].nowait = true;
|
||
|
||
/* Distribute allocate clause to do, parallel, distribute, teams, target
|
||
and taskloop. The code below itereates over variables in the
|
||
allocate list and checks if that available is also in any
|
||
privatization clause on those construct. If yes, then we add it
|
||
to the list of 'allocate'ed variables for that construct. If a
|
||
variable is found in none of them then we issue an error. */
|
||
|
||
if (code->ext.omp_clauses->lists[OMP_LIST_ALLOCATE])
|
||
{
|
||
gfc_omp_namelist *alloc_nl, *priv_nl;
|
||
gfc_omp_namelist *tails[GFC_OMP_SPLIT_NUM];
|
||
for (alloc_nl = code->ext.omp_clauses->lists[OMP_LIST_ALLOCATE];
|
||
alloc_nl; alloc_nl = alloc_nl->next)
|
||
{
|
||
bool found = false;
|
||
for (int i = GFC_OMP_SPLIT_DO; i <= GFC_OMP_SPLIT_TASKLOOP; i++)
|
||
{
|
||
gfc_omp_namelist *p;
|
||
int list;
|
||
for (list = 0; list < OMP_LIST_NUM; list++)
|
||
{
|
||
switch (list)
|
||
{
|
||
case OMP_LIST_PRIVATE:
|
||
case OMP_LIST_FIRSTPRIVATE:
|
||
case OMP_LIST_LASTPRIVATE:
|
||
case OMP_LIST_REDUCTION:
|
||
case OMP_LIST_REDUCTION_INSCAN:
|
||
case OMP_LIST_REDUCTION_TASK:
|
||
case OMP_LIST_IN_REDUCTION:
|
||
case OMP_LIST_TASK_REDUCTION:
|
||
case OMP_LIST_LINEAR:
|
||
for (priv_nl = clausesa[i].lists[list]; priv_nl;
|
||
priv_nl = priv_nl->next)
|
||
if (alloc_nl->sym == priv_nl->sym)
|
||
{
|
||
found = true;
|
||
p = gfc_get_omp_namelist ();
|
||
p->sym = alloc_nl->sym;
|
||
p->expr = alloc_nl->expr;
|
||
p->where = alloc_nl->where;
|
||
if (clausesa[i].lists[OMP_LIST_ALLOCATE] == NULL)
|
||
{
|
||
clausesa[i].lists[OMP_LIST_ALLOCATE] = p;
|
||
tails[i] = p;
|
||
}
|
||
else
|
||
{
|
||
tails[i]->next = p;
|
||
tails[i] = tails[i]->next;
|
||
}
|
||
}
|
||
break;
|
||
default:
|
||
break;
|
||
}
|
||
}
|
||
}
|
||
if (!found)
|
||
gfc_error ("%qs specified in 'allocate' clause at %L but not "
|
||
"in an explicit privatization clause",
|
||
alloc_nl->sym->name, &alloc_nl->where);
|
||
}
|
||
}
|
||
}
|
||
|
||
static tree
|
||
gfc_trans_omp_do_simd (gfc_code *code, stmtblock_t *pblock,
|
||
gfc_omp_clauses *clausesa, tree omp_clauses)
|
||
{
|
||
stmtblock_t block;
|
||
gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM];
|
||
tree stmt, body, omp_do_clauses = NULL_TREE;
|
||
bool free_clausesa = false;
|
||
|
||
if (pblock == NULL)
|
||
gfc_start_block (&block);
|
||
else
|
||
gfc_init_block (&block);
|
||
|
||
if (clausesa == NULL)
|
||
{
|
||
clausesa = clausesa_buf;
|
||
gfc_split_omp_clauses (code, clausesa);
|
||
free_clausesa = true;
|
||
}
|
||
if (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 (flag_openmp)
|
||
{
|
||
stmt = make_node (OMP_FOR);
|
||
TREE_TYPE (stmt) = void_type_node;
|
||
OMP_FOR_BODY (stmt) = body;
|
||
OMP_FOR_CLAUSES (stmt) = omp_do_clauses;
|
||
}
|
||
else
|
||
stmt = body;
|
||
gfc_add_expr_to_block (&block, stmt);
|
||
if (free_clausesa)
|
||
gfc_free_split_omp_clauses (code, clausesa);
|
||
return gfc_finish_block (&block);
|
||
}
|
||
|
||
static tree
|
||
gfc_trans_omp_parallel_do (gfc_code *code, bool is_loop, 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;
|
||
bool free_clausesa = false;
|
||
|
||
if (pblock == NULL)
|
||
gfc_start_block (&block);
|
||
else
|
||
gfc_init_block (&block);
|
||
|
||
if (clausesa == NULL)
|
||
{
|
||
clausesa = clausesa_buf;
|
||
gfc_split_omp_clauses (code, clausesa);
|
||
free_clausesa = true;
|
||
}
|
||
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, is_loop ? EXEC_OMP_LOOP : 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 (gfc_get_location (&code->loc), OMP_PARALLEL,
|
||
void_type_node, stmt, omp_clauses);
|
||
OMP_PARALLEL_COMBINED (stmt) = 1;
|
||
gfc_add_expr_to_block (&block, stmt);
|
||
if (free_clausesa)
|
||
gfc_free_split_omp_clauses (code, clausesa);
|
||
return gfc_finish_block (&block);
|
||
}
|
||
|
||
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;
|
||
bool free_clausesa = false;
|
||
|
||
if (pblock == NULL)
|
||
gfc_start_block (&block);
|
||
else
|
||
gfc_init_block (&block);
|
||
|
||
if (clausesa == NULL)
|
||
{
|
||
clausesa = clausesa_buf;
|
||
gfc_split_omp_clauses (code, clausesa);
|
||
free_clausesa = true;
|
||
}
|
||
if (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 (flag_openmp)
|
||
{
|
||
stmt = build2_loc (gfc_get_location (&code->loc), OMP_PARALLEL,
|
||
void_type_node, stmt, omp_clauses);
|
||
OMP_PARALLEL_COMBINED (stmt) = 1;
|
||
}
|
||
gfc_add_expr_to_block (&block, stmt);
|
||
if (free_clausesa)
|
||
gfc_free_split_omp_clauses (code, clausesa);
|
||
return gfc_finish_block (&block);
|
||
}
|
||
|
||
static tree
|
||
gfc_trans_omp_parallel_sections (gfc_code *code)
|
||
{
|
||
stmtblock_t block;
|
||
gfc_omp_clauses section_clauses;
|
||
tree stmt, omp_clauses;
|
||
|
||
memset (§ion_clauses, 0, sizeof (section_clauses));
|
||
section_clauses.nowait = true;
|
||
|
||
gfc_start_block (&block);
|
||
omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
|
||
code->loc);
|
||
pushlevel ();
|
||
stmt = gfc_trans_omp_sections (code, §ion_clauses);
|
||
if (TREE_CODE (stmt) != BIND_EXPR)
|
||
stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
|
||
else
|
||
poplevel (0, 0);
|
||
stmt = build2_loc (gfc_get_location (&code->loc), 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_workshare (gfc_code *code)
|
||
{
|
||
stmtblock_t block;
|
||
gfc_omp_clauses workshare_clauses;
|
||
tree stmt, omp_clauses;
|
||
|
||
memset (&workshare_clauses, 0, sizeof (workshare_clauses));
|
||
workshare_clauses.nowait = true;
|
||
|
||
gfc_start_block (&block);
|
||
omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
|
||
code->loc);
|
||
pushlevel ();
|
||
stmt = gfc_trans_omp_workshare (code, &workshare_clauses);
|
||
stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
|
||
stmt = build2_loc (gfc_get_location (&code->loc), 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_scope (gfc_code *code)
|
||
{
|
||
stmtblock_t block;
|
||
tree body = gfc_trans_code (code->block->next);
|
||
if (IS_EMPTY_STMT (body))
|
||
return body;
|
||
gfc_start_block (&block);
|
||
tree omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
|
||
code->loc);
|
||
tree stmt = make_node (OMP_SCOPE);
|
||
TREE_TYPE (stmt) = void_type_node;
|
||
OMP_SCOPE_BODY (stmt) = body;
|
||
OMP_SCOPE_CLAUSES (stmt) = omp_clauses;
|
||
gfc_add_expr_to_block (&block, stmt);
|
||
return gfc_finish_block (&block);
|
||
}
|
||
|
||
static tree
|
||
gfc_trans_omp_sections (gfc_code *code, gfc_omp_clauses *clauses)
|
||
{
|
||
stmtblock_t block, body;
|
||
tree omp_clauses, stmt;
|
||
bool has_lastprivate = clauses->lists[OMP_LIST_LASTPRIVATE] != NULL;
|
||
location_t loc = gfc_get_location (&code->loc);
|
||
|
||
gfc_start_block (&block);
|
||
|
||
omp_clauses = gfc_trans_omp_clauses (&block, clauses, code->loc);
|
||
|
||
gfc_init_block (&body);
|
||
for (code = code->block; code; code = code->block)
|
||
{
|
||
/* Last section is special because of lastprivate, so even if it
|
||
is empty, chain it in. */
|
||
stmt = gfc_trans_omp_code (code->next,
|
||
has_lastprivate && code->block == NULL);
|
||
if (! IS_EMPTY_STMT (stmt))
|
||
{
|
||
stmt = build1_v (OMP_SECTION, stmt);
|
||
gfc_add_expr_to_block (&body, stmt);
|
||
}
|
||
}
|
||
stmt = gfc_finish_block (&body);
|
||
|
||
stmt = build2_loc (loc, OMP_SECTIONS, void_type_node, stmt, omp_clauses);
|
||
gfc_add_expr_to_block (&block, stmt);
|
||
|
||
return gfc_finish_block (&block);
|
||
}
|
||
|
||
static tree
|
||
gfc_trans_omp_single (gfc_code *code, gfc_omp_clauses *clauses)
|
||
{
|
||
tree omp_clauses = gfc_trans_omp_clauses (NULL, clauses, code->loc);
|
||
tree stmt = gfc_trans_omp_code (code->block->next, true);
|
||
stmt = build2_loc (gfc_get_location (&code->loc), OMP_SINGLE, void_type_node,
|
||
stmt, omp_clauses);
|
||
return stmt;
|
||
}
|
||
|
||
static tree
|
||
gfc_trans_omp_task (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);
|
||
pushlevel ();
|
||
stmt = gfc_trans_omp_code (code->block->next, true);
|
||
stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
|
||
stmt = build2_loc (gfc_get_location (&code->loc), OMP_TASK, void_type_node,
|
||
stmt, omp_clauses);
|
||
gfc_add_expr_to_block (&block, stmt);
|
||
return gfc_finish_block (&block);
|
||
}
|
||
|
||
static tree
|
||
gfc_trans_omp_taskgroup (gfc_code *code)
|
||
{
|
||
stmtblock_t block;
|
||
gfc_start_block (&block);
|
||
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) = gfc_trans_omp_clauses (&block,
|
||
code->ext.omp_clauses,
|
||
code->loc);
|
||
gfc_add_expr_to_block (&block, stmt);
|
||
return gfc_finish_block (&block);
|
||
}
|
||
|
||
static tree
|
||
gfc_trans_omp_taskwait (gfc_code *code)
|
||
{
|
||
if (!code->ext.omp_clauses)
|
||
{
|
||
tree decl = builtin_decl_explicit (BUILT_IN_GOMP_TASKWAIT);
|
||
return build_call_expr_loc (input_location, decl, 0);
|
||
}
|
||
stmtblock_t block;
|
||
gfc_start_block (&block);
|
||
tree stmt = make_node (OMP_TASK);
|
||
TREE_TYPE (stmt) = void_type_node;
|
||
OMP_TASK_BODY (stmt) = NULL_TREE;
|
||
OMP_TASK_CLAUSES (stmt) = gfc_trans_omp_clauses (&block,
|
||
code->ext.omp_clauses,
|
||
code->loc);
|
||
gfc_add_expr_to_block (&block, stmt);
|
||
return gfc_finish_block (&block);
|
||
}
|
||
|
||
static tree
|
||
gfc_trans_omp_taskyield (void)
|
||
{
|
||
tree decl = builtin_decl_explicit (BUILT_IN_GOMP_TASKYIELD);
|
||
return build_call_expr_loc (input_location, decl, 0);
|
||
}
|
||
|
||
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;
|
||
bool free_clausesa = false;
|
||
|
||
gfc_start_block (&block);
|
||
if (clausesa == NULL)
|
||
{
|
||
clausesa = clausesa_buf;
|
||
gfc_split_omp_clauses (code, clausesa);
|
||
free_clausesa = true;
|
||
}
|
||
if (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, false, &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 (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);
|
||
if (free_clausesa)
|
||
gfc_free_split_omp_clauses (code, clausesa);
|
||
return gfc_finish_block (&block);
|
||
}
|
||
|
||
static tree
|
||
gfc_trans_omp_teams (gfc_code *code, gfc_omp_clauses *clausesa,
|
||
tree omp_clauses)
|
||
{
|
||
stmtblock_t block;
|
||
gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM];
|
||
tree stmt;
|
||
bool combined = true, free_clausesa = false;
|
||
|
||
gfc_start_block (&block);
|
||
if (clausesa == NULL)
|
||
{
|
||
clausesa = clausesa_buf;
|
||
gfc_split_omp_clauses (code, clausesa);
|
||
free_clausesa = true;
|
||
}
|
||
if (flag_openmp)
|
||
{
|
||
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:
|
||
case EXEC_OMP_TEAMS:
|
||
stmt = gfc_trans_omp_code (code->block->next, true);
|
||
combined = false;
|
||
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;
|
||
case EXEC_OMP_TARGET_TEAMS_LOOP:
|
||
case EXEC_OMP_TEAMS_LOOP:
|
||
stmt = gfc_trans_omp_do (code, EXEC_OMP_LOOP, NULL,
|
||
&clausesa[GFC_OMP_SPLIT_DO],
|
||
NULL);
|
||
break;
|
||
default:
|
||
stmt = gfc_trans_omp_distribute (code, clausesa);
|
||
break;
|
||
}
|
||
if (flag_openmp)
|
||
{
|
||
stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
|
||
stmt = build2_loc (gfc_get_location (&code->loc), OMP_TEAMS,
|
||
void_type_node, stmt, omp_clauses);
|
||
if (combined)
|
||
OMP_TEAMS_COMBINED (stmt) = 1;
|
||
}
|
||
gfc_add_expr_to_block (&block, stmt);
|
||
if (free_clausesa)
|
||
gfc_free_split_omp_clauses (code, clausesa);
|
||
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 (flag_openmp)
|
||
omp_clauses
|
||
= gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_TARGET],
|
||
code->loc);
|
||
switch (code->op)
|
||
{
|
||
case EXEC_OMP_TARGET:
|
||
pushlevel ();
|
||
stmt = gfc_trans_omp_code (code->block->next, true);
|
||
stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
|
||
break;
|
||
case EXEC_OMP_TARGET_PARALLEL:
|
||
{
|
||
stmtblock_t iblock;
|
||
|
||
pushlevel ();
|
||
gfc_start_block (&iblock);
|
||
tree inner_clauses
|
||
= gfc_trans_omp_clauses (&iblock, &clausesa[GFC_OMP_SPLIT_PARALLEL],
|
||
code->loc);
|
||
stmt = gfc_trans_omp_code (code->block->next, true);
|
||
stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt,
|
||
inner_clauses);
|
||
gfc_add_expr_to_block (&iblock, stmt);
|
||
stmt = gfc_finish_block (&iblock);
|
||
if (TREE_CODE (stmt) != BIND_EXPR)
|
||
stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
|
||
else
|
||
poplevel (0, 0);
|
||
}
|
||
break;
|
||
case EXEC_OMP_TARGET_PARALLEL_DO:
|
||
case EXEC_OMP_TARGET_PARALLEL_LOOP:
|
||
stmt = gfc_trans_omp_parallel_do (code,
|
||
(code->op
|
||
== EXEC_OMP_TARGET_PARALLEL_LOOP),
|
||
&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_TARGET_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_TARGET_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:
|
||
if (flag_openmp
|
||
&& (clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_upper
|
||
|| clausesa[GFC_OMP_SPLIT_TEAMS].thread_limit))
|
||
{
|
||
gfc_omp_clauses clausesb;
|
||
tree teams_clauses;
|
||
/* For combined !$omp target teams, the num_teams and
|
||
thread_limit clauses are evaluated before entering the
|
||
target construct. */
|
||
memset (&clausesb, '\0', sizeof (clausesb));
|
||
clausesb.num_teams_lower
|
||
= clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_lower;
|
||
clausesb.num_teams_upper
|
||
= clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_upper;
|
||
clausesb.thread_limit = clausesa[GFC_OMP_SPLIT_TEAMS].thread_limit;
|
||
clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_lower = NULL;
|
||
clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_upper = NULL;
|
||
clausesa[GFC_OMP_SPLIT_TEAMS].thread_limit = NULL;
|
||
teams_clauses
|
||
= gfc_trans_omp_clauses (&block, &clausesb, code->loc);
|
||
pushlevel ();
|
||
stmt = gfc_trans_omp_teams (code, clausesa, teams_clauses);
|
||
}
|
||
else
|
||
{
|
||
pushlevel ();
|
||
stmt = gfc_trans_omp_teams (code, clausesa, NULL_TREE);
|
||
}
|
||
if (TREE_CODE (stmt) != BIND_EXPR)
|
||
stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
|
||
else
|
||
poplevel (0, 0);
|
||
break;
|
||
}
|
||
if (flag_openmp)
|
||
{
|
||
stmt = build2_loc (gfc_get_location (&code->loc), OMP_TARGET,
|
||
void_type_node, stmt, omp_clauses);
|
||
if (code->op != EXEC_OMP_TARGET)
|
||
OMP_TARGET_COMBINED (stmt) = 1;
|
||
cfun->has_omp_target = true;
|
||
}
|
||
gfc_add_expr_to_block (&block, stmt);
|
||
gfc_free_split_omp_clauses (code, clausesa);
|
||
return gfc_finish_block (&block);
|
||
}
|
||
|
||
static tree
|
||
gfc_trans_omp_taskloop (gfc_code *code, gfc_exec_op op)
|
||
{
|
||
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 (flag_openmp)
|
||
omp_clauses
|
||
= gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_TASKLOOP],
|
||
code->loc);
|
||
switch (op)
|
||
{
|
||
case EXEC_OMP_TASKLOOP:
|
||
/* This is handled in gfc_trans_omp_do. */
|
||
gcc_unreachable ();
|
||
break;
|
||
case EXEC_OMP_TASKLOOP_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 (flag_openmp)
|
||
{
|
||
tree taskloop = make_node (OMP_TASKLOOP);
|
||
TREE_TYPE (taskloop) = void_type_node;
|
||
OMP_FOR_BODY (taskloop) = stmt;
|
||
OMP_FOR_CLAUSES (taskloop) = omp_clauses;
|
||
stmt = taskloop;
|
||
}
|
||
gfc_add_expr_to_block (&block, stmt);
|
||
gfc_free_split_omp_clauses (code, clausesa);
|
||
return gfc_finish_block (&block);
|
||
}
|
||
|
||
static tree
|
||
gfc_trans_omp_master_masked_taskloop (gfc_code *code, gfc_exec_op op)
|
||
{
|
||
gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM];
|
||
stmtblock_t block;
|
||
tree stmt;
|
||
|
||
if (op != EXEC_OMP_MASTER_TASKLOOP_SIMD
|
||
&& code->op != EXEC_OMP_MASTER_TASKLOOP)
|
||
gfc_split_omp_clauses (code, clausesa);
|
||
|
||
pushlevel ();
|
||
if (op == EXEC_OMP_MASKED_TASKLOOP_SIMD
|
||
|| op == EXEC_OMP_MASTER_TASKLOOP_SIMD)
|
||
stmt = gfc_trans_omp_taskloop (code, EXEC_OMP_TASKLOOP_SIMD);
|
||
else
|
||
{
|
||
gcc_assert (op == EXEC_OMP_MASKED_TASKLOOP
|
||
|| op == EXEC_OMP_MASTER_TASKLOOP);
|
||
stmt = gfc_trans_omp_do (code, EXEC_OMP_TASKLOOP, NULL,
|
||
code->op != EXEC_OMP_MASTER_TASKLOOP
|
||
? &clausesa[GFC_OMP_SPLIT_TASKLOOP]
|
||
: code->ext.omp_clauses, NULL);
|
||
}
|
||
if (TREE_CODE (stmt) != BIND_EXPR)
|
||
stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
|
||
else
|
||
poplevel (0, 0);
|
||
gfc_start_block (&block);
|
||
if (op == EXEC_OMP_MASKED_TASKLOOP || op == EXEC_OMP_MASKED_TASKLOOP_SIMD)
|
||
{
|
||
tree clauses = gfc_trans_omp_clauses (&block,
|
||
&clausesa[GFC_OMP_SPLIT_MASKED],
|
||
code->loc);
|
||
tree msk = make_node (OMP_MASKED);
|
||
TREE_TYPE (msk) = void_type_node;
|
||
OMP_MASKED_BODY (msk) = stmt;
|
||
OMP_MASKED_CLAUSES (msk) = clauses;
|
||
OMP_MASKED_COMBINED (msk) = 1;
|
||
gfc_add_expr_to_block (&block, msk);
|
||
}
|
||
else
|
||
{
|
||
gcc_assert (op == EXEC_OMP_MASTER_TASKLOOP
|
||
|| op == EXEC_OMP_MASTER_TASKLOOP_SIMD);
|
||
stmt = build1_v (OMP_MASTER, stmt);
|
||
gfc_add_expr_to_block (&block, stmt);
|
||
}
|
||
if (op != EXEC_OMP_MASTER_TASKLOOP_SIMD
|
||
&& code->op != EXEC_OMP_MASTER_TASKLOOP)
|
||
gfc_free_split_omp_clauses (code, clausesa);
|
||
return gfc_finish_block (&block);
|
||
}
|
||
|
||
static tree
|
||
gfc_trans_omp_parallel_master_masked (gfc_code *code)
|
||
{
|
||
stmtblock_t block;
|
||
tree stmt, omp_clauses;
|
||
gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM];
|
||
bool parallel_combined = false;
|
||
|
||
if (code->op != EXEC_OMP_PARALLEL_MASTER)
|
||
gfc_split_omp_clauses (code, clausesa);
|
||
|
||
gfc_start_block (&block);
|
||
omp_clauses = gfc_trans_omp_clauses (&block,
|
||
code->op == EXEC_OMP_PARALLEL_MASTER
|
||
? code->ext.omp_clauses
|
||
: &clausesa[GFC_OMP_SPLIT_PARALLEL],
|
||
code->loc);
|
||
pushlevel ();
|
||
if (code->op == EXEC_OMP_PARALLEL_MASTER)
|
||
stmt = gfc_trans_omp_master (code);
|
||
else if (code->op == EXEC_OMP_PARALLEL_MASKED)
|
||
stmt = gfc_trans_omp_masked (code, &clausesa[GFC_OMP_SPLIT_MASKED]);
|
||
else
|
||
{
|
||
gfc_exec_op op;
|
||
switch (code->op)
|
||
{
|
||
case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
|
||
op = EXEC_OMP_MASKED_TASKLOOP;
|
||
break;
|
||
case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
|
||
op = EXEC_OMP_MASKED_TASKLOOP_SIMD;
|
||
break;
|
||
case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
|
||
op = EXEC_OMP_MASTER_TASKLOOP;
|
||
break;
|
||
case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
|
||
op = EXEC_OMP_MASTER_TASKLOOP_SIMD;
|
||
break;
|
||
default:
|
||
gcc_unreachable ();
|
||
}
|
||
stmt = gfc_trans_omp_master_masked_taskloop (code, op);
|
||
parallel_combined = true;
|
||
}
|
||
if (TREE_CODE (stmt) != BIND_EXPR)
|
||
stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
|
||
else
|
||
poplevel (0, 0);
|
||
stmt = build2_loc (gfc_get_location (&code->loc), OMP_PARALLEL,
|
||
void_type_node, stmt, omp_clauses);
|
||
/* masked does have just filter clause, but during gimplification
|
||
isn't represented by a gimplification omp context, so for
|
||
!$omp parallel masked don't set OMP_PARALLEL_COMBINED,
|
||
so that
|
||
!$omp parallel masked
|
||
!$omp taskloop simd lastprivate (x)
|
||
isn't confused with
|
||
!$omp parallel masked taskloop simd lastprivate (x) */
|
||
if (parallel_combined)
|
||
OMP_PARALLEL_COMBINED (stmt) = 1;
|
||
gfc_add_expr_to_block (&block, stmt);
|
||
if (code->op != EXEC_OMP_PARALLEL_MASTER)
|
||
gfc_free_split_omp_clauses (code, clausesa);
|
||
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 (gfc_get_location (&code->loc), 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_enter_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 = build1_loc (input_location, OMP_TARGET_ENTER_DATA, void_type_node,
|
||
omp_clauses);
|
||
gfc_add_expr_to_block (&block, stmt);
|
||
return gfc_finish_block (&block);
|
||
}
|
||
|
||
static tree
|
||
gfc_trans_omp_target_exit_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 = build1_loc (input_location, OMP_TARGET_EXIT_DATA, void_type_node,
|
||
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;
|
||
stmtblock_t block, *pblock = NULL;
|
||
stmtblock_t singleblock;
|
||
int saved_ompws_flags;
|
||
bool singleblock_in_progress = false;
|
||
/* True if previous gfc_code in workshare construct is not workshared. */
|
||
bool prev_singleunit;
|
||
location_t loc = gfc_get_location (&code->loc);
|
||
|
||
code = code->block->next;
|
||
|
||
pushlevel ();
|
||
|
||
gfc_start_block (&block);
|
||
pblock = █
|
||
|
||
ompws_flags = OMPWS_WORKSHARE_FLAG;
|
||
prev_singleunit = false;
|
||
|
||
/* Translate statements one by one to trees until we reach
|
||
the end of the workshare construct. Adjacent gfc_codes that
|
||
are a single unit of work are clustered and encapsulated in a
|
||
single OMP_SINGLE construct. */
|
||
for (; code; code = code->next)
|
||
{
|
||
if (code->here != 0)
|
||
{
|
||
res = gfc_trans_label_here (code);
|
||
gfc_add_expr_to_block (pblock, res);
|
||
}
|
||
|
||
/* No dependence analysis, use for clauses with wait.
|
||
If this is the last gfc_code, use default omp_clauses. */
|
||
if (code->next == NULL && clauses->nowait)
|
||
ompws_flags |= OMPWS_NOWAIT;
|
||
|
||
/* By default, every gfc_code is a single unit of work. */
|
||
ompws_flags |= OMPWS_CURR_SINGLEUNIT;
|
||
ompws_flags &= ~(OMPWS_SCALARIZER_WS | OMPWS_SCALARIZER_BODY);
|
||
|
||
switch (code->op)
|
||
{
|
||
case EXEC_NOP:
|
||
res = NULL_TREE;
|
||
break;
|
||
|
||
case EXEC_ASSIGN:
|
||
res = gfc_trans_assign (code);
|
||
break;
|
||
|
||
case EXEC_POINTER_ASSIGN:
|
||
res = gfc_trans_pointer_assign (code);
|
||
break;
|
||
|
||
case EXEC_INIT_ASSIGN:
|
||
res = gfc_trans_init_assign (code);
|
||
break;
|
||
|
||
case EXEC_FORALL:
|
||
res = gfc_trans_forall (code);
|
||
break;
|
||
|
||
case EXEC_WHERE:
|
||
res = gfc_trans_where (code);
|
||
break;
|
||
|
||
case EXEC_OMP_ATOMIC:
|
||
res = gfc_trans_omp_directive (code);
|
||
break;
|
||
|
||
case EXEC_OMP_PARALLEL:
|
||
case EXEC_OMP_PARALLEL_DO:
|
||
case EXEC_OMP_PARALLEL_MASTER:
|
||
case EXEC_OMP_PARALLEL_SECTIONS:
|
||
case EXEC_OMP_PARALLEL_WORKSHARE:
|
||
case EXEC_OMP_CRITICAL:
|
||
saved_ompws_flags = ompws_flags;
|
||
ompws_flags = 0;
|
||
res = gfc_trans_omp_directive (code);
|
||
ompws_flags = saved_ompws_flags;
|
||
break;
|
||
|
||
case EXEC_BLOCK:
|
||
res = gfc_trans_block_construct (code);
|
||
break;
|
||
|
||
default:
|
||
gfc_internal_error ("gfc_trans_omp_workshare(): Bad statement code");
|
||
}
|
||
|
||
gfc_set_backend_locus (&code->loc);
|
||
|
||
if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
|
||
{
|
||
if (prev_singleunit)
|
||
{
|
||
if (ompws_flags & OMPWS_CURR_SINGLEUNIT)
|
||
/* Add current gfc_code to single block. */
|
||
gfc_add_expr_to_block (&singleblock, res);
|
||
else
|
||
{
|
||
/* Finish single block and add it to pblock. */
|
||
tmp = gfc_finish_block (&singleblock);
|
||
tmp = build2_loc (loc, OMP_SINGLE,
|
||
void_type_node, tmp, NULL_TREE);
|
||
gfc_add_expr_to_block (pblock, tmp);
|
||
/* Add current gfc_code to pblock. */
|
||
gfc_add_expr_to_block (pblock, res);
|
||
singleblock_in_progress = false;
|
||
}
|
||
}
|
||
else
|
||
{
|
||
if (ompws_flags & OMPWS_CURR_SINGLEUNIT)
|
||
{
|
||
/* Start single block. */
|
||
gfc_init_block (&singleblock);
|
||
gfc_add_expr_to_block (&singleblock, res);
|
||
singleblock_in_progress = true;
|
||
loc = gfc_get_location (&code->loc);
|
||
}
|
||
else
|
||
/* Add the new statement to the block. */
|
||
gfc_add_expr_to_block (pblock, res);
|
||
}
|
||
prev_singleunit = (ompws_flags & OMPWS_CURR_SINGLEUNIT) != 0;
|
||
}
|
||
}
|
||
|
||
/* Finish remaining SINGLE block, if we were in the middle of one. */
|
||
if (singleblock_in_progress)
|
||
{
|
||
/* Finish single block and add it to pblock. */
|
||
tmp = gfc_finish_block (&singleblock);
|
||
tmp = build2_loc (loc, OMP_SINGLE, void_type_node, tmp,
|
||
clauses->nowait
|
||
? build_omp_clause (input_location, OMP_CLAUSE_NOWAIT)
|
||
: NULL_TREE);
|
||
gfc_add_expr_to_block (pblock, tmp);
|
||
}
|
||
|
||
stmt = gfc_finish_block (pblock);
|
||
if (TREE_CODE (stmt) != BIND_EXPR)
|
||
{
|
||
if (!IS_EMPTY_STMT (stmt))
|
||
{
|
||
tree bindblock = poplevel (1, 0);
|
||
stmt = build3_v (BIND_EXPR, NULL, stmt, bindblock);
|
||
}
|
||
else
|
||
poplevel (0, 0);
|
||
}
|
||
else
|
||
poplevel (0, 0);
|
||
|
||
if (IS_EMPTY_STMT (stmt) && !clauses->nowait)
|
||
stmt = gfc_trans_omp_barrier ();
|
||
|
||
ompws_flags = 0;
|
||
return stmt;
|
||
}
|
||
|
||
tree
|
||
gfc_trans_oacc_declare (gfc_code *code)
|
||
{
|
||
stmtblock_t block;
|
||
tree stmt, oacc_clauses;
|
||
enum tree_code construct_code;
|
||
|
||
construct_code = OACC_DATA;
|
||
|
||
gfc_start_block (&block);
|
||
|
||
oacc_clauses = gfc_trans_omp_clauses (&block, code->ext.oacc_declare->clauses,
|
||
code->loc, false, true);
|
||
stmt = gfc_trans_omp_code (code->block->next, true);
|
||
stmt = build2_loc (input_location, construct_code, void_type_node, stmt,
|
||
oacc_clauses);
|
||
gfc_add_expr_to_block (&block, stmt);
|
||
|
||
return gfc_finish_block (&block);
|
||
}
|
||
|
||
tree
|
||
gfc_trans_oacc_directive (gfc_code *code)
|
||
{
|
||
switch (code->op)
|
||
{
|
||
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);
|
||
case EXEC_OACC_LOOP:
|
||
return gfc_trans_omp_do (code, code->op, NULL, code->ext.omp_clauses,
|
||
NULL);
|
||
case EXEC_OACC_UPDATE:
|
||
case EXEC_OACC_CACHE:
|
||
case EXEC_OACC_ENTER_DATA:
|
||
case EXEC_OACC_EXIT_DATA:
|
||
return gfc_trans_oacc_executable_directive (code);
|
||
case EXEC_OACC_WAIT:
|
||
return gfc_trans_oacc_wait_directive (code);
|
||
case EXEC_OACC_ATOMIC:
|
||
return gfc_trans_omp_atomic (code);
|
||
case EXEC_OACC_DECLARE:
|
||
return gfc_trans_oacc_declare (code);
|
||
default:
|
||
gcc_unreachable ();
|
||
}
|
||
}
|
||
|
||
tree
|
||
gfc_trans_omp_directive (gfc_code *code)
|
||
{
|
||
switch (code->op)
|
||
{
|
||
case EXEC_OMP_ATOMIC:
|
||
return gfc_trans_omp_atomic (code);
|
||
case EXEC_OMP_BARRIER:
|
||
return gfc_trans_omp_barrier ();
|
||
case EXEC_OMP_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_DEPOBJ:
|
||
return gfc_trans_omp_depobj (code);
|
||
case EXEC_OMP_DISTRIBUTE:
|
||
case EXEC_OMP_DO:
|
||
case EXEC_OMP_LOOP:
|
||
case EXEC_OMP_SIMD:
|
||
case EXEC_OMP_TASKLOOP:
|
||
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_ERROR:
|
||
return gfc_trans_omp_error (code);
|
||
case EXEC_OMP_FLUSH:
|
||
return gfc_trans_omp_flush (code);
|
||
case EXEC_OMP_MASKED:
|
||
return gfc_trans_omp_masked (code, NULL);
|
||
case EXEC_OMP_MASTER:
|
||
return gfc_trans_omp_master (code);
|
||
case EXEC_OMP_MASKED_TASKLOOP:
|
||
case EXEC_OMP_MASKED_TASKLOOP_SIMD:
|
||
case EXEC_OMP_MASTER_TASKLOOP:
|
||
case EXEC_OMP_MASTER_TASKLOOP_SIMD:
|
||
return gfc_trans_omp_master_masked_taskloop (code, code->op);
|
||
case EXEC_OMP_ORDERED:
|
||
return gfc_trans_omp_ordered (code);
|
||
case EXEC_OMP_PARALLEL:
|
||
return gfc_trans_omp_parallel (code);
|
||
case EXEC_OMP_PARALLEL_DO:
|
||
return gfc_trans_omp_parallel_do (code, false, NULL, NULL);
|
||
case EXEC_OMP_PARALLEL_LOOP:
|
||
return gfc_trans_omp_parallel_do (code, true, NULL, NULL);
|
||
case EXEC_OMP_PARALLEL_DO_SIMD:
|
||
return gfc_trans_omp_parallel_do_simd (code, NULL, NULL);
|
||
case EXEC_OMP_PARALLEL_MASKED:
|
||
case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
|
||
case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
|
||
case EXEC_OMP_PARALLEL_MASTER:
|
||
case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
|
||
case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
|
||
return gfc_trans_omp_parallel_master_masked (code);
|
||
case EXEC_OMP_PARALLEL_SECTIONS:
|
||
return gfc_trans_omp_parallel_sections (code);
|
||
case EXEC_OMP_PARALLEL_WORKSHARE:
|
||
return gfc_trans_omp_parallel_workshare (code);
|
||
case EXEC_OMP_SCOPE:
|
||
return gfc_trans_omp_scope (code);
|
||
case EXEC_OMP_SECTIONS:
|
||
return gfc_trans_omp_sections (code, code->ext.omp_clauses);
|
||
case EXEC_OMP_SINGLE:
|
||
return gfc_trans_omp_single (code, code->ext.omp_clauses);
|
||
case EXEC_OMP_TARGET:
|
||
case EXEC_OMP_TARGET_PARALLEL:
|
||
case EXEC_OMP_TARGET_PARALLEL_DO:
|
||
case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
|
||
case EXEC_OMP_TARGET_PARALLEL_LOOP:
|
||
case EXEC_OMP_TARGET_SIMD:
|
||
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:
|
||
case EXEC_OMP_TARGET_TEAMS_LOOP:
|
||
return gfc_trans_omp_target (code);
|
||
case EXEC_OMP_TARGET_DATA:
|
||
return gfc_trans_omp_target_data (code);
|
||
case EXEC_OMP_TARGET_ENTER_DATA:
|
||
return gfc_trans_omp_target_enter_data (code);
|
||
case EXEC_OMP_TARGET_EXIT_DATA:
|
||
return gfc_trans_omp_target_exit_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_TASKLOOP_SIMD:
|
||
return gfc_trans_omp_taskloop (code, code->op);
|
||
case EXEC_OMP_TASKWAIT:
|
||
return gfc_trans_omp_taskwait (code);
|
||
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:
|
||
case EXEC_OMP_TEAMS_LOOP:
|
||
return gfc_trans_omp_teams (code, NULL, NULL_TREE);
|
||
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;
|
||
}
|
||
}
|
||
|
||
void
|
||
gfc_trans_omp_declare_variant (gfc_namespace *ns)
|
||
{
|
||
tree base_fn_decl = ns->proc_name->backend_decl;
|
||
gfc_namespace *search_ns = ns;
|
||
gfc_omp_declare_variant *next;
|
||
|
||
for (gfc_omp_declare_variant *odv = search_ns->omp_declare_variant;
|
||
search_ns; odv = next)
|
||
{
|
||
/* Look in the parent namespace if there are no more directives in the
|
||
current namespace. */
|
||
if (!odv)
|
||
{
|
||
search_ns = search_ns->parent;
|
||
if (search_ns)
|
||
next = search_ns->omp_declare_variant;
|
||
continue;
|
||
}
|
||
|
||
next = odv->next;
|
||
|
||
if (odv->error_p)
|
||
continue;
|
||
|
||
/* Check directive the first time it is encountered. */
|
||
bool error_found = true;
|
||
|
||
if (odv->checked_p)
|
||
error_found = false;
|
||
if (odv->base_proc_symtree == NULL)
|
||
{
|
||
if (!search_ns->proc_name->attr.function
|
||
&& !search_ns->proc_name->attr.subroutine)
|
||
gfc_error ("The base name for 'declare variant' must be "
|
||
"specified at %L ", &odv->where);
|
||
else
|
||
error_found = false;
|
||
}
|
||
else
|
||
{
|
||
if (!search_ns->contained
|
||
&& strcmp (odv->base_proc_symtree->name,
|
||
ns->proc_name->name))
|
||
gfc_error ("The base name at %L does not match the name of the "
|
||
"current procedure", &odv->where);
|
||
else if (odv->base_proc_symtree->n.sym->attr.entry)
|
||
gfc_error ("The base name at %L must not be an entry name",
|
||
&odv->where);
|
||
else if (odv->base_proc_symtree->n.sym->attr.generic)
|
||
gfc_error ("The base name at %L must not be a generic name",
|
||
&odv->where);
|
||
else if (odv->base_proc_symtree->n.sym->attr.proc_pointer)
|
||
gfc_error ("The base name at %L must not be a procedure pointer",
|
||
&odv->where);
|
||
else if (odv->base_proc_symtree->n.sym->attr.implicit_type)
|
||
gfc_error ("The base procedure at %L must have an explicit "
|
||
"interface", &odv->where);
|
||
else
|
||
error_found = false;
|
||
}
|
||
|
||
odv->checked_p = true;
|
||
if (error_found)
|
||
{
|
||
odv->error_p = true;
|
||
continue;
|
||
}
|
||
|
||
/* Ignore directives that do not apply to the current procedure. */
|
||
if ((odv->base_proc_symtree == NULL && search_ns != ns)
|
||
|| (odv->base_proc_symtree != NULL
|
||
&& strcmp (odv->base_proc_symtree->name, ns->proc_name->name)))
|
||
continue;
|
||
|
||
tree set_selectors = NULL_TREE;
|
||
gfc_omp_set_selector *oss;
|
||
|
||
for (oss = odv->set_selectors; oss; oss = oss->next)
|
||
{
|
||
tree selectors = NULL_TREE;
|
||
gfc_omp_selector *os;
|
||
for (os = oss->trait_selectors; os; os = os->next)
|
||
{
|
||
tree properties = NULL_TREE;
|
||
gfc_omp_trait_property *otp;
|
||
|
||
for (otp = os->properties; otp; otp = otp->next)
|
||
{
|
||
switch (otp->property_kind)
|
||
{
|
||
case CTX_PROPERTY_USER:
|
||
case CTX_PROPERTY_EXPR:
|
||
{
|
||
gfc_se se;
|
||
gfc_init_se (&se, NULL);
|
||
gfc_conv_expr (&se, otp->expr);
|
||
properties = tree_cons (NULL_TREE, se.expr,
|
||
properties);
|
||
}
|
||
break;
|
||
case CTX_PROPERTY_ID:
|
||
properties = tree_cons (get_identifier (otp->name),
|
||
NULL_TREE, properties);
|
||
break;
|
||
case CTX_PROPERTY_NAME_LIST:
|
||
{
|
||
tree prop = NULL_TREE, value = NULL_TREE;
|
||
if (otp->is_name)
|
||
prop = get_identifier (otp->name);
|
||
else
|
||
value = gfc_conv_constant_to_tree (otp->expr);
|
||
|
||
properties = tree_cons (prop, value, properties);
|
||
}
|
||
break;
|
||
case CTX_PROPERTY_SIMD:
|
||
properties = gfc_trans_omp_clauses (NULL, otp->clauses,
|
||
odv->where, true);
|
||
break;
|
||
default:
|
||
gcc_unreachable ();
|
||
}
|
||
}
|
||
|
||
if (os->score)
|
||
{
|
||
gfc_se se;
|
||
gfc_init_se (&se, NULL);
|
||
gfc_conv_expr (&se, os->score);
|
||
properties = tree_cons (get_identifier (" score"),
|
||
se.expr, properties);
|
||
}
|
||
|
||
selectors = tree_cons (get_identifier (os->trait_selector_name),
|
||
properties, selectors);
|
||
}
|
||
|
||
set_selectors
|
||
= tree_cons (get_identifier (oss->trait_set_selector_name),
|
||
selectors, set_selectors);
|
||
}
|
||
|
||
const char *variant_proc_name = odv->variant_proc_symtree->name;
|
||
gfc_symbol *variant_proc_sym = odv->variant_proc_symtree->n.sym;
|
||
if (variant_proc_sym == NULL || variant_proc_sym->attr.implicit_type)
|
||
{
|
||
gfc_symtree *proc_st;
|
||
gfc_find_sym_tree (variant_proc_name, gfc_current_ns, 1, &proc_st);
|
||
variant_proc_sym = proc_st->n.sym;
|
||
}
|
||
if (variant_proc_sym == NULL)
|
||
{
|
||
gfc_error ("Cannot find symbol %qs", variant_proc_name);
|
||
continue;
|
||
}
|
||
set_selectors = omp_check_context_selector
|
||
(gfc_get_location (&odv->where), set_selectors);
|
||
if (set_selectors != error_mark_node)
|
||
{
|
||
if (!variant_proc_sym->attr.implicit_type
|
||
&& !variant_proc_sym->attr.subroutine
|
||
&& !variant_proc_sym->attr.function)
|
||
{
|
||
gfc_error ("variant %qs at %L is not a function or subroutine",
|
||
variant_proc_name, &odv->where);
|
||
variant_proc_sym = NULL;
|
||
}
|
||
else if (omp_get_context_selector (set_selectors, "construct",
|
||
"simd") == NULL_TREE)
|
||
{
|
||
char err[256];
|
||
if (!gfc_compare_interfaces (ns->proc_name, variant_proc_sym,
|
||
variant_proc_sym->name, 0, 1,
|
||
err, sizeof (err), NULL, NULL))
|
||
{
|
||
gfc_error ("variant %qs and base %qs at %L have "
|
||
"incompatible types: %s",
|
||
variant_proc_name, ns->proc_name->name,
|
||
&odv->where, err);
|
||
variant_proc_sym = NULL;
|
||
}
|
||
}
|
||
if (variant_proc_sym != NULL)
|
||
{
|
||
gfc_set_sym_referenced (variant_proc_sym);
|
||
tree construct = omp_get_context_selector (set_selectors,
|
||
"construct", NULL);
|
||
omp_mark_declare_variant (gfc_get_location (&odv->where),
|
||
gfc_get_symbol_decl (variant_proc_sym),
|
||
construct);
|
||
if (omp_context_selector_matches (set_selectors))
|
||
{
|
||
tree id = get_identifier ("omp declare variant base");
|
||
tree variant = gfc_get_symbol_decl (variant_proc_sym);
|
||
DECL_ATTRIBUTES (base_fn_decl)
|
||
= tree_cons (id, build_tree_list (variant, set_selectors),
|
||
DECL_ATTRIBUTES (base_fn_decl));
|
||
}
|
||
}
|
||
}
|
||
}
|
||
}
|