/* OpenMP directive translation -- generate GCC trees from gfc_code.
|
/* OpenMP directive translation -- generate GCC trees from gfc_code.
|
Copyright (C) 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
|
Copyright (C) 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
|
Contributed by Jakub Jelinek <jakub@redhat.com>
|
Contributed by Jakub Jelinek <jakub@redhat.com>
|
|
|
This file is part of GCC.
|
This file is part of GCC.
|
|
|
GCC is free software; you can redistribute it and/or modify it under
|
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
|
the terms of the GNU General Public License as published by the Free
|
Software Foundation; either version 3, or (at your option) any later
|
Software Foundation; either version 3, or (at your option) any later
|
version.
|
version.
|
|
|
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
|
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
|
WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
|
FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
|
for more details.
|
for more details.
|
|
|
You should have received a copy of the GNU General Public License
|
You should have received a copy of the GNU General Public License
|
along with GCC; see the file COPYING3. If not see
|
along with GCC; see the file COPYING3. If not see
|
<http://www.gnu.org/licenses/>. */
|
<http://www.gnu.org/licenses/>. */
|
|
|
|
|
#include "config.h"
|
#include "config.h"
|
#include "system.h"
|
#include "system.h"
|
#include "coretypes.h"
|
#include "coretypes.h"
|
#include "tree.h"
|
#include "tree.h"
|
#include "gimple.h"
|
#include "gimple.h"
|
#include "ggc.h"
|
#include "ggc.h"
|
#include "toplev.h"
|
#include "toplev.h"
|
#include "real.h"
|
#include "real.h"
|
#include "gfortran.h"
|
#include "gfortran.h"
|
#include "trans.h"
|
#include "trans.h"
|
#include "trans-stmt.h"
|
#include "trans-stmt.h"
|
#include "trans-types.h"
|
#include "trans-types.h"
|
#include "trans-array.h"
|
#include "trans-array.h"
|
#include "trans-const.h"
|
#include "trans-const.h"
|
#include "arith.h"
|
#include "arith.h"
|
|
|
int ompws_flags;
|
int ompws_flags;
|
|
|
/* True if OpenMP should privatize what this DECL points to rather
|
/* True if OpenMP should privatize what this DECL points to rather
|
than the DECL itself. */
|
than the DECL itself. */
|
|
|
bool
|
bool
|
gfc_omp_privatize_by_reference (const_tree decl)
|
gfc_omp_privatize_by_reference (const_tree decl)
|
{
|
{
|
tree type = TREE_TYPE (decl);
|
tree type = TREE_TYPE (decl);
|
|
|
if (TREE_CODE (type) == REFERENCE_TYPE
|
if (TREE_CODE (type) == REFERENCE_TYPE
|
&& (!DECL_ARTIFICIAL (decl) || TREE_CODE (decl) == PARM_DECL))
|
&& (!DECL_ARTIFICIAL (decl) || TREE_CODE (decl) == PARM_DECL))
|
return true;
|
return true;
|
|
|
if (TREE_CODE (type) == POINTER_TYPE)
|
if (TREE_CODE (type) == POINTER_TYPE)
|
{
|
{
|
/* Array POINTER/ALLOCATABLE have aggregate types, all user variables
|
/* Array POINTER/ALLOCATABLE have aggregate types, all user variables
|
that have POINTER_TYPE type and don't have GFC_POINTER_TYPE_P
|
that have POINTER_TYPE type and don't have GFC_POINTER_TYPE_P
|
set are supposed to be privatized by reference. */
|
set are supposed to be privatized by reference. */
|
if (GFC_POINTER_TYPE_P (type))
|
if (GFC_POINTER_TYPE_P (type))
|
return false;
|
return false;
|
|
|
if (!DECL_ARTIFICIAL (decl)
|
if (!DECL_ARTIFICIAL (decl)
|
&& TREE_CODE (TREE_TYPE (type)) != FUNCTION_TYPE)
|
&& TREE_CODE (TREE_TYPE (type)) != FUNCTION_TYPE)
|
return true;
|
return true;
|
|
|
/* Some arrays are expanded as DECL_ARTIFICIAL pointers
|
/* Some arrays are expanded as DECL_ARTIFICIAL pointers
|
by the frontend. */
|
by the frontend. */
|
if (DECL_LANG_SPECIFIC (decl)
|
if (DECL_LANG_SPECIFIC (decl)
|
&& GFC_DECL_SAVED_DESCRIPTOR (decl))
|
&& GFC_DECL_SAVED_DESCRIPTOR (decl))
|
return true;
|
return true;
|
}
|
}
|
|
|
return false;
|
return false;
|
}
|
}
|
|
|
/* True if OpenMP sharing attribute of DECL is predetermined. */
|
/* True if OpenMP sharing attribute of DECL is predetermined. */
|
|
|
enum omp_clause_default_kind
|
enum omp_clause_default_kind
|
gfc_omp_predetermined_sharing (tree decl)
|
gfc_omp_predetermined_sharing (tree decl)
|
{
|
{
|
if (DECL_ARTIFICIAL (decl)
|
if (DECL_ARTIFICIAL (decl)
|
&& ! GFC_DECL_RESULT (decl)
|
&& ! GFC_DECL_RESULT (decl)
|
&& ! (DECL_LANG_SPECIFIC (decl)
|
&& ! (DECL_LANG_SPECIFIC (decl)
|
&& GFC_DECL_SAVED_DESCRIPTOR (decl)))
|
&& GFC_DECL_SAVED_DESCRIPTOR (decl)))
|
return OMP_CLAUSE_DEFAULT_SHARED;
|
return OMP_CLAUSE_DEFAULT_SHARED;
|
|
|
/* Cray pointees shouldn't be listed in any clauses and should be
|
/* Cray pointees shouldn't be listed in any clauses and should be
|
gimplified to dereference of the corresponding Cray pointer.
|
gimplified to dereference of the corresponding Cray pointer.
|
Make them all private, so that they are emitted in the debug
|
Make them all private, so that they are emitted in the debug
|
information. */
|
information. */
|
if (GFC_DECL_CRAY_POINTEE (decl))
|
if (GFC_DECL_CRAY_POINTEE (decl))
|
return OMP_CLAUSE_DEFAULT_PRIVATE;
|
return OMP_CLAUSE_DEFAULT_PRIVATE;
|
|
|
/* Assumed-size arrays are predetermined to inherit sharing
|
/* Assumed-size arrays are predetermined to inherit sharing
|
attributes of the associated actual argument, which is shared
|
attributes of the associated actual argument, which is shared
|
for all we care. */
|
for all we care. */
|
if (TREE_CODE (decl) == PARM_DECL
|
if (TREE_CODE (decl) == PARM_DECL
|
&& GFC_ARRAY_TYPE_P (TREE_TYPE (decl))
|
&& GFC_ARRAY_TYPE_P (TREE_TYPE (decl))
|
&& GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl)) == GFC_ARRAY_UNKNOWN
|
&& GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl)) == GFC_ARRAY_UNKNOWN
|
&& GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (decl),
|
&& GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (decl),
|
GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl)) - 1)
|
GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl)) - 1)
|
== NULL)
|
== NULL)
|
return OMP_CLAUSE_DEFAULT_SHARED;
|
return OMP_CLAUSE_DEFAULT_SHARED;
|
|
|
/* Dummy procedures aren't considered variables by OpenMP, thus are
|
/* Dummy procedures aren't considered variables by OpenMP, thus are
|
disallowed in OpenMP clauses. They are represented as PARM_DECLs
|
disallowed in OpenMP clauses. They are represented as PARM_DECLs
|
in the middle-end, so return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE here
|
in the middle-end, so return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE here
|
to avoid complaining about their uses with default(none). */
|
to avoid complaining about their uses with default(none). */
|
if (TREE_CODE (decl) == PARM_DECL
|
if (TREE_CODE (decl) == PARM_DECL
|
&& TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE
|
&& TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE
|
&& TREE_CODE (TREE_TYPE (TREE_TYPE (decl))) == FUNCTION_TYPE)
|
&& TREE_CODE (TREE_TYPE (TREE_TYPE (decl))) == FUNCTION_TYPE)
|
return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE;
|
return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE;
|
|
|
/* COMMON and EQUIVALENCE decls are shared. They
|
/* COMMON and EQUIVALENCE decls are shared. They
|
are only referenced through DECL_VALUE_EXPR of the variables
|
are only referenced through DECL_VALUE_EXPR of the variables
|
contained in them. If those are privatized, they will not be
|
contained in them. If those are privatized, they will not be
|
gimplified to the COMMON or EQUIVALENCE decls. */
|
gimplified to the COMMON or EQUIVALENCE decls. */
|
if (GFC_DECL_COMMON_OR_EQUIV (decl) && ! DECL_HAS_VALUE_EXPR_P (decl))
|
if (GFC_DECL_COMMON_OR_EQUIV (decl) && ! DECL_HAS_VALUE_EXPR_P (decl))
|
return OMP_CLAUSE_DEFAULT_SHARED;
|
return OMP_CLAUSE_DEFAULT_SHARED;
|
|
|
if (GFC_DECL_RESULT (decl) && ! DECL_HAS_VALUE_EXPR_P (decl))
|
if (GFC_DECL_RESULT (decl) && ! DECL_HAS_VALUE_EXPR_P (decl))
|
return OMP_CLAUSE_DEFAULT_SHARED;
|
return OMP_CLAUSE_DEFAULT_SHARED;
|
|
|
return OMP_CLAUSE_DEFAULT_UNSPECIFIED;
|
return OMP_CLAUSE_DEFAULT_UNSPECIFIED;
|
}
|
}
|
|
|
/* Return decl that should be used when reporting DEFAULT(NONE)
|
/* Return decl that should be used when reporting DEFAULT(NONE)
|
diagnostics. */
|
diagnostics. */
|
|
|
tree
|
tree
|
gfc_omp_report_decl (tree decl)
|
gfc_omp_report_decl (tree decl)
|
{
|
{
|
if (DECL_ARTIFICIAL (decl)
|
if (DECL_ARTIFICIAL (decl)
|
&& DECL_LANG_SPECIFIC (decl)
|
&& DECL_LANG_SPECIFIC (decl)
|
&& GFC_DECL_SAVED_DESCRIPTOR (decl))
|
&& GFC_DECL_SAVED_DESCRIPTOR (decl))
|
return GFC_DECL_SAVED_DESCRIPTOR (decl);
|
return GFC_DECL_SAVED_DESCRIPTOR (decl);
|
|
|
return decl;
|
return decl;
|
}
|
}
|
|
|
/* Return true if DECL in private clause needs
|
/* Return true if DECL in private clause needs
|
OMP_CLAUSE_PRIVATE_OUTER_REF on the private clause. */
|
OMP_CLAUSE_PRIVATE_OUTER_REF on the private clause. */
|
bool
|
bool
|
gfc_omp_private_outer_ref (tree decl)
|
gfc_omp_private_outer_ref (tree decl)
|
{
|
{
|
tree type = TREE_TYPE (decl);
|
tree type = TREE_TYPE (decl);
|
|
|
if (GFC_DESCRIPTOR_TYPE_P (type)
|
if (GFC_DESCRIPTOR_TYPE_P (type)
|
&& GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
|
&& GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
|
return true;
|
return true;
|
|
|
return false;
|
return false;
|
}
|
}
|
|
|
/* Return code to initialize DECL with its default constructor, or
|
/* Return code to initialize DECL with its default constructor, or
|
NULL if there's nothing to do. */
|
NULL if there's nothing to do. */
|
|
|
tree
|
tree
|
gfc_omp_clause_default_ctor (tree clause, tree decl, tree outer)
|
gfc_omp_clause_default_ctor (tree clause, tree decl, tree outer)
|
{
|
{
|
tree type = TREE_TYPE (decl), rank, size, esize, ptr, cond, then_b, else_b;
|
tree type = TREE_TYPE (decl), rank, size, esize, ptr, cond, then_b, else_b;
|
stmtblock_t block, cond_block;
|
stmtblock_t block, cond_block;
|
|
|
if (! GFC_DESCRIPTOR_TYPE_P (type)
|
if (! GFC_DESCRIPTOR_TYPE_P (type)
|
|| GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
|
|| GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
|
return NULL;
|
return NULL;
|
|
|
gcc_assert (outer != NULL);
|
gcc_assert (outer != NULL);
|
gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_PRIVATE
|
gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_PRIVATE
|
|| OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LASTPRIVATE);
|
|| OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LASTPRIVATE);
|
|
|
/* Allocatable arrays in PRIVATE clauses need to be set to
|
/* Allocatable arrays in PRIVATE clauses need to be set to
|
"not currently allocated" allocation status if outer
|
"not currently allocated" allocation status if outer
|
array is "not currently allocated", otherwise should be allocated. */
|
array is "not currently allocated", otherwise should be allocated. */
|
gfc_start_block (&block);
|
gfc_start_block (&block);
|
|
|
gfc_init_block (&cond_block);
|
gfc_init_block (&cond_block);
|
|
|
gfc_add_modify (&cond_block, decl, outer);
|
gfc_add_modify (&cond_block, decl, outer);
|
rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
|
rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
|
size = gfc_conv_descriptor_ubound_get (decl, rank);
|
size = gfc_conv_descriptor_ubound_get (decl, rank);
|
size = fold_build2 (MINUS_EXPR, gfc_array_index_type, size,
|
size = fold_build2 (MINUS_EXPR, gfc_array_index_type, size,
|
gfc_conv_descriptor_lbound_get (decl, rank));
|
gfc_conv_descriptor_lbound_get (decl, rank));
|
size = fold_build2 (PLUS_EXPR, gfc_array_index_type, size,
|
size = fold_build2 (PLUS_EXPR, gfc_array_index_type, size,
|
gfc_index_one_node);
|
gfc_index_one_node);
|
if (GFC_TYPE_ARRAY_RANK (type) > 1)
|
if (GFC_TYPE_ARRAY_RANK (type) > 1)
|
size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
|
size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
|
gfc_conv_descriptor_stride_get (decl, rank));
|
gfc_conv_descriptor_stride_get (decl, rank));
|
esize = fold_convert (gfc_array_index_type,
|
esize = fold_convert (gfc_array_index_type,
|
TYPE_SIZE_UNIT (gfc_get_element_type (type)));
|
TYPE_SIZE_UNIT (gfc_get_element_type (type)));
|
size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, esize);
|
size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, esize);
|
size = gfc_evaluate_now (fold_convert (size_type_node, size), &cond_block);
|
size = gfc_evaluate_now (fold_convert (size_type_node, size), &cond_block);
|
ptr = gfc_allocate_array_with_status (&cond_block,
|
ptr = gfc_allocate_array_with_status (&cond_block,
|
build_int_cst (pvoid_type_node, 0),
|
build_int_cst (pvoid_type_node, 0),
|
size, NULL, NULL);
|
size, NULL, NULL);
|
gfc_conv_descriptor_data_set (&cond_block, decl, ptr);
|
gfc_conv_descriptor_data_set (&cond_block, decl, ptr);
|
then_b = gfc_finish_block (&cond_block);
|
then_b = gfc_finish_block (&cond_block);
|
|
|
gfc_init_block (&cond_block);
|
gfc_init_block (&cond_block);
|
gfc_conv_descriptor_data_set (&cond_block, decl, null_pointer_node);
|
gfc_conv_descriptor_data_set (&cond_block, decl, null_pointer_node);
|
else_b = gfc_finish_block (&cond_block);
|
else_b = gfc_finish_block (&cond_block);
|
|
|
cond = fold_build2 (NE_EXPR, boolean_type_node,
|
cond = fold_build2 (NE_EXPR, boolean_type_node,
|
fold_convert (pvoid_type_node,
|
fold_convert (pvoid_type_node,
|
gfc_conv_descriptor_data_get (outer)),
|
gfc_conv_descriptor_data_get (outer)),
|
null_pointer_node);
|
null_pointer_node);
|
gfc_add_expr_to_block (&block, build3 (COND_EXPR, void_type_node,
|
gfc_add_expr_to_block (&block, build3 (COND_EXPR, void_type_node,
|
cond, then_b, else_b));
|
cond, then_b, else_b));
|
|
|
return gfc_finish_block (&block);
|
return gfc_finish_block (&block);
|
}
|
}
|
|
|
/* Build and return code for a copy constructor from SRC to DEST. */
|
/* Build and return code for a copy constructor from SRC to DEST. */
|
|
|
tree
|
tree
|
gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src)
|
gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src)
|
{
|
{
|
tree type = TREE_TYPE (dest), ptr, size, esize, rank, call;
|
tree type = TREE_TYPE (dest), ptr, size, esize, rank, call;
|
stmtblock_t block;
|
stmtblock_t block;
|
|
|
if (! GFC_DESCRIPTOR_TYPE_P (type)
|
if (! GFC_DESCRIPTOR_TYPE_P (type)
|
|| GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
|
|| GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
|
return build2_v (MODIFY_EXPR, dest, src);
|
return build2_v (MODIFY_EXPR, dest, src);
|
|
|
gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_FIRSTPRIVATE);
|
gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_FIRSTPRIVATE);
|
|
|
/* Allocatable arrays in FIRSTPRIVATE clauses need to be allocated
|
/* Allocatable arrays in FIRSTPRIVATE clauses need to be allocated
|
and copied from SRC. */
|
and copied from SRC. */
|
gfc_start_block (&block);
|
gfc_start_block (&block);
|
|
|
gfc_add_modify (&block, dest, src);
|
gfc_add_modify (&block, dest, src);
|
rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
|
rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
|
size = gfc_conv_descriptor_ubound_get (dest, rank);
|
size = gfc_conv_descriptor_ubound_get (dest, rank);
|
size = fold_build2 (MINUS_EXPR, gfc_array_index_type, size,
|
size = fold_build2 (MINUS_EXPR, gfc_array_index_type, size,
|
gfc_conv_descriptor_lbound_get (dest, rank));
|
gfc_conv_descriptor_lbound_get (dest, rank));
|
size = fold_build2 (PLUS_EXPR, gfc_array_index_type, size,
|
size = fold_build2 (PLUS_EXPR, gfc_array_index_type, size,
|
gfc_index_one_node);
|
gfc_index_one_node);
|
if (GFC_TYPE_ARRAY_RANK (type) > 1)
|
if (GFC_TYPE_ARRAY_RANK (type) > 1)
|
size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
|
size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
|
gfc_conv_descriptor_stride_get (dest, rank));
|
gfc_conv_descriptor_stride_get (dest, rank));
|
esize = fold_convert (gfc_array_index_type,
|
esize = fold_convert (gfc_array_index_type,
|
TYPE_SIZE_UNIT (gfc_get_element_type (type)));
|
TYPE_SIZE_UNIT (gfc_get_element_type (type)));
|
size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, esize);
|
size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, esize);
|
size = gfc_evaluate_now (fold_convert (size_type_node, size), &block);
|
size = gfc_evaluate_now (fold_convert (size_type_node, size), &block);
|
ptr = gfc_allocate_array_with_status (&block,
|
ptr = gfc_allocate_array_with_status (&block,
|
build_int_cst (pvoid_type_node, 0),
|
build_int_cst (pvoid_type_node, 0),
|
size, NULL, NULL);
|
size, NULL, NULL);
|
gfc_conv_descriptor_data_set (&block, dest, ptr);
|
gfc_conv_descriptor_data_set (&block, dest, ptr);
|
call = build_call_expr_loc (input_location,
|
call = build_call_expr_loc (input_location,
|
built_in_decls[BUILT_IN_MEMCPY], 3, ptr,
|
built_in_decls[BUILT_IN_MEMCPY], 3, ptr,
|
fold_convert (pvoid_type_node,
|
fold_convert (pvoid_type_node,
|
gfc_conv_descriptor_data_get (src)),
|
gfc_conv_descriptor_data_get (src)),
|
size);
|
size);
|
gfc_add_expr_to_block (&block, fold_convert (void_type_node, call));
|
gfc_add_expr_to_block (&block, fold_convert (void_type_node, call));
|
|
|
return gfc_finish_block (&block);
|
return gfc_finish_block (&block);
|
}
|
}
|
|
|
/* Similarly, except use an assignment operator instead. */
|
/* Similarly, except use an assignment operator instead. */
|
|
|
tree
|
tree
|
gfc_omp_clause_assign_op (tree clause ATTRIBUTE_UNUSED, tree dest, tree src)
|
gfc_omp_clause_assign_op (tree clause ATTRIBUTE_UNUSED, tree dest, tree src)
|
{
|
{
|
tree type = TREE_TYPE (dest), rank, size, esize, call;
|
tree type = TREE_TYPE (dest), rank, size, esize, call;
|
stmtblock_t block;
|
stmtblock_t block;
|
|
|
if (! GFC_DESCRIPTOR_TYPE_P (type)
|
if (! GFC_DESCRIPTOR_TYPE_P (type)
|
|| GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
|
|| GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
|
return build2_v (MODIFY_EXPR, dest, src);
|
return build2_v (MODIFY_EXPR, dest, src);
|
|
|
/* Handle copying allocatable arrays. */
|
/* Handle copying allocatable arrays. */
|
gfc_start_block (&block);
|
gfc_start_block (&block);
|
|
|
rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
|
rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
|
size = gfc_conv_descriptor_ubound_get (dest, rank);
|
size = gfc_conv_descriptor_ubound_get (dest, rank);
|
size = fold_build2 (MINUS_EXPR, gfc_array_index_type, size,
|
size = fold_build2 (MINUS_EXPR, gfc_array_index_type, size,
|
gfc_conv_descriptor_lbound_get (dest, rank));
|
gfc_conv_descriptor_lbound_get (dest, rank));
|
size = fold_build2 (PLUS_EXPR, gfc_array_index_type, size,
|
size = fold_build2 (PLUS_EXPR, gfc_array_index_type, size,
|
gfc_index_one_node);
|
gfc_index_one_node);
|
if (GFC_TYPE_ARRAY_RANK (type) > 1)
|
if (GFC_TYPE_ARRAY_RANK (type) > 1)
|
size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
|
size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
|
gfc_conv_descriptor_stride_get (dest, rank));
|
gfc_conv_descriptor_stride_get (dest, rank));
|
esize = fold_convert (gfc_array_index_type,
|
esize = fold_convert (gfc_array_index_type,
|
TYPE_SIZE_UNIT (gfc_get_element_type (type)));
|
TYPE_SIZE_UNIT (gfc_get_element_type (type)));
|
size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, esize);
|
size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, esize);
|
size = gfc_evaluate_now (fold_convert (size_type_node, size), &block);
|
size = gfc_evaluate_now (fold_convert (size_type_node, size), &block);
|
call = build_call_expr_loc (input_location,
|
call = build_call_expr_loc (input_location,
|
built_in_decls[BUILT_IN_MEMCPY], 3,
|
built_in_decls[BUILT_IN_MEMCPY], 3,
|
fold_convert (pvoid_type_node,
|
fold_convert (pvoid_type_node,
|
gfc_conv_descriptor_data_get (dest)),
|
gfc_conv_descriptor_data_get (dest)),
|
fold_convert (pvoid_type_node,
|
fold_convert (pvoid_type_node,
|
gfc_conv_descriptor_data_get (src)),
|
gfc_conv_descriptor_data_get (src)),
|
size);
|
size);
|
gfc_add_expr_to_block (&block, fold_convert (void_type_node, call));
|
gfc_add_expr_to_block (&block, fold_convert (void_type_node, call));
|
|
|
return gfc_finish_block (&block);
|
return gfc_finish_block (&block);
|
}
|
}
|
|
|
/* Build and return code destructing DECL. Return NULL if nothing
|
/* Build and return code destructing DECL. Return NULL if nothing
|
to be done. */
|
to be done. */
|
|
|
tree
|
tree
|
gfc_omp_clause_dtor (tree clause ATTRIBUTE_UNUSED, tree decl)
|
gfc_omp_clause_dtor (tree clause ATTRIBUTE_UNUSED, tree decl)
|
{
|
{
|
tree type = TREE_TYPE (decl);
|
tree type = TREE_TYPE (decl);
|
|
|
if (! GFC_DESCRIPTOR_TYPE_P (type)
|
if (! GFC_DESCRIPTOR_TYPE_P (type)
|
|| GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
|
|| GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
|
return NULL;
|
return NULL;
|
|
|
/* Allocatable arrays in FIRSTPRIVATE/LASTPRIVATE etc. clauses need
|
/* Allocatable arrays in FIRSTPRIVATE/LASTPRIVATE etc. clauses need
|
to be deallocated if they were allocated. */
|
to be deallocated if they were allocated. */
|
return gfc_trans_dealloc_allocated (decl);
|
return gfc_trans_dealloc_allocated (decl);
|
}
|
}
|
|
|
|
|
/* Return true if DECL's DECL_VALUE_EXPR (if any) should be
|
/* Return true if DECL's DECL_VALUE_EXPR (if any) should be
|
disregarded in OpenMP construct, because it is going to be
|
disregarded in OpenMP construct, because it is going to be
|
remapped during OpenMP lowering. SHARED is true if DECL
|
remapped during OpenMP lowering. SHARED is true if DECL
|
is going to be shared, false if it is going to be privatized. */
|
is going to be shared, false if it is going to be privatized. */
|
|
|
bool
|
bool
|
gfc_omp_disregard_value_expr (tree decl, bool shared)
|
gfc_omp_disregard_value_expr (tree decl, bool shared)
|
{
|
{
|
if (GFC_DECL_COMMON_OR_EQUIV (decl)
|
if (GFC_DECL_COMMON_OR_EQUIV (decl)
|
&& DECL_HAS_VALUE_EXPR_P (decl))
|
&& DECL_HAS_VALUE_EXPR_P (decl))
|
{
|
{
|
tree value = DECL_VALUE_EXPR (decl);
|
tree value = DECL_VALUE_EXPR (decl);
|
|
|
if (TREE_CODE (value) == COMPONENT_REF
|
if (TREE_CODE (value) == COMPONENT_REF
|
&& TREE_CODE (TREE_OPERAND (value, 0)) == VAR_DECL
|
&& TREE_CODE (TREE_OPERAND (value, 0)) == VAR_DECL
|
&& GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value, 0)))
|
&& GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value, 0)))
|
{
|
{
|
/* If variable in COMMON or EQUIVALENCE is privatized, return
|
/* If variable in COMMON or EQUIVALENCE is privatized, return
|
true, as just that variable is supposed to be privatized,
|
true, as just that variable is supposed to be privatized,
|
not the whole COMMON or whole EQUIVALENCE.
|
not the whole COMMON or whole EQUIVALENCE.
|
For shared variables in COMMON or EQUIVALENCE, let them be
|
For shared variables in COMMON or EQUIVALENCE, let them be
|
gimplified to DECL_VALUE_EXPR, so that for multiple shared vars
|
gimplified to DECL_VALUE_EXPR, so that for multiple shared vars
|
from the same COMMON or EQUIVALENCE just one sharing of the
|
from the same COMMON or EQUIVALENCE just one sharing of the
|
whole COMMON or EQUIVALENCE is enough. */
|
whole COMMON or EQUIVALENCE is enough. */
|
return ! shared;
|
return ! shared;
|
}
|
}
|
}
|
}
|
|
|
if (GFC_DECL_RESULT (decl) && DECL_HAS_VALUE_EXPR_P (decl))
|
if (GFC_DECL_RESULT (decl) && DECL_HAS_VALUE_EXPR_P (decl))
|
return ! shared;
|
return ! shared;
|
|
|
return false;
|
return false;
|
}
|
}
|
|
|
/* Return true if DECL that is shared iff SHARED is true should
|
/* Return true if DECL that is shared iff SHARED is true should
|
be put into OMP_CLAUSE_PRIVATE with OMP_CLAUSE_PRIVATE_DEBUG
|
be put into OMP_CLAUSE_PRIVATE with OMP_CLAUSE_PRIVATE_DEBUG
|
flag set. */
|
flag set. */
|
|
|
bool
|
bool
|
gfc_omp_private_debug_clause (tree decl, bool shared)
|
gfc_omp_private_debug_clause (tree decl, bool shared)
|
{
|
{
|
if (GFC_DECL_CRAY_POINTEE (decl))
|
if (GFC_DECL_CRAY_POINTEE (decl))
|
return true;
|
return true;
|
|
|
if (GFC_DECL_COMMON_OR_EQUIV (decl)
|
if (GFC_DECL_COMMON_OR_EQUIV (decl)
|
&& DECL_HAS_VALUE_EXPR_P (decl))
|
&& DECL_HAS_VALUE_EXPR_P (decl))
|
{
|
{
|
tree value = DECL_VALUE_EXPR (decl);
|
tree value = DECL_VALUE_EXPR (decl);
|
|
|
if (TREE_CODE (value) == COMPONENT_REF
|
if (TREE_CODE (value) == COMPONENT_REF
|
&& TREE_CODE (TREE_OPERAND (value, 0)) == VAR_DECL
|
&& TREE_CODE (TREE_OPERAND (value, 0)) == VAR_DECL
|
&& GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value, 0)))
|
&& GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value, 0)))
|
return shared;
|
return shared;
|
}
|
}
|
|
|
return false;
|
return false;
|
}
|
}
|
|
|
/* Register language specific type size variables as potentially OpenMP
|
/* Register language specific type size variables as potentially OpenMP
|
firstprivate variables. */
|
firstprivate variables. */
|
|
|
void
|
void
|
gfc_omp_firstprivatize_type_sizes (struct gimplify_omp_ctx *ctx, tree type)
|
gfc_omp_firstprivatize_type_sizes (struct gimplify_omp_ctx *ctx, tree type)
|
{
|
{
|
if (GFC_ARRAY_TYPE_P (type) || GFC_DESCRIPTOR_TYPE_P (type))
|
if (GFC_ARRAY_TYPE_P (type) || GFC_DESCRIPTOR_TYPE_P (type))
|
{
|
{
|
int r;
|
int r;
|
|
|
gcc_assert (TYPE_LANG_SPECIFIC (type) != NULL);
|
gcc_assert (TYPE_LANG_SPECIFIC (type) != NULL);
|
for (r = 0; r < GFC_TYPE_ARRAY_RANK (type); r++)
|
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_LBOUND (type, r));
|
omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_UBOUND (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_STRIDE (type, r));
|
}
|
}
|
omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_SIZE (type));
|
omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_SIZE (type));
|
omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_OFFSET (type));
|
omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_OFFSET (type));
|
}
|
}
|
}
|
}
|
|
|
|
|
static inline tree
|
static inline tree
|
gfc_trans_add_clause (tree node, tree tail)
|
gfc_trans_add_clause (tree node, tree tail)
|
{
|
{
|
OMP_CLAUSE_CHAIN (node) = tail;
|
OMP_CLAUSE_CHAIN (node) = tail;
|
return node;
|
return node;
|
}
|
}
|
|
|
static tree
|
static tree
|
gfc_trans_omp_variable (gfc_symbol *sym)
|
gfc_trans_omp_variable (gfc_symbol *sym)
|
{
|
{
|
tree t = gfc_get_symbol_decl (sym);
|
tree t = gfc_get_symbol_decl (sym);
|
tree parent_decl;
|
tree parent_decl;
|
int parent_flag;
|
int parent_flag;
|
bool return_value;
|
bool return_value;
|
bool alternate_entry;
|
bool alternate_entry;
|
bool entry_master;
|
bool entry_master;
|
|
|
return_value = sym->attr.function && sym->result == sym;
|
return_value = sym->attr.function && sym->result == sym;
|
alternate_entry = sym->attr.function && sym->attr.entry
|
alternate_entry = sym->attr.function && sym->attr.entry
|
&& sym->result == sym;
|
&& sym->result == sym;
|
entry_master = sym->attr.result
|
entry_master = sym->attr.result
|
&& sym->ns->proc_name->attr.entry_master
|
&& sym->ns->proc_name->attr.entry_master
|
&& !gfc_return_by_reference (sym->ns->proc_name);
|
&& !gfc_return_by_reference (sym->ns->proc_name);
|
parent_decl = DECL_CONTEXT (current_function_decl);
|
parent_decl = DECL_CONTEXT (current_function_decl);
|
|
|
if ((t == parent_decl && return_value)
|
if ((t == parent_decl && return_value)
|
|| (sym->ns && sym->ns->proc_name
|
|| (sym->ns && sym->ns->proc_name
|
&& sym->ns->proc_name->backend_decl == parent_decl
|
&& sym->ns->proc_name->backend_decl == parent_decl
|
&& (alternate_entry || entry_master)))
|
&& (alternate_entry || entry_master)))
|
parent_flag = 1;
|
parent_flag = 1;
|
else
|
else
|
parent_flag = 0;
|
parent_flag = 0;
|
|
|
/* Special case for assigning the return value of a function.
|
/* Special case for assigning the return value of a function.
|
Self recursive functions must have an explicit return value. */
|
Self recursive functions must have an explicit return value. */
|
if (return_value && (t == current_function_decl || parent_flag))
|
if (return_value && (t == current_function_decl || parent_flag))
|
t = gfc_get_fake_result_decl (sym, parent_flag);
|
t = gfc_get_fake_result_decl (sym, parent_flag);
|
|
|
/* Similarly for alternate entry points. */
|
/* Similarly for alternate entry points. */
|
else if (alternate_entry
|
else if (alternate_entry
|
&& (sym->ns->proc_name->backend_decl == current_function_decl
|
&& (sym->ns->proc_name->backend_decl == current_function_decl
|
|| parent_flag))
|
|| parent_flag))
|
{
|
{
|
gfc_entry_list *el = NULL;
|
gfc_entry_list *el = NULL;
|
|
|
for (el = sym->ns->entries; el; el = el->next)
|
for (el = sym->ns->entries; el; el = el->next)
|
if (sym == el->sym)
|
if (sym == el->sym)
|
{
|
{
|
t = gfc_get_fake_result_decl (sym, parent_flag);
|
t = gfc_get_fake_result_decl (sym, parent_flag);
|
break;
|
break;
|
}
|
}
|
}
|
}
|
|
|
else if (entry_master
|
else if (entry_master
|
&& (sym->ns->proc_name->backend_decl == current_function_decl
|
&& (sym->ns->proc_name->backend_decl == current_function_decl
|
|| parent_flag))
|
|| parent_flag))
|
t = gfc_get_fake_result_decl (sym, parent_flag);
|
t = gfc_get_fake_result_decl (sym, parent_flag);
|
|
|
return t;
|
return t;
|
}
|
}
|
|
|
static tree
|
static tree
|
gfc_trans_omp_variable_list (enum omp_clause_code code, gfc_namelist *namelist,
|
gfc_trans_omp_variable_list (enum omp_clause_code code, gfc_namelist *namelist,
|
tree list)
|
tree list)
|
{
|
{
|
for (; namelist != NULL; namelist = namelist->next)
|
for (; namelist != NULL; namelist = namelist->next)
|
if (namelist->sym->attr.referenced)
|
if (namelist->sym->attr.referenced)
|
{
|
{
|
tree t = gfc_trans_omp_variable (namelist->sym);
|
tree t = gfc_trans_omp_variable (namelist->sym);
|
if (t != error_mark_node)
|
if (t != error_mark_node)
|
{
|
{
|
tree node = build_omp_clause (input_location, code);
|
tree node = build_omp_clause (input_location, code);
|
OMP_CLAUSE_DECL (node) = t;
|
OMP_CLAUSE_DECL (node) = t;
|
list = gfc_trans_add_clause (node, list);
|
list = gfc_trans_add_clause (node, list);
|
}
|
}
|
}
|
}
|
return list;
|
return list;
|
}
|
}
|
|
|
static void
|
static void
|
gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where)
|
gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where)
|
{
|
{
|
gfc_symtree *root1 = NULL, *root2 = NULL, *root3 = NULL, *root4 = NULL;
|
gfc_symtree *root1 = NULL, *root2 = NULL, *root3 = NULL, *root4 = NULL;
|
gfc_symtree *symtree1, *symtree2, *symtree3, *symtree4 = NULL;
|
gfc_symtree *symtree1, *symtree2, *symtree3, *symtree4 = NULL;
|
gfc_symbol init_val_sym, outer_sym, intrinsic_sym;
|
gfc_symbol init_val_sym, outer_sym, intrinsic_sym;
|
gfc_expr *e1, *e2, *e3, *e4;
|
gfc_expr *e1, *e2, *e3, *e4;
|
gfc_ref *ref;
|
gfc_ref *ref;
|
tree decl, backend_decl, stmt;
|
tree decl, backend_decl, stmt;
|
locus old_loc = gfc_current_locus;
|
locus old_loc = gfc_current_locus;
|
const char *iname;
|
const char *iname;
|
gfc_try t;
|
gfc_try t;
|
|
|
decl = OMP_CLAUSE_DECL (c);
|
decl = OMP_CLAUSE_DECL (c);
|
gfc_current_locus = where;
|
gfc_current_locus = where;
|
|
|
/* Create a fake symbol for init value. */
|
/* Create a fake symbol for init value. */
|
memset (&init_val_sym, 0, sizeof (init_val_sym));
|
memset (&init_val_sym, 0, sizeof (init_val_sym));
|
init_val_sym.ns = sym->ns;
|
init_val_sym.ns = sym->ns;
|
init_val_sym.name = sym->name;
|
init_val_sym.name = sym->name;
|
init_val_sym.ts = sym->ts;
|
init_val_sym.ts = sym->ts;
|
init_val_sym.attr.referenced = 1;
|
init_val_sym.attr.referenced = 1;
|
init_val_sym.declared_at = where;
|
init_val_sym.declared_at = where;
|
init_val_sym.attr.flavor = FL_VARIABLE;
|
init_val_sym.attr.flavor = FL_VARIABLE;
|
backend_decl = omp_reduction_init (c, gfc_sym_type (&init_val_sym));
|
backend_decl = omp_reduction_init (c, gfc_sym_type (&init_val_sym));
|
init_val_sym.backend_decl = backend_decl;
|
init_val_sym.backend_decl = backend_decl;
|
|
|
/* Create a fake symbol for the outer array reference. */
|
/* Create a fake symbol for the outer array reference. */
|
outer_sym = *sym;
|
outer_sym = *sym;
|
outer_sym.as = gfc_copy_array_spec (sym->as);
|
outer_sym.as = gfc_copy_array_spec (sym->as);
|
outer_sym.attr.dummy = 0;
|
outer_sym.attr.dummy = 0;
|
outer_sym.attr.result = 0;
|
outer_sym.attr.result = 0;
|
outer_sym.attr.flavor = FL_VARIABLE;
|
outer_sym.attr.flavor = FL_VARIABLE;
|
outer_sym.backend_decl = create_tmp_var_raw (TREE_TYPE (decl), NULL);
|
outer_sym.backend_decl = create_tmp_var_raw (TREE_TYPE (decl), NULL);
|
|
|
/* Create fake symtrees for it. */
|
/* Create fake symtrees for it. */
|
symtree1 = gfc_new_symtree (&root1, sym->name);
|
symtree1 = gfc_new_symtree (&root1, sym->name);
|
symtree1->n.sym = sym;
|
symtree1->n.sym = sym;
|
gcc_assert (symtree1 == root1);
|
gcc_assert (symtree1 == root1);
|
|
|
symtree2 = gfc_new_symtree (&root2, sym->name);
|
symtree2 = gfc_new_symtree (&root2, sym->name);
|
symtree2->n.sym = &init_val_sym;
|
symtree2->n.sym = &init_val_sym;
|
gcc_assert (symtree2 == root2);
|
gcc_assert (symtree2 == root2);
|
|
|
symtree3 = gfc_new_symtree (&root3, sym->name);
|
symtree3 = gfc_new_symtree (&root3, sym->name);
|
symtree3->n.sym = &outer_sym;
|
symtree3->n.sym = &outer_sym;
|
gcc_assert (symtree3 == root3);
|
gcc_assert (symtree3 == root3);
|
|
|
/* Create expressions. */
|
/* Create expressions. */
|
e1 = gfc_get_expr ();
|
e1 = gfc_get_expr ();
|
e1->expr_type = EXPR_VARIABLE;
|
e1->expr_type = EXPR_VARIABLE;
|
e1->where = where;
|
e1->where = where;
|
e1->symtree = symtree1;
|
e1->symtree = symtree1;
|
e1->ts = sym->ts;
|
e1->ts = sym->ts;
|
e1->ref = ref = gfc_get_ref ();
|
e1->ref = ref = gfc_get_ref ();
|
ref->type = REF_ARRAY;
|
ref->type = REF_ARRAY;
|
ref->u.ar.where = where;
|
ref->u.ar.where = where;
|
ref->u.ar.as = sym->as;
|
ref->u.ar.as = sym->as;
|
ref->u.ar.type = AR_FULL;
|
ref->u.ar.type = AR_FULL;
|
ref->u.ar.dimen = 0;
|
ref->u.ar.dimen = 0;
|
t = gfc_resolve_expr (e1);
|
t = gfc_resolve_expr (e1);
|
gcc_assert (t == SUCCESS);
|
gcc_assert (t == SUCCESS);
|
|
|
e2 = gfc_get_expr ();
|
e2 = gfc_get_expr ();
|
e2->expr_type = EXPR_VARIABLE;
|
e2->expr_type = EXPR_VARIABLE;
|
e2->where = where;
|
e2->where = where;
|
e2->symtree = symtree2;
|
e2->symtree = symtree2;
|
e2->ts = sym->ts;
|
e2->ts = sym->ts;
|
t = gfc_resolve_expr (e2);
|
t = gfc_resolve_expr (e2);
|
gcc_assert (t == SUCCESS);
|
gcc_assert (t == SUCCESS);
|
|
|
e3 = gfc_copy_expr (e1);
|
e3 = gfc_copy_expr (e1);
|
e3->symtree = symtree3;
|
e3->symtree = symtree3;
|
t = gfc_resolve_expr (e3);
|
t = gfc_resolve_expr (e3);
|
gcc_assert (t == SUCCESS);
|
gcc_assert (t == SUCCESS);
|
|
|
iname = NULL;
|
iname = NULL;
|
switch (OMP_CLAUSE_REDUCTION_CODE (c))
|
switch (OMP_CLAUSE_REDUCTION_CODE (c))
|
{
|
{
|
case PLUS_EXPR:
|
case PLUS_EXPR:
|
case MINUS_EXPR:
|
case MINUS_EXPR:
|
e4 = gfc_add (e3, e1);
|
e4 = gfc_add (e3, e1);
|
break;
|
break;
|
case MULT_EXPR:
|
case MULT_EXPR:
|
e4 = gfc_multiply (e3, e1);
|
e4 = gfc_multiply (e3, e1);
|
break;
|
break;
|
case TRUTH_ANDIF_EXPR:
|
case TRUTH_ANDIF_EXPR:
|
e4 = gfc_and (e3, e1);
|
e4 = gfc_and (e3, e1);
|
break;
|
break;
|
case TRUTH_ORIF_EXPR:
|
case TRUTH_ORIF_EXPR:
|
e4 = gfc_or (e3, e1);
|
e4 = gfc_or (e3, e1);
|
break;
|
break;
|
case EQ_EXPR:
|
case EQ_EXPR:
|
e4 = gfc_eqv (e3, e1);
|
e4 = gfc_eqv (e3, e1);
|
break;
|
break;
|
case NE_EXPR:
|
case NE_EXPR:
|
e4 = gfc_neqv (e3, e1);
|
e4 = gfc_neqv (e3, e1);
|
break;
|
break;
|
case MIN_EXPR:
|
case MIN_EXPR:
|
iname = "min";
|
iname = "min";
|
break;
|
break;
|
case MAX_EXPR:
|
case MAX_EXPR:
|
iname = "max";
|
iname = "max";
|
break;
|
break;
|
case BIT_AND_EXPR:
|
case BIT_AND_EXPR:
|
iname = "iand";
|
iname = "iand";
|
break;
|
break;
|
case BIT_IOR_EXPR:
|
case BIT_IOR_EXPR:
|
iname = "ior";
|
iname = "ior";
|
break;
|
break;
|
case BIT_XOR_EXPR:
|
case BIT_XOR_EXPR:
|
iname = "ieor";
|
iname = "ieor";
|
break;
|
break;
|
default:
|
default:
|
gcc_unreachable ();
|
gcc_unreachable ();
|
}
|
}
|
if (iname != NULL)
|
if (iname != NULL)
|
{
|
{
|
memset (&intrinsic_sym, 0, sizeof (intrinsic_sym));
|
memset (&intrinsic_sym, 0, sizeof (intrinsic_sym));
|
intrinsic_sym.ns = sym->ns;
|
intrinsic_sym.ns = sym->ns;
|
intrinsic_sym.name = iname;
|
intrinsic_sym.name = iname;
|
intrinsic_sym.ts = sym->ts;
|
intrinsic_sym.ts = sym->ts;
|
intrinsic_sym.attr.referenced = 1;
|
intrinsic_sym.attr.referenced = 1;
|
intrinsic_sym.attr.intrinsic = 1;
|
intrinsic_sym.attr.intrinsic = 1;
|
intrinsic_sym.attr.function = 1;
|
intrinsic_sym.attr.function = 1;
|
intrinsic_sym.result = &intrinsic_sym;
|
intrinsic_sym.result = &intrinsic_sym;
|
intrinsic_sym.declared_at = where;
|
intrinsic_sym.declared_at = where;
|
|
|
symtree4 = gfc_new_symtree (&root4, iname);
|
symtree4 = gfc_new_symtree (&root4, iname);
|
symtree4->n.sym = &intrinsic_sym;
|
symtree4->n.sym = &intrinsic_sym;
|
gcc_assert (symtree4 == root4);
|
gcc_assert (symtree4 == root4);
|
|
|
e4 = gfc_get_expr ();
|
e4 = gfc_get_expr ();
|
e4->expr_type = EXPR_FUNCTION;
|
e4->expr_type = EXPR_FUNCTION;
|
e4->where = where;
|
e4->where = where;
|
e4->symtree = symtree4;
|
e4->symtree = symtree4;
|
e4->value.function.isym = gfc_find_function (iname);
|
e4->value.function.isym = gfc_find_function (iname);
|
e4->value.function.actual = gfc_get_actual_arglist ();
|
e4->value.function.actual = gfc_get_actual_arglist ();
|
e4->value.function.actual->expr = e3;
|
e4->value.function.actual->expr = e3;
|
e4->value.function.actual->next = gfc_get_actual_arglist ();
|
e4->value.function.actual->next = gfc_get_actual_arglist ();
|
e4->value.function.actual->next->expr = e1;
|
e4->value.function.actual->next->expr = e1;
|
}
|
}
|
/* e1 and e3 have been stored as arguments of e4, avoid sharing. */
|
/* e1 and e3 have been stored as arguments of e4, avoid sharing. */
|
e1 = gfc_copy_expr (e1);
|
e1 = gfc_copy_expr (e1);
|
e3 = gfc_copy_expr (e3);
|
e3 = gfc_copy_expr (e3);
|
t = gfc_resolve_expr (e4);
|
t = gfc_resolve_expr (e4);
|
gcc_assert (t == SUCCESS);
|
gcc_assert (t == SUCCESS);
|
|
|
/* Create the init statement list. */
|
/* Create the init statement list. */
|
pushlevel (0);
|
pushlevel (0);
|
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
|
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
|
&& GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl)) == GFC_ARRAY_ALLOCATABLE)
|
&& GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl)) == GFC_ARRAY_ALLOCATABLE)
|
{
|
{
|
/* If decl is an allocatable array, it needs to be allocated
|
/* If decl is an allocatable array, it needs to be allocated
|
with the same bounds as the outer var. */
|
with the same bounds as the outer var. */
|
tree type = TREE_TYPE (decl), rank, size, esize, ptr;
|
tree type = TREE_TYPE (decl), rank, size, esize, ptr;
|
stmtblock_t block;
|
stmtblock_t block;
|
|
|
gfc_start_block (&block);
|
gfc_start_block (&block);
|
|
|
gfc_add_modify (&block, decl, outer_sym.backend_decl);
|
gfc_add_modify (&block, decl, outer_sym.backend_decl);
|
rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
|
rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
|
size = gfc_conv_descriptor_ubound_get (decl, rank);
|
size = gfc_conv_descriptor_ubound_get (decl, rank);
|
size = fold_build2 (MINUS_EXPR, gfc_array_index_type, size,
|
size = fold_build2 (MINUS_EXPR, gfc_array_index_type, size,
|
gfc_conv_descriptor_lbound_get (decl, rank));
|
gfc_conv_descriptor_lbound_get (decl, rank));
|
size = fold_build2 (PLUS_EXPR, gfc_array_index_type, size,
|
size = fold_build2 (PLUS_EXPR, gfc_array_index_type, size,
|
gfc_index_one_node);
|
gfc_index_one_node);
|
if (GFC_TYPE_ARRAY_RANK (type) > 1)
|
if (GFC_TYPE_ARRAY_RANK (type) > 1)
|
size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
|
size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
|
gfc_conv_descriptor_stride_get (decl, rank));
|
gfc_conv_descriptor_stride_get (decl, rank));
|
esize = fold_convert (gfc_array_index_type,
|
esize = fold_convert (gfc_array_index_type,
|
TYPE_SIZE_UNIT (gfc_get_element_type (type)));
|
TYPE_SIZE_UNIT (gfc_get_element_type (type)));
|
size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, esize);
|
size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, esize);
|
size = gfc_evaluate_now (fold_convert (size_type_node, size), &block);
|
size = gfc_evaluate_now (fold_convert (size_type_node, size), &block);
|
ptr = gfc_allocate_array_with_status (&block,
|
ptr = gfc_allocate_array_with_status (&block,
|
build_int_cst (pvoid_type_node, 0),
|
build_int_cst (pvoid_type_node, 0),
|
size, NULL, NULL);
|
size, NULL, NULL);
|
gfc_conv_descriptor_data_set (&block, decl, ptr);
|
gfc_conv_descriptor_data_set (&block, decl, ptr);
|
gfc_add_expr_to_block (&block, gfc_trans_assignment (e1, e2, false));
|
gfc_add_expr_to_block (&block, gfc_trans_assignment (e1, e2, false));
|
stmt = gfc_finish_block (&block);
|
stmt = gfc_finish_block (&block);
|
}
|
}
|
else
|
else
|
stmt = gfc_trans_assignment (e1, e2, false);
|
stmt = gfc_trans_assignment (e1, e2, false);
|
if (TREE_CODE (stmt) != BIND_EXPR)
|
if (TREE_CODE (stmt) != BIND_EXPR)
|
stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
|
stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
|
else
|
else
|
poplevel (0, 0, 0);
|
poplevel (0, 0, 0);
|
OMP_CLAUSE_REDUCTION_INIT (c) = stmt;
|
OMP_CLAUSE_REDUCTION_INIT (c) = stmt;
|
|
|
/* Create the merge statement list. */
|
/* Create the merge statement list. */
|
pushlevel (0);
|
pushlevel (0);
|
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
|
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
|
&& GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl)) == GFC_ARRAY_ALLOCATABLE)
|
&& GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl)) == GFC_ARRAY_ALLOCATABLE)
|
{
|
{
|
/* If decl is an allocatable array, it needs to be deallocated
|
/* If decl is an allocatable array, it needs to be deallocated
|
afterwards. */
|
afterwards. */
|
stmtblock_t block;
|
stmtblock_t block;
|
|
|
gfc_start_block (&block);
|
gfc_start_block (&block);
|
gfc_add_expr_to_block (&block, gfc_trans_assignment (e3, e4, false));
|
gfc_add_expr_to_block (&block, gfc_trans_assignment (e3, e4, false));
|
gfc_add_expr_to_block (&block, gfc_trans_dealloc_allocated (decl));
|
gfc_add_expr_to_block (&block, gfc_trans_dealloc_allocated (decl));
|
stmt = gfc_finish_block (&block);
|
stmt = gfc_finish_block (&block);
|
}
|
}
|
else
|
else
|
stmt = gfc_trans_assignment (e3, e4, false);
|
stmt = gfc_trans_assignment (e3, e4, false);
|
if (TREE_CODE (stmt) != BIND_EXPR)
|
if (TREE_CODE (stmt) != BIND_EXPR)
|
stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
|
stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
|
else
|
else
|
poplevel (0, 0, 0);
|
poplevel (0, 0, 0);
|
OMP_CLAUSE_REDUCTION_MERGE (c) = stmt;
|
OMP_CLAUSE_REDUCTION_MERGE (c) = stmt;
|
|
|
/* And stick the placeholder VAR_DECL into the clause as well. */
|
/* And stick the placeholder VAR_DECL into the clause as well. */
|
OMP_CLAUSE_REDUCTION_PLACEHOLDER (c) = outer_sym.backend_decl;
|
OMP_CLAUSE_REDUCTION_PLACEHOLDER (c) = outer_sym.backend_decl;
|
|
|
gfc_current_locus = old_loc;
|
gfc_current_locus = old_loc;
|
|
|
gfc_free_expr (e1);
|
gfc_free_expr (e1);
|
gfc_free_expr (e2);
|
gfc_free_expr (e2);
|
gfc_free_expr (e3);
|
gfc_free_expr (e3);
|
gfc_free_expr (e4);
|
gfc_free_expr (e4);
|
gfc_free (symtree1);
|
gfc_free (symtree1);
|
gfc_free (symtree2);
|
gfc_free (symtree2);
|
gfc_free (symtree3);
|
gfc_free (symtree3);
|
if (symtree4)
|
if (symtree4)
|
gfc_free (symtree4);
|
gfc_free (symtree4);
|
gfc_free_array_spec (outer_sym.as);
|
gfc_free_array_spec (outer_sym.as);
|
}
|
}
|
|
|
static tree
|
static tree
|
gfc_trans_omp_reduction_list (gfc_namelist *namelist, tree list,
|
gfc_trans_omp_reduction_list (gfc_namelist *namelist, tree list,
|
enum tree_code reduction_code, locus where)
|
enum tree_code reduction_code, locus where)
|
{
|
{
|
for (; namelist != NULL; namelist = namelist->next)
|
for (; namelist != NULL; namelist = namelist->next)
|
if (namelist->sym->attr.referenced)
|
if (namelist->sym->attr.referenced)
|
{
|
{
|
tree t = gfc_trans_omp_variable (namelist->sym);
|
tree t = gfc_trans_omp_variable (namelist->sym);
|
if (t != error_mark_node)
|
if (t != error_mark_node)
|
{
|
{
|
tree node = build_omp_clause (where.lb->location,
|
tree node = build_omp_clause (where.lb->location,
|
OMP_CLAUSE_REDUCTION);
|
OMP_CLAUSE_REDUCTION);
|
OMP_CLAUSE_DECL (node) = t;
|
OMP_CLAUSE_DECL (node) = t;
|
OMP_CLAUSE_REDUCTION_CODE (node) = reduction_code;
|
OMP_CLAUSE_REDUCTION_CODE (node) = reduction_code;
|
if (namelist->sym->attr.dimension)
|
if (namelist->sym->attr.dimension)
|
gfc_trans_omp_array_reduction (node, namelist->sym, where);
|
gfc_trans_omp_array_reduction (node, namelist->sym, where);
|
list = gfc_trans_add_clause (node, list);
|
list = gfc_trans_add_clause (node, list);
|
}
|
}
|
}
|
}
|
return list;
|
return list;
|
}
|
}
|
|
|
static tree
|
static tree
|
gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
|
gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
|
locus where)
|
locus where)
|
{
|
{
|
tree omp_clauses = NULL_TREE, chunk_size, c;
|
tree omp_clauses = NULL_TREE, chunk_size, c;
|
int list;
|
int list;
|
enum omp_clause_code clause_code;
|
enum omp_clause_code clause_code;
|
gfc_se se;
|
gfc_se se;
|
|
|
if (clauses == NULL)
|
if (clauses == NULL)
|
return NULL_TREE;
|
return NULL_TREE;
|
|
|
for (list = 0; list < OMP_LIST_NUM; list++)
|
for (list = 0; list < OMP_LIST_NUM; list++)
|
{
|
{
|
gfc_namelist *n = clauses->lists[list];
|
gfc_namelist *n = clauses->lists[list];
|
|
|
if (n == NULL)
|
if (n == NULL)
|
continue;
|
continue;
|
if (list >= OMP_LIST_REDUCTION_FIRST
|
if (list >= OMP_LIST_REDUCTION_FIRST
|
&& list <= OMP_LIST_REDUCTION_LAST)
|
&& list <= OMP_LIST_REDUCTION_LAST)
|
{
|
{
|
enum tree_code reduction_code;
|
enum tree_code reduction_code;
|
switch (list)
|
switch (list)
|
{
|
{
|
case OMP_LIST_PLUS:
|
case OMP_LIST_PLUS:
|
reduction_code = PLUS_EXPR;
|
reduction_code = PLUS_EXPR;
|
break;
|
break;
|
case OMP_LIST_MULT:
|
case OMP_LIST_MULT:
|
reduction_code = MULT_EXPR;
|
reduction_code = MULT_EXPR;
|
break;
|
break;
|
case OMP_LIST_SUB:
|
case OMP_LIST_SUB:
|
reduction_code = MINUS_EXPR;
|
reduction_code = MINUS_EXPR;
|
break;
|
break;
|
case OMP_LIST_AND:
|
case OMP_LIST_AND:
|
reduction_code = TRUTH_ANDIF_EXPR;
|
reduction_code = TRUTH_ANDIF_EXPR;
|
break;
|
break;
|
case OMP_LIST_OR:
|
case OMP_LIST_OR:
|
reduction_code = TRUTH_ORIF_EXPR;
|
reduction_code = TRUTH_ORIF_EXPR;
|
break;
|
break;
|
case OMP_LIST_EQV:
|
case OMP_LIST_EQV:
|
reduction_code = EQ_EXPR;
|
reduction_code = EQ_EXPR;
|
break;
|
break;
|
case OMP_LIST_NEQV:
|
case OMP_LIST_NEQV:
|
reduction_code = NE_EXPR;
|
reduction_code = NE_EXPR;
|
break;
|
break;
|
case OMP_LIST_MAX:
|
case OMP_LIST_MAX:
|
reduction_code = MAX_EXPR;
|
reduction_code = MAX_EXPR;
|
break;
|
break;
|
case OMP_LIST_MIN:
|
case OMP_LIST_MIN:
|
reduction_code = MIN_EXPR;
|
reduction_code = MIN_EXPR;
|
break;
|
break;
|
case OMP_LIST_IAND:
|
case OMP_LIST_IAND:
|
reduction_code = BIT_AND_EXPR;
|
reduction_code = BIT_AND_EXPR;
|
break;
|
break;
|
case OMP_LIST_IOR:
|
case OMP_LIST_IOR:
|
reduction_code = BIT_IOR_EXPR;
|
reduction_code = BIT_IOR_EXPR;
|
break;
|
break;
|
case OMP_LIST_IEOR:
|
case OMP_LIST_IEOR:
|
reduction_code = BIT_XOR_EXPR;
|
reduction_code = BIT_XOR_EXPR;
|
break;
|
break;
|
default:
|
default:
|
gcc_unreachable ();
|
gcc_unreachable ();
|
}
|
}
|
omp_clauses
|
omp_clauses
|
= gfc_trans_omp_reduction_list (n, omp_clauses, reduction_code,
|
= gfc_trans_omp_reduction_list (n, omp_clauses, reduction_code,
|
where);
|
where);
|
continue;
|
continue;
|
}
|
}
|
switch (list)
|
switch (list)
|
{
|
{
|
case OMP_LIST_PRIVATE:
|
case OMP_LIST_PRIVATE:
|
clause_code = OMP_CLAUSE_PRIVATE;
|
clause_code = OMP_CLAUSE_PRIVATE;
|
goto add_clause;
|
goto add_clause;
|
case OMP_LIST_SHARED:
|
case OMP_LIST_SHARED:
|
clause_code = OMP_CLAUSE_SHARED;
|
clause_code = OMP_CLAUSE_SHARED;
|
goto add_clause;
|
goto add_clause;
|
case OMP_LIST_FIRSTPRIVATE:
|
case OMP_LIST_FIRSTPRIVATE:
|
clause_code = OMP_CLAUSE_FIRSTPRIVATE;
|
clause_code = OMP_CLAUSE_FIRSTPRIVATE;
|
goto add_clause;
|
goto add_clause;
|
case OMP_LIST_LASTPRIVATE:
|
case OMP_LIST_LASTPRIVATE:
|
clause_code = OMP_CLAUSE_LASTPRIVATE;
|
clause_code = OMP_CLAUSE_LASTPRIVATE;
|
goto add_clause;
|
goto add_clause;
|
case OMP_LIST_COPYIN:
|
case OMP_LIST_COPYIN:
|
clause_code = OMP_CLAUSE_COPYIN;
|
clause_code = OMP_CLAUSE_COPYIN;
|
goto add_clause;
|
goto add_clause;
|
case OMP_LIST_COPYPRIVATE:
|
case OMP_LIST_COPYPRIVATE:
|
clause_code = OMP_CLAUSE_COPYPRIVATE;
|
clause_code = OMP_CLAUSE_COPYPRIVATE;
|
/* FALLTHROUGH */
|
/* FALLTHROUGH */
|
add_clause:
|
add_clause:
|
omp_clauses
|
omp_clauses
|
= gfc_trans_omp_variable_list (clause_code, n, omp_clauses);
|
= gfc_trans_omp_variable_list (clause_code, n, omp_clauses);
|
break;
|
break;
|
default:
|
default:
|
break;
|
break;
|
}
|
}
|
}
|
}
|
|
|
if (clauses->if_expr)
|
if (clauses->if_expr)
|
{
|
{
|
tree if_var;
|
tree if_var;
|
|
|
gfc_init_se (&se, NULL);
|
gfc_init_se (&se, NULL);
|
gfc_conv_expr (&se, clauses->if_expr);
|
gfc_conv_expr (&se, clauses->if_expr);
|
gfc_add_block_to_block (block, &se.pre);
|
gfc_add_block_to_block (block, &se.pre);
|
if_var = gfc_evaluate_now (se.expr, block);
|
if_var = gfc_evaluate_now (se.expr, block);
|
gfc_add_block_to_block (block, &se.post);
|
gfc_add_block_to_block (block, &se.post);
|
|
|
c = build_omp_clause (where.lb->location, OMP_CLAUSE_IF);
|
c = build_omp_clause (where.lb->location, OMP_CLAUSE_IF);
|
OMP_CLAUSE_IF_EXPR (c) = if_var;
|
OMP_CLAUSE_IF_EXPR (c) = if_var;
|
omp_clauses = gfc_trans_add_clause (c, omp_clauses);
|
omp_clauses = gfc_trans_add_clause (c, omp_clauses);
|
}
|
}
|
|
|
if (clauses->num_threads)
|
if (clauses->num_threads)
|
{
|
{
|
tree num_threads;
|
tree num_threads;
|
|
|
gfc_init_se (&se, NULL);
|
gfc_init_se (&se, NULL);
|
gfc_conv_expr (&se, clauses->num_threads);
|
gfc_conv_expr (&se, clauses->num_threads);
|
gfc_add_block_to_block (block, &se.pre);
|
gfc_add_block_to_block (block, &se.pre);
|
num_threads = gfc_evaluate_now (se.expr, block);
|
num_threads = gfc_evaluate_now (se.expr, block);
|
gfc_add_block_to_block (block, &se.post);
|
gfc_add_block_to_block (block, &se.post);
|
|
|
c = build_omp_clause (where.lb->location, OMP_CLAUSE_NUM_THREADS);
|
c = build_omp_clause (where.lb->location, OMP_CLAUSE_NUM_THREADS);
|
OMP_CLAUSE_NUM_THREADS_EXPR (c) = num_threads;
|
OMP_CLAUSE_NUM_THREADS_EXPR (c) = num_threads;
|
omp_clauses = gfc_trans_add_clause (c, omp_clauses);
|
omp_clauses = gfc_trans_add_clause (c, omp_clauses);
|
}
|
}
|
|
|
chunk_size = NULL_TREE;
|
chunk_size = NULL_TREE;
|
if (clauses->chunk_size)
|
if (clauses->chunk_size)
|
{
|
{
|
gfc_init_se (&se, NULL);
|
gfc_init_se (&se, NULL);
|
gfc_conv_expr (&se, clauses->chunk_size);
|
gfc_conv_expr (&se, clauses->chunk_size);
|
gfc_add_block_to_block (block, &se.pre);
|
gfc_add_block_to_block (block, &se.pre);
|
chunk_size = gfc_evaluate_now (se.expr, block);
|
chunk_size = gfc_evaluate_now (se.expr, block);
|
gfc_add_block_to_block (block, &se.post);
|
gfc_add_block_to_block (block, &se.post);
|
}
|
}
|
|
|
if (clauses->sched_kind != OMP_SCHED_NONE)
|
if (clauses->sched_kind != OMP_SCHED_NONE)
|
{
|
{
|
c = build_omp_clause (where.lb->location, OMP_CLAUSE_SCHEDULE);
|
c = build_omp_clause (where.lb->location, OMP_CLAUSE_SCHEDULE);
|
OMP_CLAUSE_SCHEDULE_CHUNK_EXPR (c) = chunk_size;
|
OMP_CLAUSE_SCHEDULE_CHUNK_EXPR (c) = chunk_size;
|
switch (clauses->sched_kind)
|
switch (clauses->sched_kind)
|
{
|
{
|
case OMP_SCHED_STATIC:
|
case OMP_SCHED_STATIC:
|
OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_STATIC;
|
OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_STATIC;
|
break;
|
break;
|
case OMP_SCHED_DYNAMIC:
|
case OMP_SCHED_DYNAMIC:
|
OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_DYNAMIC;
|
OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_DYNAMIC;
|
break;
|
break;
|
case OMP_SCHED_GUIDED:
|
case OMP_SCHED_GUIDED:
|
OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_GUIDED;
|
OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_GUIDED;
|
break;
|
break;
|
case OMP_SCHED_RUNTIME:
|
case OMP_SCHED_RUNTIME:
|
OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_RUNTIME;
|
OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_RUNTIME;
|
break;
|
break;
|
case OMP_SCHED_AUTO:
|
case OMP_SCHED_AUTO:
|
OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_AUTO;
|
OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_AUTO;
|
break;
|
break;
|
default:
|
default:
|
gcc_unreachable ();
|
gcc_unreachable ();
|
}
|
}
|
omp_clauses = gfc_trans_add_clause (c, omp_clauses);
|
omp_clauses = gfc_trans_add_clause (c, omp_clauses);
|
}
|
}
|
|
|
if (clauses->default_sharing != OMP_DEFAULT_UNKNOWN)
|
if (clauses->default_sharing != OMP_DEFAULT_UNKNOWN)
|
{
|
{
|
c = build_omp_clause (where.lb->location, OMP_CLAUSE_DEFAULT);
|
c = build_omp_clause (where.lb->location, OMP_CLAUSE_DEFAULT);
|
switch (clauses->default_sharing)
|
switch (clauses->default_sharing)
|
{
|
{
|
case OMP_DEFAULT_NONE:
|
case OMP_DEFAULT_NONE:
|
OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_NONE;
|
OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_NONE;
|
break;
|
break;
|
case OMP_DEFAULT_SHARED:
|
case OMP_DEFAULT_SHARED:
|
OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_SHARED;
|
OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_SHARED;
|
break;
|
break;
|
case OMP_DEFAULT_PRIVATE:
|
case OMP_DEFAULT_PRIVATE:
|
OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_PRIVATE;
|
OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_PRIVATE;
|
break;
|
break;
|
case OMP_DEFAULT_FIRSTPRIVATE:
|
case OMP_DEFAULT_FIRSTPRIVATE:
|
OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_FIRSTPRIVATE;
|
OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_FIRSTPRIVATE;
|
break;
|
break;
|
default:
|
default:
|
gcc_unreachable ();
|
gcc_unreachable ();
|
}
|
}
|
omp_clauses = gfc_trans_add_clause (c, omp_clauses);
|
omp_clauses = gfc_trans_add_clause (c, omp_clauses);
|
}
|
}
|
|
|
if (clauses->nowait)
|
if (clauses->nowait)
|
{
|
{
|
c = build_omp_clause (where.lb->location, OMP_CLAUSE_NOWAIT);
|
c = build_omp_clause (where.lb->location, OMP_CLAUSE_NOWAIT);
|
omp_clauses = gfc_trans_add_clause (c, omp_clauses);
|
omp_clauses = gfc_trans_add_clause (c, omp_clauses);
|
}
|
}
|
|
|
if (clauses->ordered)
|
if (clauses->ordered)
|
{
|
{
|
c = build_omp_clause (where.lb->location, OMP_CLAUSE_ORDERED);
|
c = build_omp_clause (where.lb->location, OMP_CLAUSE_ORDERED);
|
omp_clauses = gfc_trans_add_clause (c, omp_clauses);
|
omp_clauses = gfc_trans_add_clause (c, omp_clauses);
|
}
|
}
|
|
|
if (clauses->untied)
|
if (clauses->untied)
|
{
|
{
|
c = build_omp_clause (where.lb->location, OMP_CLAUSE_UNTIED);
|
c = build_omp_clause (where.lb->location, OMP_CLAUSE_UNTIED);
|
omp_clauses = gfc_trans_add_clause (c, omp_clauses);
|
omp_clauses = gfc_trans_add_clause (c, omp_clauses);
|
}
|
}
|
|
|
if (clauses->collapse)
|
if (clauses->collapse)
|
{
|
{
|
c = build_omp_clause (where.lb->location, OMP_CLAUSE_COLLAPSE);
|
c = build_omp_clause (where.lb->location, OMP_CLAUSE_COLLAPSE);
|
OMP_CLAUSE_COLLAPSE_EXPR (c) = build_int_cst (NULL, clauses->collapse);
|
OMP_CLAUSE_COLLAPSE_EXPR (c) = build_int_cst (NULL, clauses->collapse);
|
omp_clauses = gfc_trans_add_clause (c, omp_clauses);
|
omp_clauses = gfc_trans_add_clause (c, omp_clauses);
|
}
|
}
|
|
|
return omp_clauses;
|
return omp_clauses;
|
}
|
}
|
|
|
/* Like gfc_trans_code, but force creation of a BIND_EXPR around it. */
|
/* Like gfc_trans_code, but force creation of a BIND_EXPR around it. */
|
|
|
static tree
|
static tree
|
gfc_trans_omp_code (gfc_code *code, bool force_empty)
|
gfc_trans_omp_code (gfc_code *code, bool force_empty)
|
{
|
{
|
tree stmt;
|
tree stmt;
|
|
|
pushlevel (0);
|
pushlevel (0);
|
stmt = gfc_trans_code (code);
|
stmt = gfc_trans_code (code);
|
if (TREE_CODE (stmt) != BIND_EXPR)
|
if (TREE_CODE (stmt) != BIND_EXPR)
|
{
|
{
|
if (!IS_EMPTY_STMT (stmt) || force_empty)
|
if (!IS_EMPTY_STMT (stmt) || force_empty)
|
{
|
{
|
tree block = poplevel (1, 0, 0);
|
tree block = poplevel (1, 0, 0);
|
stmt = build3_v (BIND_EXPR, NULL, stmt, block);
|
stmt = build3_v (BIND_EXPR, NULL, stmt, block);
|
}
|
}
|
else
|
else
|
poplevel (0, 0, 0);
|
poplevel (0, 0, 0);
|
}
|
}
|
else
|
else
|
poplevel (0, 0, 0);
|
poplevel (0, 0, 0);
|
return stmt;
|
return stmt;
|
}
|
}
|
|
|
|
|
static tree gfc_trans_omp_sections (gfc_code *, gfc_omp_clauses *);
|
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_workshare (gfc_code *, gfc_omp_clauses *);
|
|
|
static tree
|
static tree
|
gfc_trans_omp_atomic (gfc_code *code)
|
gfc_trans_omp_atomic (gfc_code *code)
|
{
|
{
|
gfc_se lse;
|
gfc_se lse;
|
gfc_se rse;
|
gfc_se rse;
|
gfc_expr *expr2, *e;
|
gfc_expr *expr2, *e;
|
gfc_symbol *var;
|
gfc_symbol *var;
|
stmtblock_t block;
|
stmtblock_t block;
|
tree lhsaddr, type, rhs, x;
|
tree lhsaddr, type, rhs, x;
|
enum tree_code op = ERROR_MARK;
|
enum tree_code op = ERROR_MARK;
|
bool var_on_left = false;
|
bool var_on_left = false;
|
|
|
code = code->block->next;
|
code = code->block->next;
|
gcc_assert (code->op == EXEC_ASSIGN);
|
gcc_assert (code->op == EXEC_ASSIGN);
|
gcc_assert (code->next == NULL);
|
gcc_assert (code->next == NULL);
|
var = code->expr1->symtree->n.sym;
|
var = code->expr1->symtree->n.sym;
|
|
|
gfc_init_se (&lse, NULL);
|
gfc_init_se (&lse, NULL);
|
gfc_init_se (&rse, NULL);
|
gfc_init_se (&rse, NULL);
|
gfc_start_block (&block);
|
gfc_start_block (&block);
|
|
|
gfc_conv_expr (&lse, code->expr1);
|
gfc_conv_expr (&lse, code->expr1);
|
gfc_add_block_to_block (&block, &lse.pre);
|
gfc_add_block_to_block (&block, &lse.pre);
|
type = TREE_TYPE (lse.expr);
|
type = TREE_TYPE (lse.expr);
|
lhsaddr = gfc_build_addr_expr (NULL, lse.expr);
|
lhsaddr = gfc_build_addr_expr (NULL, lse.expr);
|
|
|
expr2 = code->expr2;
|
expr2 = code->expr2;
|
if (expr2->expr_type == EXPR_FUNCTION
|
if (expr2->expr_type == EXPR_FUNCTION
|
&& expr2->value.function.isym->id == GFC_ISYM_CONVERSION)
|
&& expr2->value.function.isym->id == GFC_ISYM_CONVERSION)
|
expr2 = expr2->value.function.actual->expr;
|
expr2 = expr2->value.function.actual->expr;
|
|
|
if (expr2->expr_type == EXPR_OP)
|
if (expr2->expr_type == EXPR_OP)
|
{
|
{
|
gfc_expr *e;
|
gfc_expr *e;
|
switch (expr2->value.op.op)
|
switch (expr2->value.op.op)
|
{
|
{
|
case INTRINSIC_PLUS:
|
case INTRINSIC_PLUS:
|
op = PLUS_EXPR;
|
op = PLUS_EXPR;
|
break;
|
break;
|
case INTRINSIC_TIMES:
|
case INTRINSIC_TIMES:
|
op = MULT_EXPR;
|
op = MULT_EXPR;
|
break;
|
break;
|
case INTRINSIC_MINUS:
|
case INTRINSIC_MINUS:
|
op = MINUS_EXPR;
|
op = MINUS_EXPR;
|
break;
|
break;
|
case INTRINSIC_DIVIDE:
|
case INTRINSIC_DIVIDE:
|
if (expr2->ts.type == BT_INTEGER)
|
if (expr2->ts.type == BT_INTEGER)
|
op = TRUNC_DIV_EXPR;
|
op = TRUNC_DIV_EXPR;
|
else
|
else
|
op = RDIV_EXPR;
|
op = RDIV_EXPR;
|
break;
|
break;
|
case INTRINSIC_AND:
|
case INTRINSIC_AND:
|
op = TRUTH_ANDIF_EXPR;
|
op = TRUTH_ANDIF_EXPR;
|
break;
|
break;
|
case INTRINSIC_OR:
|
case INTRINSIC_OR:
|
op = TRUTH_ORIF_EXPR;
|
op = TRUTH_ORIF_EXPR;
|
break;
|
break;
|
case INTRINSIC_EQV:
|
case INTRINSIC_EQV:
|
op = EQ_EXPR;
|
op = EQ_EXPR;
|
break;
|
break;
|
case INTRINSIC_NEQV:
|
case INTRINSIC_NEQV:
|
op = NE_EXPR;
|
op = NE_EXPR;
|
break;
|
break;
|
default:
|
default:
|
gcc_unreachable ();
|
gcc_unreachable ();
|
}
|
}
|
e = expr2->value.op.op1;
|
e = expr2->value.op.op1;
|
if (e->expr_type == EXPR_FUNCTION
|
if (e->expr_type == EXPR_FUNCTION
|
&& e->value.function.isym->id == GFC_ISYM_CONVERSION)
|
&& e->value.function.isym->id == GFC_ISYM_CONVERSION)
|
e = e->value.function.actual->expr;
|
e = e->value.function.actual->expr;
|
if (e->expr_type == EXPR_VARIABLE
|
if (e->expr_type == EXPR_VARIABLE
|
&& e->symtree != NULL
|
&& e->symtree != NULL
|
&& e->symtree->n.sym == var)
|
&& e->symtree->n.sym == var)
|
{
|
{
|
expr2 = expr2->value.op.op2;
|
expr2 = expr2->value.op.op2;
|
var_on_left = true;
|
var_on_left = true;
|
}
|
}
|
else
|
else
|
{
|
{
|
e = expr2->value.op.op2;
|
e = expr2->value.op.op2;
|
if (e->expr_type == EXPR_FUNCTION
|
if (e->expr_type == EXPR_FUNCTION
|
&& e->value.function.isym->id == GFC_ISYM_CONVERSION)
|
&& e->value.function.isym->id == GFC_ISYM_CONVERSION)
|
e = e->value.function.actual->expr;
|
e = e->value.function.actual->expr;
|
gcc_assert (e->expr_type == EXPR_VARIABLE
|
gcc_assert (e->expr_type == EXPR_VARIABLE
|
&& e->symtree != NULL
|
&& e->symtree != NULL
|
&& e->symtree->n.sym == var);
|
&& e->symtree->n.sym == var);
|
expr2 = expr2->value.op.op1;
|
expr2 = expr2->value.op.op1;
|
var_on_left = false;
|
var_on_left = false;
|
}
|
}
|
gfc_conv_expr (&rse, expr2);
|
gfc_conv_expr (&rse, expr2);
|
gfc_add_block_to_block (&block, &rse.pre);
|
gfc_add_block_to_block (&block, &rse.pre);
|
}
|
}
|
else
|
else
|
{
|
{
|
gcc_assert (expr2->expr_type == EXPR_FUNCTION);
|
gcc_assert (expr2->expr_type == EXPR_FUNCTION);
|
switch (expr2->value.function.isym->id)
|
switch (expr2->value.function.isym->id)
|
{
|
{
|
case GFC_ISYM_MIN:
|
case GFC_ISYM_MIN:
|
op = MIN_EXPR;
|
op = MIN_EXPR;
|
break;
|
break;
|
case GFC_ISYM_MAX:
|
case GFC_ISYM_MAX:
|
op = MAX_EXPR;
|
op = MAX_EXPR;
|
break;
|
break;
|
case GFC_ISYM_IAND:
|
case GFC_ISYM_IAND:
|
op = BIT_AND_EXPR;
|
op = BIT_AND_EXPR;
|
break;
|
break;
|
case GFC_ISYM_IOR:
|
case GFC_ISYM_IOR:
|
op = BIT_IOR_EXPR;
|
op = BIT_IOR_EXPR;
|
break;
|
break;
|
case GFC_ISYM_IEOR:
|
case GFC_ISYM_IEOR:
|
op = BIT_XOR_EXPR;
|
op = BIT_XOR_EXPR;
|
break;
|
break;
|
default:
|
default:
|
gcc_unreachable ();
|
gcc_unreachable ();
|
}
|
}
|
e = expr2->value.function.actual->expr;
|
e = expr2->value.function.actual->expr;
|
gcc_assert (e->expr_type == EXPR_VARIABLE
|
gcc_assert (e->expr_type == EXPR_VARIABLE
|
&& e->symtree != NULL
|
&& e->symtree != NULL
|
&& e->symtree->n.sym == var);
|
&& e->symtree->n.sym == var);
|
|
|
gfc_conv_expr (&rse, expr2->value.function.actual->next->expr);
|
gfc_conv_expr (&rse, expr2->value.function.actual->next->expr);
|
gfc_add_block_to_block (&block, &rse.pre);
|
gfc_add_block_to_block (&block, &rse.pre);
|
if (expr2->value.function.actual->next->next != NULL)
|
if (expr2->value.function.actual->next->next != NULL)
|
{
|
{
|
tree accum = gfc_create_var (TREE_TYPE (rse.expr), NULL);
|
tree accum = gfc_create_var (TREE_TYPE (rse.expr), NULL);
|
gfc_actual_arglist *arg;
|
gfc_actual_arglist *arg;
|
|
|
gfc_add_modify (&block, accum, rse.expr);
|
gfc_add_modify (&block, accum, rse.expr);
|
for (arg = expr2->value.function.actual->next->next; arg;
|
for (arg = expr2->value.function.actual->next->next; arg;
|
arg = arg->next)
|
arg = arg->next)
|
{
|
{
|
gfc_init_block (&rse.pre);
|
gfc_init_block (&rse.pre);
|
gfc_conv_expr (&rse, arg->expr);
|
gfc_conv_expr (&rse, arg->expr);
|
gfc_add_block_to_block (&block, &rse.pre);
|
gfc_add_block_to_block (&block, &rse.pre);
|
x = fold_build2 (op, TREE_TYPE (accum), accum, rse.expr);
|
x = fold_build2 (op, TREE_TYPE (accum), accum, rse.expr);
|
gfc_add_modify (&block, accum, x);
|
gfc_add_modify (&block, accum, x);
|
}
|
}
|
|
|
rse.expr = accum;
|
rse.expr = accum;
|
}
|
}
|
|
|
expr2 = expr2->value.function.actual->next->expr;
|
expr2 = expr2->value.function.actual->next->expr;
|
}
|
}
|
|
|
lhsaddr = save_expr (lhsaddr);
|
lhsaddr = save_expr (lhsaddr);
|
rhs = gfc_evaluate_now (rse.expr, &block);
|
rhs = gfc_evaluate_now (rse.expr, &block);
|
x = convert (TREE_TYPE (rhs), build_fold_indirect_ref_loc (input_location,
|
x = convert (TREE_TYPE (rhs), build_fold_indirect_ref_loc (input_location,
|
lhsaddr));
|
lhsaddr));
|
|
|
if (var_on_left)
|
if (var_on_left)
|
x = fold_build2 (op, TREE_TYPE (rhs), x, rhs);
|
x = fold_build2 (op, TREE_TYPE (rhs), x, rhs);
|
else
|
else
|
x = fold_build2 (op, TREE_TYPE (rhs), rhs, x);
|
x = fold_build2 (op, TREE_TYPE (rhs), rhs, x);
|
|
|
if (TREE_CODE (TREE_TYPE (rhs)) == COMPLEX_TYPE
|
if (TREE_CODE (TREE_TYPE (rhs)) == COMPLEX_TYPE
|
&& TREE_CODE (type) != COMPLEX_TYPE)
|
&& TREE_CODE (type) != COMPLEX_TYPE)
|
x = fold_build1 (REALPART_EXPR, TREE_TYPE (TREE_TYPE (rhs)), x);
|
x = fold_build1 (REALPART_EXPR, TREE_TYPE (TREE_TYPE (rhs)), x);
|
|
|
x = build2_v (OMP_ATOMIC, lhsaddr, convert (type, x));
|
x = build2_v (OMP_ATOMIC, lhsaddr, convert (type, x));
|
gfc_add_expr_to_block (&block, x);
|
gfc_add_expr_to_block (&block, x);
|
|
|
gfc_add_block_to_block (&block, &lse.pre);
|
gfc_add_block_to_block (&block, &lse.pre);
|
gfc_add_block_to_block (&block, &rse.pre);
|
gfc_add_block_to_block (&block, &rse.pre);
|
|
|
return gfc_finish_block (&block);
|
return gfc_finish_block (&block);
|
}
|
}
|
|
|
static tree
|
static tree
|
gfc_trans_omp_barrier (void)
|
gfc_trans_omp_barrier (void)
|
{
|
{
|
tree decl = built_in_decls [BUILT_IN_GOMP_BARRIER];
|
tree decl = built_in_decls [BUILT_IN_GOMP_BARRIER];
|
return build_call_expr_loc (input_location, decl, 0);
|
return build_call_expr_loc (input_location, decl, 0);
|
}
|
}
|
|
|
static tree
|
static tree
|
gfc_trans_omp_critical (gfc_code *code)
|
gfc_trans_omp_critical (gfc_code *code)
|
{
|
{
|
tree name = NULL_TREE, stmt;
|
tree name = NULL_TREE, stmt;
|
if (code->ext.omp_name != NULL)
|
if (code->ext.omp_name != NULL)
|
name = get_identifier (code->ext.omp_name);
|
name = get_identifier (code->ext.omp_name);
|
stmt = gfc_trans_code (code->block->next);
|
stmt = gfc_trans_code (code->block->next);
|
return build2 (OMP_CRITICAL, void_type_node, stmt, name);
|
return build2 (OMP_CRITICAL, void_type_node, stmt, name);
|
}
|
}
|
|
|
static tree
|
static tree
|
gfc_trans_omp_do (gfc_code *code, stmtblock_t *pblock,
|
gfc_trans_omp_do (gfc_code *code, stmtblock_t *pblock,
|
gfc_omp_clauses *do_clauses, tree par_clauses)
|
gfc_omp_clauses *do_clauses, tree par_clauses)
|
{
|
{
|
gfc_se se;
|
gfc_se se;
|
tree dovar, stmt, from, to, step, type, init, cond, incr;
|
tree dovar, stmt, from, to, step, type, init, cond, incr;
|
tree count = NULL_TREE, cycle_label, tmp, omp_clauses;
|
tree count = NULL_TREE, cycle_label, tmp, omp_clauses;
|
stmtblock_t block;
|
stmtblock_t block;
|
stmtblock_t body;
|
stmtblock_t body;
|
gfc_omp_clauses *clauses = code->ext.omp_clauses;
|
gfc_omp_clauses *clauses = code->ext.omp_clauses;
|
int i, collapse = clauses->collapse;
|
int i, collapse = clauses->collapse;
|
tree dovar_init = NULL_TREE;
|
tree dovar_init = NULL_TREE;
|
|
|
if (collapse <= 0)
|
if (collapse <= 0)
|
collapse = 1;
|
collapse = 1;
|
|
|
code = code->block->next;
|
code = code->block->next;
|
gcc_assert (code->op == EXEC_DO);
|
gcc_assert (code->op == EXEC_DO);
|
|
|
init = make_tree_vec (collapse);
|
init = make_tree_vec (collapse);
|
cond = make_tree_vec (collapse);
|
cond = make_tree_vec (collapse);
|
incr = make_tree_vec (collapse);
|
incr = make_tree_vec (collapse);
|
|
|
if (pblock == NULL)
|
if (pblock == NULL)
|
{
|
{
|
gfc_start_block (&block);
|
gfc_start_block (&block);
|
pblock = █
|
pblock = █
|
}
|
}
|
|
|
omp_clauses = gfc_trans_omp_clauses (pblock, do_clauses, code->loc);
|
omp_clauses = gfc_trans_omp_clauses (pblock, do_clauses, code->loc);
|
|
|
for (i = 0; i < collapse; i++)
|
for (i = 0; i < collapse; i++)
|
{
|
{
|
int simple = 0;
|
int simple = 0;
|
int dovar_found = 0;
|
int dovar_found = 0;
|
tree dovar_decl;
|
tree dovar_decl;
|
|
|
if (clauses)
|
if (clauses)
|
{
|
{
|
gfc_namelist *n;
|
gfc_namelist *n;
|
for (n = clauses->lists[OMP_LIST_LASTPRIVATE]; n != NULL;
|
for (n = clauses->lists[OMP_LIST_LASTPRIVATE]; n != NULL;
|
n = n->next)
|
n = n->next)
|
if (code->ext.iterator->var->symtree->n.sym == n->sym)
|
if (code->ext.iterator->var->symtree->n.sym == n->sym)
|
break;
|
break;
|
if (n != NULL)
|
if (n != NULL)
|
dovar_found = 1;
|
dovar_found = 1;
|
else if (n == NULL)
|
else if (n == NULL)
|
for (n = clauses->lists[OMP_LIST_PRIVATE]; n != NULL; n = n->next)
|
for (n = clauses->lists[OMP_LIST_PRIVATE]; n != NULL; n = n->next)
|
if (code->ext.iterator->var->symtree->n.sym == n->sym)
|
if (code->ext.iterator->var->symtree->n.sym == n->sym)
|
break;
|
break;
|
if (n != NULL)
|
if (n != NULL)
|
dovar_found++;
|
dovar_found++;
|
}
|
}
|
|
|
/* Evaluate all the expressions in the iterator. */
|
/* Evaluate all the expressions in the iterator. */
|
gfc_init_se (&se, NULL);
|
gfc_init_se (&se, NULL);
|
gfc_conv_expr_lhs (&se, code->ext.iterator->var);
|
gfc_conv_expr_lhs (&se, code->ext.iterator->var);
|
gfc_add_block_to_block (pblock, &se.pre);
|
gfc_add_block_to_block (pblock, &se.pre);
|
dovar = se.expr;
|
dovar = se.expr;
|
type = TREE_TYPE (dovar);
|
type = TREE_TYPE (dovar);
|
gcc_assert (TREE_CODE (type) == INTEGER_TYPE);
|
gcc_assert (TREE_CODE (type) == INTEGER_TYPE);
|
|
|
gfc_init_se (&se, NULL);
|
gfc_init_se (&se, NULL);
|
gfc_conv_expr_val (&se, code->ext.iterator->start);
|
gfc_conv_expr_val (&se, code->ext.iterator->start);
|
gfc_add_block_to_block (pblock, &se.pre);
|
gfc_add_block_to_block (pblock, &se.pre);
|
from = gfc_evaluate_now (se.expr, pblock);
|
from = gfc_evaluate_now (se.expr, pblock);
|
|
|
gfc_init_se (&se, NULL);
|
gfc_init_se (&se, NULL);
|
gfc_conv_expr_val (&se, code->ext.iterator->end);
|
gfc_conv_expr_val (&se, code->ext.iterator->end);
|
gfc_add_block_to_block (pblock, &se.pre);
|
gfc_add_block_to_block (pblock, &se.pre);
|
to = gfc_evaluate_now (se.expr, pblock);
|
to = gfc_evaluate_now (se.expr, pblock);
|
|
|
gfc_init_se (&se, NULL);
|
gfc_init_se (&se, NULL);
|
gfc_conv_expr_val (&se, code->ext.iterator->step);
|
gfc_conv_expr_val (&se, code->ext.iterator->step);
|
gfc_add_block_to_block (pblock, &se.pre);
|
gfc_add_block_to_block (pblock, &se.pre);
|
step = gfc_evaluate_now (se.expr, pblock);
|
step = gfc_evaluate_now (se.expr, pblock);
|
dovar_decl = dovar;
|
dovar_decl = dovar;
|
|
|
/* Special case simple loops. */
|
/* Special case simple loops. */
|
if (TREE_CODE (dovar) == VAR_DECL)
|
if (TREE_CODE (dovar) == VAR_DECL)
|
{
|
{
|
if (integer_onep (step))
|
if (integer_onep (step))
|
simple = 1;
|
simple = 1;
|
else if (tree_int_cst_equal (step, integer_minus_one_node))
|
else if (tree_int_cst_equal (step, integer_minus_one_node))
|
simple = -1;
|
simple = -1;
|
}
|
}
|
else
|
else
|
dovar_decl
|
dovar_decl
|
= gfc_trans_omp_variable (code->ext.iterator->var->symtree->n.sym);
|
= gfc_trans_omp_variable (code->ext.iterator->var->symtree->n.sym);
|
|
|
/* Loop body. */
|
/* Loop body. */
|
if (simple)
|
if (simple)
|
{
|
{
|
TREE_VEC_ELT (init, i) = build2_v (MODIFY_EXPR, dovar, from);
|
TREE_VEC_ELT (init, i) = build2_v (MODIFY_EXPR, dovar, from);
|
TREE_VEC_ELT (cond, i) = fold_build2 (simple > 0 ? LE_EXPR : GE_EXPR,
|
TREE_VEC_ELT (cond, i) = fold_build2 (simple > 0 ? LE_EXPR : GE_EXPR,
|
boolean_type_node, dovar, to);
|
boolean_type_node, dovar, to);
|
TREE_VEC_ELT (incr, i) = fold_build2 (PLUS_EXPR, type, dovar, step);
|
TREE_VEC_ELT (incr, i) = fold_build2 (PLUS_EXPR, type, dovar, step);
|
TREE_VEC_ELT (incr, i) = fold_build2 (MODIFY_EXPR, type, dovar,
|
TREE_VEC_ELT (incr, i) = fold_build2 (MODIFY_EXPR, type, dovar,
|
TREE_VEC_ELT (incr, i));
|
TREE_VEC_ELT (incr, i));
|
}
|
}
|
else
|
else
|
{
|
{
|
/* STEP is not 1 or -1. Use:
|
/* STEP is not 1 or -1. Use:
|
for (count = 0; count < (to + step - from) / step; count++)
|
for (count = 0; count < (to + step - from) / step; count++)
|
{
|
{
|
dovar = from + count * step;
|
dovar = from + count * step;
|
body;
|
body;
|
cycle_label:;
|
cycle_label:;
|
} */
|
} */
|
tmp = fold_build2 (MINUS_EXPR, type, step, from);
|
tmp = fold_build2 (MINUS_EXPR, type, step, from);
|
tmp = fold_build2 (PLUS_EXPR, type, to, tmp);
|
tmp = fold_build2 (PLUS_EXPR, type, to, tmp);
|
tmp = fold_build2 (TRUNC_DIV_EXPR, type, tmp, step);
|
tmp = fold_build2 (TRUNC_DIV_EXPR, type, tmp, step);
|
tmp = gfc_evaluate_now (tmp, pblock);
|
tmp = gfc_evaluate_now (tmp, pblock);
|
count = gfc_create_var (type, "count");
|
count = gfc_create_var (type, "count");
|
TREE_VEC_ELT (init, i) = build2_v (MODIFY_EXPR, count,
|
TREE_VEC_ELT (init, i) = build2_v (MODIFY_EXPR, count,
|
build_int_cst (type, 0));
|
build_int_cst (type, 0));
|
TREE_VEC_ELT (cond, i) = fold_build2 (LT_EXPR, boolean_type_node,
|
TREE_VEC_ELT (cond, i) = fold_build2 (LT_EXPR, boolean_type_node,
|
count, tmp);
|
count, tmp);
|
TREE_VEC_ELT (incr, i) = fold_build2 (PLUS_EXPR, type, count,
|
TREE_VEC_ELT (incr, i) = fold_build2 (PLUS_EXPR, type, count,
|
build_int_cst (type, 1));
|
build_int_cst (type, 1));
|
TREE_VEC_ELT (incr, i) = fold_build2 (MODIFY_EXPR, type,
|
TREE_VEC_ELT (incr, i) = fold_build2 (MODIFY_EXPR, type,
|
count, TREE_VEC_ELT (incr, i));
|
count, TREE_VEC_ELT (incr, i));
|
|
|
/* Initialize DOVAR. */
|
/* Initialize DOVAR. */
|
tmp = fold_build2 (MULT_EXPR, type, count, step);
|
tmp = fold_build2 (MULT_EXPR, type, count, step);
|
tmp = fold_build2 (PLUS_EXPR, type, from, tmp);
|
tmp = fold_build2 (PLUS_EXPR, type, from, tmp);
|
dovar_init = tree_cons (dovar, tmp, dovar_init);
|
dovar_init = tree_cons (dovar, tmp, dovar_init);
|
}
|
}
|
|
|
if (!dovar_found)
|
if (!dovar_found)
|
{
|
{
|
tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE);
|
tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE);
|
OMP_CLAUSE_DECL (tmp) = dovar_decl;
|
OMP_CLAUSE_DECL (tmp) = dovar_decl;
|
omp_clauses = gfc_trans_add_clause (tmp, omp_clauses);
|
omp_clauses = gfc_trans_add_clause (tmp, omp_clauses);
|
}
|
}
|
else if (dovar_found == 2)
|
else if (dovar_found == 2)
|
{
|
{
|
tree c = NULL;
|
tree c = NULL;
|
|
|
tmp = NULL;
|
tmp = NULL;
|
if (!simple)
|
if (!simple)
|
{
|
{
|
/* If dovar is lastprivate, but different counter is used,
|
/* If dovar is lastprivate, but different counter is used,
|
dovar += step needs to be added to
|
dovar += step needs to be added to
|
OMP_CLAUSE_LASTPRIVATE_STMT, otherwise the copied dovar
|
OMP_CLAUSE_LASTPRIVATE_STMT, otherwise the copied dovar
|
will have the value on entry of the last loop, rather
|
will have the value on entry of the last loop, rather
|
than value after iterator increment. */
|
than value after iterator increment. */
|
tmp = gfc_evaluate_now (step, pblock);
|
tmp = gfc_evaluate_now (step, pblock);
|
tmp = fold_build2 (PLUS_EXPR, type, dovar, tmp);
|
tmp = fold_build2 (PLUS_EXPR, type, dovar, tmp);
|
tmp = fold_build2 (MODIFY_EXPR, type, dovar, tmp);
|
tmp = fold_build2 (MODIFY_EXPR, type, dovar, tmp);
|
for (c = omp_clauses; c ; c = OMP_CLAUSE_CHAIN (c))
|
for (c = omp_clauses; c ; c = OMP_CLAUSE_CHAIN (c))
|
if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LASTPRIVATE
|
if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LASTPRIVATE
|
&& OMP_CLAUSE_DECL (c) == dovar_decl)
|
&& OMP_CLAUSE_DECL (c) == dovar_decl)
|
{
|
{
|
OMP_CLAUSE_LASTPRIVATE_STMT (c) = tmp;
|
OMP_CLAUSE_LASTPRIVATE_STMT (c) = tmp;
|
break;
|
break;
|
}
|
}
|
}
|
}
|
if (c == NULL && par_clauses != NULL)
|
if (c == NULL && par_clauses != NULL)
|
{
|
{
|
for (c = par_clauses; c ; c = OMP_CLAUSE_CHAIN (c))
|
for (c = par_clauses; c ; c = OMP_CLAUSE_CHAIN (c))
|
if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LASTPRIVATE
|
if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LASTPRIVATE
|
&& OMP_CLAUSE_DECL (c) == dovar_decl)
|
&& OMP_CLAUSE_DECL (c) == dovar_decl)
|
{
|
{
|
tree l = build_omp_clause (input_location,
|
tree l = build_omp_clause (input_location,
|
OMP_CLAUSE_LASTPRIVATE);
|
OMP_CLAUSE_LASTPRIVATE);
|
OMP_CLAUSE_DECL (l) = dovar_decl;
|
OMP_CLAUSE_DECL (l) = dovar_decl;
|
OMP_CLAUSE_CHAIN (l) = omp_clauses;
|
OMP_CLAUSE_CHAIN (l) = omp_clauses;
|
OMP_CLAUSE_LASTPRIVATE_STMT (l) = tmp;
|
OMP_CLAUSE_LASTPRIVATE_STMT (l) = tmp;
|
omp_clauses = l;
|
omp_clauses = l;
|
OMP_CLAUSE_SET_CODE (c, OMP_CLAUSE_SHARED);
|
OMP_CLAUSE_SET_CODE (c, OMP_CLAUSE_SHARED);
|
break;
|
break;
|
}
|
}
|
}
|
}
|
gcc_assert (simple || c != NULL);
|
gcc_assert (simple || c != NULL);
|
}
|
}
|
if (!simple)
|
if (!simple)
|
{
|
{
|
tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE);
|
tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE);
|
OMP_CLAUSE_DECL (tmp) = count;
|
OMP_CLAUSE_DECL (tmp) = count;
|
omp_clauses = gfc_trans_add_clause (tmp, omp_clauses);
|
omp_clauses = gfc_trans_add_clause (tmp, omp_clauses);
|
}
|
}
|
|
|
if (i + 1 < collapse)
|
if (i + 1 < collapse)
|
code = code->block->next;
|
code = code->block->next;
|
}
|
}
|
|
|
if (pblock != &block)
|
if (pblock != &block)
|
{
|
{
|
pushlevel (0);
|
pushlevel (0);
|
gfc_start_block (&block);
|
gfc_start_block (&block);
|
}
|
}
|
|
|
gfc_start_block (&body);
|
gfc_start_block (&body);
|
|
|
dovar_init = nreverse (dovar_init);
|
dovar_init = nreverse (dovar_init);
|
while (dovar_init)
|
while (dovar_init)
|
{
|
{
|
gfc_add_modify (&body, TREE_PURPOSE (dovar_init),
|
gfc_add_modify (&body, TREE_PURPOSE (dovar_init),
|
TREE_VALUE (dovar_init));
|
TREE_VALUE (dovar_init));
|
dovar_init = TREE_CHAIN (dovar_init);
|
dovar_init = TREE_CHAIN (dovar_init);
|
}
|
}
|
|
|
/* Cycle statement is implemented with a goto. Exit statement must not be
|
/* Cycle statement is implemented with a goto. Exit statement must not be
|
present for this loop. */
|
present for this loop. */
|
cycle_label = gfc_build_label_decl (NULL_TREE);
|
cycle_label = gfc_build_label_decl (NULL_TREE);
|
|
|
/* Put these labels where they can be found later. We put the
|
/* Put these labels where they can be found later. We put the
|
labels in a TREE_LIST node (because TREE_CHAIN is already
|
labels in a TREE_LIST node (because TREE_CHAIN is already
|
used). cycle_label goes in TREE_PURPOSE (backend_decl), exit
|
used). cycle_label goes in TREE_PURPOSE (backend_decl), exit
|
label in TREE_VALUE (backend_decl). */
|
label in TREE_VALUE (backend_decl). */
|
|
|
code->block->backend_decl = tree_cons (cycle_label, NULL, NULL);
|
code->block->backend_decl = tree_cons (cycle_label, NULL, NULL);
|
|
|
/* Main loop body. */
|
/* Main loop body. */
|
tmp = gfc_trans_omp_code (code->block->next, true);
|
tmp = gfc_trans_omp_code (code->block->next, true);
|
gfc_add_expr_to_block (&body, tmp);
|
gfc_add_expr_to_block (&body, tmp);
|
|
|
/* Label for cycle statements (if needed). */
|
/* Label for cycle statements (if needed). */
|
if (TREE_USED (cycle_label))
|
if (TREE_USED (cycle_label))
|
{
|
{
|
tmp = build1_v (LABEL_EXPR, cycle_label);
|
tmp = build1_v (LABEL_EXPR, cycle_label);
|
gfc_add_expr_to_block (&body, tmp);
|
gfc_add_expr_to_block (&body, tmp);
|
}
|
}
|
|
|
/* End of loop body. */
|
/* End of loop body. */
|
stmt = make_node (OMP_FOR);
|
stmt = make_node (OMP_FOR);
|
|
|
TREE_TYPE (stmt) = void_type_node;
|
TREE_TYPE (stmt) = void_type_node;
|
OMP_FOR_BODY (stmt) = gfc_finish_block (&body);
|
OMP_FOR_BODY (stmt) = gfc_finish_block (&body);
|
OMP_FOR_CLAUSES (stmt) = omp_clauses;
|
OMP_FOR_CLAUSES (stmt) = omp_clauses;
|
OMP_FOR_INIT (stmt) = init;
|
OMP_FOR_INIT (stmt) = init;
|
OMP_FOR_COND (stmt) = cond;
|
OMP_FOR_COND (stmt) = cond;
|
OMP_FOR_INCR (stmt) = incr;
|
OMP_FOR_INCR (stmt) = incr;
|
gfc_add_expr_to_block (&block, stmt);
|
gfc_add_expr_to_block (&block, stmt);
|
|
|
return gfc_finish_block (&block);
|
return gfc_finish_block (&block);
|
}
|
}
|
|
|
static tree
|
static tree
|
gfc_trans_omp_flush (void)
|
gfc_trans_omp_flush (void)
|
{
|
{
|
tree decl = built_in_decls [BUILT_IN_SYNCHRONIZE];
|
tree decl = built_in_decls [BUILT_IN_SYNCHRONIZE];
|
return build_call_expr_loc (input_location, decl, 0);
|
return build_call_expr_loc (input_location, decl, 0);
|
}
|
}
|
|
|
static tree
|
static tree
|
gfc_trans_omp_master (gfc_code *code)
|
gfc_trans_omp_master (gfc_code *code)
|
{
|
{
|
tree stmt = gfc_trans_code (code->block->next);
|
tree stmt = gfc_trans_code (code->block->next);
|
if (IS_EMPTY_STMT (stmt))
|
if (IS_EMPTY_STMT (stmt))
|
return stmt;
|
return stmt;
|
return build1_v (OMP_MASTER, stmt);
|
return build1_v (OMP_MASTER, stmt);
|
}
|
}
|
|
|
static tree
|
static tree
|
gfc_trans_omp_ordered (gfc_code *code)
|
gfc_trans_omp_ordered (gfc_code *code)
|
{
|
{
|
return build1_v (OMP_ORDERED, gfc_trans_code (code->block->next));
|
return build1_v (OMP_ORDERED, gfc_trans_code (code->block->next));
|
}
|
}
|
|
|
static tree
|
static tree
|
gfc_trans_omp_parallel (gfc_code *code)
|
gfc_trans_omp_parallel (gfc_code *code)
|
{
|
{
|
stmtblock_t block;
|
stmtblock_t block;
|
tree stmt, omp_clauses;
|
tree stmt, omp_clauses;
|
|
|
gfc_start_block (&block);
|
gfc_start_block (&block);
|
omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
|
omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
|
code->loc);
|
code->loc);
|
stmt = gfc_trans_omp_code (code->block->next, true);
|
stmt = gfc_trans_omp_code (code->block->next, true);
|
stmt = build2 (OMP_PARALLEL, void_type_node, stmt, omp_clauses);
|
stmt = build2 (OMP_PARALLEL, void_type_node, stmt, omp_clauses);
|
gfc_add_expr_to_block (&block, stmt);
|
gfc_add_expr_to_block (&block, stmt);
|
return gfc_finish_block (&block);
|
return gfc_finish_block (&block);
|
}
|
}
|
|
|
static tree
|
static tree
|
gfc_trans_omp_parallel_do (gfc_code *code)
|
gfc_trans_omp_parallel_do (gfc_code *code)
|
{
|
{
|
stmtblock_t block, *pblock = NULL;
|
stmtblock_t block, *pblock = NULL;
|
gfc_omp_clauses parallel_clauses, do_clauses;
|
gfc_omp_clauses parallel_clauses, do_clauses;
|
tree stmt, omp_clauses = NULL_TREE;
|
tree stmt, omp_clauses = NULL_TREE;
|
|
|
gfc_start_block (&block);
|
gfc_start_block (&block);
|
|
|
memset (&do_clauses, 0, sizeof (do_clauses));
|
memset (&do_clauses, 0, sizeof (do_clauses));
|
if (code->ext.omp_clauses != NULL)
|
if (code->ext.omp_clauses != NULL)
|
{
|
{
|
memcpy (¶llel_clauses, code->ext.omp_clauses,
|
memcpy (¶llel_clauses, code->ext.omp_clauses,
|
sizeof (parallel_clauses));
|
sizeof (parallel_clauses));
|
do_clauses.sched_kind = parallel_clauses.sched_kind;
|
do_clauses.sched_kind = parallel_clauses.sched_kind;
|
do_clauses.chunk_size = parallel_clauses.chunk_size;
|
do_clauses.chunk_size = parallel_clauses.chunk_size;
|
do_clauses.ordered = parallel_clauses.ordered;
|
do_clauses.ordered = parallel_clauses.ordered;
|
do_clauses.collapse = parallel_clauses.collapse;
|
do_clauses.collapse = parallel_clauses.collapse;
|
parallel_clauses.sched_kind = OMP_SCHED_NONE;
|
parallel_clauses.sched_kind = OMP_SCHED_NONE;
|
parallel_clauses.chunk_size = NULL;
|
parallel_clauses.chunk_size = NULL;
|
parallel_clauses.ordered = false;
|
parallel_clauses.ordered = false;
|
parallel_clauses.collapse = 0;
|
parallel_clauses.collapse = 0;
|
omp_clauses = gfc_trans_omp_clauses (&block, ¶llel_clauses,
|
omp_clauses = gfc_trans_omp_clauses (&block, ¶llel_clauses,
|
code->loc);
|
code->loc);
|
}
|
}
|
do_clauses.nowait = true;
|
do_clauses.nowait = true;
|
if (!do_clauses.ordered && do_clauses.sched_kind != OMP_SCHED_STATIC)
|
if (!do_clauses.ordered && do_clauses.sched_kind != OMP_SCHED_STATIC)
|
pblock = █
|
pblock = █
|
else
|
else
|
pushlevel (0);
|
pushlevel (0);
|
stmt = gfc_trans_omp_do (code, pblock, &do_clauses, omp_clauses);
|
stmt = gfc_trans_omp_do (code, pblock, &do_clauses, omp_clauses);
|
if (TREE_CODE (stmt) != BIND_EXPR)
|
if (TREE_CODE (stmt) != BIND_EXPR)
|
stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
|
stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
|
else
|
else
|
poplevel (0, 0, 0);
|
poplevel (0, 0, 0);
|
stmt = build2 (OMP_PARALLEL, void_type_node, stmt, omp_clauses);
|
stmt = build2 (OMP_PARALLEL, void_type_node, stmt, omp_clauses);
|
OMP_PARALLEL_COMBINED (stmt) = 1;
|
OMP_PARALLEL_COMBINED (stmt) = 1;
|
gfc_add_expr_to_block (&block, stmt);
|
gfc_add_expr_to_block (&block, stmt);
|
return gfc_finish_block (&block);
|
return gfc_finish_block (&block);
|
}
|
}
|
|
|
static tree
|
static tree
|
gfc_trans_omp_parallel_sections (gfc_code *code)
|
gfc_trans_omp_parallel_sections (gfc_code *code)
|
{
|
{
|
stmtblock_t block;
|
stmtblock_t block;
|
gfc_omp_clauses section_clauses;
|
gfc_omp_clauses section_clauses;
|
tree stmt, omp_clauses;
|
tree stmt, omp_clauses;
|
|
|
memset (§ion_clauses, 0, sizeof (section_clauses));
|
memset (§ion_clauses, 0, sizeof (section_clauses));
|
section_clauses.nowait = true;
|
section_clauses.nowait = true;
|
|
|
gfc_start_block (&block);
|
gfc_start_block (&block);
|
omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
|
omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
|
code->loc);
|
code->loc);
|
pushlevel (0);
|
pushlevel (0);
|
stmt = gfc_trans_omp_sections (code, §ion_clauses);
|
stmt = gfc_trans_omp_sections (code, §ion_clauses);
|
if (TREE_CODE (stmt) != BIND_EXPR)
|
if (TREE_CODE (stmt) != BIND_EXPR)
|
stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
|
stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
|
else
|
else
|
poplevel (0, 0, 0);
|
poplevel (0, 0, 0);
|
stmt = build2 (OMP_PARALLEL, void_type_node, stmt, omp_clauses);
|
stmt = build2 (OMP_PARALLEL, void_type_node, stmt, omp_clauses);
|
OMP_PARALLEL_COMBINED (stmt) = 1;
|
OMP_PARALLEL_COMBINED (stmt) = 1;
|
gfc_add_expr_to_block (&block, stmt);
|
gfc_add_expr_to_block (&block, stmt);
|
return gfc_finish_block (&block);
|
return gfc_finish_block (&block);
|
}
|
}
|
|
|
static tree
|
static tree
|
gfc_trans_omp_parallel_workshare (gfc_code *code)
|
gfc_trans_omp_parallel_workshare (gfc_code *code)
|
{
|
{
|
stmtblock_t block;
|
stmtblock_t block;
|
gfc_omp_clauses workshare_clauses;
|
gfc_omp_clauses workshare_clauses;
|
tree stmt, omp_clauses;
|
tree stmt, omp_clauses;
|
|
|
memset (&workshare_clauses, 0, sizeof (workshare_clauses));
|
memset (&workshare_clauses, 0, sizeof (workshare_clauses));
|
workshare_clauses.nowait = true;
|
workshare_clauses.nowait = true;
|
|
|
gfc_start_block (&block);
|
gfc_start_block (&block);
|
omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
|
omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
|
code->loc);
|
code->loc);
|
pushlevel (0);
|
pushlevel (0);
|
stmt = gfc_trans_omp_workshare (code, &workshare_clauses);
|
stmt = gfc_trans_omp_workshare (code, &workshare_clauses);
|
if (TREE_CODE (stmt) != BIND_EXPR)
|
if (TREE_CODE (stmt) != BIND_EXPR)
|
stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
|
stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
|
else
|
else
|
poplevel (0, 0, 0);
|
poplevel (0, 0, 0);
|
stmt = build2 (OMP_PARALLEL, void_type_node, stmt, omp_clauses);
|
stmt = build2 (OMP_PARALLEL, void_type_node, stmt, omp_clauses);
|
OMP_PARALLEL_COMBINED (stmt) = 1;
|
OMP_PARALLEL_COMBINED (stmt) = 1;
|
gfc_add_expr_to_block (&block, stmt);
|
gfc_add_expr_to_block (&block, stmt);
|
return gfc_finish_block (&block);
|
return gfc_finish_block (&block);
|
}
|
}
|
|
|
static tree
|
static tree
|
gfc_trans_omp_sections (gfc_code *code, gfc_omp_clauses *clauses)
|
gfc_trans_omp_sections (gfc_code *code, gfc_omp_clauses *clauses)
|
{
|
{
|
stmtblock_t block, body;
|
stmtblock_t block, body;
|
tree omp_clauses, stmt;
|
tree omp_clauses, stmt;
|
bool has_lastprivate = clauses->lists[OMP_LIST_LASTPRIVATE] != NULL;
|
bool has_lastprivate = clauses->lists[OMP_LIST_LASTPRIVATE] != NULL;
|
|
|
gfc_start_block (&block);
|
gfc_start_block (&block);
|
|
|
omp_clauses = gfc_trans_omp_clauses (&block, clauses, code->loc);
|
omp_clauses = gfc_trans_omp_clauses (&block, clauses, code->loc);
|
|
|
gfc_init_block (&body);
|
gfc_init_block (&body);
|
for (code = code->block; code; code = code->block)
|
for (code = code->block; code; code = code->block)
|
{
|
{
|
/* Last section is special because of lastprivate, so even if it
|
/* Last section is special because of lastprivate, so even if it
|
is empty, chain it in. */
|
is empty, chain it in. */
|
stmt = gfc_trans_omp_code (code->next,
|
stmt = gfc_trans_omp_code (code->next,
|
has_lastprivate && code->block == NULL);
|
has_lastprivate && code->block == NULL);
|
if (! IS_EMPTY_STMT (stmt))
|
if (! IS_EMPTY_STMT (stmt))
|
{
|
{
|
stmt = build1_v (OMP_SECTION, stmt);
|
stmt = build1_v (OMP_SECTION, stmt);
|
gfc_add_expr_to_block (&body, stmt);
|
gfc_add_expr_to_block (&body, stmt);
|
}
|
}
|
}
|
}
|
stmt = gfc_finish_block (&body);
|
stmt = gfc_finish_block (&body);
|
|
|
stmt = build2 (OMP_SECTIONS, void_type_node, stmt, omp_clauses);
|
stmt = build2 (OMP_SECTIONS, void_type_node, stmt, omp_clauses);
|
gfc_add_expr_to_block (&block, stmt);
|
gfc_add_expr_to_block (&block, stmt);
|
|
|
return gfc_finish_block (&block);
|
return gfc_finish_block (&block);
|
}
|
}
|
|
|
static tree
|
static tree
|
gfc_trans_omp_single (gfc_code *code, gfc_omp_clauses *clauses)
|
gfc_trans_omp_single (gfc_code *code, gfc_omp_clauses *clauses)
|
{
|
{
|
tree omp_clauses = gfc_trans_omp_clauses (NULL, clauses, code->loc);
|
tree omp_clauses = gfc_trans_omp_clauses (NULL, clauses, code->loc);
|
tree stmt = gfc_trans_omp_code (code->block->next, true);
|
tree stmt = gfc_trans_omp_code (code->block->next, true);
|
stmt = build2 (OMP_SINGLE, void_type_node, stmt, omp_clauses);
|
stmt = build2 (OMP_SINGLE, void_type_node, stmt, omp_clauses);
|
return stmt;
|
return stmt;
|
}
|
}
|
|
|
static tree
|
static tree
|
gfc_trans_omp_task (gfc_code *code)
|
gfc_trans_omp_task (gfc_code *code)
|
{
|
{
|
stmtblock_t block;
|
stmtblock_t block;
|
tree stmt, omp_clauses;
|
tree stmt, omp_clauses;
|
|
|
gfc_start_block (&block);
|
gfc_start_block (&block);
|
omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
|
omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
|
code->loc);
|
code->loc);
|
stmt = gfc_trans_omp_code (code->block->next, true);
|
stmt = gfc_trans_omp_code (code->block->next, true);
|
stmt = build2 (OMP_TASK, void_type_node, stmt, omp_clauses);
|
stmt = build2 (OMP_TASK, void_type_node, stmt, omp_clauses);
|
gfc_add_expr_to_block (&block, stmt);
|
gfc_add_expr_to_block (&block, stmt);
|
return gfc_finish_block (&block);
|
return gfc_finish_block (&block);
|
}
|
}
|
|
|
static tree
|
static tree
|
gfc_trans_omp_taskwait (void)
|
gfc_trans_omp_taskwait (void)
|
{
|
{
|
tree decl = built_in_decls [BUILT_IN_GOMP_TASKWAIT];
|
tree decl = built_in_decls [BUILT_IN_GOMP_TASKWAIT];
|
return build_call_expr_loc (input_location, decl, 0);
|
return build_call_expr_loc (input_location, decl, 0);
|
}
|
}
|
|
|
static tree
|
static tree
|
gfc_trans_omp_workshare (gfc_code *code, gfc_omp_clauses *clauses)
|
gfc_trans_omp_workshare (gfc_code *code, gfc_omp_clauses *clauses)
|
{
|
{
|
tree res, tmp, stmt;
|
tree res, tmp, stmt;
|
stmtblock_t block, *pblock = NULL;
|
stmtblock_t block, *pblock = NULL;
|
stmtblock_t singleblock;
|
stmtblock_t singleblock;
|
int saved_ompws_flags;
|
int saved_ompws_flags;
|
bool singleblock_in_progress = false;
|
bool singleblock_in_progress = false;
|
/* True if previous gfc_code in workshare construct is not workshared. */
|
/* True if previous gfc_code in workshare construct is not workshared. */
|
bool prev_singleunit;
|
bool prev_singleunit;
|
|
|
code = code->block->next;
|
code = code->block->next;
|
|
|
pushlevel (0);
|
pushlevel (0);
|
|
|
if (!code)
|
if (!code)
|
return build_empty_stmt (input_location);
|
return build_empty_stmt (input_location);
|
|
|
gfc_start_block (&block);
|
gfc_start_block (&block);
|
pblock = █
|
pblock = █
|
|
|
ompws_flags = OMPWS_WORKSHARE_FLAG;
|
ompws_flags = OMPWS_WORKSHARE_FLAG;
|
prev_singleunit = false;
|
prev_singleunit = false;
|
|
|
/* Translate statements one by one to trees until we reach
|
/* Translate statements one by one to trees until we reach
|
the end of the workshare construct. Adjacent gfc_codes that
|
the end of the workshare construct. Adjacent gfc_codes that
|
are a single unit of work are clustered and encapsulated in a
|
are a single unit of work are clustered and encapsulated in a
|
single OMP_SINGLE construct. */
|
single OMP_SINGLE construct. */
|
for (; code; code = code->next)
|
for (; code; code = code->next)
|
{
|
{
|
if (code->here != 0)
|
if (code->here != 0)
|
{
|
{
|
res = gfc_trans_label_here (code);
|
res = gfc_trans_label_here (code);
|
gfc_add_expr_to_block (pblock, res);
|
gfc_add_expr_to_block (pblock, res);
|
}
|
}
|
|
|
/* No dependence analysis, use for clauses with wait.
|
/* No dependence analysis, use for clauses with wait.
|
If this is the last gfc_code, use default omp_clauses. */
|
If this is the last gfc_code, use default omp_clauses. */
|
if (code->next == NULL && clauses->nowait)
|
if (code->next == NULL && clauses->nowait)
|
ompws_flags |= OMPWS_NOWAIT;
|
ompws_flags |= OMPWS_NOWAIT;
|
|
|
/* By default, every gfc_code is a single unit of work. */
|
/* By default, every gfc_code is a single unit of work. */
|
ompws_flags |= OMPWS_CURR_SINGLEUNIT;
|
ompws_flags |= OMPWS_CURR_SINGLEUNIT;
|
ompws_flags &= ~OMPWS_SCALARIZER_WS;
|
ompws_flags &= ~OMPWS_SCALARIZER_WS;
|
|
|
switch (code->op)
|
switch (code->op)
|
{
|
{
|
case EXEC_NOP:
|
case EXEC_NOP:
|
res = NULL_TREE;
|
res = NULL_TREE;
|
break;
|
break;
|
|
|
case EXEC_ASSIGN:
|
case EXEC_ASSIGN:
|
res = gfc_trans_assign (code);
|
res = gfc_trans_assign (code);
|
break;
|
break;
|
|
|
case EXEC_POINTER_ASSIGN:
|
case EXEC_POINTER_ASSIGN:
|
res = gfc_trans_pointer_assign (code);
|
res = gfc_trans_pointer_assign (code);
|
break;
|
break;
|
|
|
case EXEC_INIT_ASSIGN:
|
case EXEC_INIT_ASSIGN:
|
res = gfc_trans_init_assign (code);
|
res = gfc_trans_init_assign (code);
|
break;
|
break;
|
|
|
case EXEC_FORALL:
|
case EXEC_FORALL:
|
res = gfc_trans_forall (code);
|
res = gfc_trans_forall (code);
|
break;
|
break;
|
|
|
case EXEC_WHERE:
|
case EXEC_WHERE:
|
res = gfc_trans_where (code);
|
res = gfc_trans_where (code);
|
break;
|
break;
|
|
|
case EXEC_OMP_ATOMIC:
|
case EXEC_OMP_ATOMIC:
|
res = gfc_trans_omp_directive (code);
|
res = gfc_trans_omp_directive (code);
|
break;
|
break;
|
|
|
case EXEC_OMP_PARALLEL:
|
case EXEC_OMP_PARALLEL:
|
case EXEC_OMP_PARALLEL_DO:
|
case EXEC_OMP_PARALLEL_DO:
|
case EXEC_OMP_PARALLEL_SECTIONS:
|
case EXEC_OMP_PARALLEL_SECTIONS:
|
case EXEC_OMP_PARALLEL_WORKSHARE:
|
case EXEC_OMP_PARALLEL_WORKSHARE:
|
case EXEC_OMP_CRITICAL:
|
case EXEC_OMP_CRITICAL:
|
saved_ompws_flags = ompws_flags;
|
saved_ompws_flags = ompws_flags;
|
ompws_flags = 0;
|
ompws_flags = 0;
|
res = gfc_trans_omp_directive (code);
|
res = gfc_trans_omp_directive (code);
|
ompws_flags = saved_ompws_flags;
|
ompws_flags = saved_ompws_flags;
|
break;
|
break;
|
|
|
default:
|
default:
|
internal_error ("gfc_trans_omp_workshare(): Bad statement code");
|
internal_error ("gfc_trans_omp_workshare(): Bad statement code");
|
}
|
}
|
|
|
gfc_set_backend_locus (&code->loc);
|
gfc_set_backend_locus (&code->loc);
|
|
|
if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
|
if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
|
{
|
{
|
if (prev_singleunit)
|
if (prev_singleunit)
|
{
|
{
|
if (ompws_flags & OMPWS_CURR_SINGLEUNIT)
|
if (ompws_flags & OMPWS_CURR_SINGLEUNIT)
|
/* Add current gfc_code to single block. */
|
/* Add current gfc_code to single block. */
|
gfc_add_expr_to_block (&singleblock, res);
|
gfc_add_expr_to_block (&singleblock, res);
|
else
|
else
|
{
|
{
|
/* Finish single block and add it to pblock. */
|
/* Finish single block and add it to pblock. */
|
tmp = gfc_finish_block (&singleblock);
|
tmp = gfc_finish_block (&singleblock);
|
tmp = build2 (OMP_SINGLE, void_type_node, tmp, NULL_TREE);
|
tmp = build2 (OMP_SINGLE, void_type_node, tmp, NULL_TREE);
|
gfc_add_expr_to_block (pblock, tmp);
|
gfc_add_expr_to_block (pblock, tmp);
|
/* Add current gfc_code to pblock. */
|
/* Add current gfc_code to pblock. */
|
gfc_add_expr_to_block (pblock, res);
|
gfc_add_expr_to_block (pblock, res);
|
singleblock_in_progress = false;
|
singleblock_in_progress = false;
|
}
|
}
|
}
|
}
|
else
|
else
|
{
|
{
|
if (ompws_flags & OMPWS_CURR_SINGLEUNIT)
|
if (ompws_flags & OMPWS_CURR_SINGLEUNIT)
|
{
|
{
|
/* Start single block. */
|
/* Start single block. */
|
gfc_init_block (&singleblock);
|
gfc_init_block (&singleblock);
|
gfc_add_expr_to_block (&singleblock, res);
|
gfc_add_expr_to_block (&singleblock, res);
|
singleblock_in_progress = true;
|
singleblock_in_progress = true;
|
}
|
}
|
else
|
else
|
/* Add the new statement to the block. */
|
/* Add the new statement to the block. */
|
gfc_add_expr_to_block (pblock, res);
|
gfc_add_expr_to_block (pblock, res);
|
}
|
}
|
prev_singleunit = (ompws_flags & OMPWS_CURR_SINGLEUNIT) != 0;
|
prev_singleunit = (ompws_flags & OMPWS_CURR_SINGLEUNIT) != 0;
|
}
|
}
|
}
|
}
|
|
|
/* Finish remaining SINGLE block, if we were in the middle of one. */
|
/* Finish remaining SINGLE block, if we were in the middle of one. */
|
if (singleblock_in_progress)
|
if (singleblock_in_progress)
|
{
|
{
|
/* Finish single block and add it to pblock. */
|
/* Finish single block and add it to pblock. */
|
tmp = gfc_finish_block (&singleblock);
|
tmp = gfc_finish_block (&singleblock);
|
tmp = build2 (OMP_SINGLE, void_type_node, tmp,
|
tmp = build2 (OMP_SINGLE, void_type_node, tmp,
|
clauses->nowait
|
clauses->nowait
|
? build_omp_clause (input_location, OMP_CLAUSE_NOWAIT)
|
? build_omp_clause (input_location, OMP_CLAUSE_NOWAIT)
|
: NULL_TREE);
|
: NULL_TREE);
|
gfc_add_expr_to_block (pblock, tmp);
|
gfc_add_expr_to_block (pblock, tmp);
|
}
|
}
|
|
|
stmt = gfc_finish_block (pblock);
|
stmt = gfc_finish_block (pblock);
|
if (TREE_CODE (stmt) != BIND_EXPR)
|
if (TREE_CODE (stmt) != BIND_EXPR)
|
{
|
{
|
if (!IS_EMPTY_STMT (stmt))
|
if (!IS_EMPTY_STMT (stmt))
|
{
|
{
|
tree bindblock = poplevel (1, 0, 0);
|
tree bindblock = poplevel (1, 0, 0);
|
stmt = build3_v (BIND_EXPR, NULL, stmt, bindblock);
|
stmt = build3_v (BIND_EXPR, NULL, stmt, bindblock);
|
}
|
}
|
else
|
else
|
poplevel (0, 0, 0);
|
poplevel (0, 0, 0);
|
}
|
}
|
else
|
else
|
poplevel (0, 0, 0);
|
poplevel (0, 0, 0);
|
|
|
ompws_flags = 0;
|
ompws_flags = 0;
|
return stmt;
|
return stmt;
|
}
|
}
|
|
|
tree
|
tree
|
gfc_trans_omp_directive (gfc_code *code)
|
gfc_trans_omp_directive (gfc_code *code)
|
{
|
{
|
switch (code->op)
|
switch (code->op)
|
{
|
{
|
case EXEC_OMP_ATOMIC:
|
case EXEC_OMP_ATOMIC:
|
return gfc_trans_omp_atomic (code);
|
return gfc_trans_omp_atomic (code);
|
case EXEC_OMP_BARRIER:
|
case EXEC_OMP_BARRIER:
|
return gfc_trans_omp_barrier ();
|
return gfc_trans_omp_barrier ();
|
case EXEC_OMP_CRITICAL:
|
case EXEC_OMP_CRITICAL:
|
return gfc_trans_omp_critical (code);
|
return gfc_trans_omp_critical (code);
|
case EXEC_OMP_DO:
|
case EXEC_OMP_DO:
|
return gfc_trans_omp_do (code, NULL, code->ext.omp_clauses, NULL);
|
return gfc_trans_omp_do (code, NULL, code->ext.omp_clauses, NULL);
|
case EXEC_OMP_FLUSH:
|
case EXEC_OMP_FLUSH:
|
return gfc_trans_omp_flush ();
|
return gfc_trans_omp_flush ();
|
case EXEC_OMP_MASTER:
|
case EXEC_OMP_MASTER:
|
return gfc_trans_omp_master (code);
|
return gfc_trans_omp_master (code);
|
case EXEC_OMP_ORDERED:
|
case EXEC_OMP_ORDERED:
|
return gfc_trans_omp_ordered (code);
|
return gfc_trans_omp_ordered (code);
|
case EXEC_OMP_PARALLEL:
|
case EXEC_OMP_PARALLEL:
|
return gfc_trans_omp_parallel (code);
|
return gfc_trans_omp_parallel (code);
|
case EXEC_OMP_PARALLEL_DO:
|
case EXEC_OMP_PARALLEL_DO:
|
return gfc_trans_omp_parallel_do (code);
|
return gfc_trans_omp_parallel_do (code);
|
case EXEC_OMP_PARALLEL_SECTIONS:
|
case EXEC_OMP_PARALLEL_SECTIONS:
|
return gfc_trans_omp_parallel_sections (code);
|
return gfc_trans_omp_parallel_sections (code);
|
case EXEC_OMP_PARALLEL_WORKSHARE:
|
case EXEC_OMP_PARALLEL_WORKSHARE:
|
return gfc_trans_omp_parallel_workshare (code);
|
return gfc_trans_omp_parallel_workshare (code);
|
case EXEC_OMP_SECTIONS:
|
case EXEC_OMP_SECTIONS:
|
return gfc_trans_omp_sections (code, code->ext.omp_clauses);
|
return gfc_trans_omp_sections (code, code->ext.omp_clauses);
|
case EXEC_OMP_SINGLE:
|
case EXEC_OMP_SINGLE:
|
return gfc_trans_omp_single (code, code->ext.omp_clauses);
|
return gfc_trans_omp_single (code, code->ext.omp_clauses);
|
case EXEC_OMP_TASK:
|
case EXEC_OMP_TASK:
|
return gfc_trans_omp_task (code);
|
return gfc_trans_omp_task (code);
|
case EXEC_OMP_TASKWAIT:
|
case EXEC_OMP_TASKWAIT:
|
return gfc_trans_omp_taskwait ();
|
return gfc_trans_omp_taskwait ();
|
case EXEC_OMP_WORKSHARE:
|
case EXEC_OMP_WORKSHARE:
|
return gfc_trans_omp_workshare (code, code->ext.omp_clauses);
|
return gfc_trans_omp_workshare (code, code->ext.omp_clauses);
|
default:
|
default:
|
gcc_unreachable ();
|
gcc_unreachable ();
|
}
|
}
|
}
|
}
|
|
|
