aboutsummaryrefslogtreecommitdiff
path: root/gcc/ada/gcc-interface
diff options
context:
space:
mode:
authorAldy Hernandez <aldyh@redhat.com>2020-06-17 07:50:57 -0400
committerAldy Hernandez <aldyh@redhat.com>2020-06-17 07:50:57 -0400
commitb9e67f2840ce0d8859d96e7f8df8fe9584af5eba (patch)
treeed3b7284ff15c802583f6409b9c71b3739642d15 /gcc/ada/gcc-interface
parent1957047ed1c94bf17cf993a2b1866965f493ba87 (diff)
parent56638b9b1853666f575928f8baf17f70e4ed3517 (diff)
downloadgcc-b9e67f2840ce0d8859d96e7f8df8fe9584af5eba.zip
gcc-b9e67f2840ce0d8859d96e7f8df8fe9584af5eba.tar.gz
gcc-b9e67f2840ce0d8859d96e7f8df8fe9584af5eba.tar.bz2
Merge from trunk at:
commit 56638b9b1853666f575928f8baf17f70e4ed3517 Author: GCC Administrator <gccadmin@gcc.gnu.org> Date: Wed Jun 17 00:16:36 2020 +0000 Daily bump.
Diffstat (limited to 'gcc/ada/gcc-interface')
-rw-r--r--gcc/ada/gcc-interface/Make-lang.in8
-rw-r--r--gcc/ada/gcc-interface/Makefile.in6
-rw-r--r--gcc/ada/gcc-interface/ada-tree.h16
-rw-r--r--gcc/ada/gcc-interface/ada.h2
-rw-r--r--gcc/ada/gcc-interface/cuintp.c2
-rw-r--r--gcc/ada/gcc-interface/decl.c554
-rw-r--r--gcc/ada/gcc-interface/gadaint.h2
-rw-r--r--gcc/ada/gcc-interface/gigi.h75
-rw-r--r--gcc/ada/gcc-interface/lang-specs.h22
-rw-r--r--gcc/ada/gcc-interface/lang.opt4
-rw-r--r--gcc/ada/gcc-interface/misc.c149
-rw-r--r--gcc/ada/gcc-interface/targtyps.c2
-rw-r--r--gcc/ada/gcc-interface/trans.c925
-rw-r--r--gcc/ada/gcc-interface/utils.c196
-rw-r--r--gcc/ada/gcc-interface/utils2.c68
15 files changed, 778 insertions, 1253 deletions
diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in
index acbe2b87..7d2ea52 100644
--- a/gcc/ada/gcc-interface/Make-lang.in
+++ b/gcc/ada/gcc-interface/Make-lang.in
@@ -302,6 +302,7 @@ GNAT_ADA_OBJS = \
ada/exp_intr.o \
ada/exp_pakd.o \
ada/exp_prag.o \
+ ada/exp_put_image.o \
ada/exp_sel.o \
ada/exp_smem.o \
ada/exp_strm.o \
@@ -472,9 +473,6 @@ GNAT_ADA_OBJS = \
ada/table.o \
ada/targparm.o \
ada/tbuild.o \
- ada/tree_gen.o \
- ada/tree_in.o \
- ada/tree_io.o \
ada/treepr.o \
ada/treeprs.o \
ada/ttypes.o \
@@ -484,6 +482,7 @@ GNAT_ADA_OBJS = \
ada/urealp.o \
ada/usage.o \
ada/validsw.o \
+ ada/vast.o \
ada/warnsw.o \
ada/widechar.o
@@ -632,7 +631,6 @@ GNATBIND_OBJS = \
ada/table.o \
ada/targext.o \
ada/targparm.o \
- ada/tree_io.o \
ada/types.o \
ada/uintp.o \
ada/uname.o \
@@ -1040,7 +1038,7 @@ ada/sdefault.o : ada/libgnat/ada.ads ada/libgnat/a-except.ads ada/libgnat/a-uncc
ada/libgnat/s-exctab.ads ada/libgnat/s-memory.ads ada/libgnat/s-os_lib.ads ada/libgnat/s-parame.ads \
ada/libgnat/s-stalib.ads ada/libgnat/s-strops.ads ada/libgnat/s-sopco3.ads ada/libgnat/s-sopco4.ads \
ada/libgnat/s-sopco5.ads ada/libgnat/s-string.ads ada/libgnat/s-traent.ads ada/libgnat/s-unstyp.ads \
- ada/libgnat/s-wchcon.ads ada/libgnat/system.ads ada/table.adb ada/table.ads ada/tree_io.ads \
+ ada/libgnat/s-wchcon.ads ada/libgnat/system.ads ada/table.adb ada/table.ads \
ada/types.ads ada/libgnat/unchdeal.ads ada/libgnat/unchconv.ads
# Special flags - see gcc-interface/Makefile.in for the template.
diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in
index 3342e33..6177d75 100644
--- a/gcc/ada/gcc-interface/Makefile.in
+++ b/gcc/ada/gcc-interface/Makefile.in
@@ -318,7 +318,7 @@ GNATLINK_OBJS = gnatlink.o \
a-except.o ali.o alloc.o butil.o casing.o csets.o debug.o fmap.o fname.o \
gnatvsn.o hostparm.o indepsw.o interfac.o i-c.o i-cstrin.o namet.o opt.o \
osint.o output.o rident.o s-exctab.o s-secsta.o s-stalib.o s-stoele.o \
- sdefault.o snames.o stylesw.o switch.o system.o table.o targparm.o tree_io.o \
+ sdefault.o snames.o stylesw.o switch.o system.o table.o targparm.o \
types.o validsw.o widechar.o
GNATMAKE_OBJS = a-except.o ali.o ali-util.o aspects.o s-casuti.o alloc.o \
@@ -330,7 +330,7 @@ GNATMAKE_OBJS = a-except.o ali.o ali-util.o aspects.o s-casuti.o alloc.o \
s-secsta.o s-stalib.o s-stoele.o scans.o scng.o sdefault.o sfn_scan.o \
s-purexc.o s-htable.o scil_ll.o sem_aux.o sinfo.o sinput.o sinput-c.o \
snames.o stand.o stringt.o styleg.o stylesw.o system.o validsw.o \
- switch.o switch-m.o table.o targparm.o tempdir.o tree_io.o types.o uintp.o \
+ switch.o switch-m.o table.o targparm.o tempdir.o types.o uintp.o \
uname.o urealp.o usage.o widechar.o \
$(EXTRA_GNATMAKE_OBJS)
@@ -895,7 +895,7 @@ ADA_RTL_DSO_DIR = $(toolexeclibdir)
# need to keep the frame pointer in tracebak.o to pop the stack properly on
# some targets.
-tracebak.o : tracebak.c tb-gcc.c
+tracebak.o : tracebak.c
$(COMPILER) -c $(ALL_COMPILERFLAGS) $(ADA_CFLAGS) $(ALL_CPPFLAGS) \
$(INCLUDES) $(NO_OMIT_ADAFLAGS) $< $(OUTPUT_OPTION)
diff --git a/gcc/ada/gcc-interface/ada-tree.h b/gcc/ada/gcc-interface/ada-tree.h
index acea5d1..11bfc37 100644
--- a/gcc/ada/gcc-interface/ada-tree.h
+++ b/gcc/ada/gcc-interface/ada-tree.h
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 1992-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -73,15 +73,15 @@ do { \
#define TYPE_IS_FAT_POINTER_P(NODE) \
(TREE_CODE (NODE) == RECORD_TYPE && TYPE_FAT_POINTER_P (NODE))
-/* For integral types and array types, nonzero if this is a packed array type
- used for bit-packed types. Such types should not be extended to a larger
- size or validated against a specified size. */
-#define TYPE_PACKED_ARRAY_TYPE_P(NODE) \
+/* For integral types and array types, nonzero if this is an implementation
+ type for a bit-packed array type. Such types should not be extended to a
+ larger size or validated against a specified size. */
+#define TYPE_BIT_PACKED_ARRAY_TYPE_P(NODE) \
TYPE_LANG_FLAG_0 (TREE_CHECK2 (NODE, INTEGER_TYPE, ARRAY_TYPE))
-#define TYPE_IS_PACKED_ARRAY_TYPE_P(NODE) \
+#define BIT_PACKED_ARRAY_TYPE_P(NODE) \
((TREE_CODE (NODE) == INTEGER_TYPE || TREE_CODE (NODE) == ARRAY_TYPE) \
- && TYPE_PACKED_ARRAY_TYPE_P (NODE))
+ && TYPE_BIT_PACKED_ARRAY_TYPE_P (NODE))
/* For FUNCTION_TYPE and METHOD_TYPE, nonzero if the function returns by
direct reference, i.e. the callee returns a pointer to a memory location
@@ -196,7 +196,7 @@ do { \
types. */
#define TYPE_IMPL_PACKED_ARRAY_P(NODE) \
((TREE_CODE (NODE) == ARRAY_TYPE && TYPE_PACKED (NODE)) \
- || (TREE_CODE (NODE) == INTEGER_TYPE && TYPE_PACKED_ARRAY_TYPE_P (NODE)))
+ || (TREE_CODE (NODE) == INTEGER_TYPE && TYPE_BIT_PACKED_ARRAY_TYPE_P (NODE)))
/* True for types that can hold a debug type. */
#define TYPE_CAN_HAVE_DEBUG_TYPE_P(NODE) (!TYPE_IMPL_PACKED_ARRAY_P (NODE))
diff --git a/gcc/ada/gcc-interface/ada.h b/gcc/ada/gcc-interface/ada.h
index 197ab95..c5a1916 100644
--- a/gcc/ada/gcc-interface/ada.h
+++ b/gcc/ada/gcc-interface/ada.h
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 1992-2013, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
diff --git a/gcc/ada/gcc-interface/cuintp.c b/gcc/ada/gcc-interface/cuintp.c
index 8233f68..dada72a 100644
--- a/gcc/ada/gcc-interface/cuintp.c
+++ b/gcc/ada/gcc-interface/cuintp.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c
index 871a309..38c73cb 100644
--- a/gcc/ada/gcc-interface/decl.c
+++ b/gcc/ada/gcc-interface/decl.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -230,7 +230,7 @@ static Uint annotate_value (tree);
static void annotate_rep (Entity_Id, tree);
static tree build_position_list (tree, bool, tree, tree, unsigned int, tree);
static vec<subst_pair> build_subst_list (Entity_Id, Entity_Id, bool);
-static vec<variant_desc> build_variant_list (tree, vec<subst_pair>,
+static vec<variant_desc> build_variant_list (tree, Node_Id, vec<subst_pair>,
vec<variant_desc>);
static tree maybe_saturate_size (tree);
static tree validate_size (Uint, tree, Entity_Id, enum tree_code, bool, bool,
@@ -248,7 +248,7 @@ static tree create_variant_part_from (tree, vec<variant_desc>, tree,
static void copy_and_substitute_in_size (tree, tree, vec<subst_pair>);
static void copy_and_substitute_in_layout (Entity_Id, Entity_Id, tree, tree,
vec<subst_pair>, bool);
-static void associate_original_type_to_packed_array (tree, Entity_Id);
+static tree associate_original_type_to_packed_array (tree, Entity_Id);
static const char *get_entity_char (Entity_Id);
/* The relevant constituents of a subprogram binding to a GCC builtin. Used
@@ -280,6 +280,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
{
/* The construct that declared the entity. */
const Node_Id gnat_decl = Declaration_Node (gnat_entity);
+ /* The object that the entity renames, if any. */
+ const Entity_Id gnat_renamed_obj = Renamed_Object (gnat_entity);
/* The kind of the entity. */
const Entity_Kind kind = Ekind (gnat_entity);
/* True if this is a type. */
@@ -327,7 +329,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
/* Contains the list of attributes directly attached to the entity. */
struct attrib *attr_list = NULL;
- /* Since a use of an Itype is a definition, process it as such if it is in
+ /* Since a use of an itype is a definition, process it as such if it is in
the main unit, except for E_Access_Subtype because it's actually a use
of its base type, see below. */
if (!definition
@@ -375,7 +377,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
}
}
- /* This abort means the Itype has an incorrect scope, i.e. that its
+ /* This abort means the itype has an incorrect scope, i.e. that its
scope does not correspond to the subprogram it is first used in. */
gcc_unreachable ();
}
@@ -446,7 +448,20 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
/* If we get here, it means we have not yet done anything with this entity.
If we are not defining it, it must be a type or an entity that is defined
- elsewhere or externally, otherwise we should have defined it already. */
+ elsewhere or externally, otherwise we should have defined it already.
+
+ In other words, the failure of this assertion typically arises when a
+ reference to an entity (type or object) is made before its declaration,
+ either directly or by means of a freeze node which is incorrectly placed.
+ This can also happen for an entity referenced out of context, for example
+ a parameter outside of the subprogram where it is declared. GNAT_ENTITY
+ is the N_Defining_Identifier of the entity, the problematic N_Identifier
+ being the argument passed to Identifier_to_gnu in the parent frame.
+
+ One exception is for an entity, typically an inherited operation, which is
+ a local alias for the parent's operation. It is neither defined, since it
+ is an inherited operation, nor public, since it is declared in the current
+ compilation unit, so we test Is_Public on the Alias entity instead. */
gcc_assert (definition
|| is_type
|| kind == E_Discriminant
@@ -454,6 +469,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
|| kind == E_Label
|| (kind == E_Constant && Present (Full_View (gnat_entity)))
|| Is_Public (gnat_entity)
+ || (Present (Alias (gnat_entity))
+ && Is_Public (Alias (gnat_entity)))
|| type_annotate_only);
/* Get the name of the entity and set up the line number and filename of
@@ -629,7 +646,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
&& !gnu_expr
&& No (Address_Clause (gnat_entity))
&& !No_Initialization (gnat_decl)
- && No (Renamed_Object (gnat_entity)))
+ && No (gnat_renamed_obj))
{
gnu_decl = error_mark_node;
saved = true;
@@ -685,7 +702,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
&& !Treat_As_Volatile (gnat_entity)
&& (((Nkind (gnat_decl) == N_Object_Declaration)
&& Present (Expression (gnat_decl)))
- || Present (Renamed_Object (gnat_entity))
+ || Present (gnat_renamed_obj)
|| imported_p));
bool inner_const_flag = const_flag;
bool static_flag = Is_Statically_Allocated (gnat_entity);
@@ -697,20 +714,20 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
bool mutable_p = false;
bool used_by_ref = false;
tree gnu_ext_name = NULL_TREE;
- tree renamed_obj = NULL_TREE;
+ tree gnu_renamed_obj = NULL_TREE;
tree gnu_ada_size = NULL_TREE;
/* We need to translate the renamed object even though we are only
referencing the renaming. But it may contain a call for which
we'll generate a temporary to hold the return value and which
is part of the definition of the renaming, so discard it. */
- if (Present (Renamed_Object (gnat_entity)) && !definition)
+ if (Present (gnat_renamed_obj) && !definition)
{
if (kind == E_Exception)
gnu_expr = gnat_to_gnu_entity (Renamed_Entity (gnat_entity),
NULL_TREE, false);
else
- gnu_expr = gnat_to_gnu_external (Renamed_Object (gnat_entity));
+ gnu_expr = gnat_to_gnu_external (gnat_renamed_obj);
}
/* Get the type after elaborating the renamed object. */
@@ -757,7 +774,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
/* Reject non-renamed objects whose type is an unconstrained array or
any object whose type is a dummy type or void. */
if ((TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE
- && No (Renamed_Object (gnat_entity)))
+ && No (gnat_renamed_obj))
|| TYPE_IS_DUMMY_P (gnu_type)
|| TREE_CODE (gnu_type) == VOID_TYPE)
{
@@ -799,7 +816,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
initializing expression, in which case we can get the size from
that. Note that the resulting size may still be a variable, so
this may end up with an indirect allocation. */
- if (No (Renamed_Object (gnat_entity))
+ if (No (gnat_renamed_obj)
&& CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
{
if (gnu_expr && kind == E_Constant)
@@ -875,7 +892,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
&& integer_zerop (TYPE_SIZE (gnu_type))
&& !TREE_OVERFLOW (TYPE_SIZE (gnu_type))))
&& !Is_Constr_Subt_For_UN_Aliased (gnat_type)
- && No (Renamed_Object (gnat_entity))
+ && No (gnat_renamed_obj)
&& No (Address_Clause (gnat_entity)))
gnu_size = bitsize_unit_node;
@@ -894,7 +911,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
&& !Is_Constr_Subt_For_UN_Aliased (gnat_type)
&& !Is_Exported (gnat_entity)
&& !imported_p
- && No (Renamed_Object (gnat_entity))
+ && No (gnat_renamed_obj)
&& No (Address_Clause (gnat_entity))))
&& TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST)
align = promote_object_alignment (gnu_type, gnat_entity);
@@ -938,7 +955,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
because we don't support dynamic alignment. */
if (align == 0
&& Ekind (gnat_type) == E_Class_Wide_Subtype
- && No (Renamed_Object (gnat_entity))
+ && No (gnat_renamed_obj)
&& No (Address_Clause (gnat_entity)))
align = get_target_system_allocator_alignment () * BITS_PER_UNIT;
@@ -954,7 +971,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
if (align == 0
&& MINIMUM_ATOMIC_ALIGNMENT > TYPE_ALIGN (gnu_type)
&& !FLOAT_TYPE_P (gnu_type)
- && !const_flag && No (Renamed_Object (gnat_entity))
+ && !const_flag && No (gnat_renamed_obj)
&& !imported_p && No (Address_Clause (gnat_entity))
&& kind != E_Out_Parameter
&& (gnu_size ? TREE_CODE (gnu_size) == INTEGER_CST
@@ -962,16 +979,25 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
align = MINIMUM_ATOMIC_ALIGNMENT;
#endif
- /* Make a new type with the desired size and alignment, if needed.
- But do not take into account alignment promotions to compute the
- size of the object. */
+ /* Do not take into account aliased adjustments or alignment promotions
+ to compute the size of the object. */
tree gnu_object_size = gnu_size ? gnu_size : TYPE_SIZE (gnu_type);
+
+ /* If the object is aliased, of a constrained nominal subtype and its
+ size might be zero at run time, we force at least the unit size. */
+ if (Is_Aliased (gnat_entity)
+ && !Is_Constr_Subt_For_UN_Aliased (gnat_type)
+ && Is_Array_Type (Underlying_Type (gnat_type))
+ && !TREE_CONSTANT (gnu_object_size))
+ gnu_size = size_binop (MAX_EXPR, gnu_object_size, bitsize_unit_node);
+
+ /* Make a new type with the desired size and alignment, if needed. */
if (gnu_size || align > 0)
{
tree orig_type = gnu_type;
gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity,
- false, false, definition, true);
+ false, definition, true);
/* If the nominal subtype of the object is unconstrained and its
size is not fixed, compute the Ada size from the Ada size of
@@ -997,7 +1023,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
renaming can be applied to objects that are not names in Ada.
This processing needs to be applied to the raw expression so as
to make it more likely to rename the underlying object. */
- if (Present (Renamed_Object (gnat_entity)))
+ if (Present (gnat_renamed_obj))
{
/* If the renamed object had padding, strip off the reference to
the inner object and reset our type. */
@@ -1067,8 +1093,11 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
the elaborated renamed expression for the renaming. But this
means that the caller is responsible for evaluating the address
of the renaming in the correct place for the definition case to
- instantiate the SAVE_EXPRs. */
- else if (!Materialize_Entity (gnat_entity))
+ instantiate the SAVE_EXPRs. But we cannot use this mechanism if
+ the renamed object is an N_Expression_With_Actions because this
+ would fail the assertion below. */
+ else if (!Materialize_Entity (gnat_entity)
+ && Nkind (gnat_renamed_obj) != N_Expression_With_Actions)
{
tree init = NULL_TREE;
@@ -1124,7 +1153,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
inner_const_flag = TREE_READONLY (gnu_expr);
gnu_size = NULL_TREE;
- renamed_obj
+ gnu_renamed_obj
= elaborate_reference (gnu_expr, gnat_entity, definition,
&init);
@@ -1132,15 +1161,15 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
likely be shared, even for a definition since the ADDR_EXPR
built below can cause the first few nodes to be folded. */
if (global_bindings_p ())
- MARK_VISITED (renamed_obj);
+ MARK_VISITED (gnu_renamed_obj);
if (type_annotate_only
- && TREE_CODE (renamed_obj) == ERROR_MARK)
+ && TREE_CODE (gnu_renamed_obj) == ERROR_MARK)
gnu_expr = NULL_TREE;
else
{
gnu_expr
- = build_unary_op (ADDR_EXPR, gnu_type, renamed_obj);
+ = build_unary_op (ADDR_EXPR, gnu_type, gnu_renamed_obj);
if (init)
gnu_expr
= build_compound_expr (TREE_TYPE (gnu_expr), init,
@@ -1509,7 +1538,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
imported_p || !definition, static_flag,
volatile_flag, artificial_p,
debug_info_p && definition, attr_list,
- gnat_entity, !renamed_obj);
+ gnat_entity, !gnu_renamed_obj);
DECL_BY_REF_P (gnu_decl) = used_by_ref;
DECL_POINTS_TO_READONLY_P (gnu_decl) = used_by_ref && inner_const_flag;
DECL_CAN_NEVER_BE_NULL_P (gnu_decl) = Can_Never_Be_Null (gnat_entity);
@@ -1538,8 +1567,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
DECL_LOOP_PARM_P (gnu_decl) = 1;
/* If this is a renaming pointer, attach the renamed object to it. */
- if (renamed_obj)
- SET_DECL_RENAMED_OBJECT (gnu_decl, renamed_obj);
+ if (gnu_renamed_obj)
+ SET_DECL_RENAMED_OBJECT (gnu_decl, gnu_renamed_obj);
/* If this is a constant and we are defining it or it generates a real
symbol at the object level and we are referencing it, we may want
@@ -1738,9 +1767,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
{
/* Given RM restrictions on 'Small values, we assume here that
the denominator fits in an int. */
- const tree base = build_int_cst (integer_type_node,
- Rbase (gnat_small_value));
- const tree exponent
+ tree base
+ = build_int_cst (integer_type_node, Rbase (gnat_small_value));
+ tree exponent
= build_int_cst (integer_type_node,
UI_To_Int (Denominator (gnat_small_value)));
scale_factor
@@ -1758,10 +1787,10 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
if (UI_Is_In_Int_Range (num) && UI_Is_In_Int_Range (den))
{
- const tree gnu_num
+ tree gnu_num
= build_int_cst (integer_type_node,
UI_To_Int (Norm_Num (gnat_small_value)));
- const tree gnu_den
+ tree gnu_den
= build_int_cst (integer_type_node,
UI_To_Int (Norm_Den (gnat_small_value)));
scale_factor = build2 (RDIV_EXPR, integer_type_node,
@@ -1840,8 +1869,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity), gnu_expr, false);
/* Set the precision to the Esize except for bit-packed arrays. */
- if (Is_Packed_Array_Impl_Type (gnat_entity)
- && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
+ if (Is_Packed_Array_Impl_Type (gnat_entity))
esize = UI_To_Int (RM_Size (gnat_entity));
/* Boolean types with foreign convention have precision 1. */
@@ -1918,11 +1946,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
TYPE_STUB_DECL (gnu_type)
= create_type_stub_decl (gnu_entity_name, gnu_type);
- /* For a packed array, make the original array type a parallel/debug
- type. */
- if (debug_info_p && Is_Packed_Array_Impl_Type (gnat_entity))
- associate_original_type_to_packed_array (gnu_type, gnat_entity);
-
discrete_type:
/* We have to handle clauses that under-align the type specially. */
@@ -1944,19 +1967,30 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
such values), we only get the good bits, since the unused bits
are uninitialized. Both goals are accomplished by wrapping up
the modular type in an enclosing record type. */
- if (Is_Packed_Array_Impl_Type (gnat_entity)
- && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
+ if (Is_Packed_Array_Impl_Type (gnat_entity))
{
- tree gnu_field_type, gnu_field;
+ tree gnu_field_type, gnu_field, t;
+
+ gcc_assert (Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)));
+ TYPE_BIT_PACKED_ARRAY_TYPE_P (gnu_type) = 1;
+
+ /* Make the original array type a parallel/debug type. */
+ if (debug_info_p)
+ {
+ tree gnu_name
+ = associate_original_type_to_packed_array (gnu_type,
+ gnat_entity);
+ if (gnu_name)
+ gnu_entity_name = gnu_name;
+ }
/* Set the RM size before wrapping up the original type. */
SET_TYPE_RM_SIZE (gnu_type,
UI_To_gnu (RM_Size (gnat_entity), bitsizetype));
- TYPE_PACKED_ARRAY_TYPE_P (gnu_type) = 1;
/* Create a stripped-down declaration, mainly for debugging. */
- create_type_decl (gnu_entity_name, gnu_type, true, debug_info_p,
- gnat_entity);
+ t = create_type_decl (gnu_entity_name, gnu_type, true, debug_info_p,
+ gnat_entity);
/* Now save it and build the enclosing record type. */
gnu_field_type = gnu_type;
@@ -1995,15 +2029,15 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
finish_record_type (gnu_type, gnu_field, 2, false);
TYPE_JUSTIFIED_MODULAR_P (gnu_type) = 1;
+ /* Make the original array type a parallel/debug type. Note that
+ gnat_get_array_descr_info needs a TYPE_IMPL_PACKED_ARRAY_P type
+ so we use an intermediate step for standard DWARF. */
if (debug_info_p)
{
- /* Make the original array type a parallel/debug type. */
- associate_original_type_to_packed_array (gnu_type, gnat_entity);
-
- /* Since GNU_TYPE is a padding type around the packed array
- implementation type, the padded type is its debug type. */
if (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
SET_TYPE_DEBUG_TYPE (gnu_type, gnu_field_type);
+ else if (DECL_PARALLEL_TYPE (t))
+ add_parallel_type (gnu_type, DECL_PARALLEL_TYPE (t));
}
}
@@ -2017,9 +2051,13 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
/* Set the RM size before wrapping the type. */
SET_TYPE_RM_SIZE (gnu_type, gnu_size);
+ /* Create a stripped-down declaration, mainly for debugging. */
+ create_type_decl (gnu_entity_name, gnu_type, true, debug_info_p,
+ gnat_entity);
+
gnu_type
= maybe_pad_type (gnu_type, TYPE_SIZE (gnu_type), align,
- gnat_entity, false, true, definition, false);
+ gnat_entity, false, definition, false);
TYPE_PACKED (gnu_type) = 1;
SET_TYPE_ADA_SIZE (gnu_type, gnu_size);
@@ -2074,16 +2112,28 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
/* Array Types and Subtypes
- Unconstrained array types are represented by E_Array_Type and
- constrained array types are represented by E_Array_Subtype. There
- are no actual objects of an unconstrained array type; all we have
- are pointers to that type.
+ In GNAT unconstrained array types are represented by E_Array_Type and
+ constrained array types are represented by E_Array_Subtype. They are
+ translated into UNCONSTRAINED_ARRAY_TYPE and ARRAY_TYPE respectively.
+ But there are no actual objects of an unconstrained array type; all we
+ have are pointers to that type. In addition to the type node itself,
+ 4 other types associated with it are built in the process:
+
+ 1. the array type (suffix XUA) containing the actual data,
+
+ 2. the template type (suffix XUB) containng the bounds,
- The following fields are defined on array types and subtypes:
+ 3. the fat pointer type (suffix XUP) representing a pointer or a
+ reference to the unconstrained array type:
+ XUP = struct { XUA *, XUB * }
- Component_Type Component type of the array.
- Number_Dimensions Number of dimensions (an int).
- First_Index Type of first index. */
+ 4. the object record type (suffix XUT) containing bounds and data:
+ XUT = struct { XUB, XUA }
+
+ The bounds of the array type XUA (de)reference the XUB * field of a
+ PLACEHOLDER_EXPR for the fat pointer type XUP, so the array type XUA
+ is to be interpreted in the context of the fat pointer type XUB for
+ debug info purposes. */
case E_Array_Type:
{
@@ -2095,8 +2145,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
tree gnu_template_reference, gnu_template_fields, gnu_fat_type;
tree *gnu_index_types = XALLOCAVEC (tree, ndim);
tree *gnu_temp_fields = XALLOCAVEC (tree, ndim);
- tree gnu_max_size = size_one_node, tem, t;
- Entity_Id gnat_index, gnat_name;
+ tree gnu_max_size = size_one_node, tem, obj;
+ Entity_Id gnat_index;
int index;
tree comp_type;
@@ -2170,7 +2220,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
TREE_TYPE (tem) = ptr_type_node;
TREE_TYPE (DECL_CHAIN (tem)) = gnu_ptr_template;
TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (gnu_fat_type)) = 0;
- for (t = gnu_fat_type; t; t = TYPE_NEXT_VARIANT (t))
+ for (tree t = gnu_fat_type; t; t = TYPE_NEXT_VARIANT (t))
SET_TYPE_UNCONSTRAINED_ARRAY (t, gnu_type);
}
else
@@ -2187,6 +2237,22 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
SET_TYPE_UNCONSTRAINED_ARRAY (gnu_fat_type, gnu_type);
}
+ /* If the GNAT encodings are used, give the fat pointer type a name.
+ If this is a packed array, tell the debugger how to interpret the
+ underlying bits by fetching that of the implementation type. But
+ in any case, mark it as artificial so the debugger can skip it. */
+ const Entity_Id gnat_name
+ = (Present (Packed_Array_Impl_Type (gnat_entity))
+ && gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL)
+ ? Packed_Array_Impl_Type (gnat_entity)
+ : gnat_entity;
+ tree xup_name
+ = (gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL)
+ ? create_concat_name (gnat_name, "XUP")
+ : gnu_entity_name;
+ create_type_decl (xup_name, gnu_fat_type, true, debug_info_p,
+ gnat_entity);
+
/* Build a reference to the template from a PLACEHOLDER_EXPR that
is the fat pointer. This will be used to access the individual
fields once we build them. */
@@ -2288,6 +2354,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
= chainon (gnu_template_fields, gnu_temp_fields[index]);
finish_record_type (gnu_template_type, gnu_template_fields, 0,
debug_info_p);
+ TYPE_CONTEXT (gnu_template_type) = current_function_decl;
TYPE_READONLY (gnu_template_type) = 1;
/* If Component_Size is not already specified, annotate it with the
@@ -2344,14 +2411,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
if (TYPE_ALIAS_SET_KNOWN_P (gnu_fat_type))
record_component_aliases (gnu_fat_type);
- /* The result type is an UNCONSTRAINED_ARRAY_TYPE that indicates the
- corresponding fat pointer. */
- TREE_TYPE (gnu_type) = gnu_fat_type;
- TYPE_POINTER_TO (gnu_type) = gnu_fat_type;
- TYPE_REFERENCE_TO (gnu_type) = gnu_fat_type;
- SET_TYPE_MODE (gnu_type, BLKmode);
- SET_TYPE_ALIGN (gnu_type, TYPE_ALIGN (tem));
-
/* If the maximum size doesn't overflow, use it. */
if (gnu_max_size
&& TREE_CODE (gnu_max_size) == INTEGER_CST
@@ -2359,22 +2418,11 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
&& compare_tree_int (gnu_max_size, TYPE_ARRAY_SIZE_LIMIT) <= 0)
TYPE_ARRAY_MAX_SIZE (tem) = gnu_max_size;
+ /* See the above description for the rationale. */
create_type_decl (create_concat_name (gnat_entity, "XUA"), tem,
artificial_p, debug_info_p, gnat_entity);
-
- /* If told to generate GNAT encodings for them (GDB rely on them at the
- moment): give the fat pointer type a name. If this is a packed
- array, tell the debugger how to interpret the underlying bits. */
- if (Present (Packed_Array_Impl_Type (gnat_entity)))
- gnat_name = Packed_Array_Impl_Type (gnat_entity);
- else
- gnat_name = gnat_entity;
- tree xup_name
- = (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
- ? get_entity_name (gnat_name)
- : create_concat_name (gnat_name, "XUP");
- create_type_decl (xup_name, gnu_fat_type, artificial_p, debug_info_p,
- gnat_entity);
+ TYPE_CONTEXT (tem) = gnu_fat_type;
+ TYPE_CONTEXT (TYPE_POINTER_TO (tem)) = gnu_fat_type;
/* Create the type to be designated by thin pointers: a record type for
the array and its template. We used to shift the fields to have the
@@ -2385,14 +2433,22 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
don't have to name them as a GNAT encoding, except if specifically
asked to. */
tree xut_name
- = (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
- ? get_entity_name (gnat_name)
- : create_concat_name (gnat_name, "XUT");
- tem = build_unc_object_type (gnu_template_type, tem, xut_name,
+ = (gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL)
+ ? create_concat_name (gnat_name, "XUT")
+ : gnu_entity_name;
+ obj = build_unc_object_type (gnu_template_type, tem, xut_name,
debug_info_p);
- SET_TYPE_UNCONSTRAINED_ARRAY (tem, gnu_type);
- TYPE_OBJECT_RECORD_TYPE (gnu_type) = tem;
+ SET_TYPE_UNCONSTRAINED_ARRAY (obj, gnu_type);
+ TYPE_OBJECT_RECORD_TYPE (gnu_type) = obj;
+
+ /* The result type is an UNCONSTRAINED_ARRAY_TYPE that indicates the
+ corresponding fat pointer. */
+ TREE_TYPE (gnu_type) = gnu_fat_type;
+ TYPE_POINTER_TO (gnu_type) = gnu_fat_type;
+ TYPE_REFERENCE_TO (gnu_type) = gnu_fat_type;
+ SET_TYPE_MODE (gnu_type, BLKmode);
+ SET_TYPE_ALIGN (gnu_type, TYPE_ALIGN (tem));
}
break;
@@ -2678,6 +2734,22 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
set_reverse_storage_order_on_array_type (gnu_type);
if (array_type_has_nonaliased_component (gnu_type, gnat_entity))
set_nonaliased_component_on_array_type (gnu_type);
+
+ /* Kludge to remove the TREE_OVERFLOW flag for the sake of LTO
+ on maximally-sized array types designed by access types. */
+ if (integer_zerop (TYPE_SIZE (gnu_type))
+ && TREE_OVERFLOW (TYPE_SIZE (gnu_type))
+ && Is_Itype (gnat_entity)
+ && (gnat_temp = Associated_Node_For_Itype (gnat_entity))
+ && IN (Nkind (gnat_temp), N_Declaration)
+ && Is_Access_Type (Defining_Entity (gnat_temp))
+ && Is_Entity_Name (First_Index (gnat_entity))
+ && UI_To_Int (RM_Size (Entity (First_Index (gnat_entity))))
+ == BITS_PER_WORD)
+ {
+ TYPE_SIZE (gnu_type) = bitsize_zero_node;
+ TYPE_SIZE_UNIT (gnu_type) = size_zero_node;
+ }
}
/* Attach the TYPE_STUB_DECL in case we have a parallel type. */
@@ -2720,6 +2792,24 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
}
}
+ /* Set the TYPE_PACKED flag on packed array types and also on their
+ implementation types, so that the DWARF back-end can output the
+ appropriate description for them. */
+ TYPE_PACKED (gnu_type)
+ = (Is_Packed (gnat_entity)
+ || Is_Packed_Array_Impl_Type (gnat_entity));
+
+ TYPE_BIT_PACKED_ARRAY_TYPE_P (gnu_type)
+ = (Is_Packed_Array_Impl_Type (gnat_entity)
+ && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)));
+
+ /* If the maximum size doesn't overflow, use it. */
+ if (gnu_max_size
+ && TREE_CODE (gnu_max_size) == INTEGER_CST
+ && !TREE_OVERFLOW (gnu_max_size)
+ && compare_tree_int (gnu_max_size, TYPE_ARRAY_SIZE_LIMIT) <= 0)
+ TYPE_ARRAY_MAX_SIZE (gnu_type) = gnu_max_size;
+
/* If we need to write out a record type giving the names of the
bounds for debugging purposes, do it now and make the record
type a parallel type. This is not needed for a packed array
@@ -2754,44 +2844,32 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
}
/* If this is a packed array type, make the original array type a
- parallel/debug type. Otherwise, if such GNAT encodings are
- required, do it for the base array type if it isn't artificial to
- make sure it is kept in the debug info. */
+ parallel/debug type. Otherwise, if GNAT encodings are used, do
+ it for the base array type if it is not artificial to make sure
+ that it is kept in the debug info. */
if (debug_info_p)
{
if (Is_Packed_Array_Impl_Type (gnat_entity))
- associate_original_type_to_packed_array (gnu_type,
- gnat_entity);
- else
+ {
+ tree gnu_name
+ = associate_original_type_to_packed_array (gnu_type,
+ gnat_entity);
+ if (gnu_name)
+ gnu_entity_name = gnu_name;
+ }
+
+ else if (gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL)
{
tree gnu_base_decl
= gnat_to_gnu_entity (Etype (gnat_entity), NULL_TREE,
false);
- if (!DECL_ARTIFICIAL (gnu_base_decl)
- && gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL)
+
+ if (!DECL_ARTIFICIAL (gnu_base_decl))
add_parallel_type (gnu_type,
TREE_TYPE (TREE_TYPE (gnu_base_decl)));
}
}
- TYPE_PACKED_ARRAY_TYPE_P (gnu_type)
- = (Is_Packed_Array_Impl_Type (gnat_entity)
- && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)));
-
- /* Tag top-level ARRAY_TYPE nodes for packed arrays and their
- implementation types as such so that the debug information back-end
- can output the appropriate description for them. */
- TYPE_PACKED (gnu_type)
- = (Is_Packed (gnat_entity)
- || Is_Packed_Array_Impl_Type (gnat_entity));
-
- /* If the maximum size doesn't overflow, use it. */
- if (gnu_max_size
- && TREE_CODE (gnu_max_size) == INTEGER_CST
- && !TREE_OVERFLOW (gnu_max_size)
- && compare_tree_int (gnu_max_size, TYPE_ARRAY_SIZE_LIMIT) <= 0)
- TYPE_ARRAY_MAX_SIZE (gnu_type) = gnu_max_size;
-
/* Set our alias set to that of our base type. This gives all
array subtypes the same alias set. */
relate_alias_sets (gnu_type, gnu_base_type, ALIAS_SET_COPY);
@@ -2927,15 +3005,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
/* Record Types and Subtypes
- The following fields are defined on record types:
-
- Has_Discriminants True if the record has discriminants
- First_Discriminant Points to head of list of discriminants
- First_Entity Points to head of list of fields
- Is_Tagged_Type True if the record is tagged
-
- Implementation of Ada records and discriminated records:
-
A record type definition is transformed into the equivalent of a C
struct definition. The fields that are the discriminants which are
found in the Full_Type_Declaration node and the elements of the
@@ -3340,7 +3409,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
/* If there are entities in the chain corresponding to components
that we did not elaborate, ensure we elaborate their types if
- they are Itypes. */
+ they are itypes. */
for (gnat_temp = First_Entity (gnat_entity);
Present (gnat_temp);
gnat_temp = Next_Entity (gnat_temp))
@@ -3426,7 +3495,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
/* When the subtype has discriminants and these discriminants affect
the initial shape it has inherited, factor them in. But for an
- Unchecked_Union (it must be an Itype), just return the type. */
+ Unchecked_Union (it must be an itype), just return the type. */
if (Has_Discriminants (gnat_entity)
&& Stored_Constraint (gnat_entity) != No_Elist
&& Is_Record_Type (gnat_base_type)
@@ -3479,7 +3548,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
we are asked to output such encodings, write a record that
shows what we are a subtype of and also make a variable that
indicates our size, if still variable. */
- if (gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL)
+ if (debug_info_p
+ && gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL)
{
tree gnu_subtype_marker = make_node (RECORD_TYPE);
tree gnu_unpad_base_name
@@ -3913,16 +3983,14 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
of its type, so we must elaborate that type now. */
if (Present (Alias (gnat_entity)))
{
- const Entity_Id gnat_renamed = Renamed_Object (gnat_entity);
+ const Entity_Id gnat_alias = Alias (gnat_entity);
- if (Ekind (Alias (gnat_entity)) == E_Enumeration_Literal)
- gnat_to_gnu_entity (Etype (Alias (gnat_entity)), NULL_TREE,
- false);
+ if (Ekind (gnat_alias) == E_Enumeration_Literal)
+ gnat_to_gnu_entity (Etype (gnat_alias), NULL_TREE, false);
- gnu_decl
- = gnat_to_gnu_entity (Alias (gnat_entity), gnu_expr, false);
+ gnu_decl = gnat_to_gnu_entity (gnat_alias, gnu_expr, false);
- /* Elaborate any Itypes in the parameters of this entity. */
+ /* Elaborate any itypes in the parameters of this entity. */
for (gnat_temp = First_Formal_With_Extras (gnat_entity);
Present (gnat_temp);
gnat_temp = Next_Formal_With_Extras (gnat_temp))
@@ -3930,24 +3998,22 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, false);
/* Materialize renamed subprograms in the debugging information
- when the renamed object is compile time known. We can consider
+ when the renamed object is known at compile time; we consider
such renamings as imported declarations.
- Because the parameters in generics instantiation are generally
- materialized as renamings, we ofter end up having both the
+ Because the parameters in generic instantiations are generally
+ materialized as renamings, we often end up having both the
renamed subprogram and the renaming in the same context and with
- the same name: in this case, renaming is both useless debug-wise
+ the same name; in this case, renaming is both useless debug-wise
and potentially harmful as name resolution in the debugger could
return twice the same entity! So avoid this case. */
- if (debug_info_p && !artificial_p
+ if (debug_info_p
+ && !artificial_p
+ && (Ekind (gnat_alias) == E_Function
+ || Ekind (gnat_alias) == E_Procedure)
&& !(get_debug_scope (gnat_entity, NULL)
- == get_debug_scope (gnat_renamed, NULL)
- && Name_Equals (Chars (gnat_entity),
- Chars (gnat_renamed)))
- && Present (gnat_renamed)
- && (Ekind (gnat_renamed) == E_Function
- || Ekind (gnat_renamed) == E_Procedure)
- && gnu_decl
+ == get_debug_scope (gnat_alias, NULL)
+ && Name_Equals (Chars (gnat_entity), Chars (gnat_alias)))
&& TREE_CODE (gnu_decl) == FUNCTION_DECL)
{
tree decl = build_decl (input_location, IMPORTED_DECL,
@@ -4320,15 +4386,20 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
&& integer_pow2p (gnu_size))
align = MIN (BIGGEST_ALIGNMENT, tree_to_uhwi (gnu_size));
- /* See if we need to pad the type. If we did, and made a record,
- the name of the new type may be changed. So get it back for
- us when we make the new TYPE_DECL below. */
+ /* See if we need to pad the type. If we did and built a new type,
+ then create a stripped-down declaration for the original type,
+ mainly for debugging, unless there was already one. */
if (gnu_size || align > 0)
- gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity,
- false, !gnu_decl, definition, false);
+ {
+ tree orig_type = gnu_type;
+
+ gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity,
+ false, definition, false);
- if (TYPE_IS_PADDING_P (gnu_type))
- gnu_entity_name = TYPE_IDENTIFIER (gnu_type);
+ if (gnu_type != orig_type && !gnu_decl)
+ create_type_decl (gnu_entity_name, orig_type, true, debug_info_p,
+ gnat_entity);
+ }
/* Now set the RM size of the type. We cannot do it before padding
because we need to accept arbitrary RM sizes on integral types. */
@@ -4785,7 +4856,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
force_global--;
/* If this is a packed array type whose original array type is itself
- an Itype without freeze node, make sure the latter is processed. */
+ an itype without freeze node, make sure the latter is processed. */
if (Is_Packed_Array_Impl_Type (gnat_entity)
&& Is_Itype (Original_Array_Type (gnat_entity))
&& No (Freeze_Node (Original_Array_Type (gnat_entity)))
@@ -5075,13 +5146,14 @@ gnat_to_gnu_component_type (Entity_Id gnat_array, bool definition,
bool debug_info_p)
{
const Entity_Id gnat_type = Component_Type (gnat_array);
+ const bool is_bit_packed = Is_Bit_Packed_Array (gnat_array);
tree gnu_type = gnat_to_gnu_type (gnat_type);
- bool has_packed_components = Is_Bit_Packed_Array (gnat_array);
tree gnu_comp_size;
+ bool has_packed_components;
unsigned int max_align;
/* If an alignment is specified, use it as a cap on the component type
- so that it can be honored for the whole type. But ignore it for the
+ so that it can be honored for the whole type, but ignore it for the
original type of packed array types. */
if (No (Packed_Array_Impl_Type (gnat_array))
&& Known_Alignment (gnat_array))
@@ -5091,9 +5163,9 @@ gnat_to_gnu_component_type (Entity_Id gnat_array, bool definition,
/* Try to get a packable form of the component if needed. */
if ((Is_Packed (gnat_array) || Has_Component_Size_Clause (gnat_array))
+ && !is_bit_packed
&& !Has_Aliased_Components (gnat_array)
&& !Strict_Alignment (gnat_type)
- && !has_packed_components
&& RECORD_OR_UNION_TYPE_P (gnu_type)
&& !TYPE_FAT_POINTER_P (gnu_type)
&& tree_fits_uhwi_p (TYPE_SIZE (gnu_type)))
@@ -5101,6 +5173,8 @@ gnat_to_gnu_component_type (Entity_Id gnat_array, bool definition,
gnu_type = make_packable_type (gnu_type, false, max_align);
has_packed_components = true;
}
+ else
+ has_packed_components = is_bit_packed;
/* Get and validate any specified Component_Size. */
gnu_comp_size
@@ -5123,9 +5197,10 @@ gnat_to_gnu_component_type (Entity_Id gnat_array, bool definition,
gnu_comp_size = bitsize_unit_node;
/* Honor the component size. This is not needed for bit-packed arrays. */
- if (gnu_comp_size && !Is_Bit_Packed_Array (gnat_array))
+ if (gnu_comp_size && !is_bit_packed)
{
tree orig_type = gnu_type;
+ unsigned int gnu_comp_align;
gnu_type = make_type_from_size (gnu_type, gnu_comp_size, false);
if (max_align > 0 && TYPE_ALIGN (gnu_type) > max_align)
@@ -5133,8 +5208,22 @@ gnat_to_gnu_component_type (Entity_Id gnat_array, bool definition,
else
orig_type = gnu_type;
- gnu_type = maybe_pad_type (gnu_type, gnu_comp_size, 0, gnat_array,
- true, false, definition, true);
+ /* We need to make sure that the size is a multiple of the alignment.
+ But we do not misalign the component type because of the alignment
+ of the array type here; this either must have been done earlier in
+ the packed case or should be rejected in the non-packed case. */
+ if (TREE_CODE (gnu_comp_size) == INTEGER_CST)
+ {
+ const unsigned HOST_WIDE_INT int_size = tree_to_uhwi (gnu_comp_size);
+ gnu_comp_align = int_size & -int_size;
+ if (gnu_comp_align > TYPE_ALIGN (gnu_type))
+ gnu_comp_align = 0;
+ }
+ else
+ gnu_comp_align = 0;
+
+ gnu_type = maybe_pad_type (gnu_type, gnu_comp_size, gnu_comp_align,
+ gnat_array, true, definition, true);
/* If a padding record was made, declare it now since it will never be
declared otherwise. This is necessary to ensure that its subtrees
@@ -5161,7 +5250,7 @@ gnat_to_gnu_component_type (Entity_Id gnat_array, bool definition,
= size_binop (MAX_EXPR, TYPE_SIZE (gnu_type), bitsize_unit_node);
TYPE_PADDING_FOR_COMPONENT (gnu_type)
= maybe_pad_type (gnu_type, gnu_comp_size, 0, gnat_array,
- true, false, definition, true);
+ true, definition, true);
gnu_type = TYPE_PADDING_FOR_COMPONENT (gnu_type);
create_type_decl (TYPE_NAME (gnu_type), gnu_type, true, debug_info_p,
gnat_array);
@@ -5177,8 +5266,8 @@ gnat_to_gnu_component_type (Entity_Id gnat_array, bool definition,
storage order to the padding type since it is the innermost enclosing
aggregate type around the scalar. */
if (TYPE_IS_PADDING_P (gnu_type)
+ && !is_bit_packed
&& Reverse_Storage_Order (gnat_array)
- && !Is_Bit_Packed_Array (gnat_array)
&& Is_Scalar_Type (gnat_type))
gnu_type = set_reverse_storage_order_on_pad_type (gnu_type);
@@ -5319,12 +5408,6 @@ gnat_to_gnu_param (Entity_Id gnat_param, tree gnu_param_type, bool first,
gnu_param_type = unpadded_type;
}
- /* If this is a read-only parameter, make a variant of the type that is
- read-only. ??? However, if this is a self-referential type, the type
- can be very complex, so skip it for now. */
- if (ro_param && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_param_type)))
- gnu_param_type = change_qualified_type (gnu_param_type, TYPE_QUAL_CONST);
-
/* For foreign conventions, pass arrays as pointers to the element type.
First check for unconstrained array and get the underlying array. */
if (foreign && TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE)
@@ -5412,7 +5495,10 @@ gnat_to_gnu_param (Entity_Id gnat_param, tree gnu_param_type, bool first,
&& (!type_requires_init_of_formal (Etype (gnat_param))
|| Is_Init_Proc (gnat_subprog)
|| by_return))
- return gnu_param_type;
+ {
+ Set_Mechanism (gnat_param, By_Copy);
+ return gnu_param_type;
+ }
gnu_param = create_param_decl (gnu_param_name, gnu_param_type);
TREE_READONLY (gnu_param) = ro_param || by_ref || by_component_ptr;
@@ -5808,8 +5894,8 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition,
}
gnu_return_type = maybe_pad_type (gnu_return_type, max_return_size,
- 0, gnat_subprog, false, false,
- definition, true);
+ 0, gnat_subprog, false, definition,
+ true);
/* Declare it now since it will never be declared otherwise. This
is necessary to ensure that its subtrees are properly marked. */
@@ -7155,7 +7241,7 @@ gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed,
if (align > 0)
gnu_field_type
= maybe_pad_type (gnu_field_type, NULL_TREE, align, gnat_field,
- false, false, definition, true);
+ false, definition, true);
check_ok_for_atomic_type (gnu_field_type, gnat_field, false);
}
@@ -7316,7 +7402,7 @@ gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed,
orig_field_type = gnu_field_type;
gnu_field_type = maybe_pad_type (gnu_field_type, gnu_size, 0, gnat_field,
- false, false, definition, true);
+ false, definition, true);
/* If a padding record was made, declare it now since it will never be
declared otherwise. This is necessary to ensure that its subtrees
@@ -8791,20 +8877,29 @@ build_subst_list (Entity_Id gnat_subtype, Entity_Id gnat_type, bool definition)
return gnu_list;
}
-/* Scan all fields in QUAL_UNION_TYPE and return a list describing the
- variants of QUAL_UNION_TYPE that are still relevant after applying
- the substitutions described in SUBST_LIST. GNU_LIST is a pre-existing
+/* Scan all fields in {GNU_QUAL_UNION_TYPE,GNAT_VARIANT_PART} and return a list
+ describing the variants of GNU_QUAL_UNION_TYPE that are still relevant after
+ applying the substitutions described in SUBST_LIST. GNU_LIST is an existing
list to be prepended to the newly created entries. */
static vec<variant_desc>
-build_variant_list (tree qual_union_type, vec<subst_pair> subst_list,
- vec<variant_desc> gnu_list)
+build_variant_list (tree gnu_qual_union_type, Node_Id gnat_variant_part,
+ vec<subst_pair> subst_list, vec<variant_desc> gnu_list)
{
+ Node_Id gnat_variant;
tree gnu_field;
- for (gnu_field = TYPE_FIELDS (qual_union_type);
+ for (gnu_field = TYPE_FIELDS (gnu_qual_union_type),
+ gnat_variant
+ = Present (gnat_variant_part)
+ ? First_Non_Pragma (Variants (gnat_variant_part))
+ : Empty;
gnu_field;
- gnu_field = DECL_CHAIN (gnu_field))
+ gnu_field = DECL_CHAIN (gnu_field),
+ gnat_variant
+ = Present (gnat_variant_part)
+ ? Next_Non_Pragma (gnat_variant)
+ : Empty)
{
tree qual = DECL_QUALIFIER (gnu_field);
unsigned int i;
@@ -8823,11 +8918,21 @@ build_variant_list (tree qual_union_type, vec<subst_pair> subst_list,
gnu_list.safe_push (v);
+ /* Annotate the GNAT node if present. */
+ if (Present (gnat_variant))
+ Set_Present_Expr (gnat_variant, annotate_value (qual));
+
/* Recurse on the variant subpart of the variant, if any. */
variant_subpart = get_variant_part (variant_type);
if (variant_subpart)
- gnu_list = build_variant_list (TREE_TYPE (variant_subpart),
- subst_list, gnu_list);
+ gnu_list
+ = build_variant_list (TREE_TYPE (variant_subpart),
+ Present (gnat_variant)
+ ? Variant_Part
+ (Component_List (gnat_variant))
+ : Empty,
+ subst_list,
+ gnu_list);
/* If the new qualifier is unconditionally true, the subsequent
variants cannot be accessed. */
@@ -8921,11 +9026,11 @@ validate_size (Uint uint_size, tree gnu_type, Entity_Id gnat_object,
return NULL_TREE;
}
- /* If this is an integral type or a packed array type, the front-end has
- already verified the size, so we need not do it here (which would mean
- checking against the bounds). However, if this is an aliased object,
- it may not be smaller than the type of the object. */
- if ((INTEGRAL_TYPE_P (gnu_type) || TYPE_IS_PACKED_ARRAY_TYPE_P (gnu_type))
+ /* If this is an integral type or a bit-packed array type, the front-end has
+ already verified the size, so we need not do it again (which would mean
+ checking against the bounds). However, if this is an aliased object, it
+ may not be smaller than the type of the object. */
+ if ((INTEGRAL_TYPE_P (gnu_type) || BIT_PACKED_ARRAY_TYPE_P (gnu_type))
&& !(kind == VAR_DECL && Is_Aliased (gnat_object)))
return size;
@@ -9023,16 +9128,13 @@ set_rm_size (Uint uint_size, tree gnu_type, Entity_Id gnat_entity)
/* Issue an error either if the old size of the object isn't a constant or
if the new size is smaller than it. The front-end has already verified
- this for scalar and packed array types. */
+ this for scalar and bit-packed array types. */
if (TREE_CODE (old_size) != INTEGER_CST
|| TREE_OVERFLOW (old_size)
|| (AGGREGATE_TYPE_P (gnu_type)
- && !(TREE_CODE (gnu_type) == ARRAY_TYPE
- && TYPE_PACKED_ARRAY_TYPE_P (gnu_type))
+ && !BIT_PACKED_ARRAY_TYPE_P (gnu_type)
&& !(TYPE_IS_PADDING_P (gnu_type)
- && TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type))) == ARRAY_TYPE
- && TYPE_PACKED_ARRAY_TYPE_P
- (TREE_TYPE (TYPE_FIELDS (gnu_type))))
+ && BIT_PACKED_ARRAY_TYPE_P (TREE_TYPE (TYPE_FIELDS (gnu_type))))
&& tree_int_cst_lt (size, old_size)))
{
if (Present (gnat_attr_node))
@@ -9714,7 +9816,7 @@ copy_and_substitute_in_layout (Entity_Id gnat_new_type,
Entity_Id gnat_old_type,
tree gnu_new_type,
tree gnu_old_type,
- vec<subst_pair> gnu_subst_list,
+ vec<subst_pair> subst_list,
bool debug_info_p)
{
const bool is_subtype = (Ekind (gnat_new_type) == E_Record_Subtype);
@@ -9733,11 +9835,18 @@ copy_and_substitute_in_layout (Entity_Id gnat_new_type,
build a new qualified union for the variants that are still relevant. */
if (gnu_variant_part)
{
+ const Node_Id gnat_decl = Declaration_Node (gnat_new_type);
variant_desc *v;
unsigned int i;
- gnu_variant_list = build_variant_list (TREE_TYPE (gnu_variant_part),
- gnu_subst_list, vNULL);
+ gnu_variant_list
+ = build_variant_list (TREE_TYPE (gnu_variant_part),
+ is_subtype
+ ? Empty
+ : Variant_Part
+ (Component_List (Type_Definition (gnat_decl))),
+ subst_list,
+ vNULL);
/* If all the qualifiers are unconditionally true, the innermost variant
is statically selected. */
@@ -9763,8 +9872,7 @@ copy_and_substitute_in_layout (Entity_Id gnat_new_type,
IDENTIFIER_POINTER (suffix));
TYPE_REVERSE_STORAGE_ORDER (new_variant)
= TYPE_REVERSE_STORAGE_ORDER (gnu_new_type);
- copy_and_substitute_in_size (new_variant, old_variant,
- gnu_subst_list);
+ copy_and_substitute_in_size (new_variant, old_variant, subst_list);
v->new_type = new_variant;
}
}
@@ -9875,7 +9983,7 @@ copy_and_substitute_in_layout (Entity_Id gnat_new_type,
gnu_field
= create_field_decl_from (gnu_old_field, gnu_field_type,
gnu_cont_type, gnu_size,
- gnu_pos_list, gnu_subst_list);
+ gnu_pos_list, subst_list);
gnu_pos = DECL_FIELD_OFFSET (gnu_field);
/* If the context is a variant, put it in the new variant directly. */
@@ -9962,20 +10070,20 @@ copy_and_substitute_in_layout (Entity_Id gnat_new_type,
tree new_variant_part
= create_variant_part_from (gnu_variant_part, gnu_variant_list,
gnu_new_type, gnu_pos_list,
- gnu_subst_list, debug_info_p);
+ subst_list, debug_info_p);
DECL_CHAIN (new_variant_part) = gnu_field_list;
gnu_field_list = new_variant_part;
}
gnu_variant_list.release ();
- gnu_subst_list.release ();
+ subst_list.release ();
/* If NEW_TYPE is a subtype, it inherits all the attributes from OLD_TYPE.
Otherwise sizes and alignment must be computed independently. */
finish_record_type (gnu_new_type, nreverse (gnu_field_list),
is_subtype ? 2 : 1, debug_info_p);
- /* Now go through the entities again looking for Itypes that we have not yet
+ /* Now go through the entities again looking for itypes that we have not yet
elaborated (e.g. Etypes of fields that have Original_Components). */
for (Entity_Id gnat_field = First_Entity (gnat_new_type);
Present (gnat_field);
@@ -9987,39 +10095,43 @@ copy_and_substitute_in_layout (Entity_Id gnat_new_type,
gnat_to_gnu_entity (Etype (gnat_field), NULL_TREE, false);
}
-/* Associate to GNU_TYPE, the translation of GNAT_ENTITY, which is
- the implementation type of a packed array type (Is_Packed_Array_Impl_Type),
- the original array type if it has been translated. This association is a
- parallel type for GNAT encodings or a debug type for standard DWARF. Note
- that for standard DWARF, we also want to get the original type name. */
+/* Associate to the implementation type of a packed array type specified by
+ GNU_TYPE, which is the translation of GNAT_ENTITY, the original array type
+ if it has been translated. This association is a parallel type for GNAT
+ encodings or a debug type for standard DWARF. Note that for standard DWARF,
+ we also want to get the original type name and therefore we return it. */
-static void
+static tree
associate_original_type_to_packed_array (tree gnu_type, Entity_Id gnat_entity)
{
- Entity_Id gnat_original_array_type
+ const Entity_Id gnat_original_array_type
= Underlying_Type (Original_Array_Type (gnat_entity));
tree gnu_original_array_type;
if (!present_gnu_tree (gnat_original_array_type))
- return;
+ return NULL_TREE;
gnu_original_array_type = gnat_to_gnu_type (gnat_original_array_type);
if (TYPE_IS_DUMMY_P (gnu_original_array_type))
- return;
+ return NULL_TREE;
+
+ gcc_assert (TYPE_IMPL_PACKED_ARRAY_P (gnu_type));
if (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
{
- tree original_name = TYPE_NAME (gnu_original_array_type);
+ SET_TYPE_ORIGINAL_PACKED_ARRAY (gnu_type, gnu_original_array_type);
+ tree original_name = TYPE_NAME (gnu_original_array_type);
if (TREE_CODE (original_name) == TYPE_DECL)
original_name = DECL_NAME (original_name);
-
- SET_TYPE_ORIGINAL_PACKED_ARRAY (gnu_type, gnu_original_array_type);
- TYPE_NAME (gnu_type) = original_name;
+ return original_name;
}
else
- add_parallel_type (gnu_type, gnu_original_array_type);
+ {
+ add_parallel_type (gnu_type, gnu_original_array_type);
+ return NULL_TREE;
+ }
}
/* Given a type T, a FIELD_DECL F, and a replacement value R, return an
diff --git a/gcc/ada/gcc-interface/gadaint.h b/gcc/ada/gcc-interface/gadaint.h
index ce27a14..bf49794 100644
--- a/gcc/ada/gcc-interface/gadaint.h
+++ b/gcc/ada/gcc-interface/gadaint.h
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 2010-2011, Free Software Foundation, Inc. *
+ * Copyright (C) 2010-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
diff --git a/gcc/ada/gcc-interface/gigi.h b/gcc/ada/gcc-interface/gigi.h
index edfcbd5..e43b3db 100644
--- a/gcc/ada/gcc-interface/gigi.h
+++ b/gcc/ada/gcc-interface/gigi.h
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 1992-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -138,14 +138,12 @@ extern tree make_type_from_size (tree type, tree size_tree, bool for_biased);
if needed. We have already verified that SIZE and ALIGN are large enough.
GNAT_ENTITY is used to name the resulting record and to issue a warning.
IS_COMPONENT_TYPE is true if this is being done for the component type of
- an array. IS_USER_TYPE is true if the original type needs to be completed.
- DEFINITION is true if this type is being defined. SET_RM_SIZE is true if
- the RM size of the resulting type is to be set to SIZE too; in this case,
- the padded type is canonicalized before being returned. */
+ an array. DEFINITION is true if this type is being defined. SET_RM_SIZE
+ is true if the RM size of the resulting type is to be set to SIZE too; in
+ this case, the padded type is canonicalized before being returned. */
extern tree maybe_pad_type (tree type, tree size, unsigned int align,
Entity_Id gnat_entity, bool is_component_type,
- bool is_user_type, bool definition,
- bool set_rm_size);
+ bool definition, bool set_rm_size);
/* Return true if padded TYPE was built with an RM size. */
extern bool pad_type_has_rm_size (tree type);
@@ -1065,20 +1063,6 @@ extern void enumerate_modes (void (*f) (const char *, int, int, int, int, int,
#define gigi_checking_assert(EXPR) \
gcc_checking_assert ((EXPR) || type_annotate_only)
-/* If EXP's type is a VECTOR_TYPE, return EXP converted to the associated
- TYPE_REPRESENTATIVE_ARRAY. */
-
-static inline tree
-maybe_vector_array (tree exp)
-{
- tree etype = TREE_TYPE (exp);
-
- if (VECTOR_TYPE_P (etype))
- exp = convert (TYPE_REPRESENTATIVE_ARRAY (etype), exp);
-
- return exp;
-}
-
/* Return the smallest power of 2 larger than X. */
static inline unsigned HOST_WIDE_INT
@@ -1144,6 +1128,33 @@ gnat_signed_type_for (tree type_node)
return gnat_signed_or_unsigned_type_for (0, type_node);
}
+/* Like build_qualified_type, but TYPE_QUALS is added to the existing
+ qualifiers on TYPE. */
+
+static inline tree
+change_qualified_type (tree type, int type_quals)
+{
+ /* Qualifiers must be put on the associated array type. */
+ if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
+ return type;
+
+ return build_qualified_type (type, TYPE_QUALS (type) | type_quals);
+}
+
+/* If EXPR's type is a VECTOR_TYPE, return EXPR converted to the associated
+ TYPE_REPRESENTATIVE_ARRAY. */
+
+static inline tree
+maybe_vector_array (tree expr)
+{
+ tree type = TREE_TYPE (expr);
+
+ if (VECTOR_TYPE_P (type))
+ expr = convert (TYPE_REPRESENTATIVE_ARRAY (type), expr);
+
+ return expr;
+}
+
/* Adjust the character type TYPE if need be. */
static inline tree
@@ -1186,15 +1197,23 @@ maybe_debug_type (tree type)
return type;
}
-/* Like build_qualified_type, but TYPE_QUALS is added to the existing
- qualifiers on TYPE. */
+/* Remove the padding around EXPR if need be. */
static inline tree
-change_qualified_type (tree type, int type_quals)
+maybe_padded_object (tree expr)
{
- /* Qualifiers must be put on the associated array type. */
- if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
- return type;
+ tree type = TREE_TYPE (expr);
- return build_qualified_type (type, TYPE_QUALS (type) | type_quals);
+ if (TYPE_IS_PADDING_P (type))
+ expr = convert (TREE_TYPE (TYPE_FIELDS (type)), expr);
+
+ return expr;
+}
+
+/* Return the type of operand #0 of EXPR. */
+
+static inline tree
+operand_type (tree expr)
+{
+ return TREE_TYPE (TREE_OPERAND (expr, 0));
}
diff --git a/gcc/ada/gcc-interface/lang-specs.h b/gcc/ada/gcc-interface/lang-specs.h
index 374fc1e..f0ef3b92 100644
--- a/gcc/ada/gcc-interface/lang-specs.h
+++ b/gcc/ada/gcc-interface/lang-specs.h
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 1992-2018, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -23,6 +23,10 @@
* *
****************************************************************************/
+/* Pass -d* flags to the actual compiler, but mapping non-Ada
+ extensions to .ada in dump file names. */
+#define ADA_DUMPS_OPTIONS DUMPS_OPTIONS ("%{!.adb:%{!.ads:.ada}}")
+
/* This is the contribution to the `default_compilers' array in gcc.c for
GNAT. */
@@ -34,17 +38,15 @@
%{!S:%{!c:%e-c or -S required for Ada}}\
gnat1 %{I*} %{k8:-gnatk8} %{Wall:-gnatwa} %{w:-gnatws} %{!Q:-quiet}\
%{nostdinc*} %{nostdlib*}\
- -dumpbase %{.adb:%b.adb}%{.ads:%b.ads}%{!.adb:%{!.ads:%b.ada}}\
- %{fcompare-debug-second:%:compare-debug-auxbase-opt(%b) -gnatd_A} \
- %{!fcompare-debug-second:%{c|S:%{o*:-auxbase-strip %*}%{!o*:-auxbase %b}}%{!c:%{!S:-auxbase %b}}} \
- %{O*} %{W*} %{w} %{p} %{pg:-p} %{d*} \
+ %{fcompare-debug-second:-gnatd_A} \
+ %{O*} %{W*} %{w} %{p} %{pg:-p} " ADA_DUMPS_OPTIONS " \
%{coverage:-fprofile-arcs -ftest-coverage} "
#if defined(TARGET_VXWORKS_RTP)
"%{fRTS=rtp|fRTS=rtp-smp|fRTS=ravenscar-cert-rtp:-mrtp} "
#endif
"%{gnatea:-gnatez} %{g*&m*&f*} "
"%1 %{!S:%{o*:%w%*-gnatO}} \
- %i %{S:%W{o*}%{!o*:-o %b.s}} \
+ %i %{S:%W{o*}%{!o*:-o %w%b.s}} \
%{gnatc*|gnats*: -o %j} %{-param*} \
%{!gnatc*:%{!gnats*:%(invoke_as)}}", 0, 0, 0},
@@ -53,9 +55,7 @@
%{!c:%e-c required for gnat2why}\
gnat1why %{I*} %{k8:-gnatk8} %{!Q:-quiet}\
%{nostdinc*} %{nostdlib*}\
- -dumpbase %{.adb:%b.adb}%{.ads:%b.ads}%{!.adb:%{!.ads:%b.ada}}\
- %{o*:-auxbase-strip %*}%{!o*:-auxbase %b} \
- %{a} %{d*} \
+ %{a} " ADA_DUMPS_OPTIONS " \
%{gnatea:-gnatez} %{g*&m*&f*} \
%1 %{o*:%w%*-gnatO} \
%i \
@@ -66,9 +66,7 @@
%{!c:%e-c required for gnat2scil}\
gnat1scil %{I*} %{k8:-gnatk8} %{!Q:-quiet}\
%{nostdinc*} %{nostdlib*}\
- -dumpbase %{.adb:%b.adb}%{.ads:%b.ads}%{!.adb:%{!.ads:%b.ada}}\
- %{o*:-auxbase-strip %*}%{!o*:-auxbase %b} \
- %{a} %{d*} \
+ %{a} " ADA_DUMPS_OPTIONS " \
%{gnatea:-gnatez} %{g*&m*&f*} \
%1 %{o*:%w%*-gnatO} \
%i \
diff --git a/gcc/ada/gcc-interface/lang.opt b/gcc/ada/gcc-interface/lang.opt
index 6691136..379157c 100644
--- a/gcc/ada/gcc-interface/lang.opt
+++ b/gcc/ada/gcc-interface/lang.opt
@@ -104,8 +104,4 @@ fbuiltin-printf
Ada Undocumented
Ignored.
-fopenacc
-Ada LTO
-; Documented in C but it should be: Enable OpenACC support
-
; This comment is to ensure we retain the blank line above.
diff --git a/gcc/ada/gcc-interface/misc.c b/gcc/ada/gcc-interface/misc.c
index d68b373..f72122b 100644
--- a/gcc/ada/gcc-interface/misc.c
+++ b/gcc/ada/gcc-interface/misc.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -164,7 +164,6 @@ gnat_handle_option (size_t scode, const char *arg, HOST_WIDE_INT value,
/* These are handled by the front-end. */
break;
- case OPT_fopenacc:
case OPT_fshort_enums:
case OPT_fsigned_char:
case OPT_funsigned_char:
@@ -417,7 +416,8 @@ gnat_init_gcc_eh (void)
}
else
{
- flag_non_call_exceptions = 1;
+ if (!global_options_set.x_flag_non_call_exceptions)
+ flag_non_call_exceptions = 1;
flag_aggressive_loop_optimizations = 0;
warn_aggressive_loop_optimizations = 0;
}
@@ -601,20 +601,10 @@ gnat_enum_underlying_base_type (const_tree)
static tree
gnat_get_debug_type (const_tree type)
{
- if (TYPE_CAN_HAVE_DEBUG_TYPE_P (type) && TYPE_DEBUG_TYPE (type))
- {
- type = TYPE_DEBUG_TYPE (type);
-
- /* ??? The get_debug_type language hook is processed after the array
- descriptor language hook, so if there is an array behind this type,
- the latter is supposed to handle it. Still, we can get here with
- a type we are not supposed to handle (e.g. when the DWARF back-end
- processes the type of a variable), so keep this guard. */
- if (type && TYPE_CAN_HAVE_DEBUG_TYPE_P (type))
- return const_cast<tree> (type);
- }
-
- return NULL_TREE;
+ if (TYPE_CAN_HAVE_DEBUG_TYPE_P (type))
+ return TYPE_DEBUG_TYPE (type);
+ else
+ return NULL_TREE;
}
/* Provide information in INFO for debugging output about the TYPE fixed-point
@@ -649,14 +639,14 @@ gnat_get_fixed_point_type_info (const_tree type,
if (TREE_CODE (scale_factor) == RDIV_EXPR)
{
- const tree num = TREE_OPERAND (scale_factor, 0);
- const tree den = TREE_OPERAND (scale_factor, 1);
+ tree num = TREE_OPERAND (scale_factor, 0);
+ tree den = TREE_OPERAND (scale_factor, 1);
/* See if we have a binary or decimal scale. */
if (TREE_CODE (den) == POWER_EXPR)
{
- const tree base = TREE_OPERAND (den, 0);
- const tree exponent = TREE_OPERAND (den, 1);
+ tree base = TREE_OPERAND (den, 0);
+ tree exponent = TREE_OPERAND (den, 1);
/* We expect the scale factor to be 1 / 2 ** N or 1 / 10 ** N. */
gcc_assert (num == integer_one_node
@@ -785,14 +775,9 @@ static bool
gnat_get_array_descr_info (const_tree const_type,
struct array_descr_info *info)
{
- bool convention_fortran_p;
- bool is_array = false;
- bool is_fat_ptr = false;
- bool is_packed_array = false;
tree type = const_cast<tree> (const_type);
- const_tree first_dimen = NULL_TREE;
- const_tree last_dimen = NULL_TREE;
- const_tree dimen;
+ tree first_dimen, dimen;
+ bool is_packed_array, is_array;
int i;
/* Temporaries created in the first pass and used in the second one for thin
@@ -802,9 +787,6 @@ gnat_get_array_descr_info (const_tree const_type,
tree thinptr_template_expr = NULL_TREE;
tree thinptr_bound_field = NULL_TREE;
- /* ??? See gnat_get_debug_type. */
- type = maybe_debug_type (type);
-
/* If we have an implementation type for a packed array, get the orignial
array type. */
if (TYPE_IMPL_PACKED_ARRAY_P (type) && TYPE_ORIGINAL_PACKED_ARRAY (type))
@@ -812,6 +794,8 @@ gnat_get_array_descr_info (const_tree const_type,
type = TYPE_ORIGINAL_PACKED_ARRAY (type);
is_packed_array = true;
}
+ else
+ is_packed_array = false;
/* First pass: gather all information about this array except everything
related to dimensions. */
@@ -823,54 +807,27 @@ gnat_get_array_descr_info (const_tree const_type,
{
is_array = true;
first_dimen = type;
- info->data_location = NULL_TREE;
}
- else if (TYPE_IS_FAT_POINTER_P (type)
- && gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
- {
- const tree ua_type = TYPE_UNCONSTRAINED_ARRAY (type);
-
- /* This will be our base object address. */
- const tree placeholder_expr = build0 (PLACEHOLDER_EXPR, type);
-
- /* We assume below that maybe_unconstrained_array returns an INDIRECT_REF
- node. */
- const tree ua_val
- = maybe_unconstrained_array (build_unary_op (INDIRECT_REF,
- ua_type,
- placeholder_expr));
-
- is_fat_ptr = true;
- first_dimen = TREE_TYPE (ua_val);
-
- /* Get the *address* of the array, not the array itself. */
- info->data_location = TREE_OPERAND (ua_val, 0);
- }
-
- /* Unlike fat pointers (which appear for unconstrained arrays passed in
- argument), thin pointers are used only for array access types, so we want
- them to appear in the debug info as pointers to an array type. That's why
- we match only the RECORD_TYPE here instead of the POINTER_TYPE with the
- TYPE_IS_THIN_POINTER_P predicate. */
+ /* As well as array types embedded in a record type with their bounds. */
else if (TREE_CODE (type) == RECORD_TYPE
&& TYPE_CONTAINS_TEMPLATE_P (type)
&& gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
{
/* This will be our base object address. Note that we assume that
- pointers to these will actually point to the array field (thin
+ pointers to this will actually point to the array field (thin
pointers are shifted). */
- const tree placeholder_expr = build0 (PLACEHOLDER_EXPR, type);
- const tree placeholder_addr
- = build_unary_op (ADDR_EXPR, NULL_TREE, placeholder_expr);
+ tree placeholder_expr = build0 (PLACEHOLDER_EXPR, type);
+ tree placeholder_addr
+ = build_unary_op (ADDR_EXPR, NULL_TREE, placeholder_expr);
- const tree bounds_field = TYPE_FIELDS (type);
- const tree bounds_type = TREE_TYPE (bounds_field);
- const tree array_field = DECL_CHAIN (bounds_field);
- const tree array_type = TREE_TYPE (array_field);
+ tree bounds_field = TYPE_FIELDS (type);
+ tree bounds_type = TREE_TYPE (bounds_field);
+ tree array_field = DECL_CHAIN (bounds_field);
+ tree array_type = TREE_TYPE (array_field);
- /* Shift the thin pointer address to get the address of the template. */
- const tree shift_amount
+ /* Shift back the address to get the address of the template. */
+ tree shift_amount
= fold_build1 (NEGATE_EXPR, sizetype, byte_position (array_field));
tree template_addr
= build_binary_op (POINTER_PLUS_EXPR, TREE_TYPE (placeholder_addr),
@@ -878,46 +835,44 @@ gnat_get_array_descr_info (const_tree const_type,
template_addr
= fold_convert (TYPE_POINTER_TO (bounds_type), template_addr);
- first_dimen = array_type;
-
- /* The thin pointer is already the pointer to the array data, so there's
- no need for a specific "data location" expression. */
- info->data_location = NULL_TREE;
-
- thinptr_template_expr = build_unary_op (INDIRECT_REF,
- bounds_type,
- template_addr);
+ thinptr_template_expr
+ = build_unary_op (INDIRECT_REF, NULL_TREE, template_addr);
thinptr_bound_field = TYPE_FIELDS (bounds_type);
+
+ is_array = false;
+ first_dimen = array_type;
}
+
else
return false;
/* Second pass: compute the remaining information: dimensions and
corresponding bounds. */
- if (TYPE_PACKED (first_dimen))
- is_packed_array = true;
/* If this array has fortran convention, it's arranged in column-major
order, so our view here has reversed dimensions. */
- convention_fortran_p = TYPE_CONVENTION_FORTRAN_P (first_dimen);
+ const bool convention_fortran_p = TYPE_CONVENTION_FORTRAN_P (first_dimen);
+
+ if (TYPE_PACKED (first_dimen))
+ is_packed_array = true;
+
/* ??? For row major ordering, we probably want to emit nothing and
instead specify it as the default in Dw_TAG_compile_unit. */
info->ordering = (convention_fortran_p
? array_descr_ordering_column_major
: array_descr_ordering_row_major);
+ info->rank = NULL_TREE;
- /* Count how many dimensions this array has. */
- for (i = 0, dimen = first_dimen; ; ++i, dimen = TREE_TYPE (dimen))
+ /* Count the number of dimensions and determine the element type. */
+ i = 1;
+ dimen = TREE_TYPE (first_dimen);
+ while (TREE_CODE (dimen) == ARRAY_TYPE && TYPE_MULTI_ARRAY_P (dimen))
{
- if (i > 0
- && (TREE_CODE (dimen) != ARRAY_TYPE
- || !TYPE_MULTI_ARRAY_P (dimen)))
- break;
- last_dimen = dimen;
+ i++;
+ dimen = TREE_TYPE (dimen);
}
-
info->ndimensions = i;
- info->rank = NULL_TREE;
+ info->element_type = dimen;
/* Too many dimensions? Give up generating proper description: yield instead
nested arrays. Note that in this case, this hook is invoked once on each
@@ -927,12 +882,10 @@ gnat_get_array_descr_info (const_tree const_type,
|| TYPE_MULTI_ARRAY_P (first_dimen))
{
info->ndimensions = 1;
- last_dimen = first_dimen;
+ info->element_type = TREE_TYPE (first_dimen);
}
- info->element_type = TREE_TYPE (last_dimen);
-
- /* Now iterate over all dimensions in source-order and fill the info
+ /* Now iterate over all dimensions in source order and fill the info
structure. */
for (i = (convention_fortran_p ? info->ndimensions - 1 : 0),
dimen = first_dimen;
@@ -943,7 +896,7 @@ gnat_get_array_descr_info (const_tree const_type,
/* We are interested in the stored bounds for the debug info. */
tree index_type = TYPE_INDEX_TYPE (TYPE_DOMAIN (dimen));
- if (is_array || is_fat_ptr)
+ if (is_array)
{
/* GDB does not handle very well the self-referencial bound
expressions we are able to generate here for XUA types (they are
@@ -994,6 +947,7 @@ gnat_get_array_descr_info (const_tree const_type,
/* These are Fortran-specific fields. They make no sense here. */
info->allocated = NULL_TREE;
info->associated = NULL_TREE;
+ info->data_location = NULL_TREE;
if (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
{
@@ -1048,6 +1002,9 @@ get_array_bit_stride (tree comp_type)
if (INTEGRAL_TYPE_P (comp_type))
return TYPE_RM_SIZE (comp_type);
+ /* The gnat_get_array_descr_info debug hook expects a debug tyoe. */
+ comp_type = maybe_debug_type (comp_type);
+
/* Otherwise, see if this is an array we can analyze; if it's not, punt. */
memset (&info, 0, sizeof (info));
if (!gnat_get_array_descr_info (comp_type, &info) || !info.stride)
@@ -1185,7 +1142,7 @@ must_pass_by_ref (tree gnu_type)
void
enumerate_modes (void (*f) (const char *, int, int, int, int, int, int, int))
{
- const tree c_types[]
+ tree const c_types[]
= { float_type_node, double_type_node, long_double_type_node };
const char *const c_names[]
= { "float", "double", "long double" };
diff --git a/gcc/ada/gcc-interface/targtyps.c b/gcc/ada/gcc-interface/targtyps.c
index 1a4d33b..9b2d241 100644
--- a/gcc/ada/gcc-interface/targtyps.c
+++ b/gcc/ada/gcc-interface/targtyps.c
@@ -6,7 +6,7 @@
* *
* Body *
* *
- * Copyright (C) 1992-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c
index 5f87bc3..b60b03d 100644
--- a/gcc/ada/gcc-interface/trans.c
+++ b/gcc/ada/gcc-interface/trans.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -871,8 +871,9 @@ lvalue_required_p (Node_Id gnat_node, tree gnu_type, bool constant,
/* ... fall through ... */
+ case N_Selected_Component:
case N_Slice:
- /* Only the array expression can require an lvalue. */
+ /* Only the prefix expression can require an lvalue. */
if (Prefix (gnat_parent) != gnat_node)
return 0;
@@ -880,11 +881,6 @@ lvalue_required_p (Node_Id gnat_node, tree gnu_type, bool constant,
get_unpadded_type (Etype (gnat_parent)),
constant, address_of_constant);
- case N_Selected_Component:
- return lvalue_required_p (gnat_parent,
- get_unpadded_type (Etype (gnat_parent)),
- constant, address_of_constant);
-
case N_Object_Renaming_Declaration:
/* We need to preserve addresses through a renaming. */
return 1;
@@ -925,12 +921,6 @@ lvalue_required_p (Node_Id gnat_node, tree gnu_type, bool constant,
get_unpadded_type (Etype (gnat_parent)),
constant, address_of_constant);
- case N_Allocator:
- /* We should only reach here through the N_Qualified_Expression case.
- Force an lvalue for composite types since a block-copy to the newly
- allocated area of memory is made. */
- return Is_Composite_Type (Underlying_Type (Etype (gnat_node)));
-
case N_Explicit_Dereference:
/* We look through dereferences for address of constant because we need
to handle the special cases listed above. */
@@ -948,6 +938,74 @@ lvalue_required_p (Node_Id gnat_node, tree gnu_type, bool constant,
gcc_unreachable ();
}
+/* Return true if an lvalue should be used for GNAT_NODE. GNU_TYPE is the type
+ that will be used for GNAT_NODE in the translated GNU tree and is assumed to
+ be an aggregate type.
+
+ The function climbs up the GNAT tree starting from the node and returns true
+ upon encountering a node that makes it doable to decide. lvalue_required_p
+ should have been previously invoked on the arguments and returned false. */
+
+static bool
+lvalue_for_aggregate_p (Node_Id gnat_node, tree gnu_type)
+{
+ Node_Id gnat_parent = Parent (gnat_node);
+
+ switch (Nkind (gnat_parent))
+ {
+ case N_Parameter_Association:
+ case N_Function_Call:
+ case N_Procedure_Call_Statement:
+ /* Even if the parameter is by copy, prefer an lvalue. */
+ return true;
+
+ case N_Indexed_Component:
+ case N_Selected_Component:
+ /* If an elementary component is used, take it from the constant. */
+ if (!Is_Composite_Type (Underlying_Type (Etype (gnat_parent))))
+ return false;
+
+ /* ... fall through ... */
+
+ case N_Slice:
+ return lvalue_for_aggregate_p (gnat_parent,
+ get_unpadded_type (Etype (gnat_parent)));
+
+ case N_Object_Declaration:
+ /* For an aggregate object declaration, return the constant at top level
+ in order to avoid generating elaboration code. */
+ if (global_bindings_p ())
+ return false;
+
+ /* ... fall through ... */
+
+ case N_Assignment_Statement:
+ /* For an aggregate assignment, decide based on the size. */
+ {
+ const HOST_WIDE_INT size = int_size_in_bytes (gnu_type);
+ return size < 0 || size >= param_large_stack_frame / 4;
+ }
+
+ case N_Unchecked_Type_Conversion:
+ case N_Type_Conversion:
+ case N_Qualified_Expression:
+ return lvalue_for_aggregate_p (gnat_parent,
+ get_unpadded_type (Etype (gnat_parent)));
+
+ case N_Allocator:
+ /* We should only reach here through the N_Qualified_Expression case.
+ Force an lvalue for aggregate types since a block-copy to the newly
+ allocated area of memory is made. */
+ return true;
+
+ default:
+ return false;
+ }
+
+ gcc_unreachable ();
+}
+
+
/* Return true if T is a constant DECL node that can be safely replaced
by its initializer. */
@@ -1232,7 +1290,9 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
if ((!constant_only || address_of_constant) && require_lvalue < 0)
require_lvalue
= lvalue_required_p (gnat_node, gnu_result_type, true,
- address_of_constant);
+ address_of_constant)
+ || (AGGREGATE_TYPE_P (gnu_result_type)
+ && lvalue_for_aggregate_p (gnat_node, gnu_result_type));
/* Finally retrieve the initializer if this is deemed valid. */
if ((constant_only && !address_of_constant) || !require_lvalue)
@@ -1276,234 +1336,6 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
return gnu_result;
}
-/* If GNAT_EXPR is an N_Identifier, N_Integer_Literal or N_Operator_Symbol,
- call FN on it. If GNAT_EXPR is an aggregate, call FN on each of its
- elements. In both cases, pass GNU_EXPR and DATA as additional arguments.
-
- This function is used everywhere OpenAcc pragmas are processed if these
- pragmas can accept aggregates. */
-
-static tree
-Iterate_Acc_Clause_Arg (Node_Id gnat_expr, tree gnu_expr,
- tree (*fn)(Node_Id, tree, void*),
- void* data)
-{
- switch (Nkind (gnat_expr))
- {
- case N_Aggregate:
- if (Present (Expressions (gnat_expr)))
- {
- for (Node_Id gnat_list_expr = First (Expressions (gnat_expr));
- Present (gnat_list_expr);
- gnat_list_expr = Next (gnat_list_expr))
- gnu_expr = fn (gnat_list_expr, gnu_expr, data);
- }
- else if (Present (Component_Associations (gnat_expr)))
- {
- for (Node_Id gnat_list_expr = First (Component_Associations
- (gnat_expr));
- Present (gnat_list_expr);
- gnat_list_expr = Next (gnat_list_expr))
- gnu_expr = fn (Expression (gnat_list_expr), gnu_expr, data);
- }
- else
- gcc_unreachable ();
- break;
-
- case N_Identifier:
- case N_Integer_Literal:
- case N_Operator_Symbol:
- gnu_expr = fn (gnat_expr, gnu_expr, data);
- break;
-
- default:
- gcc_unreachable ();
- }
-
- return gnu_expr;
-}
-
-/* Same as gnat_to_gnu for a GNAT_NODE referenced within an OpenAcc directive,
- undoing transformations that are inappropriate for such context. */
-
-tree
-Acc_gnat_to_gnu (Node_Id gnat_node)
-{
- tree gnu_result = gnat_to_gnu (gnat_node);
-
- /* If gnat_node is an identifier for a boolean, gnat_to_gnu might have
- turned it into `identifier != 0`. Since arguments to OpenAcc pragmas
- need to be writable, we need to return the identifier residing in such
- expressions rather than the expression itself. */
- if (Nkind (gnat_node) == N_Identifier
- && TREE_CODE (gnu_result) == NE_EXPR
- && TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_result, 0))) == BOOLEAN_TYPE
- && integer_zerop (TREE_OPERAND (gnu_result, 1)))
- gnu_result = TREE_OPERAND (gnu_result, 0);
-
- return gnu_result;
-}
-
-/* Turn GNAT_EXPR into a tree node representing an OMP data clause and chain
- it to GNU_CLAUSES, a list of pre-existing OMP clauses. GNAT_EXPR should be
- a N_Identifier, this is enforced by the frontend.
-
- This function is called every time translation of an argument for an OpenAcc
- clause (e.g. Acc_Parallel(Copy => My_Identifier)) is needed. */
-
-static tree
-Acc_Data_to_gnu (Node_Id gnat_expr, tree gnu_clauses, void* data)
-{
- const enum gomp_map_kind kind = *((enum gomp_map_kind*) data);
- tree gnu_clause
- = build_omp_clause (EXPR_LOCATION(gnu_loop_stack->last ()->stmt),
- OMP_CLAUSE_MAP);
-
- gcc_assert (Nkind (gnat_expr) == N_Identifier);
- OMP_CLAUSE_DECL (gnu_clause)
- = gnat_to_gnu_entity (Entity (gnat_expr), NULL_TREE, false);
-
- TREE_ADDRESSABLE (OMP_CLAUSE_DECL (gnu_clause)) = 1;
- OMP_CLAUSE_SET_MAP_KIND (gnu_clause, kind);
- OMP_CLAUSE_CHAIN (gnu_clause) = gnu_clauses;
-
- return gnu_clause;
-}
-
-/* Turn GNAT_EXPR into a tree node representing an OMP clause and chain it to
- GNU_CLAUSES, a list of existing OMP clauses.
-
- This function is used for parsing arguments of non-data clauses (e.g.
- Acc_Parallel(Wait => gnatexpr)). */
-
-static tree
-Acc_Var_to_gnu (Node_Id gnat_expr, tree gnu_clauses, void* data)
-{
- const enum omp_clause_code kind = *((enum omp_clause_code*) data);
- tree gnu_clause
- = build_omp_clause (EXPR_LOCATION (gnu_loop_stack->last ()->stmt), kind);
-
- OMP_CLAUSE_DECL (gnu_clause) = Acc_gnat_to_gnu (gnat_expr);
- OMP_CLAUSE_CHAIN (gnu_clause) = gnu_clauses;
-
- return gnu_clause;
-}
-
-/* Turn GNAT_EXPR into a tree OMP clause representing a reduction clause.
- GNAT_EXPR has to be a N_Identifier, this is enforced by the frontend.
-
- For example, GNAT_EXPR could be My_Identifier in the following pragma:
- Acc_Parallel(Reduction => ("+" => My_Identifier)). */
-
-static tree
-Acc_Reduc_Var_to_gnu (Node_Id gnat_expr, tree gnu_clauses, void* data)
-{
- const tree_code code = *((tree_code*) data);
- tree gnu_clause
- = build_omp_clause (EXPR_LOCATION (gnu_loop_stack->last ()->stmt),
- OMP_CLAUSE_REDUCTION);
-
- OMP_CLAUSE_DECL (gnu_clause) = Acc_gnat_to_gnu (gnat_expr);
- OMP_CLAUSE_REDUCTION_CODE (gnu_clause) = code;
- OMP_CLAUSE_CHAIN (gnu_clause) = gnu_clauses;
-
- return gnu_clause;
-}
-
-/* Turn GNAT_EXPR into a list of OMP reduction clauses. GNAT_EXPR has to
- follow the structure of a reduction clause, e.g. ("+" => Identifier). */
-
-static tree
-Acc_Reduc_to_gnu (Node_Id gnat_expr)
-{
- tree gnu_clauses = NULL_TREE;
-
- for (Node_Id gnat_op = First (Component_Associations (gnat_expr));
- Present (gnat_op);
- gnat_op = Next (gnat_op))
- {
- tree_code code = ERROR_MARK;
- String_Id str = Strval (First (Choices (gnat_op)));
- switch (Get_String_Char (str, 1))
- {
- case '+':
- code = PLUS_EXPR;
- break;
- case '*':
- code = MULT_EXPR;
- break;
- case 'm':
- if (Get_String_Char (str, 2) == 'i'
- && Get_String_Char (str, 3) == 'n')
- code = MIN_EXPR;
- else if (Get_String_Char (str, 2) == 'a'
- && Get_String_Char (str, 3) == 'x')
- code = MAX_EXPR;
- break;
- case 'a':
- if (Get_String_Char (str, 2) == 'n'
- && Get_String_Char (str, 3) == 'd')
- code = TRUTH_ANDIF_EXPR;
- break;
- case 'o':
- if (Get_String_Char (str, 2) == 'r')
- code = TRUTH_ORIF_EXPR;
- break;
- default:
- gcc_unreachable ();
- }
-
- /* Unsupported reduction operation. This should have been
- caught in sem_prag.adb. */
- gcc_assert (code != ERROR_MARK);
-
- gnu_clauses = Iterate_Acc_Clause_Arg (Expression (gnat_op),
- gnu_clauses,
- Acc_Reduc_Var_to_gnu,
- &code);
- }
-
- return gnu_clauses;
-}
-
-/* Turn GNAT_EXPR, either '*' or an integer literal, into a tree_cons. This is
- only used by Acc_Size_List_to_gnu. */
-
-static tree
-Acc_Size_Expr_to_gnu (Node_Id gnat_expr, tree gnu_clauses, void *)
-{
- tree gnu_expr;
-
- if (Nkind (gnat_expr) == N_Operator_Symbol
- && Get_String_Char (Strval (gnat_expr), 1) == '*')
- gnu_expr = integer_zero_node;
- else
- gnu_expr = Acc_gnat_to_gnu (gnat_expr);
-
- return tree_cons (NULL_TREE, gnu_expr, gnu_clauses);
-}
-
-/* Turn GNAT_EXPR, an aggregate of either '*' or integer literals, into an OMP
- clause node.
-
- This function is used for the Tile clause of the Loop directive. This is
- what GNAT_EXPR might look like: (1, 1, '*'). */
-
-static tree
-Acc_Size_List_to_gnu (Node_Id gnat_expr)
-{
- tree gnu_clause
- = build_omp_clause (EXPR_LOCATION (gnu_loop_stack->last ()->stmt),
- OMP_CLAUSE_TILE);
- tree gnu_list = Iterate_Acc_Clause_Arg (gnat_expr, NULL_TREE,
- Acc_Size_Expr_to_gnu,
- NULL);
-
- OMP_CLAUSE_TILE_LIST (gnu_clause) = nreverse (gnu_list);
-
- return gnu_clause;
-}
-
/* Subroutine of gnat_to_gnu to process gnat_node, an N_Pragma. Return
any statements we generate. */
@@ -1575,279 +1407,6 @@ Pragma_to_gnu (Node_Id gnat_node)
}
break;
- case Pragma_Acc_Loop:
- {
- if (!flag_openacc)
- break;
-
- tree gnu_clauses = gnu_loop_stack->last ()->omp_loop_clauses;
-
- if (!Present (Pragma_Argument_Associations (gnat_node)))
- break;
-
- for (gnat_temp = First (Pragma_Argument_Associations (gnat_node));
- Present (gnat_temp);
- gnat_temp = Next (gnat_temp))
- {
- Node_Id gnat_expr = Expression (gnat_temp);
- tree gnu_clause = NULL_TREE;
- enum omp_clause_code kind;
-
- if (Chars (gnat_temp) == No_Name)
- {
- /* The clause is an identifier without a parameter. */
- switch (Chars (gnat_expr))
- {
- case Name_Auto:
- kind = OMP_CLAUSE_AUTO;
- break;
- case Name_Gang:
- kind = OMP_CLAUSE_GANG;
- break;
- case Name_Independent:
- kind = OMP_CLAUSE_INDEPENDENT;
- break;
- case Name_Seq:
- kind = OMP_CLAUSE_SEQ;
- break;
- case Name_Vector:
- kind = OMP_CLAUSE_VECTOR;
- break;
- case Name_Worker:
- kind = OMP_CLAUSE_WORKER;
- break;
- default:
- gcc_unreachable ();
- }
- gnu_clause = build_omp_clause (EXPR_LOCATION
- (gnu_loop_stack->last ()->stmt),
- kind);
- }
- else
- {
- /* The clause is an identifier parameter(s). */
- switch (Chars (gnat_temp))
- {
- case Name_Collapse:
- gnu_clause = build_omp_clause
- (EXPR_LOCATION (gnu_loop_stack->last ()->stmt),
- OMP_CLAUSE_COLLAPSE);
- OMP_CLAUSE_COLLAPSE_EXPR (gnu_clause) =
- Acc_gnat_to_gnu (gnat_expr);
- break;
- case Name_Device_Type:
- /* Unimplemented by GCC yet. */
- gcc_unreachable ();
- break;
- case Name_Independent:
- gnu_clause = build_omp_clause
- (EXPR_LOCATION (gnu_loop_stack->last ()->stmt),
- OMP_CLAUSE_INDEPENDENT);
- break;
- case Name_Acc_Private:
- kind = OMP_CLAUSE_PRIVATE;
- gnu_clause = Iterate_Acc_Clause_Arg (gnat_expr, 0,
- Acc_Var_to_gnu,
- &kind);
- break;
- case Name_Reduction:
- gnu_clause = Acc_Reduc_to_gnu (gnat_expr);
- break;
- case Name_Tile:
- gnu_clause = Acc_Size_List_to_gnu (gnat_expr);
- break;
- case Name_Gang:
- case Name_Vector:
- case Name_Worker:
- /* These are for the Loop+Kernel combination, which is
- unimplemented by the frontend for now. */
- default:
- gcc_unreachable ();
- }
- }
- OMP_CLAUSE_CHAIN (gnu_clause) = gnu_clauses;
- gnu_clauses = gnu_clause;
- }
- gnu_loop_stack->last ()->omp_loop_clauses = gnu_clauses;
- }
- break;
-
- /* Grouping the transformation of these pragmas together makes sense
- because they are mutually exclusive, share most of their clauses and
- the verification that each clause can legally appear for the pragma has
- been done in the frontend. */
- case Pragma_Acc_Data:
- case Pragma_Acc_Kernels:
- case Pragma_Acc_Parallel:
- {
- if (!flag_openacc)
- break;
-
- tree gnu_clauses = gnu_loop_stack->last ()->omp_construct_clauses;
- if (id == Pragma_Acc_Data)
- gnu_loop_stack->last ()->omp_code = OACC_DATA;
- else if (id == Pragma_Acc_Kernels)
- gnu_loop_stack->last ()->omp_code = OACC_KERNELS;
- else if (id == Pragma_Acc_Parallel)
- gnu_loop_stack->last ()->omp_code = OACC_PARALLEL;
- else
- gcc_unreachable ();
-
- if (!Present (Pragma_Argument_Associations (gnat_node)))
- break;
-
- for (gnat_temp = First (Pragma_Argument_Associations (gnat_node));
- Present (gnat_temp);
- gnat_temp = Next (gnat_temp))
- {
- Node_Id gnat_expr = Expression (gnat_temp);
- tree gnu_clause;
- enum omp_clause_code clause_code;
- enum gomp_map_kind map_kind;
-
- switch (Chars (gnat_temp))
- {
- case Name_Async:
- gnu_clause = build_omp_clause
- (EXPR_LOCATION (gnu_loop_stack->last ()->stmt),
- OMP_CLAUSE_ASYNC);
- OMP_CLAUSE_ASYNC_EXPR (gnu_clause) =
- Acc_gnat_to_gnu (gnat_expr);
- OMP_CLAUSE_CHAIN (gnu_clause) = gnu_clauses;
- gnu_clauses = gnu_clause;
- break;
-
- case Name_Num_Gangs:
- gnu_clause = build_omp_clause
- (EXPR_LOCATION (gnu_loop_stack->last ()->stmt),
- OMP_CLAUSE_NUM_GANGS);
- OMP_CLAUSE_NUM_GANGS_EXPR (gnu_clause) =
- Acc_gnat_to_gnu (gnat_expr);
- OMP_CLAUSE_CHAIN (gnu_clause) = gnu_clauses;
- gnu_clauses = gnu_clause;
- break;
-
- case Name_Num_Workers:
- gnu_clause = build_omp_clause
- (EXPR_LOCATION (gnu_loop_stack->last ()->stmt),
- OMP_CLAUSE_NUM_WORKERS);
- OMP_CLAUSE_NUM_WORKERS_EXPR (gnu_clause) =
- Acc_gnat_to_gnu (gnat_expr);
- OMP_CLAUSE_CHAIN (gnu_clause) = gnu_clauses;
- gnu_clauses = gnu_clause;
- break;
-
- case Name_Vector_Length:
- gnu_clause = build_omp_clause
- (EXPR_LOCATION (gnu_loop_stack->last ()->stmt),
- OMP_CLAUSE_VECTOR_LENGTH);
- OMP_CLAUSE_VECTOR_LENGTH_EXPR (gnu_clause) =
- Acc_gnat_to_gnu (gnat_expr);
- OMP_CLAUSE_CHAIN (gnu_clause) = gnu_clauses;
- gnu_clauses = gnu_clause;
- break;
-
- case Name_Wait:
- clause_code = OMP_CLAUSE_WAIT;
- gnu_clauses = Iterate_Acc_Clause_Arg (gnat_expr, gnu_clauses,
- Acc_Var_to_gnu,
- &clause_code);
- break;
-
- case Name_Acc_If:
- gnu_clause = build_omp_clause (EXPR_LOCATION
- (gnu_loop_stack->last ()->stmt),
- OMP_CLAUSE_IF);
- OMP_CLAUSE_IF_MODIFIER (gnu_clause) = ERROR_MARK;
- OMP_CLAUSE_IF_EXPR (gnu_clause) = Acc_gnat_to_gnu (gnat_expr);
- OMP_CLAUSE_CHAIN (gnu_clause) = gnu_clauses;
- gnu_clauses = gnu_clause;
- break;
-
- case Name_Copy:
- map_kind = GOMP_MAP_FORCE_TOFROM;
- gnu_clauses = Iterate_Acc_Clause_Arg (gnat_expr, gnu_clauses,
- Acc_Data_to_gnu,
- &map_kind);
- break;
-
- case Name_Copy_In:
- map_kind = GOMP_MAP_FORCE_TO;
- gnu_clauses = Iterate_Acc_Clause_Arg (gnat_expr, gnu_clauses,
- Acc_Data_to_gnu,
- &map_kind);
- break;
-
- case Name_Copy_Out:
- map_kind = GOMP_MAP_FORCE_FROM;
- gnu_clauses = Iterate_Acc_Clause_Arg (gnat_expr, gnu_clauses,
- Acc_Data_to_gnu,
- &map_kind);
- break;
-
- case Name_Present:
- map_kind = GOMP_MAP_FORCE_PRESENT;
- gnu_clauses = Iterate_Acc_Clause_Arg (gnat_expr, gnu_clauses,
- Acc_Data_to_gnu,
- &map_kind);
- break;
-
- case Name_Create:
- map_kind = GOMP_MAP_FORCE_ALLOC;
- gnu_clauses = Iterate_Acc_Clause_Arg (gnat_expr, gnu_clauses,
- Acc_Data_to_gnu,
- &map_kind);
- break;
-
- case Name_Device_Ptr:
- map_kind = GOMP_MAP_FORCE_DEVICEPTR;
- gnu_clauses = Iterate_Acc_Clause_Arg (gnat_expr, gnu_clauses,
- Acc_Data_to_gnu,
- &map_kind);
- break;
-
- case Name_Acc_Private:
- clause_code = OMP_CLAUSE_PRIVATE;
- gnu_clauses = Iterate_Acc_Clause_Arg (gnat_expr, gnu_clauses,
- Acc_Var_to_gnu,
- &clause_code);
- break;
-
- case Name_First_Private:
- clause_code = OMP_CLAUSE_FIRSTPRIVATE;
- gnu_clauses = Iterate_Acc_Clause_Arg (gnat_expr, gnu_clauses,
- Acc_Var_to_gnu,
- &clause_code);
- break;
-
- case Name_Default:
- gnu_clause = build_omp_clause (EXPR_LOCATION
- (gnu_loop_stack->last ()->stmt),
- OMP_CLAUSE_DEFAULT);
- OMP_CLAUSE_CHAIN (gnu_clause) = gnu_clauses;
- /* The standard also accepts "present" but this isn't
- implemented in GCC yet. */
- OMP_CLAUSE_DEFAULT_KIND (gnu_clause) = OMP_CLAUSE_DEFAULT_NONE;
- OMP_CLAUSE_CHAIN (gnu_clause) = gnu_clauses;
- gnu_clauses = gnu_clause;
- break;
-
- case Name_Reduction:
- gnu_clauses = Acc_Reduc_to_gnu(gnat_expr);
- break;
-
- case Name_Detach:
- case Name_Attach:
- case Name_Device_Type:
- /* Unimplemented by GCC. */
- default:
- gcc_unreachable ();
- }
- }
- gnu_loop_stack->last ()->omp_construct_clauses = gnu_clauses;
- }
- break;
-
case Pragma_Loop_Optimize:
for (gnat_temp = First (Pragma_Argument_Associations (gnat_node));
Present (gnat_temp);
@@ -2242,6 +1801,9 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
case Attr_Access:
case Attr_Unchecked_Access:
case Attr_Code_Address:
+ /* Taking the address of a type does not make sense. */
+ gcc_assert (TREE_CODE (gnu_prefix) != TYPE_DECL);
+
gnu_result_type = get_unpadded_type (Etype (gnat_node));
gnu_result
= build_unary_op (((attribute == Attr_Address
@@ -2893,10 +2455,6 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
break;
case Attr_Component_Size:
- if (TREE_CODE (gnu_prefix) == COMPONENT_REF
- && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))))
- gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
-
gnu_prefix = maybe_implicit_deref (gnu_prefix);
gnu_type = TREE_TYPE (gnu_prefix);
@@ -2934,7 +2492,6 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
= build_unary_op (INDIRECT_REF, NULL_TREE,
convert (build_pointer_type (gnu_result_type),
integer_zero_node));
- TREE_PRIVATE (gnu_result) = 1;
break;
case Attr_Mechanism_Code:
@@ -3404,148 +2961,6 @@ independent_iterations_p (tree stmt_list)
return true;
}
-/* Helper for Loop_Statement_to_gnu to translate the body of a loop,
- designated by GNAT_LOOP, to which an Acc_Loop pragma applies. The pragma
- arguments might instruct us to collapse a nest of loops, where computation
- statements are expected only within the innermost loop, as in:
-
- for I in 1 .. 5 loop
- pragma Acc_Parallel;
- pragma Acc_Loop(Collapse => 3);
- for J in 1 .. 8 loop
- for K in 1 .. 4 loop
- X (I, J, K) := Y (I, J, K) + 2;
- end loop;
- end loop;
- end loop;
-
- We expect the top of gnu_loop_stack to hold a pointer to the loop info
- setup for the translation of GNAT_LOOP, which holds a pointer to the
- initial gnu loop stmt node. We return the new gnu loop statement to
- use. */
-
-static tree
-Acc_Loop_to_gnu (Node_Id gnat_loop)
-{
- tree acc_loop = make_node (OACC_LOOP);
- tree acc_bind_expr = NULL_TREE;
- Node_Id cur_loop = gnat_loop;
- int collapse_count = 1;
- tree initv;
- tree condv;
- tree incrv;
-
- /* Parse the pragmas, adding clauses to the current gnu_loop_stack through
- side effects. */
- for (Node_Id tmp = First (Statements (gnat_loop));
- Present (tmp) && Nkind (tmp) == N_Pragma;
- tmp = Next (tmp))
- Pragma_to_gnu(tmp);
-
- /* Find the number of loops that should be collapsed. */
- for (tree tmp = gnu_loop_stack->last ()->omp_loop_clauses; tmp ;
- tmp = OMP_CLAUSE_CHAIN (tmp))
- if (OMP_CLAUSE_CODE (tmp) == OMP_CLAUSE_COLLAPSE)
- collapse_count = tree_to_shwi (OMP_CLAUSE_COLLAPSE_EXPR (tmp));
- else if (OMP_CLAUSE_CODE (tmp) == OMP_CLAUSE_TILE)
- collapse_count = list_length (OMP_CLAUSE_TILE_LIST (tmp));
-
- initv = make_tree_vec (collapse_count);
- condv = make_tree_vec (collapse_count);
- incrv = make_tree_vec (collapse_count);
-
- start_stmt_group ();
- gnat_pushlevel ();
-
- /* For each nested loop that should be collapsed ... */
- for (int count = 0; count < collapse_count; ++count)
- {
- Node_Id lps =
- Loop_Parameter_Specification (Iteration_Scheme (cur_loop));
- tree low =
- Acc_gnat_to_gnu (Low_Bound (Discrete_Subtype_Definition (lps)));
- tree high =
- Acc_gnat_to_gnu (High_Bound (Discrete_Subtype_Definition (lps)));
- tree variable =
- gnat_to_gnu_entity (Defining_Identifier (lps), NULL_TREE, true);
-
- /* Build the initial value of the variable of the invariant. */
- TREE_VEC_ELT (initv, count) = build2 (MODIFY_EXPR,
- TREE_TYPE (variable),
- variable,
- low);
- add_stmt (TREE_VEC_ELT (initv, count));
-
- /* Build the invariant of the loop. */
- TREE_VEC_ELT (condv, count) = build2 (LE_EXPR,
- boolean_type_node,
- variable,
- high);
-
- /* Build the incrementation expression of the loop. */
- TREE_VEC_ELT (incrv, count) =
- build2 (MODIFY_EXPR,
- TREE_TYPE (variable),
- variable,
- build2 (PLUS_EXPR,
- TREE_TYPE (variable),
- variable,
- build_int_cst (TREE_TYPE (variable), 1)));
-
- /* Don't process the innermost loop because its statements belong to
- another statement group. */
- if (count < collapse_count - 1)
- /* Process the current loop's body. */
- for (Node_Id stmt = First (Statements (cur_loop));
- Present (stmt); stmt = Next (stmt))
- {
- /* If we are processsing the outermost loop, it is ok for it to
- contain pragmas. */
- if (Nkind (stmt) == N_Pragma && count == 0)
- ;
- /* The frontend might have inserted a N_Object_Declaration in the
- loop's body to declare the iteration variable of the next loop.
- It will need to be hoisted before the collapsed loops. */
- else if (Nkind (stmt) == N_Object_Declaration)
- Acc_gnat_to_gnu (stmt);
- else if (Nkind (stmt) == N_Loop_Statement)
- cur_loop = stmt;
- /* Every other kind of statement is prohibited in collapsed
- loops. */
- else if (count < collapse_count - 1)
- gcc_unreachable();
- }
- }
- gnat_poplevel ();
- acc_bind_expr = end_stmt_group ();
-
- /* Parse the innermost loop. */
- start_stmt_group();
- for (Node_Id stmt = First (Statements (cur_loop));
- Present (stmt);
- stmt = Next (stmt))
- {
- /* When the innermost loop is the only loop, do not parse the pragmas
- again. */
- if (Nkind (stmt) == N_Pragma && collapse_count == 1)
- continue;
- add_stmt (Acc_gnat_to_gnu (stmt));
- }
-
- TREE_TYPE (acc_loop) = void_type_node;
- OMP_FOR_INIT (acc_loop) = initv;
- OMP_FOR_COND (acc_loop) = condv;
- OMP_FOR_INCR (acc_loop) = incrv;
- OMP_FOR_BODY (acc_loop) = end_stmt_group ();
- OMP_FOR_PRE_BODY (acc_loop) = NULL;
- OMP_FOR_ORIG_DECLS (acc_loop) = NULL;
- OMP_FOR_CLAUSES (acc_loop) = gnu_loop_stack->last ()->omp_loop_clauses;
-
- BIND_EXPR_BODY (acc_bind_expr) = acc_loop;
-
- return acc_bind_expr;
-}
-
/* Helper for Loop_Statement_to_gnu, to translate the body of a loop not
subject to any sort of parallelization directive or restriction, designated
by GNAT_NODE.
@@ -3945,34 +3360,7 @@ Loop_Statement_to_gnu (Node_Id gnat_node)
gnu_loop_info->stmt = gnu_loop_stmt;
/* Perform the core loop body translation. */
- if (Is_OpenAcc_Loop (gnat_node))
- gnu_loop_stmt = Acc_Loop_to_gnu (gnat_node);
- else
- gnu_loop_stmt = Regular_Loop_to_gnu (gnat_node, &gnu_cond_expr);
-
- /* A gnat_node that has its OpenAcc_Environment flag set needs to be
- offloaded. Note that the OpenAcc_Loop flag is not necessarily set. */
- if (Is_OpenAcc_Environment (gnat_node))
- {
- tree_code code = gnu_loop_stack->last ()->omp_code;
- tree tmp = make_node (code);
- TREE_TYPE (tmp) = void_type_node;
- if (code == OACC_PARALLEL || code == OACC_KERNELS)
- {
- OMP_BODY (tmp) = gnu_loop_stmt;
- OMP_CLAUSES (tmp) = gnu_loop_stack->last ()->omp_construct_clauses;
- }
- else if (code == OACC_DATA)
- {
- OACC_DATA_BODY (tmp) = gnu_loop_stmt;
- OACC_DATA_CLAUSES (tmp) =
- gnu_loop_stack->last ()->omp_construct_clauses;
- }
- else
- gcc_unreachable();
- set_expr_location_from_node (tmp, gnat_node);
- gnu_loop_stmt = tmp;
- }
+ gnu_loop_stmt = Regular_Loop_to_gnu (gnat_node, &gnu_cond_expr);
/* If we have an outer COND_EXPR, that's our result and this loop is its
"true" statement. Otherwise, the result is the LOOP_STMT. */
@@ -5468,8 +4856,6 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
/* Otherwise the parameter is passed by copy. */
else
{
- tree gnu_size;
-
if (!in_param)
gnu_name_list = tree_cons (NULL_TREE, gnu_name, gnu_name_list);
@@ -5490,25 +4876,9 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
gnu_actual = convert (gnu_formal_type, gnu_actual);
- /* If this is 'Null_Parameter, pass a zero even though we are
- dereferencing it. */
- if (TREE_CODE (gnu_actual) == INDIRECT_REF
- && TREE_PRIVATE (gnu_actual)
- && (gnu_size = TYPE_SIZE (TREE_TYPE (gnu_actual)))
- && TREE_CODE (gnu_size) == INTEGER_CST
- && compare_tree_int (gnu_size, BITS_PER_WORD) <= 0)
- {
- tree type_for_size
- = gnat_type_for_size (TREE_INT_CST_LOW (gnu_size), 1);
- gnu_actual
- = unchecked_convert (DECL_ARG_TYPE (gnu_formal),
- build_int_cst (type_for_size, 0),
- false);
- }
-
/* If this is a front-end built-in function, there is no need to
convert to the type used to pass the argument. */
- else if (!frontend_builtin)
+ if (!frontend_builtin)
gnu_actual = convert (DECL_ARG_TYPE (gnu_formal), gnu_actual);
}
@@ -5630,11 +5000,8 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
tree gnu_actual
= maybe_unconstrained_array (TREE_VALUE (gnu_name_list));
- /* If the result is a padded type, remove the padding. */
- if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
- gnu_result
- = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
- gnu_result);
+ /* If the result is padded, remove the padding. */
+ gnu_result = maybe_padded_object (gnu_result);
/* If the actual is a type conversion, the real target object is
denoted by the inner Expression and we need to convert the
@@ -6501,13 +5868,14 @@ static tree
Raise_Error_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
{
const Node_Kind kind = Nkind (gnat_node);
- const int reason = UI_To_Int (Reason (gnat_node));
const Node_Id gnat_cond = Condition (gnat_node);
+ const int reason = UI_To_Int (Reason (gnat_node));
const bool with_extra_info
= Exception_Extra_Info
&& !No_Exception_Handlers_Set ()
&& No (get_exception_label (kind));
tree gnu_result = NULL_TREE, gnu_cond = NULL_TREE;
+ Node_Id gnat_rcond;
/* The following processing is not required for correctness. Its purpose is
to give more precise error messages and to record some information. */
@@ -6521,51 +5889,51 @@ Raise_Error_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
case CE_Index_Check_Failed:
case CE_Range_Check_Failed:
case CE_Invalid_Data:
- if (Present (gnat_cond) && Nkind (gnat_cond) == N_Op_Not)
+ if (No (gnat_cond) || Nkind (gnat_cond) != N_Op_Not)
+ break;
+ gnat_rcond = Right_Opnd (gnat_cond);
+ if (Nkind (gnat_rcond) == N_In
+ || Nkind (gnat_rcond) == N_Op_Ge
+ || Nkind (gnat_rcond) == N_Op_Le)
{
- Node_Id gnat_index, gnat_type;
- tree gnu_type, gnu_index, gnu_low_bound, gnu_high_bound, disp;
- bool neg_p;
+ const Node_Id gnat_index = Left_Opnd (gnat_rcond);
+ const Node_Id gnat_type = Etype (gnat_index);
+ tree gnu_index = gnat_to_gnu (gnat_index);
+ tree gnu_type = get_unpadded_type (gnat_type);
+ tree gnu_low_bound, gnu_high_bound, disp;
struct loop_info_d *loop;
+ bool neg_p;
- switch (Nkind (Right_Opnd (gnat_cond)))
+ switch (Nkind (gnat_rcond))
{
case N_In:
- Range_to_gnu (Right_Opnd (Right_Opnd (gnat_cond)),
+ Range_to_gnu (Right_Opnd (gnat_rcond),
&gnu_low_bound, &gnu_high_bound);
break;
case N_Op_Ge:
- gnu_low_bound = gnat_to_gnu (Right_Opnd (Right_Opnd (gnat_cond)));
- gnu_high_bound = NULL_TREE;
+ gnu_low_bound = gnat_to_gnu (Right_Opnd (gnat_rcond));
+ gnu_high_bound = TYPE_MAX_VALUE (gnu_type);
break;
case N_Op_Le:
- gnu_low_bound = NULL_TREE;
- gnu_high_bound = gnat_to_gnu (Right_Opnd (Right_Opnd (gnat_cond)));
+ gnu_low_bound = TYPE_MIN_VALUE (gnu_type);
+ gnu_high_bound = gnat_to_gnu (Right_Opnd (gnat_rcond));
break;
default:
- goto common;
+ gcc_unreachable ();
}
- gnat_index = Left_Opnd (Right_Opnd (gnat_cond));
- gnat_type = Etype (gnat_index);
- gnu_type = maybe_character_type (get_unpadded_type (gnat_type));
- gnu_index = gnat_to_gnu (gnat_index);
-
+ gnu_type = maybe_character_type (gnu_type);
if (TREE_TYPE (gnu_index) != gnu_type)
{
- if (gnu_low_bound)
- gnu_low_bound = convert (gnu_type, gnu_low_bound);
- if (gnu_high_bound)
- gnu_high_bound = convert (gnu_type, gnu_high_bound);
+ gnu_low_bound = convert (gnu_type, gnu_low_bound);
+ gnu_high_bound = convert (gnu_type, gnu_high_bound);
gnu_index = convert (gnu_type, gnu_index);
}
if (with_extra_info
- && gnu_low_bound
- && gnu_high_bound
&& Known_Esize (gnat_type)
&& UI_To_Int (Esize (gnat_type)) <= 32)
gnu_result
@@ -6630,8 +5998,8 @@ Raise_Error_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
break;
}
- /* The following processing does the common work. */
-common:
+ /* The following processing does the real work, but we must nevertheless make
+ sure not to override the result of the previous processing. */
if (!gnu_result)
gnu_result = build_call_raise (reason, gnat_node, kind);
set_expr_location_from_node (gnu_result, gnat_node);
@@ -6958,19 +6326,15 @@ gnat_to_gnu (Node_Id gnat_node)
int i;
char *string;
if (length >= ALLOCA_THRESHOLD)
- string = XNEWVEC (char, length + 1);
+ string = XNEWVEC (char, length);
else
- string = (char *) alloca (length + 1);
+ string = (char *) alloca (length);
/* Build the string with the characters in the literal. Note
that Ada strings are 1-origin. */
for (i = 0; i < length; i++)
string[i] = Get_String_Char (gnat_string, i + 1);
- /* Put a null at the end of the string in case it's in a context
- where GCC will want to treat it as a C string. */
- string[i] = 0;
-
gnu_result = build_string (length, string);
/* Strings in GCC don't normally have types, but we want
@@ -7198,6 +6562,7 @@ gnat_to_gnu (Node_Id gnat_node)
Node_Id *gnat_expr_array;
gnu_array_object = maybe_implicit_deref (gnu_array_object);
+ gnu_array_object = maybe_unconstrained_array (gnu_array_object);
/* Convert vector inputs to their representative array type, to fit
what the code below expects. */
@@ -7208,14 +6573,6 @@ gnat_to_gnu (Node_Id gnat_node)
gnu_array_object = maybe_vector_array (gnu_array_object);
}
- gnu_array_object = maybe_unconstrained_array (gnu_array_object);
-
- /* If we got a padded type, remove it too. */
- if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_array_object)))
- gnu_array_object
- = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_array_object))),
- gnu_array_object);
-
/* The failure of this assertion will very likely come from a missing
expansion for a packed array access. */
gcc_assert (TREE_CODE (TREE_TYPE (gnu_array_object)) == ARRAY_TYPE);
@@ -7849,25 +7206,29 @@ gnat_to_gnu (Node_Id gnat_node)
else
{
const Node_Id gnat_expr = Expression (gnat_node);
+ const Node_Id gnat_inner
+ = Nkind (gnat_expr) == N_Qualified_Expression
+ ? Expression (gnat_expr)
+ : gnat_expr;
const Entity_Id gnat_type
= Underlying_Type (Etype (Name (gnat_node)));
const bool regular_array_type_p
- = (Is_Array_Type (gnat_type) && !Is_Bit_Packed_Array (gnat_type));
+ = Is_Array_Type (gnat_type) && !Is_Bit_Packed_Array (gnat_type);
const bool use_memset_p
- = (regular_array_type_p
- && Nkind (gnat_expr) == N_Aggregate
- && Is_Others_Aggregate (gnat_expr));
+ = regular_array_type_p
+ && Nkind (gnat_inner) == N_Aggregate
+ && Is_Single_Aggregate (gnat_inner);
- /* If we'll use memset, we need to find the inner expression. */
+ /* If we use memset, we need to find the innermost expression. */
if (use_memset_p)
{
- Node_Id gnat_inner
- = Expression (First (Component_Associations (gnat_expr)));
- while (Nkind (gnat_inner) == N_Aggregate
- && Is_Others_Aggregate (gnat_inner))
- gnat_inner
- = Expression (First (Component_Associations (gnat_inner)));
- gnu_rhs = gnat_to_gnu (gnat_inner);
+ gnat_temp = gnat_inner;
+ do {
+ gnat_temp
+ = Expression (First (Component_Associations (gnat_temp)));
+ } while (Nkind (gnat_temp) == N_Aggregate
+ && Is_Single_Aggregate (gnat_temp));
+ gnu_rhs = gnat_to_gnu (gnat_temp);
}
else
gnu_rhs = maybe_unconstrained_array (gnat_to_gnu (gnat_expr));
@@ -8727,8 +8088,9 @@ gnat_to_gnu (Node_Id gnat_node)
|| kind == N_Indexed_Component
|| kind == N_Selected_Component)
&& TREE_CODE (get_base_type (gnu_result_type)) == BOOLEAN_TYPE
- && !lvalue_required_p (gnat_node, gnu_result_type, false, false)
- && Nkind (Parent (gnat_node)) != N_Variant_Part)
+ && Nkind (Parent (gnat_node)) != N_Attribute_Reference
+ && Nkind (Parent (gnat_node)) != N_Variant_Part
+ && !lvalue_required_p (gnat_node, gnu_result_type, false, false))
{
gnu_result
= build_binary_op (NE_EXPR, gnu_result_type,
@@ -8789,7 +8151,8 @@ gnat_to_gnu (Node_Id gnat_node)
1. If this is the LHS of an assignment or an actual parameter of a
call, return the result almost unmodified since the RHS will have
to be converted to our type in that case, unless the result type
- has a simpler size. Likewise if there is just a no-op unchecked
+ has a simpler size or for array types because this size might be
+ changed in-between. Likewise if there is just a no-op unchecked
conversion in-between. Similarly, don't convert integral types
that are the operands of an unchecked conversion since we need
to ignore those conversions (for 'Valid).
@@ -8824,15 +8187,17 @@ gnat_to_gnu (Node_Id gnat_node)
&& !AGGREGATE_TYPE_P (TREE_TYPE (gnu_result))))
&& !(TYPE_SIZE (gnu_result_type)
&& TYPE_SIZE (TREE_TYPE (gnu_result))
- && (AGGREGATE_TYPE_P (gnu_result_type)
- == AGGREGATE_TYPE_P (TREE_TYPE (gnu_result)))
+ && AGGREGATE_TYPE_P (gnu_result_type)
+ == AGGREGATE_TYPE_P (TREE_TYPE (gnu_result))
&& ((TREE_CODE (TYPE_SIZE (gnu_result_type)) == INTEGER_CST
&& (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_result)))
!= INTEGER_CST))
|| (TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST
&& !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type))
&& (CONTAINS_PLACEHOLDER_P
- (TYPE_SIZE (TREE_TYPE (gnu_result))))))
+ (TYPE_SIZE (TREE_TYPE (gnu_result)))))
+ || (TREE_CODE (gnu_result_type) == ARRAY_TYPE
+ && TREE_CODE (TREE_TYPE (gnu_result)) == ARRAY_TYPE))
&& !(TREE_CODE (gnu_result_type) == RECORD_TYPE
&& TYPE_JUSTIFIED_MODULAR_P (gnu_result_type))))
{
@@ -8854,9 +8219,7 @@ gnat_to_gnu (Node_Id gnat_node)
&& TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE))
{
/* Remove any padding. */
- if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
- gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
- gnu_result);
+ gnu_result = maybe_padded_object (gnu_result);
}
else if (gnu_result == error_mark_node || gnu_result_type == void_type_node)
@@ -9082,10 +8445,8 @@ add_decl_expr (tree gnu_decl, Node_Id gnat_node)
DECL_READONLY_ONCE_ELAB (gnu_decl) = 1;
}
- /* If GNU_DECL has a padded type, convert it to the unpadded
- type so the assignment is done properly. */
- if (TYPE_IS_PADDING_P (type))
- gnu_decl = convert (TREE_TYPE (TYPE_FIELDS (type)), gnu_decl);
+ /* Remove any padding so the assignment is done properly. */
+ gnu_decl = maybe_padded_object (gnu_decl);
gnu_stmt = build_binary_op (INIT_EXPR, NULL_TREE, gnu_decl, gnu_init);
add_stmt_with_node (gnu_stmt, gnat_node);
@@ -9134,6 +8495,7 @@ add_cleanup (tree gnu_cleanup, Node_Id gnat_node)
{
if (Present (gnat_node))
set_expr_location_from_node (gnu_cleanup, gnat_node, true);
+
/* An EH_ELSE_EXPR must be by itself, and that's all we need when we
use it. The assert below makes sure that is so. Should we ever
need more than that, we could combine EH_ELSE_EXPRs, and copy
@@ -10804,14 +10166,13 @@ adjust_for_implicit_deref (Node_Id exp)
static tree
maybe_implicit_deref (tree exp)
{
- /* If the type is a pointer, dereference it. */
+ /* If the object is a pointer, dereference it. */
if (POINTER_TYPE_P (TREE_TYPE (exp))
|| TYPE_IS_FAT_POINTER_P (TREE_TYPE (exp)))
exp = build_unary_op (INDIRECT_REF, NULL_TREE, exp);
- /* If we got a padded type, remove it too. */
- if (TYPE_IS_PADDING_P (TREE_TYPE (exp)))
- exp = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp))), exp);
+ /* If the object is padded, remove the padding. */
+ exp = maybe_padded_object (exp);
return exp;
}
diff --git a/gcc/ada/gcc-interface/utils.c b/gcc/ada/gcc-interface/utils.c
index fa98a5a..fb08b6c 100644
--- a/gcc/ada/gcc-interface/utils.c
+++ b/gcc/ada/gcc-interface/utils.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -258,6 +258,29 @@ static GTY(()) vec<tree, va_gc> *builtin_decls;
/* A chain of unused BLOCK nodes. */
static GTY((deletable)) tree free_block_chain;
+/* A hash table of packable types. It is modelled on the generic type
+ hash table in tree.c, which must thus be used as a reference. */
+
+struct GTY((for_user)) packable_type_hash
+{
+ hashval_t hash;
+ tree type;
+};
+
+struct packable_type_hasher : ggc_cache_ptr_hash<packable_type_hash>
+{
+ static inline hashval_t hash (packable_type_hash *t) { return t->hash; }
+ static bool equal (packable_type_hash *a, packable_type_hash *b);
+
+ static int
+ keep_cache_entry (packable_type_hash *&t)
+ {
+ return ggc_marked_p (t->type);
+ }
+};
+
+static GTY ((cache)) hash_table<packable_type_hasher> *packable_type_hash_table;
+
/* A hash table of padded types. It is modelled on the generic type
hash table in tree.c, which must thus be used as a reference. */
@@ -333,6 +356,9 @@ init_gnat_utils (void)
/* Initialize the association of GNAT nodes to GCC trees as dummies. */
dummy_node_table = ggc_cleared_vec_alloc<tree> (max_gnat_nodes);
+ /* Initialize the hash table of packable types. */
+ packable_type_hash_table = hash_table<packable_type_hasher>::create_ggc (512);
+
/* Initialize the hash table of padded types. */
pad_type_hash_table = hash_table<pad_type_hasher>::create_ggc (512);
}
@@ -350,6 +376,10 @@ destroy_gnat_utils (void)
ggc_free (dummy_node_table);
dummy_node_table = NULL;
+ /* Destroy the hash table of packable types. */
+ packable_type_hash_table->empty ();
+ packable_type_hash_table = NULL;
+
/* Destroy the hash table of padded types. */
pad_type_hash_table->empty ();
pad_type_hash_table = NULL;
@@ -861,6 +891,9 @@ gnat_pushdecl (tree decl, Node_Id gnat_node)
their GNAT encodings. */
if (TREE_CODE (t) == ARRAY_TYPE && !TYPE_NAME (t))
TYPE_NAME (t) = DECL_NAME (decl);
+ /* Remark the canonical fat pointer type as artificial. */
+ if (TYPE_IS_FAT_POINTER_P (t))
+ TYPE_ARTIFICIAL (t) = 1;
t = NULL_TREE;
}
else if (TYPE_NAME (t)
@@ -983,6 +1016,71 @@ make_aligning_type (tree type, unsigned int align, tree size,
return record_type;
}
+/* Return true iff the packable types are equivalent. */
+
+bool
+packable_type_hasher::equal (packable_type_hash *t1, packable_type_hash *t2)
+{
+ tree type1, type2;
+
+ if (t1->hash != t2->hash)
+ return 0;
+
+ type1 = t1->type;
+ type2 = t2->type;
+
+ /* We consider that packable types are equivalent if they have the same name,
+ size, alignment, RM size and storage order. Taking the mode into account
+ is redundant since it is determined by the others. */
+ return
+ TYPE_NAME (type1) == TYPE_NAME (type2)
+ && TYPE_SIZE (type1) == TYPE_SIZE (type2)
+ && TYPE_ALIGN (type1) == TYPE_ALIGN (type2)
+ && TYPE_ADA_SIZE (type1) == TYPE_ADA_SIZE (type2)
+ && TYPE_REVERSE_STORAGE_ORDER (type1) == TYPE_REVERSE_STORAGE_ORDER (type2);
+}
+
+/* Compute the hash value for the packable TYPE. */
+
+static hashval_t
+hash_packable_type (tree type)
+{
+ hashval_t hashcode;
+
+ hashcode = iterative_hash_expr (TYPE_NAME (type), 0);
+ hashcode = iterative_hash_expr (TYPE_SIZE (type), hashcode);
+ hashcode = iterative_hash_hashval_t (TYPE_ALIGN (type), hashcode);
+ hashcode = iterative_hash_expr (TYPE_ADA_SIZE (type), hashcode);
+ hashcode
+ = iterative_hash_hashval_t (TYPE_REVERSE_STORAGE_ORDER (type), hashcode);
+
+ return hashcode;
+}
+
+/* Look up the packable TYPE in the hash table and return its canonical version
+ if it exists; otherwise, insert it into the hash table. */
+
+static tree
+canonicalize_packable_type (tree type)
+{
+ const hashval_t hashcode = hash_packable_type (type);
+ struct packable_type_hash in, *h, **slot;
+
+ in.hash = hashcode;
+ in.type = type;
+ slot = packable_type_hash_table->find_slot_with_hash (&in, hashcode, INSERT);
+ h = *slot;
+ if (!h)
+ {
+ h = ggc_alloc<packable_type_hash> ();
+ h->hash = hashcode;
+ h->type = type;
+ *slot = h;
+ }
+
+ return h->type;
+}
+
/* TYPE is an ARRAY_TYPE that is being used as the type of a field in a packed
record. See if we can rewrite it as a type that has non-BLKmode, which we
can pack tighter in the packed record. If so, return the new type; if not,
@@ -1062,16 +1160,16 @@ make_packable_type (tree type, bool in_record, unsigned int max_align)
}
else
{
- tree type_size = TYPE_ADA_SIZE (type);
+ tree ada_size = TYPE_ADA_SIZE (type);
+
/* Do not try to shrink the size if the RM size is not constant. */
- if (TYPE_CONTAINS_TEMPLATE_P (type)
- || !tree_fits_uhwi_p (type_size))
+ if (TYPE_CONTAINS_TEMPLATE_P (type) || !tree_fits_uhwi_p (ada_size))
return type;
/* Round the RM size up to a unit boundary to get the minimal size
for a BLKmode record. Give up if it's already the size and we
don't need to lower the alignment. */
- new_size = tree_to_uhwi (type_size);
+ new_size = tree_to_uhwi (ada_size);
new_size = (new_size + BITS_PER_UNIT - 1) & -BITS_PER_UNIT;
if (new_size == size && (max_align == 0 || align <= max_align))
return type;
@@ -1117,7 +1215,13 @@ make_packable_type (tree type, bool in_record, unsigned int max_align)
&& TYPE_ADA_SIZE (new_field_type))
new_field_size = TYPE_ADA_SIZE (new_field_type);
else
- new_field_size = DECL_SIZE (field);
+ {
+ new_field_size = DECL_SIZE (field);
+
+ /* Make sure not to use too small a type for the size. */
+ if (TYPE_MODE (new_field_type) == BLKmode)
+ new_field_type = TREE_TYPE (field);
+ }
/* This is a layout with full representation, alignment and size clauses
so we simply pass 0 as PACKED like gnat_to_gnu_field in this case. */
@@ -1160,8 +1264,8 @@ make_packable_type (tree type, bool in_record, unsigned int max_align)
SET_DECL_PARALLEL_TYPE (TYPE_STUB_DECL (new_type),
DECL_PARALLEL_TYPE (TYPE_STUB_DECL (type)));
- /* Try harder to get a packable type if necessary, for example
- in case the record itself contains a BLKmode field. */
+ /* Try harder to get a packable type if necessary, for example in case
+ the record itself contains a BLKmode field. */
if (in_record && TYPE_MODE (new_type) == BLKmode)
SET_TYPE_MODE (new_type,
mode_for_size_tree (TYPE_SIZE (new_type),
@@ -1171,7 +1275,11 @@ make_packable_type (tree type, bool in_record, unsigned int max_align)
if (TYPE_MODE (new_type) == BLKmode && new_size >= size && max_align == 0)
return type;
- return new_type;
+ /* If the packable type is named, we canonicalize it by means of the hash
+ table. This is consistent with the language semantics and ensures that
+ gigi and the middle-end have a common view of these packable types. */
+ return
+ TYPE_NAME (new_type) ? canonicalize_packable_type (new_type) : new_type;
}
/* Return true if TYPE has an unsigned representation. This needs to be used
@@ -1230,9 +1338,9 @@ make_type_from_size (tree type, tree size_tree, bool for_biased)
if (size == 0)
size = 1;
- /* Only do something if the type isn't a packed array type and doesn't
- already have the proper size and the size isn't too large. */
- if (TYPE_IS_PACKED_ARRAY_TYPE_P (type)
+ /* Only do something if the type is not a bit-packed array type and does
+ not already have the proper size and the size is not too large. */
+ if (BIT_PACKED_ARRAY_TYPE_P (type)
|| (TYPE_PRECISION (type) == size && biased_p == for_biased)
|| size > LONG_LONG_TYPE_SIZE)
break;
@@ -1300,7 +1408,7 @@ pad_type_hasher::equal (pad_type_hash *t1, pad_type_hash *t2)
type1 = t1->type;
type2 = t2->type;
- /* We consider that the padded types are equivalent if they pad the same type
+ /* We consider that padded types are equivalent if they pad the same type
and have the same size, alignment, RM size and storage order. Taking the
mode into account is redundant since it is determined by the others. */
return
@@ -1323,6 +1431,8 @@ hash_pad_type (tree type)
hashcode = iterative_hash_expr (TYPE_SIZE (type), hashcode);
hashcode = iterative_hash_hashval_t (TYPE_ALIGN (type), hashcode);
hashcode = iterative_hash_expr (TYPE_ADA_SIZE (type), hashcode);
+ hashcode
+ = iterative_hash_hashval_t (TYPE_REVERSE_STORAGE_ORDER (type), hashcode);
return hashcode;
}
@@ -1355,15 +1465,14 @@ canonicalize_pad_type (tree type)
if needed. We have already verified that SIZE and ALIGN are large enough.
GNAT_ENTITY is used to name the resulting record and to issue a warning.
IS_COMPONENT_TYPE is true if this is being done for the component type of
- an array. IS_USER_TYPE is true if the original type needs to be completed.
- DEFINITION is true if this type is being defined. SET_RM_SIZE is true if
- the RM size of the resulting type is to be set to SIZE too; in this case,
- the padded type is canonicalized before being returned. */
+ an array. DEFINITION is true if this type is being defined. SET_RM_SIZE
+ is true if the RM size of the resulting type is to be set to SIZE too; in
+ this case, the padded type is canonicalized before being returned. */
tree
maybe_pad_type (tree type, tree size, unsigned int align,
Entity_Id gnat_entity, bool is_component_type,
- bool is_user_type, bool definition, bool set_rm_size)
+ bool definition, bool set_rm_size)
{
tree orig_size = TYPE_SIZE (type);
unsigned int orig_align = TYPE_ALIGN (type);
@@ -1407,31 +1516,13 @@ maybe_pad_type (tree type, tree size, unsigned int align,
if (align == 0 && !size)
return type;
- /* If requested, complete the original type and give it a name. */
- if (is_user_type)
- create_type_decl (get_entity_name (gnat_entity), type,
- !Comes_From_Source (gnat_entity),
- !(TYPE_NAME (type)
- && TREE_CODE (TYPE_NAME (type)) == TYPE_DECL
- && DECL_IGNORED_P (TYPE_NAME (type))),
- gnat_entity);
-
/* We used to modify the record in place in some cases, but that could
generate incorrect debugging information. So make a new record
type and name. */
record = make_node (RECORD_TYPE);
TYPE_PADDING_P (record) = 1;
- /* ??? Padding types around packed array implementation types will be
- considered as root types in the array descriptor language hook (see
- gnat_get_array_descr_info). Give them the original packed array type
- name so that the one coming from sources appears in the debugging
- information. */
- if (TYPE_IMPL_PACKED_ARRAY_P (type)
- && TYPE_ORIGINAL_PACKED_ARRAY (type)
- && gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
- TYPE_NAME (record) = TYPE_NAME (TYPE_ORIGINAL_PACKED_ARRAY (type));
- else if (Present (gnat_entity))
+ if (Present (gnat_entity))
TYPE_NAME (record) = create_concat_name (gnat_entity, "PAD");
SET_TYPE_ALIGN (record, align ? align : orig_align);
@@ -1499,6 +1590,7 @@ maybe_pad_type (tree type, tree size, unsigned int align,
}
}
+ /* Make the inner type the debug type of the padded type. */
if (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
SET_TYPE_DEBUG_TYPE (record, maybe_debug_type (type));
@@ -3127,7 +3219,7 @@ compute_deferred_decl_context (Entity_Id gnat_scope)
if (TREE_CODE (context) == TYPE_DECL)
{
- const tree context_type = TREE_TYPE (context);
+ tree context_type = TREE_TYPE (context);
/* Skip dummy types: only the final ones can appear in the context
chain. */
@@ -4078,7 +4170,6 @@ tree
build_unc_object_type (tree template_type, tree object_type, tree name,
bool debug_info_p)
{
- tree decl;
tree type = make_node (RECORD_TYPE);
tree template_field
= create_field_decl (get_identifier ("BOUNDS"), template_type, type,
@@ -4094,12 +4185,7 @@ build_unc_object_type (tree template_type, tree object_type, tree name,
/* Declare it now since it will never be declared otherwise. This is
necessary to ensure that its subtrees are properly marked. */
- decl = create_type_decl (name, type, true, debug_info_p, Empty);
-
- /* template_type will not be used elsewhere than here, so to keep the debug
- info clean and in order to avoid scoping issues, make decl its
- context. */
- gnat_set_type_context (template_type, decl);
+ create_type_decl (name, type, true, debug_info_p, Empty);
return type;
}
@@ -4773,7 +4859,7 @@ convert (tree type, tree expr)
&& smaller_form_type_p (etype, type))
{
expr = convert (maybe_pad_type (etype, TYPE_SIZE (type), 0, Empty,
- false, false, false, true),
+ false, false, true),
expr);
return build1 (VIEW_CONVERT_EXPR, type, expr);
}
@@ -5155,11 +5241,9 @@ maybe_unconstrained_array (tree exp)
exp = build_component_ref (exp, DECL_CHAIN (TYPE_FIELDS (type)),
false);
- type = TREE_TYPE (exp);
- /* If the array type is padded, convert to the unpadded type. */
- if (TYPE_IS_PADDING_P (type))
- exp = convert (TREE_TYPE (TYPE_FIELDS (type)), exp);
+ /* If the array is padded, remove the padding. */
+ exp = maybe_padded_object (exp);
}
break;
@@ -5395,14 +5479,14 @@ unchecked_convert (tree type, tree expr, bool notrunc_p)
if (c < 0)
{
expr = convert (maybe_pad_type (etype, TYPE_SIZE (type), 0, Empty,
- false, false, false, true),
+ false, false, true),
expr);
expr = unchecked_convert (type, expr, notrunc_p);
}
else
{
tree rec_type = maybe_pad_type (type, TYPE_SIZE (etype), 0, Empty,
- false, false, false, true);
+ false, false, true);
expr = unchecked_convert (rec_type, expr, notrunc_p);
expr = build_component_ref (expr, TYPE_FIELDS (rec_type), false);
}
@@ -5420,14 +5504,14 @@ unchecked_convert (tree type, tree expr, bool notrunc_p)
if (c < 0)
{
expr = convert (maybe_pad_type (etype, new_size, 0, Empty,
- false, false, false, true),
+ false, false, true),
expr);
expr = unchecked_convert (type, expr, notrunc_p);
}
else
{
tree rec_type = maybe_pad_type (type, TYPE_SIZE (etype), 0, Empty,
- false, false, false, true);
+ false, false, true);
expr = unchecked_convert (rec_type, expr, notrunc_p);
expr = build_component_ref (expr, TYPE_FIELDS (rec_type), false);
}
@@ -5472,7 +5556,7 @@ unchecked_convert (tree type, tree expr, bool notrunc_p)
&& TYPE_ALIGN (etype) < TYPE_ALIGN (type))
{
expr = convert (maybe_pad_type (etype, NULL_TREE, TYPE_ALIGN (type),
- Empty, false, false, false, true),
+ Empty, false, false, true),
expr);
return unchecked_convert (type, expr, notrunc_p);
}
@@ -5489,7 +5573,7 @@ unchecked_convert (tree type, tree expr, bool notrunc_p)
|| tree_int_cst_lt (TYPE_SIZE (etype), TYPE_SIZE (type))))
{
expr = convert (maybe_pad_type (etype, TYPE_SIZE (type), 0,
- Empty, false, false, false, true),
+ Empty, false, false, true),
expr);
return unchecked_convert (type, expr, notrunc_p);
}
diff --git a/gcc/ada/gcc-interface/utils2.c b/gcc/ada/gcc-interface/utils2.c
index 6ff1372..a18d50f 100644
--- a/gcc/ada/gcc-interface/utils2.c
+++ b/gcc/ada/gcc-interface/utils2.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2019, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -32,6 +32,7 @@
#include "alias.h"
#include "tree.h"
#include "inchash.h"
+#include "builtins.h"
#include "fold-const.h"
#include "stor-layout.h"
#include "stringpool.h"
@@ -167,7 +168,10 @@ known_alignment (tree exp)
break;
case ADDR_EXPR:
- this_alignment = expr_align (TREE_OPERAND (exp, 0));
+ if (DECL_P (TREE_OPERAND (exp, 0)))
+ this_alignment = DECL_ALIGN (TREE_OPERAND (exp, 0));
+ else
+ this_alignment = get_object_alignment (TREE_OPERAND (exp, 0));
break;
case CALL_EXPR:
@@ -871,31 +875,21 @@ build_binary_op (enum tree_code op_code, tree result_type,
/* If there were integral or pointer conversions on the LHS, remove
them; we'll be putting them back below if needed. Likewise for
- conversions between array and record types, except for justified
- modular types. But don't do this if the right operand is not
- BLKmode (for packed arrays) unless we are not changing the mode. */
+ conversions between record types, except for justified modular types.
+ But don't do this if the right operand is not BLKmode (for packed
+ arrays) unless we are not changing the mode. */
while ((CONVERT_EXPR_P (left_operand)
|| TREE_CODE (left_operand) == VIEW_CONVERT_EXPR)
&& (((INTEGRAL_TYPE_P (left_type)
|| POINTER_TYPE_P (left_type))
- && (INTEGRAL_TYPE_P (TREE_TYPE
- (TREE_OPERAND (left_operand, 0)))
- || POINTER_TYPE_P (TREE_TYPE
- (TREE_OPERAND (left_operand, 0)))))
- || (((TREE_CODE (left_type) == RECORD_TYPE
- && !TYPE_JUSTIFIED_MODULAR_P (left_type))
- || TREE_CODE (left_type) == ARRAY_TYPE)
- && ((TREE_CODE (TREE_TYPE
- (TREE_OPERAND (left_operand, 0)))
- == RECORD_TYPE)
- || (TREE_CODE (TREE_TYPE
- (TREE_OPERAND (left_operand, 0)))
- == ARRAY_TYPE))
+ && (INTEGRAL_TYPE_P (operand_type (left_operand))
+ || POINTER_TYPE_P (operand_type (left_operand))))
+ || (TREE_CODE (left_type) == RECORD_TYPE
+ && !TYPE_JUSTIFIED_MODULAR_P (left_type)
+ && TREE_CODE (operand_type (left_operand)) == RECORD_TYPE
&& (TYPE_MODE (right_type) == BLKmode
- || (TYPE_MODE (left_type)
- == TYPE_MODE (TREE_TYPE
- (TREE_OPERAND
- (left_operand, 0))))))))
+ || TYPE_MODE (left_type)
+ == TYPE_MODE (operand_type (left_operand))))))
{
left_operand = TREE_OPERAND (left_operand, 0);
left_type = TREE_TYPE (left_operand);
@@ -917,8 +911,7 @@ build_binary_op (enum tree_code op_code, tree result_type,
&& TREE_CONSTANT (TYPE_SIZE (left_type))
&& ((TREE_CODE (right_operand) == COMPONENT_REF
&& TYPE_MAIN_VARIANT (left_type)
- == TYPE_MAIN_VARIANT
- (TREE_TYPE (TREE_OPERAND (right_operand, 0))))
+ == TYPE_MAIN_VARIANT (operand_type (right_operand)))
|| (TREE_CODE (right_operand) == CONSTRUCTOR
&& !CONTAINS_PLACEHOLDER_P
(DECL_SIZE (TYPE_FIELDS (left_type)))))
@@ -972,22 +965,23 @@ build_binary_op (enum tree_code op_code, tree result_type,
|| TREE_CODE (result) == ARRAY_RANGE_REF)
while (handled_component_p (result))
result = TREE_OPERAND (result, 0);
+
else if (TREE_CODE (result) == REALPART_EXPR
|| TREE_CODE (result) == IMAGPART_EXPR
|| (CONVERT_EXPR_P (result)
&& (((TREE_CODE (restype)
- == TREE_CODE (TREE_TYPE
- (TREE_OPERAND (result, 0))))
- && (TYPE_MODE (TREE_TYPE
- (TREE_OPERAND (result, 0)))
- == TYPE_MODE (restype)))
+ == TREE_CODE (operand_type (result))
+ && TYPE_MODE (restype)
+ == TYPE_MODE (operand_type (result))))
|| TYPE_ALIGN_OK (restype))))
result = TREE_OPERAND (result, 0);
+
else if (TREE_CODE (result) == VIEW_CONVERT_EXPR)
{
TREE_ADDRESSABLE (result) = 1;
result = TREE_OPERAND (result, 0);
}
+
else
break;
}
@@ -1036,8 +1030,15 @@ build_binary_op (enum tree_code op_code, tree result_type,
/* For a range, make sure the element type is consistent. */
if (op_code == ARRAY_RANGE_REF
&& TREE_TYPE (operation_type) != TREE_TYPE (left_type))
- operation_type = build_array_type (TREE_TYPE (left_type),
- TYPE_DOMAIN (operation_type));
+ {
+ operation_type
+ = build_nonshared_array_type (TREE_TYPE (left_type),
+ TYPE_DOMAIN (operation_type));
+ /* Declare it now since it will never be declared otherwise. This
+ is necessary to ensure that its subtrees are properly marked. */
+ create_type_decl (TYPE_NAME (operation_type), operation_type, true,
+ false, Empty);
+ }
/* Then convert the right operand to its base type. This will prevent
unneeded sign conversions when sizetype is wider than integer. */
@@ -2916,7 +2917,7 @@ is_simple_additive_expression (tree expr, tree *add, tree *cst, bool *minus_p)
tree
gnat_invariant_expr (tree expr)
{
- const tree type = TREE_TYPE (expr);
+ tree type = TREE_TYPE (expr);
tree add, cst;
bool minus_p;
@@ -2930,8 +2931,7 @@ gnat_invariant_expr (tree expr)
{
expr = DECL_INITIAL (expr);
/* Look into CONSTRUCTORs built to initialize padded types. */
- if (TYPE_IS_PADDING_P (TREE_TYPE (expr)))
- expr = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))), expr);
+ expr = maybe_padded_object (expr);
expr = remove_conversions (expr, false);
}
generated by cgit v1.1 at 2025-08-14 19:32:38 +0000