bool
gfc_omp_disregard_value_expr (tree decl, bool shared)
{
if (GFC_DECL_COMMON_OR_EQUIV (decl)
&& DECL_HAS_VALUE_EXPR_P (decl))
{
tree value = DECL_VALUE_EXPR (decl);
if (TREE_CODE (value) == COMPONENT_REF
&& TREE_CODE (TREE_OPERAND (value, 0)) == VAR_DECL
&& GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value, 0)))
{
/* If variable in COMMON or EQUIVALENCE is privatized, return
true, as just that variable is supposed to be privatized,
not the whole COMMON or whole EQUIVALENCE.
For shared variables in COMMON or EQUIVALENCE, let them be
gimplified to DECL_VALUE_EXPR, so that for multiple shared vars
from the same COMMON or EQUIVALENCE just one sharing of the
whole COMMON or EQUIVALENCE is enough. */
return ! shared;
}
}
if (GFC_DECL_RESULT (decl) && DECL_HAS_VALUE_EXPR_P (decl))
return ! shared;
return false;
}
enum omp_clause_default_kind
gfc_omp_predetermined_sharing (tree decl)
{
if (DECL_ARTIFICIAL (decl) && ! GFC_DECL_RESULT (decl))
return OMP_CLAUSE_DEFAULT_SHARED;
/* Cray pointees shouldn't be listed in any clauses and should be
gimplified to dereference of the corresponding Cray pointer.
Make them all private, so that they are emitted in the debug
information. */
if (GFC_DECL_CRAY_POINTEE (decl))
return OMP_CLAUSE_DEFAULT_PRIVATE;
/* COMMON and EQUIVALENCE decls are shared. They
are only referenced through DECL_VALUE_EXPR of the variables
contained in them. If those are privatized, they will not be
gimplified to the COMMON or EQUIVALENCE decls. */
if (GFC_DECL_COMMON_OR_EQUIV (decl) && ! DECL_HAS_VALUE_EXPR_P (decl))
return OMP_CLAUSE_DEFAULT_SHARED;
if (GFC_DECL_RESULT (decl) && ! DECL_HAS_VALUE_EXPR_P (decl))
return OMP_CLAUSE_DEFAULT_SHARED;
return OMP_CLAUSE_DEFAULT_UNSPECIFIED;
}
bool
gfc_omp_private_debug_clause (tree decl, bool shared)
{
if (GFC_DECL_CRAY_POINTEE (decl))
return true;
if (GFC_DECL_COMMON_OR_EQUIV (decl)
&& DECL_HAS_VALUE_EXPR_P (decl))
{
tree value = DECL_VALUE_EXPR (decl);
if (TREE_CODE (value) == COMPONENT_REF
&& TREE_CODE (TREE_OPERAND (value, 0)) == VAR_DECL
&& GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value, 0)))
return shared;
}
return false;
}
static tree
build_equiv_decl (tree union_type, bool is_init, bool is_saved)
{
tree decl;
char name[15];
static int serial = 0;
if (is_init)
{
decl = gfc_create_var (union_type, "equiv");
TREE_STATIC (decl) = 1;
GFC_DECL_COMMON_OR_EQUIV (decl) = 1;
return decl;
}
snprintf (name, sizeof (name), "equiv.%d", serial++);
decl = build_decl (input_location,
VAR_DECL, get_identifier (name), union_type);
DECL_ARTIFICIAL (decl) = 1;
DECL_IGNORED_P (decl) = 1;
if (!gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
|| is_saved)
TREE_STATIC (decl) = 1;
TREE_ADDRESSABLE (decl) = 1;
TREE_USED (decl) = 1;
GFC_DECL_COMMON_OR_EQUIV (decl) = 1;
/* The source location has been lost, and doesn't really matter.
We need to set it to something though. */
gfc_set_decl_location (decl, &gfc_current_locus);
gfc_add_decl_to_function (decl);
return decl;
}
enum omp_clause_default_kind
gfc_omp_predetermined_sharing (tree decl)
{
if (DECL_ARTIFICIAL (decl) && ! GFC_DECL_RESULT (decl))
return OMP_CLAUSE_DEFAULT_SHARED;
/* Cray pointees shouldn't be listed in any clauses and should be
gimplified to dereference of the corresponding Cray pointer.
Make them all private, so that they are emitted in the debug
information. */
if (GFC_DECL_CRAY_POINTEE (decl))
return OMP_CLAUSE_DEFAULT_PRIVATE;
/* Assumed-size arrays are predetermined to inherit sharing
attributes of the associated actual argument, which is shared
for all we care. */
if (TREE_CODE (decl) == PARM_DECL
&& GFC_ARRAY_TYPE_P (TREE_TYPE (decl))
&& GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl)) == GFC_ARRAY_UNKNOWN
&& GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (decl),
GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl)) - 1)
== NULL)
return OMP_CLAUSE_DEFAULT_SHARED;
/* COMMON and EQUIVALENCE decls are shared. They
are only referenced through DECL_VALUE_EXPR of the variables
contained in them. If those are privatized, they will not be
gimplified to the COMMON or EQUIVALENCE decls. */
if (GFC_DECL_COMMON_OR_EQUIV (decl) && ! DECL_HAS_VALUE_EXPR_P (decl))
return OMP_CLAUSE_DEFAULT_SHARED;
if (GFC_DECL_RESULT (decl) && ! DECL_HAS_VALUE_EXPR_P (decl))
return OMP_CLAUSE_DEFAULT_SHARED;
return OMP_CLAUSE_DEFAULT_UNSPECIFIED;
}
static void
create_common (gfc_common_head *com, segment_info *head, bool saw_equiv)
{
segment_info *s, *next_s;
tree union_type;
tree *field_link;
tree field;
tree field_init = NULL_TREE;
record_layout_info rli;
tree decl;
bool is_init = false;
bool is_saved = false;
/* Declare the variables inside the common block.
If the current common block contains any equivalence object, then
make a UNION_TYPE node, otherwise RECORD_TYPE. This will let the
alias analyzer work well when there is no address overlapping for
common variables in the current common block. */
if (saw_equiv)
union_type = make_node (UNION_TYPE);
else
union_type = make_node (RECORD_TYPE);
rli = start_record_layout (union_type);
field_link = &TYPE_FIELDS (union_type);
/* Check for overlapping initializers and replace them with a single,
artificial field that contains all the data. */
if (saw_equiv)
field = get_init_field (head, union_type, &field_init, rli);
else
field = NULL_TREE;
if (field != NULL_TREE)
{
is_init = true;
*field_link = field;
field_link = &DECL_CHAIN (field);
}
for (s = head; s; s = s->next)
{
build_field (s, union_type, rli);
/* Link the field into the type. */
*field_link = s->field;
field_link = &DECL_CHAIN (s->field);
/* Has initial value. */
if (s->sym->value)
is_init = true;
/* Has SAVE attribute. */
if (s->sym->attr.save)
is_saved = true;
}
finish_record_layout (rli, true);
if (com)
decl = build_common_decl (com, union_type, is_init);
else
decl = build_equiv_decl (union_type, is_init, is_saved);
if (is_init)
{
tree ctor, tmp;
VEC(constructor_elt,gc) *v = NULL;
if (field != NULL_TREE && field_init != NULL_TREE)
CONSTRUCTOR_APPEND_ELT (v, field, field_init);
else
for (s = head; s; s = s->next)
{
if (s->sym->value)
{
/* Add the initializer for this field. */
tmp = gfc_conv_initializer (s->sym->value, &s->sym->ts,
TREE_TYPE (s->field),
s->sym->attr.dimension,
s->sym->attr.pointer
|| s->sym->attr.allocatable, false);
CONSTRUCTOR_APPEND_ELT (v, s->field, tmp);
}
}
gcc_assert (!VEC_empty (constructor_elt, v));
ctor = build_constructor (union_type, v);
TREE_CONSTANT (ctor) = 1;
TREE_STATIC (ctor) = 1;
DECL_INITIAL (decl) = ctor;
#ifdef ENABLE_CHECKING
{
tree field, value;
unsigned HOST_WIDE_INT idx;
FOR_EACH_CONSTRUCTOR_ELT (CONSTRUCTOR_ELTS (ctor), idx, field, value)
gcc_assert (TREE_CODE (field) == FIELD_DECL);
}
#endif
}
/* Build component reference for each variable. */
for (s = head; s; s = next_s)
{
tree var_decl;
var_decl = build_decl (s->sym->declared_at.lb->location,
VAR_DECL, DECL_NAME (s->field),
TREE_TYPE (s->field));
TREE_STATIC (var_decl) = TREE_STATIC (decl);
/* Mark the variable as used in order to avoid warnings about
unused variables. */
TREE_USED (var_decl) = 1;
if (s->sym->attr.use_assoc)
DECL_IGNORED_P (var_decl) = 1;
if (s->sym->attr.target)
TREE_ADDRESSABLE (var_decl) = 1;
/* Fake variables are not visible from other translation units. */
TREE_PUBLIC (var_decl) = 0;
/* To preserve identifier names in COMMON, chain to procedure
scope unless at top level in a module definition. */
if (com
&& s->sym->ns->proc_name
&& s->sym->ns->proc_name->attr.flavor == FL_MODULE)
var_decl = pushdecl_top_level (var_decl);
else
gfc_add_decl_to_function (var_decl);
SET_DECL_VALUE_EXPR (var_decl,
fold_build3_loc (input_location, COMPONENT_REF,
TREE_TYPE (s->field),
decl, s->field, NULL_TREE));
DECL_HAS_VALUE_EXPR_P (var_decl) = 1;
GFC_DECL_COMMON_OR_EQUIV (var_decl) = 1;
if (s->sym->attr.assign)
{
gfc_allocate_lang_decl (var_decl);
GFC_DECL_ASSIGN (var_decl) = 1;
GFC_DECL_STRING_LEN (var_decl) = GFC_DECL_STRING_LEN (s->field);
GFC_DECL_ASSIGN_ADDR (var_decl) = GFC_DECL_ASSIGN_ADDR (s->field);
}
s->sym->backend_decl = var_decl;
next_s = s->next;
free (s);
}
}
static tree
build_common_decl (gfc_common_head *com, tree union_type, bool is_init)
{
gfc_symbol *common_sym;
tree decl;
/* Create a namespace to store symbols for common blocks. */
if (gfc_common_ns == NULL)
gfc_common_ns = gfc_get_namespace (NULL, 0);
gfc_get_symbol (com->name, gfc_common_ns, &common_sym);
decl = common_sym->backend_decl;
/* Update the size of this common block as needed. */
if (decl != NULL_TREE)
{
tree size = TYPE_SIZE_UNIT (union_type);
/* Named common blocks of the same name shall be of the same size
in all scoping units of a program in which they appear, but
blank common blocks may be of different sizes. */
if (!tree_int_cst_equal (DECL_SIZE_UNIT (decl), size)
&& strcmp (com->name, BLANK_COMMON_NAME))
gfc_warning ("Named COMMON block '%s' at %L shall be of the "
"same size as elsewhere (%lu vs %lu bytes)", com->name,
&com->where,
(unsigned long) TREE_INT_CST_LOW (size),
(unsigned long) TREE_INT_CST_LOW (DECL_SIZE_UNIT (decl)));
if (tree_int_cst_lt (DECL_SIZE_UNIT (decl), size))
{
DECL_SIZE (decl) = TYPE_SIZE (union_type);
DECL_SIZE_UNIT (decl) = size;
DECL_MODE (decl) = TYPE_MODE (union_type);
TREE_TYPE (decl) = union_type;
layout_decl (decl, 0);
}
}
/* If this common block has been declared in a previous program unit,
and either it is already initialized or there is no new initialization
for it, just return. */
if ((decl != NULL_TREE) && (!is_init || DECL_INITIAL (decl)))
return decl;
/* If there is no backend_decl for the common block, build it. */
if (decl == NULL_TREE)
{
decl = build_decl (input_location,
VAR_DECL, get_identifier (com->name), union_type);
gfc_set_decl_assembler_name (decl, gfc_sym_mangled_common_id (com));
TREE_PUBLIC (decl) = 1;
TREE_STATIC (decl) = 1;
DECL_IGNORED_P (decl) = 1;
if (!com->is_bind_c)
DECL_ALIGN (decl) = BIGGEST_ALIGNMENT;
else
{
/* Do not set the alignment for bind(c) common blocks to
BIGGEST_ALIGNMENT because that won't match what C does. Also,
for common blocks with one element, the alignment must be
that of the field within the common block in order to match
what C will do. */
tree field = NULL_TREE;
field = TYPE_FIELDS (TREE_TYPE (decl));
if (DECL_CHAIN (field) == NULL_TREE)
DECL_ALIGN (decl) = TYPE_ALIGN (TREE_TYPE (field));
}
DECL_USER_ALIGN (decl) = 0;
GFC_DECL_COMMON_OR_EQUIV (decl) = 1;
gfc_set_decl_location (decl, &com->where);
if (com->threadprivate)
DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
/* Place the back end declaration for this common block in
GLOBAL_BINDING_LEVEL. */
common_sym->backend_decl = pushdecl_top_level (decl);
}
/* Has no initial values. */
if (!is_init)
{
DECL_INITIAL (decl) = NULL_TREE;
DECL_COMMON (decl) = 1;
DECL_DEFER_OUTPUT (decl) = 1;
}
else
{
DECL_INITIAL (decl) = error_mark_node;
DECL_COMMON (decl) = 0;
DECL_DEFER_OUTPUT (decl) = 0;
}
return decl;
}
