From db4062a0cbe00ce4075a4d7f68a2ff15165cd72b Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Fri, 8 May 2020 16:36:53 +0200 Subject: Small tweak to gnat_to_gnu_param We mark the type of In parameters in Ada with the const qualifier, but it is stripped by free_lang_data_in_type so do not do it in LTO mode. * gcc-interface/decl.c (gnat_to_gnu_param): Do not make a variant of the type in LTO mode. --- gcc/ada/gcc-interface/decl.c | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) (limited to 'gcc/ada/gcc-interface') diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index 80dfc55..3cd9d52 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -5327,9 +5327,12 @@ gnat_to_gnu_param (Entity_Id gnat_param, tree gnu_param_type, bool first, } /* 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 + read-only, except in LTO mode because free_lang_data_in_type would + undo it. ??? 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))) + if (ro_param + && !flag_generate_lto + && !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. -- cgit v1.1 From c900c70049965fad7fa02aa08f0ac3a67ab99b37 Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Fri, 8 May 2020 16:46:04 +0200 Subject: Fix missing information in exception messages with -gnateE The information was missing in cases the front-end was able to turn the range comparison into a simple comparison. * gcc-interface/trans.c (Raise_Error_to_gnu): Always compute a lower bound and an upper bound for use by the -gnateE switch for range and comparison operators. --- gcc/ada/gcc-interface/trans.c | 52 ++++++++++++++++++++++--------------------- 1 file changed, 27 insertions(+), 25 deletions(-) (limited to 'gcc/ada/gcc-interface') diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index 5f87bc3..802adc9 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -6501,13 +6501,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 +6522,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 +6631,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); @@ -9134,6 +9135,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 -- cgit v1.1 From bb1ec4773a01e5bbb7cb6e2f53ea338a74a6797f Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Fri, 8 May 2020 17:01:18 +0200 Subject: Couple of tweaks to help in LTO mode The first tweak is to remove the TREE_OVERFLOW flag on INTEGER_CSTs because it prevents them from being uniquized in LTO mode. The second, unrelated tweak is to canonicalize the packable types made by gigi so that at most one per type is present in the GENERIC IL. * gcc-interface/decl.c (gnat_to_gnu_entity) : Deal with artificial maximally-sized types designed by access types. * gcc-interface/utils.c (packable_type_hash): New structure. (packable_type_hasher): Likewise. (packable_type_hash_table): New hash table. (init_gnat_utils): Initialize it. (destroy_gnat_utils): Destroy it. (packable_type_hasher::equal): New method. (hash_packable_type): New static function. (canonicalize_packable_type): Likewise. (make_packable_type): Make sure not to use too small a type for the size of the new fields. Canonicalize the type if it is named. --- gcc/ada/gcc-interface/decl.c | 16 ++++++ gcc/ada/gcc-interface/utils.c | 118 +++++++++++++++++++++++++++++++++++++++--- 2 files changed, 126 insertions(+), 8 deletions(-) (limited to 'gcc/ada/gcc-interface') diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index 3cd9d52..a4053ee 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -2685,6 +2685,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. */ diff --git a/gcc/ada/gcc-interface/utils.c b/gcc/ada/gcc-interface/utils.c index fa98a5a..9d00148 100644 --- a/gcc/ada/gcc-interface/utils.c +++ b/gcc/ada/gcc-interface/utils.c @@ -258,6 +258,29 @@ static GTY(()) vec *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 +{ + 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_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 (max_gnat_nodes); + /* Initialize the hash table of packable types. */ + packable_type_hash_table = hash_table::create_ggc (512); + /* Initialize the hash table of padded types. */ pad_type_hash_table = hash_table::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; @@ -983,6 +1013,68 @@ 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 and RM size. 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); +} + +/* 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); + + 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 (); + 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 +1154,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 +1209,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 +1258,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 +1269,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 -- cgit v1.1 From e34495985e49545c468e664ee10bd0e66c7395bf Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Fri, 8 May 2020 17:18:20 +0200 Subject: Fix uniqueness of address for aliased objects Two aliased objects must have distinct addresses, even if they have size zero, so we make sure to allocate at least one byte for them. * gcc-interface/decl.c (gnat_to_gnu_entity) : Force at least the unit size for an aliased object of a constrained nominal subtype whose size is variable. --- gcc/ada/gcc-interface/decl.c | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) (limited to 'gcc/ada/gcc-interface') diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index a4053ee..9c1acd9 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -969,10 +969,19 @@ 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; -- cgit v1.1 From 65ba91b79e1664ba7e7f60f68e4cb956453b692e Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Sat, 9 May 2020 21:37:13 +0200 Subject: Remove last use of expr_align It was in the ada/gcc-interface repository and is outdated. * tree.h (expr_align): Delete. * tree.c (expr_align): Likewise. ada/ * gcc-interface/utils2.c: Include builtins.h. (known_alignment) : Use DECL_ALIGN for DECL_P operands and get_object_alignment for the rest. --- gcc/ada/gcc-interface/utils2.c | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) (limited to 'gcc/ada/gcc-interface') diff --git a/gcc/ada/gcc-interface/utils2.c b/gcc/ada/gcc-interface/utils2.c index 6ff1372..30d08f5 100644 --- a/gcc/ada/gcc-interface/utils2.c +++ b/gcc/ada/gcc-interface/utils2.c @@ -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: -- cgit v1.1 From ad00a297ec4236b327430c171dfbe7587901ffd7 Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Sat, 9 May 2020 22:01:24 +0200 Subject: Small housekeeping work in gigi No functional changes. * gcc-interface/gigi.h (change_qualified_type): Move around. (maybe_vector_array): Likewise. (maybe_padded_object): New static line function. * gcc-interface/trans.c (Attribute_to_gnu) : Remove useless code. : Remove obsolete code. (Call_to_gn): Likewise. Use maybe_padded_object to remove padding. (gnat_to_gnu): Likewise. : Do not add a useless null character at the end. : Likewise and remove obsolete code. (add_decl_expr): Likewise. (maybe_implicit_deref): Likewise. * gcc-interface/utils.c (maybe_unconstrained_array): Likewise. * gcc-interface/utils2.c (gnat_invariant_expr): Likewise. --- gcc/ada/gcc-interface/gigi.h | 55 +++++++++++++++++++++-------------- gcc/ada/gcc-interface/trans.c | 66 ++++++++---------------------------------- gcc/ada/gcc-interface/utils.c | 6 ++-- gcc/ada/gcc-interface/utils2.c | 3 +- 4 files changed, 49 insertions(+), 81 deletions(-) (limited to 'gcc/ada/gcc-interface') diff --git a/gcc/ada/gcc-interface/gigi.h b/gcc/ada/gcc-interface/gigi.h index edfcbd5..c4e9d77 100644 --- a/gcc/ada/gcc-interface/gigi.h +++ b/gcc/ada/gcc-interface/gigi.h @@ -1065,20 +1065,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 +1130,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 +1199,15 @@ 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; } diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index 802adc9..20529e1 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -2893,10 +2893,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 +2930,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: @@ -5468,8 +5463,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 +5483,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 +5607,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 @@ -6959,19 +6933,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 @@ -7199,6 +7169,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. */ @@ -7209,14 +7180,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); @@ -8855,9 +8818,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) @@ -9083,10 +9044,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); @@ -10806,14 +10765,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 9d00148..9dd08e2 100644 --- a/gcc/ada/gcc-interface/utils.c +++ b/gcc/ada/gcc-interface/utils.c @@ -5257,11 +5257,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; diff --git a/gcc/ada/gcc-interface/utils2.c b/gcc/ada/gcc-interface/utils2.c index 30d08f5..2ff8654 100644 --- a/gcc/ada/gcc-interface/utils2.c +++ b/gcc/ada/gcc-interface/utils2.c @@ -2934,8 +2934,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); } -- cgit v1.1 From 40bd5a536257aabc0f3899d661debc13dee18d75 Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Sat, 9 May 2020 22:26:25 +0200 Subject: Fix missing back-annotation for Out parameter This happens when it is passed by copy and not passed in. * gcc-interface/decl.c (gnat_to_gnu_param): Also back-annotate the mechanism in the case of an Out parameter only passed by copy-out. --- gcc/ada/gcc-interface/decl.c | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) (limited to 'gcc/ada/gcc-interface') diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index 9c1acd9..ec9cc38 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -5447,7 +5447,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; -- cgit v1.1 From b9364a56d107083858267a52f162391d8cabb2f7 Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Sat, 9 May 2020 22:36:11 +0200 Subject: Accept qualified aggregates in memset path Aggregates can be surrounded by a qualified expression and this prepares the support code in gigi for accepting them. * gcc-interface/trans.c (gnat_to_gnu) : Deal with qualified "others" aggregates in the memset case. --- gcc/ada/gcc-interface/trans.c | 28 ++++++++++++++++------------ 1 file changed, 16 insertions(+), 12 deletions(-) (limited to 'gcc/ada/gcc-interface') diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index 20529e1..5de04ab 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -7813,25 +7813,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_Others_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_Others_Aggregate (gnat_temp)); + gnu_rhs = gnat_to_gnu (gnat_temp); } else gnu_rhs = maybe_unconstrained_array (gnat_to_gnu (gnat_expr)); -- cgit v1.1 From aff220748ca669d4338c5ac6f0b210a29f90bbab Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Sat, 9 May 2020 22:38:29 +0200 Subject: Fix problematic cases of wrapping * gcc-interface/trans.c (gnat_to_gnu): Do not wrap boolean values if they appear in any kind of attribute references. --- gcc/ada/gcc-interface/trans.c | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'gcc/ada/gcc-interface') diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index 5de04ab..44b156a 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -8695,8 +8695,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, -- cgit v1.1 From 527ed00b715bf4a945284722b7e766a4f763049f Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Sat, 9 May 2020 22:44:39 +0200 Subject: Do not make a local copy of large aggregate This prevents gigi from making a local copy of large aggregates. * gcc-interface/trans.c (lvalue_required_p) : Merge with N_Slice. : Move to... (lvalue_for_aggregate_p): ...here. New function. (Identifier_to_gnu): For an identifier with aggregate type, also call lvalue_for_aggregate_p if lvalue_required_p returned false before substituting the identifier with the constant. --- gcc/ada/gcc-interface/trans.c | 86 ++++++++++++++++++++++++++++++++++++------- 1 file changed, 73 insertions(+), 13 deletions(-) (limited to 'gcc/ada/gcc-interface') diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index 44b156a..a2f06d7 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -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) -- cgit v1.1 From e92f85c792c8c5e7846ba2bc7f5e24f08dcdfece Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Sat, 9 May 2020 22:52:21 +0200 Subject: Do not override -fnon-call-exceptions in default mode This was already the case in -gnatp mode. * gcc-interface/misc.c (gnat_init_gcc_eh): Do not override the user for -fnon-call-exceptions in default mode. --- gcc/ada/gcc-interface/misc.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'gcc/ada/gcc-interface') diff --git a/gcc/ada/gcc-interface/misc.c b/gcc/ada/gcc-interface/misc.c index d68b373..2950cb8 100644 --- a/gcc/ada/gcc-interface/misc.c +++ b/gcc/ada/gcc-interface/misc.c @@ -417,7 +417,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; } -- cgit v1.1 From 2448ee85a89f313e48ee40eaed0d645c4c027944 Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Sat, 9 May 2020 22:56:14 +0200 Subject: Fix tree sharing issue with slices This can happen because we build an array type on the fly in case there is an apparent type inconsistency in the construct. * gcc-interface/utils2.c (build_binary_op) : Use build_nonshared_array_type to build the common type and declare it. --- gcc/ada/gcc-interface/utils2.c | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) (limited to 'gcc/ada/gcc-interface') diff --git a/gcc/ada/gcc-interface/utils2.c b/gcc/ada/gcc-interface/utils2.c index 2ff8654..0d61205 100644 --- a/gcc/ada/gcc-interface/utils2.c +++ b/gcc/ada/gcc-interface/utils2.c @@ -1040,8 +1040,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. */ -- cgit v1.1 From 1e3cabd45d499652abc3bfe28f82a363ed70390d Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Sat, 9 May 2020 23:04:38 +0200 Subject: Fix small issues with -fgnat-encodings=minimal This is the mode where the GNAT compiler does not use special encodings in the debug info to describe some Ada constructs, for example packed array types. * gcc-interface/ada-tree.h (TYPE_PACKED_ARRAY_TYPE_P): Rename into... (TYPE_BIT_PACKED_ARRAY_TYPE_P): ...this. (TYPE_IS_PACKED_ARRAY_TYPE_P): Rename into... (BIT_PACKED_ARRAY_TYPE_P): ...this. (TYPE_IMPL_PACKED_ARRAY_P): Adjust to above renaming. * gcc-interface/gigi.h (maybe_pad_type): Remove IS_USER_TYPE.. * gcc-interface/decl.c (gnat_to_gnu_entity) : Adjust call to maybe_pad_type. : Remove const qualifiers for tree. : Remove redundant test and redundant call to associate_original_type_to_packed_array. Turn into assertion. Call associate_original_type_to_packed_array and modify gnu_entity_name accordingly. Explicitly set the parallel type for GNAT encodings. Call create_type_decl in the misaligned case before maybe_pad_type. : Do not use the name of the implementation type for a packed array when not using GNAT encodings. : Move around setting flags. Use the result of the call to associate_original_type_to_packed_array for gnu_entity_name. : Create XVS type and XVZ variable only if debug info is requested for the type. Call create_type_decl if a padded type was created for a type entity (gnat_to_gnu_component_type): Use local variable and adjust calls to maybe_pad_type. (gnat_to_gnu_subprog_type): Adjust call to maybe_pad_type. (gnat_to_gnu_field): Likewise. (validate_size): Adjust to renaming of macro. (set_rm_size): Likewise. (associate_original_type_to_packed_array): Adjust return type and return the name of the original type if GNAT encodings are not used * gcc-interface/misc.c (gnat_get_debug_typ): Remove obsolete stuff. (gnat_get_fixed_point_type_info): Remove const qualifiers for tree. (gnat_get_array_descr_info): Likewise and set variables lazily. Remove call to maybe_debug_type. Simplify a few computations. (enumerate_modes): Remove const qualifier for tree. * gcc-interface/utils.c (make_type_from_size): Adjust to renaming. (maybe_pad_type): Remove IS_USER_TYPE parameter and adjust. Remove specific code for implementation types for packed arrays. (compute_deferred_decl_context): Remove const qualifier for tree. (convert): Adjust call to maybe_pad_type. (unchecked_convert): Likewise. * gcc-interface/utils2.c (is_simple_additive_expressio): Likewise. --- gcc/ada/gcc-interface/ada-tree.h | 14 +-- gcc/ada/gcc-interface/decl.c | 233 ++++++++++++++++++++++----------------- gcc/ada/gcc-interface/gigi.h | 10 +- gcc/ada/gcc-interface/misc.c | 100 ++++++++--------- gcc/ada/gcc-interface/utils.c | 52 +++------ gcc/ada/gcc-interface/utils2.c | 2 +- 6 files changed, 203 insertions(+), 208 deletions(-) (limited to 'gcc/ada/gcc-interface') diff --git a/gcc/ada/gcc-interface/ada-tree.h b/gcc/ada/gcc-interface/ada-tree.h index acea5d1..47c2e14 100644 --- a/gcc/ada/gcc-interface/ada-tree.h +++ b/gcc/ada/gcc-interface/ada-tree.h @@ -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/decl.c b/gcc/ada/gcc-interface/decl.c index ec9cc38..0393198 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -248,7 +248,7 @@ static tree create_variant_part_from (tree, vec, tree, static void copy_and_substitute_in_size (tree, tree, vec); static void copy_and_substitute_in_layout (Entity_Id, Entity_Id, tree, tree, vec, 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 @@ -987,7 +987,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) 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 @@ -1754,9 +1754,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 @@ -1774,10 +1774,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, @@ -1856,8 +1856,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. */ @@ -1934,11 +1933,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. */ @@ -1960,19 +1954,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; @@ -2011,15 +2016,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)); } } @@ -2033,9 +2038,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); @@ -2112,7 +2121,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) 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; + Entity_Id gnat_index; int index; tree comp_type; @@ -2378,13 +2387,15 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) 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; + /* 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. */ + 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) ? get_entity_name (gnat_name) @@ -2752,6 +2763,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 @@ -2786,44 +2815,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); @@ -3511,7 +3528,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 @@ -4352,15 +4370,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. */ @@ -5107,9 +5130,10 @@ 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 @@ -5123,9 +5147,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))) @@ -5133,6 +5157,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 @@ -5155,7 +5181,7 @@ 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; @@ -5166,7 +5192,7 @@ gnat_to_gnu_component_type (Entity_Id gnat_array, bool definition, orig_type = gnu_type; gnu_type = maybe_pad_type (gnu_type, gnu_comp_size, 0, gnat_array, - true, false, definition, true); + 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 @@ -5193,7 +5219,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); @@ -5209,8 +5235,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); @@ -5846,8 +5872,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. */ @@ -7193,7 +7219,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); } @@ -7354,7 +7380,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 @@ -8959,11 +8985,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; @@ -9061,16 +9087,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)) @@ -10025,39 +10048,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/gigi.h b/gcc/ada/gcc-interface/gigi.h index c4e9d77..1adf627 100644 --- a/gcc/ada/gcc-interface/gigi.h +++ b/gcc/ada/gcc-interface/gigi.h @@ -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); diff --git a/gcc/ada/gcc-interface/misc.c b/gcc/ada/gcc-interface/misc.c index 2950cb8..0867125 100644 --- a/gcc/ada/gcc-interface/misc.c +++ b/gcc/ada/gcc-interface/misc.c @@ -602,20 +602,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 (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 @@ -650,14 +640,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 @@ -786,14 +776,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 (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, is_fat_ptr; int i; /* Temporaries created in the first pass and used in the second one for thin @@ -803,9 +788,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)) @@ -813,6 +795,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,6 +807,7 @@ gnat_get_array_descr_info (const_tree const_type, && TYPE_INDEX_TYPE (TYPE_DOMAIN (type))) { is_array = true; + is_fat_ptr = false; first_dimen = type; info->data_location = NULL_TREE; } @@ -830,18 +815,19 @@ gnat_get_array_descr_info (const_tree const_type, else if (TYPE_IS_FAT_POINTER_P (type) && gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL) { - const tree ua_type = TYPE_UNCONSTRAINED_ARRAY (type); + tree ua_type = TYPE_UNCONSTRAINED_ARRAY (type); /* This will be our base object address. */ - const tree placeholder_expr = build0 (PLACEHOLDER_EXPR, type); + tree placeholder_expr = build0 (PLACEHOLDER_EXPR, type); /* We assume below that maybe_unconstrained_array returns an INDIRECT_REF node. */ - const tree ua_val + tree ua_val = maybe_unconstrained_array (build_unary_op (INDIRECT_REF, ua_type, placeholder_expr)); + is_array = false; is_fat_ptr = true; first_dimen = TREE_TYPE (ua_val); @@ -861,17 +847,17 @@ gnat_get_array_descr_info (const_tree const_type, /* This will be our base object address. Note that we assume that pointers to these 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 + 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), @@ -879,6 +865,8 @@ gnat_get_array_descr_info (const_tree const_type, template_addr = fold_convert (TYPE_POINTER_TO (bounds_type), template_addr); + is_array = false; + is_fat_ptr = false; first_dimen = array_type; /* The thin pointer is already the pointer to the array data, so there's @@ -890,35 +878,37 @@ gnat_get_array_descr_info (const_tree const_type, template_addr); thinptr_bound_field = TYPE_FIELDS (bounds_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 @@ -928,12 +918,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; @@ -1186,7 +1174,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/utils.c b/gcc/ada/gcc-interface/utils.c index 9dd08e2..1b320f5 100644 --- a/gcc/ada/gcc-interface/utils.c +++ b/gcc/ada/gcc-interface/utils.c @@ -1332,9 +1332,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; @@ -1457,15 +1457,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); @@ -1509,31 +1508,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); @@ -1601,6 +1582,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)); @@ -3229,7 +3211,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. */ @@ -4875,7 +4857,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); } @@ -5495,14 +5477,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); } @@ -5520,14 +5502,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); } @@ -5572,7 +5554,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); } @@ -5589,7 +5571,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 0d61205..edbb816 100644 --- a/gcc/ada/gcc-interface/utils2.c +++ b/gcc/ada/gcc-interface/utils2.c @@ -2927,7 +2927,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; -- cgit v1.1 From a5720c08a32e5a716f3c5cf25dc1e4e90381da05 Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Sat, 9 May 2020 23:08:18 +0200 Subject: Add assertion for access attributes * gcc-interface/trans.c (Attribute_to_gnu) : Assert that the prefix is not a type. --- gcc/ada/gcc-interface/trans.c | 3 +++ 1 file changed, 3 insertions(+) (limited to 'gcc/ada/gcc-interface') diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index a2f06d7..48c0380 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -2302,6 +2302,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 -- cgit v1.1 From 925b418e065a9d94bd2c0d87fbfc93b573a309af Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Sat, 9 May 2020 23:17:39 +0200 Subject: Update copyright year --- gcc/ada/gcc-interface/ada-tree.h | 2 +- gcc/ada/gcc-interface/ada.h | 2 +- gcc/ada/gcc-interface/cuintp.c | 2 +- gcc/ada/gcc-interface/decl.c | 2 +- gcc/ada/gcc-interface/gadaint.h | 2 +- gcc/ada/gcc-interface/gigi.h | 2 +- gcc/ada/gcc-interface/lang-specs.h | 2 +- gcc/ada/gcc-interface/misc.c | 2 +- gcc/ada/gcc-interface/targtyps.c | 2 +- gcc/ada/gcc-interface/trans.c | 2 +- gcc/ada/gcc-interface/utils.c | 2 +- gcc/ada/gcc-interface/utils2.c | 2 +- 12 files changed, 12 insertions(+), 12 deletions(-) (limited to 'gcc/ada/gcc-interface') diff --git a/gcc/ada/gcc-interface/ada-tree.h b/gcc/ada/gcc-interface/ada-tree.h index 47c2e14..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- * 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 0393198..d87a82c 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- * 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 1adf627..fcdea32 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- * diff --git a/gcc/ada/gcc-interface/lang-specs.h b/gcc/ada/gcc-interface/lang-specs.h index 374fc1e..10f8473 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- * diff --git a/gcc/ada/gcc-interface/misc.c b/gcc/ada/gcc-interface/misc.c index 0867125..63e0ca7 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- * 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 48c0380..cddeae3 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- * diff --git a/gcc/ada/gcc-interface/utils.c b/gcc/ada/gcc-interface/utils.c index 1b320f5..391b682 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- * diff --git a/gcc/ada/gcc-interface/utils2.c b/gcc/ada/gcc-interface/utils2.c index edbb816..7799776 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- * -- cgit v1.1 From 90aea3e8d4f6119a9b666275b274bc4c251a7c91 Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Tue, 12 May 2020 13:14:20 +0200 Subject: Fix incorrect scalar storage order handling This fixes an oversight in the new canonicalization code for packable types: it does not take into account the scalar storage order. PR ada/95035 * gcc-interface/utils.c (packable_type_hasher::equal): Also compare the scalar storage order. (hash_packable_type): Also hash the scalar storage order. (hash_pad_type): Likewise. --- gcc/ada/gcc-interface/utils.c | 15 ++++++++++----- 1 file changed, 10 insertions(+), 5 deletions(-) (limited to 'gcc/ada/gcc-interface') diff --git a/gcc/ada/gcc-interface/utils.c b/gcc/ada/gcc-interface/utils.c index 391b682..1527be4 100644 --- a/gcc/ada/gcc-interface/utils.c +++ b/gcc/ada/gcc-interface/utils.c @@ -1026,14 +1026,15 @@ packable_type_hasher::equal (packable_type_hash *t1, packable_type_hash *t2) type1 = t1->type; type2 = t2->type; - /* We consider that packable types are equivalent if they have the same - name, size, alignment and RM size. Taking the mode into account is - redundant since it is determined by the others. */ + /* 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_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. */ @@ -1047,6 +1048,8 @@ hash_packable_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; } @@ -1402,7 +1405,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 @@ -1425,6 +1428,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; } -- cgit v1.1 From 27c3d986c4e704336c17155c558911beff1e1385 Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Tue, 12 May 2020 22:34:50 +0200 Subject: Be prepared for more aggregates in gigi This makes sure that gigi is prepared to handle more aggregates in the special memset code path. * sem_aggr.ads (Is_Single_Aggregate): New function. * sem_aggr.adb (Is_Others_Aggregate): Use local variable. (Is_Single_Aggregate): New function to recognize an aggregate with a single association containing a single choice. * fe.h (Is_Others_Aggregate): Delete. (Is_Single_Aggregate): New declaration. * gcc-interface/trans.c (gnat_to_gnu) : Call Is_Single_Aggregate instead of Is_Others_Aggregate. --- gcc/ada/gcc-interface/trans.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'gcc/ada/gcc-interface') diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index cddeae3..b7a4cad 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -7887,7 +7887,7 @@ gnat_to_gnu (Node_Id gnat_node) const bool use_memset_p = regular_array_type_p && Nkind (gnat_inner) == N_Aggregate - && Is_Others_Aggregate (gnat_inner); + && Is_Single_Aggregate (gnat_inner); /* If we use memset, we need to find the innermost expression. */ if (use_memset_p) @@ -7897,7 +7897,7 @@ gnat_to_gnu (Node_Id gnat_node) gnat_temp = Expression (First (Component_Associations (gnat_temp))); } while (Nkind (gnat_temp) == N_Aggregate - && Is_Others_Aggregate (gnat_temp)); + && Is_Single_Aggregate (gnat_temp)); gnu_rhs = gnat_to_gnu (gnat_temp); } else -- cgit v1.1 From 5dce843f32edfd998ae4844d8115a9c9b9c394bc Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Mon, 25 May 2020 09:18:03 +0200 Subject: Fix wrong assignment to mutable Out parameter of task entry Under very specific circumstances the compiler can generate a wrong assignment to a mutable record object which contains an array component, because it does not correctly handle the update of the discriminant. gcc/ada/ChangeLog * gcc-interface/gigi.h (operand_type): New static inline function. * gcc-interface/trans.c (gnat_to_gnu): Do not suppress conversion to the resulty type at the end for array types. * gcc-interface/utils2.c (build_binary_op) : Do not remove conversions between array types on the LHS. gcc/testsuite/ChangeLog * gnat.dg/array39.adb: New test. * gnat.dg/array39_pkg.ads: New helper. * gnat.dg/array39_pkg.adb: Likewise. --- gcc/ada/gcc-interface/gigi.h | 8 ++++++++ gcc/ada/gcc-interface/trans.c | 11 +++++++---- gcc/ada/gcc-interface/utils2.c | 44 ++++++++++++++++-------------------------- 3 files changed, 32 insertions(+), 31 deletions(-) (limited to 'gcc/ada/gcc-interface') diff --git a/gcc/ada/gcc-interface/gigi.h b/gcc/ada/gcc-interface/gigi.h index fcdea32..e43b3db 100644 --- a/gcc/ada/gcc-interface/gigi.h +++ b/gcc/ada/gcc-interface/gigi.h @@ -1209,3 +1209,11 @@ maybe_padded_object (tree 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/trans.c b/gcc/ada/gcc-interface/trans.c index b7a4cad..969a480 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -8821,7 +8821,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). @@ -8856,15 +8857,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)))) { diff --git a/gcc/ada/gcc-interface/utils2.c b/gcc/ada/gcc-interface/utils2.c index 7799776..a18d50f 100644 --- a/gcc/ada/gcc-interface/utils2.c +++ b/gcc/ada/gcc-interface/utils2.c @@ -875,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); @@ -921,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))))) @@ -976,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; } -- cgit v1.1 From a27aceb98a1178297cefb6eabe24d8a2ea4b72cd Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Mon, 25 May 2020 09:41:08 +0200 Subject: Change description of fat pointertype with -fgnat-encodings=minimal This makes a step back in the representation of fat pointer types in the debug info with -fgnat-encodings=minimal so as to avoid hiding the data indirection and making it easiser to synthetize the construct. gcc/ada/ChangeLog * gcc-interface/decl.c (gnat_to_gnu_entity) : Add a description of the various types associated with the unconstrained type. Declare the fat pointer earlier. Set the current function as context on the template type, and the fat pointer type on the array type. Always mark the fat pointer type as artificial and set it as the context for the pointer type to the array. Also reuse GNU_ENTITY_NAME. Finish up the unconstrained type at the very end. * gcc-interface/misc.c (gnat_get_array_descr_info): Do not handle fat pointer types and tidy up accordingly. * gcc-interface/utils.c (build_unc_object_type): Do not set the context on the template type. --- gcc/ada/gcc-interface/decl.c | 96 +++++++++++++++++++++++++------------------ gcc/ada/gcc-interface/misc.c | 54 +++++------------------- gcc/ada/gcc-interface/utils.c | 11 ++--- 3 files changed, 70 insertions(+), 91 deletions(-) (limited to 'gcc/ada/gcc-interface') diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index d87a82c..a36b129 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -2099,16 +2099,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: - The following fields are defined on array types and subtypes: + 1. the array type (suffix XUA) containing the actual data, - Component_Type Component type of the array. - Number_Dimensions Number of dimensions (an int). - First_Index Type of first index. */ + 2. the template type (suffix XUB) containng the bounds, + + 3. the fat pointer type (suffix XUP) representing a pointer or a + reference to the unconstrained array type: + XUP = struct { XUA *, XUB * } + + 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: { @@ -2120,7 +2132,7 @@ 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; + tree gnu_max_size = size_one_node, tem, obj; Entity_Id gnat_index; int index; tree comp_type; @@ -2195,7 +2207,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 @@ -2212,6 +2224,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. */ @@ -2313,6 +2341,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 @@ -2369,14 +2398,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 @@ -2384,24 +2405,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 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. */ - 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) - ? 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 @@ -2412,14 +2420,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; diff --git a/gcc/ada/gcc-interface/misc.c b/gcc/ada/gcc-interface/misc.c index 63e0ca7..5a5850a 100644 --- a/gcc/ada/gcc-interface/misc.c +++ b/gcc/ada/gcc-interface/misc.c @@ -778,7 +778,7 @@ gnat_get_array_descr_info (const_tree const_type, { tree type = const_cast (const_type); tree first_dimen, dimen; - bool is_packed_array, is_array, is_fat_ptr; + bool is_packed_array, is_array; int i; /* Temporaries created in the first pass and used in the second one for thin @@ -807,45 +807,16 @@ gnat_get_array_descr_info (const_tree const_type, && TYPE_INDEX_TYPE (TYPE_DOMAIN (type))) { is_array = true; - is_fat_ptr = false; first_dimen = type; - info->data_location = NULL_TREE; } - else if (TYPE_IS_FAT_POINTER_P (type) - && gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL) - { - tree ua_type = TYPE_UNCONSTRAINED_ARRAY (type); - - /* This will be our base object address. */ - tree placeholder_expr = build0 (PLACEHOLDER_EXPR, type); - - /* We assume below that maybe_unconstrained_array returns an INDIRECT_REF - node. */ - tree ua_val - = maybe_unconstrained_array (build_unary_op (INDIRECT_REF, - ua_type, - placeholder_expr)); - - is_array = false; - 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). */ tree placeholder_expr = build0 (PLACEHOLDER_EXPR, type); tree placeholder_addr @@ -856,7 +827,7 @@ gnat_get_array_descr_info (const_tree const_type, 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. */ + /* 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 @@ -865,18 +836,12 @@ gnat_get_array_descr_info (const_tree const_type, template_addr = fold_convert (TYPE_POINTER_TO (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; - is_fat_ptr = false; 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_bound_field = TYPE_FIELDS (bounds_type); } else @@ -932,7 +897,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 @@ -983,6 +948,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) { diff --git a/gcc/ada/gcc-interface/utils.c b/gcc/ada/gcc-interface/utils.c index 1527be4..fb08b6c 100644 --- a/gcc/ada/gcc-interface/utils.c +++ b/gcc/ada/gcc-interface/utils.c @@ -891,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) @@ -4167,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, @@ -4183,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; } -- cgit v1.1 From 15c55b96a721721e944f8617ae59bdcb273477e6 Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Mon, 25 May 2020 10:04:10 +0200 Subject: Fix incorrect handling of Component_Size The compiler can mishandle a Component_Size clause on an array type specifying a size multiple of the storage unit, when this size is not a multiple of the alignment of the component type. gcc/ada/ChangeLog * gcc-interface/decl.c (gnat_to_gnu_component_type): Cap alignment of the component type according to the component size. gcc/testsuite/ChangeLog * gnat.dg/array40.adb: New test. * gnat.dg/array40_pkg.ads: New helper. --- gcc/ada/gcc-interface/decl.c | 21 ++++++++++++++++++--- 1 file changed, 18 insertions(+), 3 deletions(-) (limited to 'gcc/ada/gcc-interface') diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index a36b129..ab6e79c 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -5153,7 +5153,7 @@ gnat_to_gnu_component_type (Entity_Id gnat_array, bool definition, 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)) @@ -5200,6 +5200,7 @@ gnat_to_gnu_component_type (Entity_Id gnat_array, bool definition, 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) @@ -5207,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, 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 -- cgit v1.1 From 036c83b68e7a958b75d02f392d0cb60f8b6a4ba5 Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Mon, 25 May 2020 10:15:12 +0200 Subject: Fix missing back-annotation for derived types Gigi fails to back-annotate the Present_Expr field of variants present in a type derived from a discriminated untagged record type, which is for example visible in the output -gnatRj. gcc/ada/ChangeLog * gcc-interface/decl.c (gnat_to_gnu_entity) : Tidy up. (build_variant_list): Add GNAT_VARIANT_PART parameter and annotate its variants if it is present. Adjust the recursive call by passing the variant subpart of variants, if any. (copy_and_substitute_in_layout): Rename GNU_SUBST_LIST to SUBST_LIST and adjust throughout. For a type, pass the variant part in the call to build_variant_list. --- gcc/ada/gcc-interface/decl.c | 70 +++++++++++++++++++++++++++----------------- 1 file changed, 43 insertions(+), 27 deletions(-) (limited to 'gcc/ada/gcc-interface') diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index ab6e79c..bd69c3a 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -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 build_subst_list (Entity_Id, Entity_Id, bool); -static vec build_variant_list (tree, vec, +static vec build_variant_list (tree, Node_Id, vec, vec); static tree maybe_saturate_size (tree); static tree validate_size (Uint, tree, Entity_Id, enum tree_code, bool, bool, @@ -2992,15 +2992,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 @@ -8886,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 -build_variant_list (tree qual_union_type, vec subst_list, - vec gnu_list) +build_variant_list (tree gnu_qual_union_type, Node_Id gnat_variant_part, + vec subst_list, vec 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; @@ -8918,11 +8918,21 @@ build_variant_list (tree qual_union_type, vec 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. */ @@ -9806,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 gnu_subst_list, + vec subst_list, bool debug_info_p) { const bool is_subtype = (Ekind (gnat_new_type) == E_Record_Subtype); @@ -9825,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. */ @@ -9855,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; } } @@ -9967,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. */ @@ -10054,13 +10070,13 @@ 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. */ -- cgit v1.1 From 0949185aed5830fe40bd4fa4a80b21bc90410406 Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Mon, 25 May 2020 10:32:21 +0200 Subject: Fix small fallout of earlier change gcc/ada/ChangeLog * gcc-interface/misc.c (get_array_bit_stride): Get to the debug type, if any, before calling gnat_get_array_descr_info. --- gcc/ada/gcc-interface/misc.c | 3 +++ 1 file changed, 3 insertions(+) (limited to 'gcc/ada/gcc-interface') diff --git a/gcc/ada/gcc-interface/misc.c b/gcc/ada/gcc-interface/misc.c index 5a5850a..f8fa856 100644 --- a/gcc/ada/gcc-interface/misc.c +++ b/gcc/ada/gcc-interface/misc.c @@ -1003,6 +1003,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) -- cgit v1.1 From af62ba41a4ed1e760e0056ba142798e8d6266e4d Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Mon, 25 May 2020 10:42:28 +0200 Subject: Fix internal error on problematic renaming This is an internal renaming generated for a generalized loop iteration made on a tagged record type with predicate, and gigi cannot use the most efficient way of implementing renamings because the renamed object is an expression with a non-empty Actions list. gcc/ada/ChangeLog * gcc-interface/decl.c (gnat_to_gnu_entity): Add new local variable and use it throughout the function. : Rename local variable and adjust accordingly. In the case of a renaming, materialize the entity if the renamed object is an N_Expression_With_Actions node. : Use Alias accessor function consistently. gcc/testsuite/ChangeLog * gnat.dg/renaming16.adb: New test. * gnat.dg/renaming16_pkg.ads: New helper. --- gcc/ada/gcc-interface/decl.c | 101 +++++++++++++++++++++++-------------------- 1 file changed, 55 insertions(+), 46 deletions(-) (limited to 'gcc/ada/gcc-interface') diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index bd69c3a..94ea05d 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -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 (); } @@ -448,6 +450,14 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) 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. + 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 @@ -636,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; @@ -692,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); @@ -704,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. */ @@ -764,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) { @@ -806,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) @@ -882,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; @@ -901,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); @@ -945,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; @@ -961,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 @@ -1013,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. */ @@ -1083,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; @@ -1140,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); @@ -1148,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, @@ -1525,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); @@ -1554,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 @@ -3396,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)) @@ -3482,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) @@ -3970,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)) @@ -3987,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, @@ -4847,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))) @@ -10083,7 +10092,7 @@ copy_and_substitute_in_layout (Entity_Id gnat_new_type, 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); -- cgit v1.1 From 1dedc12d186a110854537e1279b4e6c29f2df35a Mon Sep 17 00:00:00 2001 From: Alexandre Oliva Date: Tue, 26 May 2020 04:30:15 -0300 Subject: revamp dump and aux output names This patch simplifies (!!!) the logic governing the naming of dump files and auxiliary output files in the driver, in the compiler, and in the LTO wrapper. No changes are made to the naming of primary outputs, there are often ways to restore past behavior, and a number of inconsistencies are fixed. Some internal options are removed (-auxbase and -auxbase-strip), sensible existing uses of -dumpdir and -dumpbase options remain unchanged, additional useful cases are added, making for what is still admittedly quite complex. Extensive documentation and testcases provide numerous examples, from normal to corner cases. The most visible changes are: - aux and dump files now always go in the same directory, that defaults to the directory of the primary output, but that can be overridden with -dumpdir, -save-temps=*, or, preserving past behavior, with a -dumpbase with a directory component. - driver and compiler now have the same notion of naming of auxiliary outputs, e.g. .dwo files will no longer be in one location while the debug info suggests they are elsewhere, and -save-temps and .dwo auxiliary outputs now go in the same location as .su, .ci and coverage data, with consistent naming. - explicitly-specified primary output names guide not only the location of aux and dump outputs: the output base name is also used in their base name, as a prefix when also linking (e.g. foo.c bar.c -o foobar creates foobar-foo.dwo and foobar-bar.dwo with -gsplit-dwarf), or as the base name instead of the input name (foo.c -c -o whatever.o creates whatever.su rather than foo.su with -fstack-usage). The preference for the input file base name, quite useful for our testsuite, can be restored with -dumpbase "". When compiling and linking tests in the testsuite with additional inputs, we now use this flag. Files named in dejagnu board ldflags, libs, and ldscripts are now quoted in the gcc testsuite with -Wl, so that they are not counted as additional inputs by the compiler driver. - naming a -dumpbase when compiling multiple sources used to cause dumps from later compiles to overwrite those of earlier ones; it is now used as a prefix when compiling multiple sources, like an executable name above. - the dumpbase, explicitly specified or computed from output or input names, now also governs the naming of aux outputs; since aux outputs usually replaced the suffix from the input name, while dump outputs append their own additional suffixes, a -dumpbase-ext option is introduced to enable a chosen suffix to be dropped from dumpbase to form aux output names. - LTO dump and aux outputs were quite a mess, sometimes leaking temporary output names into -save-temps output names, sometimes conversely generating desirable aux outputs in temporary locations. They now obey the same logic of compiler aux and dump outputs, landing in the expected location and taking the linker output name or an explicit dumpbase overrider into account. - Naming of -fdump-final-insns outputs now follows the dump file naming logic for the .gkd files, and the .gk dump files generated in the second -fcompare-debug compilation get the .gk inserted before the suffix that -dumpbase-ext drops in aux outputs. gcc/ChangeLog: * common.opt (aux_base_name): Define. (dumpbase, dumpdir): Mark as Driver options. (-dumpbase, -dumpdir): Likewise. (dumpbase-ext, -dumpbase-ext): New. (auxbase, auxbase-strip): Drop. * doc/invoke.texi (-dumpbase, -dumpbase-ext, -dumpdir): Document. (-o): Introduce the notion of primary output, mention it influences auxiliary and dump output names as well, add examples. (-save-temps): Adjust, move examples into -dump*. (-save-temps=cwd, -save-temps=obj): Likewise. (-fdump-final-insns): Adjust. * dwarf2out.c (gen_producer_string): Drop auxbase and auxbase_strip; add dumpbase_ext. * gcc.c (enum save_temps): Add SAVE_TEMPS_DUMP. (save_temps_prefix, save_temps_length): Drop. (save_temps_overrides_dumpdir): New. (dumpdir, dumpbase, dumpbase_ext): New. (dumpdir_length, dumpdir_trailing_dash_added): New. (outbase, outbase_length): New. (The Specs Language): Introduce %". Adjust %b and %B. (ASM_FINAL_SPEC): Use %b.dwo for an aux output name always. Precede object file with %w when it's the primary output. (cpp_debug_options): Do not pass on incoming -dumpdir, -dumpbase and -dumpbase-ext options; recompute them with %:dumps. (cc1_options): Drop auxbase with and without compare-debug; use cpp_debug_options instead of dumpbase. Mark asm output with %w when it's the primary output. (static_spec_functions): Drop %:compare-debug-auxbase-opt and %:replace-exception. Add %:dumps. (driver_handle_option): Implement -save-temps=*/-dumpdir mutual overriding logic. Save dumpdir, dumpbase and dumpbase-ext options. Do not save output_file in save_temps_prefix. (adds_single_suffix_p): New. (single_input_file_index): New. (process_command): Combine output dir, output base name, and dumpbase into dumpdir and outbase. (set_collect_gcc_options): Pass a possibly-adjusted -dumpdir. (do_spec_1): Optionally dumpdir instead of save_temps_prefix, and outbase instead of input_basename in %b, %B and in -save-temps aux files. Handle empty argument %". (driver::maybe_run_linker): Adjust dumpdir and auxbase. (compare_debug_dump_opt_spec_function): Adjust gkd dump file naming. Spec-quote the computed -fdump-final-insns file name. (debug_auxbase_opt): Drop. (compare_debug_self_opt_spec_function): Drop auxbase-strip computation. (compare_debug_auxbase_opt_spec_function): Drop. (not_actual_file_p): New. (replace_extension_spec_func): Drop. (dumps_spec_func): New. (convert_white_space): Split-out parts into... (quote_string, whitespace_to_convert_p): ... these. New. (quote_spec_char_p, quote_spec, quote_spec_arg): New. (driver::finalize): Release and reset new variables; drop removed ones. * lto-wrapper.c (HAVE_TARGET_EXECUTABLE_SUFFIX): Define if... (TARGET_EXECUTABLE_SUFFIX): ... is defined; define this to the empty string otherwise. (DUMPBASE_SUFFIX): Drop leading period. (debug_objcopy): Use concat. (run_gcc): Recognize -save-temps=* as -save-temps too. Obey -dumpdir. Pass on empty dumpdir and dumpbase with a directory component. Simplify temp file names. * opts.c (finish_options): Drop aux base name handling. (common_handle_option): Drop auxbase-strip handling. * toplev.c (print_switch_values): Drop auxbase, add dumpbase-ext. (process_options): Derive aux_base_name from dump_base_name and dump_base_ext. (lang_dependent_init): Compute dump_base_ext along with dump_base_name. Disable stack usage and callgraph-info during lto generation and compare-debug recompilation. gcc/fortran/ChangeLog: * options.c (gfc_get_option_string): Drop auxbase, add dumpbase_ext. gcc/ada/ChangeLog: * gcc-interface/lang-specs.h: Drop auxbase and auxbase-strip. Use %:dumps instead of -dumpbase. Add %w for implicit .s primary output. * switch.adb (Is_Internal_GCC_Switch): Recognize dumpdir and dumpbase-ext. Drop auxbase and auxbase-strip. lto-plugin/ChangeLog: * lto-plugin.c (skip_in_suffix): New. (exec_lto_wrapper): Use skip_in_suffix and concat to build non-temporary output names. (onload): Look for -dumpdir in COLLECT_GCC_OPTIONS, and override link_output_name with it. contrib/ChangeLog: * compare-debug: Adjust for .gkd files named as dump files, with the source suffix rather than the object suffix. gcc/testsuite/ChangeLog: * gcc.misc-tests/outputs.exp: New. * gcc.misc-tests/outputs-0.c: New. * gcc.misc-tests/outputs-1.c: New. * gcc.misc-tests/outputs-2.c: New. * lib/gcc-defs.exp (gcc_adjusted_linker_flags): New. (gcc_adjust_linker_flags): New. (dg-additional-files-options): Call it. Pass -dumpbase "" when there are additional sources. * lib/profopt.exp (profopt-execute): Pass the executable suffix with -dumpbase-ext. * lib/scandump.exp (dump-base): Mention -dumpbase "" use. * lib/scanltranstree.exp: Adjust dump suffix expectation. * lib/scanwpaipa.exp: Likewise. --- gcc/ada/gcc-interface/lang-specs.h | 16 +++++----------- 1 file changed, 5 insertions(+), 11 deletions(-) (limited to 'gcc/ada/gcc-interface') diff --git a/gcc/ada/gcc-interface/lang-specs.h b/gcc/ada/gcc-interface/lang-specs.h index 10f8473..12b7cf5 100644 --- a/gcc/ada/gcc-interface/lang-specs.h +++ b/gcc/ada/gcc-interface/lang-specs.h @@ -34,17 +34,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} %{d*} %:dumps(%{!.adb:%{!.ads:.ada}}) \ %{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 +51,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} %{d*} %:dumps(%{!.adb:%{!.ads:.ada}}) \ %{gnatea:-gnatez} %{g*&m*&f*} \ %1 %{o*:%w%*-gnatO} \ %i \ @@ -66,9 +62,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} %{d*} %:dumps(%{!.adb:%{!.ads:.ada}}) \ %{gnatea:-gnatez} %{g*&m*&f*} \ %1 %{o*:%w%*-gnatO} \ %i \ -- cgit v1.1 From 6232d02b4fce4c67d39815aa8fb956e4b10a4e1b Mon Sep 17 00:00:00 2001 From: Alexandre Oliva Date: Tue, 26 May 2020 11:02:21 -0300 Subject: do not skip validation of switch after % Date: Tue, 26 May 2020 21:21:08 +0200 Subject: Fix issue with LTO bootstrap gcc/ada/ChangeLog PR ada/95333 * gcc-interface/decl.c (gnat_to_gnu_param): Never make a variant of the type. --- gcc/ada/gcc-interface/decl.c | 9 --------- 1 file changed, 9 deletions(-) (limited to 'gcc/ada/gcc-interface') diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index 94ea05d..38c73cb 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -5408,15 +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, except in LTO mode because free_lang_data_in_type would - undo it. ??? However, if this is a self-referential type, the type - can be very complex, so skip it for now. */ - if (ro_param - && !flag_generate_lto - && !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) -- cgit v1.1 From 9f2e635defba9d697a6c291013b37bd2c7ed91aa Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Sat, 30 May 2020 14:40:02 -0400 Subject: Ability to build the GNAT runtime with project files This change add project files to provide the ability to rebuild the runtime with gprbuild after setup-rts is called. gcc/ada/ * Makefile.rtl (ADA_INCLUDE_SRCS): Replace Makefile.adalib by libada.gpr and associated project files. (g-debpoo.o): Add missing rule to ensure subprograms are not reordered. (setup-rts): Add generation of libgnat/libgnarl.lst. (LIBGNAT_SRCS): Remove thread.c which is part of libgnarl. * tracebak.c, tb-gcc.c: Merged the two files to simplify dependencies. * libgnarl/libgnarl.gpr, libgnat/libada.gpr, libgnat/libgnat.gpr, libgnat/libgnat_common.gpr: New files. * doc/gnat_ugn/the_gnat_compilation_model.rst: Makefile.adalib replaced by libada.gpr. * libgnat/system-mingw.ads: Remove obsolete comment. * gcc-interface/Makefile.in: Remove dependency on tb-gcc.c. --- gcc/ada/gcc-interface/Makefile.in | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'gcc/ada/gcc-interface') diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in index 3342e33..25ebc3d 100644 --- a/gcc/ada/gcc-interface/Makefile.in +++ b/gcc/ada/gcc-interface/Makefile.in @@ -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) -- cgit v1.1 From ba2034610fcc0d56dd52cb20c26f9ab1997b520e Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Wed, 1 Jan 2020 15:19:05 -0500 Subject: [Ada] Remove ASIS tree generation 2020-06-03 Arnaud Charlet gcc/ada/ * aspects.adb, aspects.ads, atree.adb, atree.ads, elists.adb, elists.ads, fname.adb, fname.ads, gnat1drv.adb, lib.adb, lib.ads, namet.adb, namet.ads, nlists.adb, nlists.ads, opt.adb, opt.ads, osint-c.adb, osint-c.ads, repinfo.adb, repinfo.ads, sem_aux.adb, sem_aux.ads, sinput.adb, sinput.ads, stand.ads, stringt.adb, stringt.ads, switch-c.adb, table.adb, table.ads, uintp.adb, uintp.ads, urealp.adb, urealp.ads (Tree_Read, Tree_Write): Remove generation of ASIS trees. * doc/gnat_ugn/building_executable_programs_with_gnat.rst: Remove -gnatt and -gnatct documentation. * gnat_ugn.texi: Regenerate. * tree_in.ads, tree_in.adb, tree_io.ads, tree_io.adb, tree_gen.ads, tree_gen.adb, stand.adb: Remove. * gcc-interface/Makefile.in, gcc-interface/Make-lang.in: Remove references to tree_gen.o tree_in.o tree_io.o. --- gcc/ada/gcc-interface/Make-lang.in | 6 +----- gcc/ada/gcc-interface/Makefile.in | 4 ++-- 2 files changed, 3 insertions(+), 7 deletions(-) (limited to 'gcc/ada/gcc-interface') diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index acbe2b87..2e0f6b4 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -472,9 +472,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 \ @@ -632,7 +629,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 +1036,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 25ebc3d..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) -- cgit v1.1 From e60b6e23741c6d6059e6f765f18ce4c56366874b Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Thu, 9 Jan 2020 11:04:35 -0500 Subject: [Ada] Initial infrastructure for adding a tree checker 2020-06-03 Arnaud Charlet gcc/ada/ * frontend.adb (Frontend): Call (dummy for now) tree checker. * debug.adb: Reserve -gnatd_V for the tree checker. * vast.ads, vast.adb: New files. * gcc-interface/Make-lang.in: Add vast.o. --- gcc/ada/gcc-interface/Make-lang.in | 1 + 1 file changed, 1 insertion(+) (limited to 'gcc/ada/gcc-interface') diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index 2e0f6b4..12a0c58 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -481,6 +481,7 @@ GNAT_ADA_OBJS = \ ada/urealp.o \ ada/usage.o \ ada/validsw.o \ + ada/vast.o \ ada/warnsw.o \ ada/widechar.o -- cgit v1.1 From e5e53c73a0cf2e326bbfdacbe94e4a3bb79cd219 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Sun, 26 Jan 2020 15:32:43 -0500 Subject: [Ada] Remove OpenACC support 2020-06-04 Arnaud Charlet gcc/ada/ * back_end.adb, opt.ads, par-prag.adb, sem_ch5.adb, sem_prag.adb, sinfo.adb, sinfo.ads, snames.ads-tmpl, doc/gnat_rm/implementation_defined_pragmas.rst: Remove experimental support for OpenACC. * gcc-interface/misc.c, gcc-interface/trans.c, gcc-interface/lang.opt: Ditto. * gnat_rm.texi: Regenerate. gcc/testsuite/ * gnat.dg/openacc1.adb: Remove testcase. --- gcc/ada/gcc-interface/lang.opt | 4 - gcc/ada/gcc-interface/misc.c | 1 - gcc/ada/gcc-interface/trans.c | 672 +---------------------------------------- 3 files changed, 1 insertion(+), 676 deletions(-) (limited to 'gcc/ada/gcc-interface') 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 f8fa856..f72122b 100644 --- a/gcc/ada/gcc-interface/misc.c +++ b/gcc/ada/gcc-interface/misc.c @@ -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: diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index 969a480..b60b03d 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -1336,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. */ @@ -1635,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); @@ -3462,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. @@ -4003,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. */ -- cgit v1.1 From 110d0820bfcb421b8c680409cf5c65aa2a0b4b8e Mon Sep 17 00:00:00 2001 From: Bob Duff Date: Tue, 28 Jan 2020 15:06:41 -0500 Subject: [Ada] Put_Image attribute 2020-06-04 Bob Duff gcc/ada/ * libgnat/a-stobbu.adb, libgnat/a-stobbu.ads, libgnat/a-stobfi.adb, libgnat/a-stobfi.ads, libgnat/a-stoubu.adb, libgnat/a-stoubu.ads, libgnat/a-stoufi.adb, libgnat/a-stoufi.ads, libgnat/a-stoufo.adb, libgnat/a-stoufo.ads, libgnat/a-stouut.adb, libgnat/a-stouut.ads, libgnat/a-stteou.ads, libgnat/s-putaim.adb, libgnat/s-putaim.ads, libgnat/s-putima.adb, libgnat/s-putima.ads (Ada.Strings.Text_Output and children, System.Put_Images): New runtime support for Put_Image. * gcc-interface/Make-lang.in (GNAT_ADA_OBJS): Add exp_put_image.o. * exp_put_image.adb, exp_put_image.ads: New compiler package that generates calls to runtime routines that implement Put_Image. * Makefile.rtl: Add object files for Ada.Strings.Text_Output and children and System.Put_Images. * aspects.adb: Simplify initialization of Canonical_Aspect. * aspects.ads: Improve documentation. Add Aspect_Put_Image. * exp_attr.adb: Add support for Put_Image, by calling routines in Exp_Put_Image. * sem_util.adb (Is_Predefined_Dispatching_Operation): Return True for new TSS_Put_Image operation. * exp_ch3.adb: For tagged types, build a dispatching TSS_Put_Image operation by calling routines in Exp_Put_Image. * exp_disp.adb, exp_disp.ads: Make TSS_Put_Image be number 10, adjusting other operations' numbers after 10. We choose 10 because that's the last number shared by all runtimes. * exp_strm.adb: Use named notation as appropriate. * exp_cg.adb, exp_tss.ads: Add TSS_Put_Image. * libgnat/a-tags.ads: Modify Max_Predef_Prims for the new TSS_Put_Image. * impunit.adb: Add new runtime packages. * rtsfind.adb, rtsfind.ads: Add support for Ada.Strings.Text_Output, Ada.Strings.Text_Output.Utils, and System.Put_Images. * sem_attr.adb: Error checking for Put_Image calls. * sem_ch12.adb (Valid_Default_Attribute): Support for passing Put_Image as a generic formal parameter. * sem_ch13.adb: Analysis of Put_Image aspect. Turn it into a Put_Image attribute definition clause. * sem_ch8.adb (Analyze_Subprogram_Renaming): Support for renaming of the Put_Image attribute. * snames.adb-tmpl: Fix comments. * snames.ads-tmpl (Name_Put_Image): New Name_Id. (Attribute_Put_Image): New Attribute_Id. * tbuild.adb, tbuild.ads (Make_Increment): New utility. --- gcc/ada/gcc-interface/Make-lang.in | 1 + 1 file changed, 1 insertion(+) (limited to 'gcc/ada/gcc-interface') diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index 12a0c58..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 \ -- cgit v1.1 From c95f808ddd5046573423c9d1ee148645e5340738 Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Tue, 3 Mar 2020 17:57:51 +0000 Subject: [Ada] AI12-0028-1 Import of variadic C functions 2020-06-19 Eric Botcazou gcc/ada/ * gcc-interface/decl.c (gnat_to_gnu_param): Tidy up. (gnat_to_gnu_subprog_type): For a variadic C function, do not build unnamed parameters and do not add final void node. * gcc-interface/misc.c: Include snames.h. * gcc-interface/trans.c (Attribute_to_gnu): Tidy up. (Call_to_gnu): Implement support for unnamed parameters in a variadic C function. * gcc-interface/utils.c: Include snames.h. (copy_type): Tidy up. --- gcc/ada/gcc-interface/decl.c | 20 +++--- gcc/ada/gcc-interface/misc.c | 1 + gcc/ada/gcc-interface/trans.c | 142 ++++++++++++++++++++++++++++++++++-------- gcc/ada/gcc-interface/utils.c | 3 +- 4 files changed, 130 insertions(+), 36 deletions(-) (limited to 'gcc/ada/gcc-interface') diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index 38c73cb..33d59d5 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -5401,8 +5401,8 @@ gnat_to_gnu_param (Entity_Id gnat_param, tree gnu_param_type, bool first, tree unpadded_type = TREE_TYPE (TYPE_FIELDS (gnu_param_type)); if (foreign - || (!must_pass_by_ref (unpadded_type) - && mech != By_Reference + || (mech != By_Reference + && !must_pass_by_ref (unpadded_type) && (mech == By_Copy || !default_pass_by_ref (unpadded_type)) && TYPE_ALIGN (unpadded_type) >= TYPE_ALIGN (gnu_param_type))) gnu_param_type = unpadded_type; @@ -5424,11 +5424,6 @@ gnat_to_gnu_param (Entity_Id gnat_param, tree gnu_param_type, bool first, gnu_param_type = TREE_TYPE (gnu_param_type); gnu_param_type = TREE_TYPE (gnu_param_type); - - if (ro_param) - gnu_param_type - = change_qualified_type (gnu_param_type, TYPE_QUAL_CONST); - gnu_param_type = build_pointer_type (gnu_param_type); by_component_ptr = true; } @@ -5760,6 +5755,7 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition, { const Entity_Kind kind = Ekind (gnat_subprog); const bool method_p = is_cplusplus_method (gnat_subprog); + const bool variadic = IN (Convention (gnat_subprog), Convention_C_Variadic); Entity_Id gnat_return_type = Etype (gnat_subprog); Entity_Id gnat_param; tree gnu_type = present_gnu_tree (gnat_subprog) @@ -5792,7 +5788,7 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition, bool return_by_invisi_ref_p = false; bool return_unconstrained_p = false; bool incomplete_profile_p = false; - unsigned int num; + int num; /* Look into the return type and get its associated GCC tree if it is not void, and then compute various flags for the subprogram type. But make @@ -5962,6 +5958,11 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition, tree gnu_param, gnu_param_type; bool cico = false; + /* For a variadic C function, do not build unnamed parameters. */ + if (variadic + && num == (Convention (gnat_subprog) - Convention_C_Variadic_0)) + break; + /* Fetch an existing parameter with complete type and reuse it. But we didn't save the CICO property so we can only do it for In parameters or parameters passed by reference. */ @@ -6195,7 +6196,8 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition, /* The lists have been built in reverse. */ gnu_param_type_list = nreverse (gnu_param_type_list); - gnu_param_type_list = chainon (gnu_param_type_list, void_list_node); + if (!variadic) + gnu_param_type_list = chainon (gnu_param_type_list, void_list_node); gnu_param_list = nreverse (gnu_param_list); gnu_cico_list = nreverse (gnu_cico_list); diff --git a/gcc/ada/gcc-interface/misc.c b/gcc/ada/gcc-interface/misc.c index f72122b..f360ad4 100644 --- a/gcc/ada/gcc-interface/misc.c +++ b/gcc/ada/gcc-interface/misc.c @@ -47,6 +47,7 @@ #include "atree.h" #include "namet.h" #include "nlists.h" +#include "snames.h" #include "uintp.h" #include "fe.h" #include "sinfo.h" diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index b60b03d..5a93c43 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -2065,7 +2065,7 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute) case Attr_Range_Length: prefix_unused = true; - if (INTEGRAL_TYPE_P (gnu_type) || TREE_CODE (gnu_type) == REAL_TYPE) + if (INTEGRAL_TYPE_P (gnu_type) || SCALAR_FLOAT_TYPE_P (gnu_type)) { gnu_result_type = get_unpadded_type (Etype (gnat_node)); @@ -4457,9 +4457,10 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, tree gnu_after_list = NULL_TREE; tree gnu_retval = NULL_TREE; tree gnu_call, gnu_result; - bool by_descriptor = false; bool went_into_elab_proc = false; bool pushed_binding_level = false; + bool variadic; + bool by_descriptor; Entity_Id gnat_formal; Node_Id gnat_actual; atomic_acces_t aa_type; @@ -4505,20 +4506,32 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, entity being called. */ if (Nkind (Name (gnat_node)) == N_Explicit_Dereference) { + const Entity_Id gnat_prefix_type + = Underlying_Type (Etype (Prefix (Name (gnat_node)))); + gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node))); + variadic = IN (Convention (gnat_prefix_type), Convention_C_Variadic); /* If the access type doesn't require foreign-compatible representation, be prepared for descriptors. */ - if (targetm.calls.custom_function_descriptors > 0 - && Can_Use_Internal_Rep - (Underlying_Type (Etype (Prefix (Name (gnat_node)))))) - by_descriptor = true; + by_descriptor + = targetm.calls.custom_function_descriptors > 0 + && Can_Use_Internal_Rep (gnat_prefix_type); } else if (Nkind (Name (gnat_node)) == N_Attribute_Reference) - /* Assume here that this must be 'Elab_Body or 'Elab_Spec. */ - gnat_formal = Empty; + { + /* Assume here that this must be 'Elab_Body or 'Elab_Spec. */ + gnat_formal = Empty; + variadic = false; + by_descriptor = false; + } else - gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node))); + { + gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node))); + variadic + = IN (Convention (Entity (Name (gnat_node))), Convention_C_Variadic); + by_descriptor = false; + } /* The lifetime of the temporaries created for the call ends right after the return value is copied, so we can give them the scope of the elaboration @@ -4853,27 +4866,12 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual); } - /* Otherwise the parameter is passed by copy. */ - else + /* Then see if the parameter is passed by copy. */ + else if (is_true_formal_parm) { if (!in_param) gnu_name_list = tree_cons (NULL_TREE, gnu_name, gnu_name_list); - /* If we didn't create a PARM_DECL for the formal, this means that - it is an Out parameter not passed by reference and that need not - be copied in. In this case, the value of the actual need not be - read. However, we still need to make sure that its side-effects - are evaluated before the call, so we evaluate its address. */ - if (!is_true_formal_parm) - { - if (TREE_SIDE_EFFECTS (gnu_name)) - { - tree addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_name); - append_to_statement_list (addr, &gnu_stmt_list); - } - continue; - } - gnu_actual = convert (gnu_formal_type, gnu_actual); /* If this is a front-end built-in function, there is no need to @@ -4882,6 +4880,98 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, gnu_actual = convert (DECL_ARG_TYPE (gnu_formal), gnu_actual); } + /* Then see if this is an unnamed parameter in a variadic C function. */ + else if (variadic) + { + /* This is based on the processing done in gnat_to_gnu_param, but + we expect the mechanism to be set in (almost) all cases. */ + const Mechanism_Type mech = Mechanism (gnat_formal); + + /* Strip off possible padding type. */ + if (TYPE_IS_PADDING_P (gnu_formal_type)) + gnu_formal_type = TREE_TYPE (TYPE_FIELDS (gnu_formal_type)); + + /* Arrays are passed as pointers to element type. First check for + unconstrained array and get the underlying array. */ + if (TREE_CODE (gnu_formal_type) == UNCONSTRAINED_ARRAY_TYPE) + gnu_formal_type + = TREE_TYPE + (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_formal_type)))); + + /* Arrays are passed as pointers to element type. */ + if (mech != By_Copy && TREE_CODE (gnu_formal_type) == ARRAY_TYPE) + { + gnu_actual = maybe_implicit_deref (gnu_actual); + gnu_actual = maybe_unconstrained_array (gnu_actual); + + /* Strip off any multi-dimensional entries, then strip + off the last array to get the component type. */ + while (TREE_CODE (TREE_TYPE (gnu_formal_type)) == ARRAY_TYPE + && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_formal_type))) + gnu_formal_type = TREE_TYPE (gnu_formal_type); + + gnu_formal_type = TREE_TYPE (gnu_formal_type); + gnu_formal_type = build_pointer_type (gnu_formal_type); + gnu_actual + = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual); + } + + /* Fat pointers are passed as thin pointers. */ + else if (TYPE_IS_FAT_POINTER_P (gnu_formal_type)) + gnu_formal_type + = make_type_from_size (gnu_formal_type, + size_int (POINTER_SIZE), 0); + + /* If we were requested or muss pass by reference, do so. + If we were requested to pass by copy, do so. + Otherwise, pass In Out or Out parameters or aggregates by + reference. */ + else if (mech == By_Reference + || must_pass_by_ref (gnu_formal_type) + || (mech != By_Copy + && (!in_param || AGGREGATE_TYPE_P (gnu_formal_type)))) + { + gnu_formal_type = build_reference_type (gnu_formal_type); + gnu_actual + = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual); + } + + /* Otherwise pass by copy after applying default C promotions. */ + else + { + if (INTEGRAL_TYPE_P (gnu_formal_type) + && TYPE_PRECISION (gnu_formal_type) + < TYPE_PRECISION (integer_type_node)) + gnu_formal_type = integer_type_node; + + else if (SCALAR_FLOAT_TYPE_P (gnu_formal_type) + && TYPE_PRECISION (gnu_formal_type) + < TYPE_PRECISION (double_type_node)) + gnu_formal_type = double_type_node; + } + + gnu_actual = convert (gnu_formal_type, gnu_actual); + } + + /* If we didn't create a PARM_DECL for the formal, this means that + it is an Out parameter not passed by reference and that need not + be copied in. In this case, the value of the actual need not be + read. However, we still need to make sure that its side-effects + are evaluated before the call, so we evaluate its address. */ + else + { + if (!in_param) + gnu_name_list = tree_cons (NULL_TREE, gnu_name, gnu_name_list); + + if (TREE_SIDE_EFFECTS (gnu_name)) + { + tree addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_name); + append_to_statement_list (addr, &gnu_stmt_list); + } + + continue; + } + gnu_actual_vec.safe_push (gnu_actual); } diff --git a/gcc/ada/gcc-interface/utils.c b/gcc/ada/gcc-interface/utils.c index fb08b6c..2a6ed04 100644 --- a/gcc/ada/gcc-interface/utils.c +++ b/gcc/ada/gcc-interface/utils.c @@ -50,6 +50,7 @@ #include "types.h" #include "atree.h" #include "nlists.h" +#include "snames.h" #include "uintp.h" #include "fe.h" #include "sinfo.h" @@ -2561,7 +2562,7 @@ copy_type (tree type) } /* And the contents of the language-specific slot if needed. */ - if ((INTEGRAL_TYPE_P (type) || TREE_CODE (type) == REAL_TYPE) + if ((INTEGRAL_TYPE_P (type) || SCALAR_FLOAT_TYPE_P (type)) && TYPE_RM_VALUES (type)) { TYPE_RM_VALUES (new_type) = NULL_TREE; -- cgit v1.1 From bb24f34350078f92e8740713a4d241cb4c2fc9a7 Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Mon, 9 Mar 2020 17:20:59 +0000 Subject: [Ada] Consolidate handling of implicit dereferences 2020-06-19 Eric Botcazou gcc/ada/ * gcc-interface/trans.c (adjust_for_implicit_deref): Delete. (maybe_implicit_deref): Likewise. (Attribute_to_gnu): Replace calls to maybe_implicit_deref by calls to maybe_padded_object. (Call_to_gnu): Likewise. (gnat_to_gnu) : Likewise. : Likewise. : Likewise. : Remove call to adjust_for_implicit_deref and manually make sure that the designated type is complete. * gcc-interface/utils2.c (build_simple_component_ref): Add comment. --- gcc/ada/gcc-interface/trans.c | 80 +++++++++++++----------------------------- gcc/ada/gcc-interface/utils2.c | 2 ++ 2 files changed, 27 insertions(+), 55 deletions(-) (limited to 'gcc/ada/gcc-interface') diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index 5a93c43..3a6aa75 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -242,8 +242,6 @@ static bool addressable_p (tree, tree); static tree assoc_to_constructor (Entity_Id, Node_Id, tree); static tree pos_to_constructor (Node_Id, tree); static void validate_unchecked_conversion (Node_Id); -static Node_Id adjust_for_implicit_deref (Node_Id); -static tree maybe_implicit_deref (tree); static void set_expr_location_from_node (tree, Node_Id, bool = false); static void set_gnu_expr_location_from_node (tree, Node_Id); static bool set_end_locus_from_node (tree, Node_Id); @@ -2089,8 +2087,7 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute) Entity_Id gnat_param = Empty; bool unconstrained_ptr_deref = false; - /* Make sure any implicit dereference gets done. */ - gnu_prefix = maybe_implicit_deref (gnu_prefix); + gnu_prefix = maybe_padded_object (gnu_prefix); gnu_prefix = maybe_unconstrained_array (gnu_prefix); /* We treat unconstrained array In parameters specially. We also note @@ -2455,7 +2452,7 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute) break; case Attr_Component_Size: - gnu_prefix = maybe_implicit_deref (gnu_prefix); + gnu_prefix = maybe_padded_object (gnu_prefix); gnu_type = TREE_TYPE (gnu_prefix); if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE) @@ -4853,7 +4850,7 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, subprogram. */ else if (is_true_formal_parm && DECL_BY_COMPONENT_PTR_P (gnu_formal)) { - gnu_actual = maybe_implicit_deref (gnu_actual); + gnu_actual = maybe_padded_object (gnu_actual); gnu_actual = maybe_unconstrained_array (gnu_actual); /* Take the address of the object and convert to the proper pointer @@ -4901,7 +4898,7 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, /* Arrays are passed as pointers to element type. */ if (mech != By_Copy && TREE_CODE (gnu_formal_type) == ARRAY_TYPE) { - gnu_actual = maybe_implicit_deref (gnu_actual); + gnu_actual = maybe_padded_object (gnu_actual); gnu_actual = maybe_unconstrained_array (gnu_actual); /* Strip off any multi-dimensional entries, then strip @@ -6644,14 +6641,12 @@ gnat_to_gnu (Node_Id gnat_node) case N_Indexed_Component: { - tree gnu_array_object - = gnat_to_gnu (adjust_for_implicit_deref (Prefix (gnat_node))); + tree gnu_array_object = gnat_to_gnu ((Prefix (gnat_node))); tree gnu_type; - int ndim; - int i; + int ndim, i; Node_Id *gnat_expr_array; - gnu_array_object = maybe_implicit_deref (gnu_array_object); + gnu_array_object = maybe_padded_object (gnu_array_object); gnu_array_object = maybe_unconstrained_array (gnu_array_object); /* Convert vector inputs to their representative array type, to fit @@ -6715,12 +6710,11 @@ gnat_to_gnu (Node_Id gnat_node) case N_Slice: { - tree gnu_array_object - = gnat_to_gnu (adjust_for_implicit_deref (Prefix (gnat_node))); + tree gnu_array_object = gnat_to_gnu (Prefix (gnat_node)); gnu_result_type = get_unpadded_type (Etype (gnat_node)); - gnu_array_object = maybe_implicit_deref (gnu_array_object); + gnu_array_object = maybe_padded_object (gnu_array_object); gnu_array_object = maybe_unconstrained_array (gnu_array_object); gnu_expr = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type)); @@ -6740,12 +6734,11 @@ gnat_to_gnu (Node_Id gnat_node) case N_Selected_Component: { - Entity_Id gnat_prefix - = adjust_for_implicit_deref (Prefix (gnat_node)); + const Entity_Id gnat_prefix = Prefix (gnat_node); Entity_Id gnat_field = Entity (Selector_Name (gnat_node)); tree gnu_prefix = gnat_to_gnu (gnat_prefix); - gnu_prefix = maybe_implicit_deref (gnu_prefix); + gnu_prefix = maybe_padded_object (gnu_prefix); /* gnat_to_gnu_entity does not save the GNU tree made for renamed discriminants so avoid making recursive calls on each reference @@ -7209,7 +7202,7 @@ gnat_to_gnu (Node_Id gnat_node) gnu_type = gnat_to_gnu_type (Entity (gnat_temp)); else if (Nkind (gnat_temp) == N_Qualified_Expression) { - Entity_Id gnat_desig_type + const Entity_Id gnat_desig_type = Designated_Type (Underlying_Type (Etype (gnat_node))); ignore_init_type = Has_Constrained_Partial_View (gnat_desig_type); @@ -8063,12 +8056,21 @@ gnat_to_gnu (Node_Id gnat_node) break; case N_Free_Statement: + gnat_temp = Expression (gnat_node); + if (!type_annotate_only) { - tree gnu_ptr - = gnat_to_gnu (adjust_for_implicit_deref (Expression (gnat_node))); - tree gnu_ptr_type = TREE_TYPE (gnu_ptr); - tree gnu_obj_type, gnu_actual_obj_type; + tree gnu_ptr, gnu_ptr_type, gnu_obj_type, gnu_actual_obj_type; + + const Entity_Id gnat_desig_type + = Designated_Type (Underlying_Type (Etype (gnat_temp))); + + /* Make sure the designated type is complete before dereferencing, + in case it is a Taft Amendment type. */ + (void) gnat_to_gnu_entity (gnat_desig_type, NULL_TREE, false); + + gnu_ptr = gnat_to_gnu (gnat_temp); + gnu_ptr_type = TREE_TYPE (gnu_ptr); /* If this is a thin pointer, we must first dereference it to create a fat pointer, then go back below to a thin pointer. The reason @@ -10235,38 +10237,6 @@ validate_unchecked_conversion (Node_Id gnat_node) } } -/* EXP is to be used in a context where access objects are implicitly - dereferenced. Handle the cases when it is an access object. */ - -static Node_Id -adjust_for_implicit_deref (Node_Id exp) -{ - Entity_Id type = Underlying_Type (Etype (exp)); - - /* Make sure the designated type is complete before dereferencing. */ - if (Is_Access_Type (type)) - gnat_to_gnu_entity (Designated_Type (type), NULL_TREE, false); - - return exp; -} - -/* EXP is to be treated as an array or record. Handle the cases when it is - an access object and perform the required dereferences. */ - -static tree -maybe_implicit_deref (tree exp) -{ - /* 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 the object is padded, remove the padding. */ - exp = maybe_padded_object (exp); - - return exp; -} - /* Convert SLOC into LOCUS. Return true if SLOC corresponds to a source code location and false if it doesn't. If CLEAR_COLUMN is true, set the column information to 0. If DECL is given and SLOC diff --git a/gcc/ada/gcc-interface/utils2.c b/gcc/ada/gcc-interface/utils2.c index a18d50f..364440b 100644 --- a/gcc/ada/gcc-interface/utils2.c +++ b/gcc/ada/gcc-interface/utils2.c @@ -1997,6 +1997,8 @@ build_simple_component_ref (tree record, tree field, bool no_fold) tree type = TYPE_MAIN_VARIANT (TREE_TYPE (record)); tree ref; + /* The failure of this assertion will very likely come from a missing + insertion of an explicit dereference. */ gcc_assert (RECORD_OR_UNION_TYPE_P (type) && COMPLETE_TYPE_P (type)); /* Try to fold a conversion from another record or union type unless the type -- cgit v1.1 From 6894d9101e6324972b5b105227f3412a6c46549d Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Fri, 10 Apr 2020 09:19:22 +0000 Subject: [Ada] Remove handling of 'Pos and 'Val attributes from gigi 2020-06-19 Eric Botcazou gcc/ada/ * gcc-interface/trans.c (lvalue_required_for_attribute_p): Do not deal with 'Pos or 'Val. (Attribute_to_gnu): Likewise. * gcc-interface/utils.c (create_field_decl): Small formatting fix. --- gcc/ada/gcc-interface/trans.c | 13 ------------- gcc/ada/gcc-interface/utils.c | 2 +- 2 files changed, 1 insertion(+), 14 deletions(-) (limited to 'gcc/ada/gcc-interface') diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index 3a6aa75..313a2fb 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -773,8 +773,6 @@ lvalue_required_for_attribute_p (Node_Id gnat_node) { switch (Get_Attribute_Id (Attribute_Name (gnat_node))) { - case Attr_Pos: - case Attr_Val: case Attr_Pred: case Attr_Succ: case Attr_First: @@ -1701,17 +1699,6 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute) switch (attribute) { - case Attr_Pos: - case Attr_Val: - /* These are just conversions since representation clauses for - enumeration types are handled in the front-end. */ - gnu_expr = gnat_to_gnu (First (Expressions (gnat_node))); - if (attribute == Attr_Pos) - gnu_expr = maybe_character_value (gnu_expr); - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - gnu_result = convert (gnu_result_type, gnu_expr); - break; - case Attr_Pred: case Attr_Succ: /* These just add or subtract the constant 1 since representation diff --git a/gcc/ada/gcc-interface/utils.c b/gcc/ada/gcc-interface/utils.c index 2a6ed04..7adc313 100644 --- a/gcc/ada/gcc-interface/utils.c +++ b/gcc/ada/gcc-interface/utils.c @@ -3017,7 +3017,7 @@ create_field_decl (tree name, tree type, tree record_type, tree size, tree pos, unsigned int known_align; if (tree_fits_uhwi_p (pos)) - known_align = tree_to_uhwi (pos) & - tree_to_uhwi (pos); + known_align = tree_to_uhwi (pos) & -tree_to_uhwi (pos); else known_align = BITS_PER_UNIT; -- cgit v1.1 From 95c9c1c0dcbe4b9bfd9ff8fcdf44d799ffcf6275 Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Tue, 23 Jun 2020 17:17:50 +0200 Subject: Minor adjustment in assignment case gcc/ada/ChangeLog: * gcc-interface/trans.c (gnat_to_gnu) : Do not test Is_Bit_Packed_Array in the memset path. --- gcc/ada/gcc-interface/trans.c | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) (limited to 'gcc/ada/gcc-interface') diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index 313a2fb..a64b6d0 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -7282,10 +7282,8 @@ gnat_to_gnu (Node_Id gnat_node) : 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); const bool use_memset_p - = regular_array_type_p + = Is_Array_Type (gnat_type) && Nkind (gnat_inner) == N_Aggregate && Is_Single_Aggregate (gnat_inner); @@ -7356,7 +7354,8 @@ gnat_to_gnu (Node_Id gnat_node) not completely disjoint, play safe and use memmove. But don't do it for a bit-packed array as it might not be byte-aligned. */ if (TREE_CODE (gnu_result) == MODIFY_EXPR - && regular_array_type_p + && Is_Array_Type (gnat_type) + && !Is_Bit_Packed_Array (gnat_type) && !(Forwards_OK (gnat_node) && Backwards_OK (gnat_node))) { tree to = TREE_OPERAND (gnu_result, 0); -- cgit v1.1 From fa0588dbec38b46d88f46229e2f2b94d16ab09ba Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Tue, 23 Jun 2020 17:37:17 +0200 Subject: Emit user subtypes with -fgnat-encodings=minimal This changes the compiler to emit debug info for user-defined subtypes with -fgnat-encodings=minimal, as they might be needed by the debugger. gcc/ada/ChangeLog: * gcc-interface/decl.c (gnat_to_gnu_entity) : Set debug type to the base type and only if the subtype is artificial. --- gcc/ada/gcc-interface/decl.c | 19 +++++++------------ 1 file changed, 7 insertions(+), 12 deletions(-) (limited to 'gcc/ada/gcc-interface') diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index 33d59d5..589154b 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -3507,18 +3507,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) gnu_type = make_node (RECORD_TYPE); TYPE_NAME (gnu_type) = gnu_entity_name; - if (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL) - { - /* Use the ultimate base record type as the debug type. - Subtypes and derived types bring no useful - information. */ - Entity_Id gnat_debug_type = gnat_entity; - while (Etype (gnat_debug_type) != gnat_debug_type) - gnat_debug_type = Etype (gnat_debug_type); - tree gnu_debug_type - = TYPE_MAIN_VARIANT (gnat_to_gnu_type (gnat_debug_type)); - SET_TYPE_DEBUG_TYPE (gnu_type, gnu_debug_type); - } TYPE_PACKED (gnu_type) = TYPE_PACKED (gnu_base_type); TYPE_REVERSE_STORAGE_ORDER (gnu_type) = Reverse_Storage_Order (gnat_entity); @@ -3580,6 +3568,13 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) true, debug_info_p, NULL, gnat_entity); } + + /* Or else, if the subtype is artificial and encodings are not + used, use the base record type as the debug type. */ + else if (debug_info_p + && artificial_p + && gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL) + SET_TYPE_DEBUG_TYPE (gnu_type, gnu_unpad_base_type); } /* Otherwise, go down all the components in the new type and make -- cgit v1.1 From cd42cdc225a905cb1eb38dfad453e654261a659e Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Tue, 23 Jun 2020 17:44:43 +0200 Subject: Minor cleanup in elaborate_expression gcc/ada/ChangeLog: * gcc-interface/decl.c (elaborate_expression): Replace calls to Is_OK_Static_Expression with Compile_Time_Known_Value. --- gcc/ada/gcc-interface/decl.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'gcc/ada/gcc-interface') diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index 589154b..63118be 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -6774,13 +6774,13 @@ elaborate_expression (Node_Id gnat_expr, Entity_Id gnat_entity, const char *s, /* If we don't need a value and this is static or a discriminant, we don't need to do anything. */ if (!need_value - && (Is_OK_Static_Expression (gnat_expr) + && (Compile_Time_Known_Value (gnat_expr) || (Nkind (gnat_expr) == N_Identifier && Ekind (Entity (gnat_expr)) == E_Discriminant))) return NULL_TREE; /* If it's a static expression, we don't need a variable for debugging. */ - if (need_debug && Is_OK_Static_Expression (gnat_expr)) + if (need_debug && Compile_Time_Known_Value (gnat_expr)) need_debug = false; /* Otherwise, convert this tree to its GCC equivalent and elaborate it. */ -- cgit v1.1 From 5bdd063b9d8082cb8c8ede2721f1f425d3b952f0 Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Tue, 23 Jun 2020 18:02:07 +0200 Subject: Streamline implementation of renaming in gigi The main changes are 1) the bulk of the implementation is put back entirely in gnat_to_gnu_entity and 2) the handling of lvalues is unified, i.e. it no longer depends on the Materialize_Entity flag being present on the entity. gcc/ada/ChangeLog: * gcc-interface/ada-tree.h (DECL_RENAMED_OBJECT): Delete. * gcc-interface/decl.c (gnat_to_gnu_entity) : Always use the stabilized reference directly for renaming and create a variable pointing to it separately if requested. * gcc-interface/misc.c (gnat_print_decl): Adjust for deletion. * gcc-interface/trans.c (Identifier_to_gnu): Likewise. (gnat_to_gnu) : Do not deal with side-effects here. : Likewise. --- gcc/ada/gcc-interface/ada-tree.h | 7 --- gcc/ada/gcc-interface/decl.c | 126 ++++++++++++++++----------------------- gcc/ada/gcc-interface/misc.c | 3 - gcc/ada/gcc-interface/trans.c | 49 +++++---------- 4 files changed, 66 insertions(+), 119 deletions(-) (limited to 'gcc/ada/gcc-interface') diff --git a/gcc/ada/gcc-interface/ada-tree.h b/gcc/ada/gcc-interface/ada-tree.h index 11bfc37..461fa2b 100644 --- a/gcc/ada/gcc-interface/ada-tree.h +++ b/gcc/ada/gcc-interface/ada-tree.h @@ -525,13 +525,6 @@ do { \ #define SET_DECL_INDUCTION_VAR(NODE, X) \ SET_DECL_LANG_SPECIFIC (VAR_DECL_CHECK (NODE), X) -/* In a VAR_DECL without the DECL_LOOP_PARM_P flag set and that is a renaming - pointer, points to the object being renamed, if any. */ -#define DECL_RENAMED_OBJECT(NODE) \ - GET_DECL_LANG_SPECIFIC (VAR_DECL_CHECK (NODE)) -#define SET_DECL_RENAMED_OBJECT(NODE, X) \ - SET_DECL_LANG_SPECIFIC (VAR_DECL_CHECK (NODE), X) - /* In a TYPE_DECL, points to the parallel type if any, otherwise 0. */ #define DECL_PARALLEL_TYPE(NODE) \ GET_DECL_LANG_SPECIFIC (TYPE_DECL_CHECK (NODE)) diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index 63118be..270710b 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -714,7 +714,6 @@ 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 gnu_renamed_obj = NULL_TREE; tree gnu_ada_size = NULL_TREE; /* We need to translate the renamed object even though we are only @@ -1041,13 +1040,13 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) else if (type_is_padding_self_referential (TREE_TYPE (gnu_expr))) gnu_type = TREE_TYPE (gnu_expr); - /* Case 1: if this is a constant renaming stemming from a function - call, treat it as a normal object whose initial value is what - is being renamed. RM 3.3 says that the result of evaluating a - function call is a constant object. Therefore, it can be the - inner object of a constant renaming and the renaming must be - fully instantiated, i.e. it cannot be a reference to (part of) - an existing object. And treat other rvalues the same way. */ + /* If this is a constant renaming stemming from a function call, + treat it as a normal object whose initial value is what is being + renamed. RM 3.3 says that the result of evaluating a function + call is a constant object. Therefore, it can be the inner + object of a constant renaming and the renaming must be fully + instantiated, i.e. it cannot be a reference to (part of) an + existing object. And treat other rvalues the same way. */ tree inner = gnu_expr; while (handled_component_p (inner) || CONVERT_EXPR_P (inner)) inner = TREE_OPERAND (inner, 0); @@ -1089,92 +1088,75 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) && DECL_RETURN_VALUE_P (inner))) ; - /* Case 2: if the renaming entity need not be materialized, use - 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. 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) + /* Otherwise, this is an lvalue being renamed, so it needs to be + elaborated as a reference and substituted for the entity. But + this means that we must evaluate the address of the renaming + in the definition case to instantiate the SAVE_EXPRs. */ + else { - tree init = NULL_TREE; + tree gnu_init = NULL_TREE; - gnu_decl - = elaborate_reference (gnu_expr, gnat_entity, definition, - &init); + if (type_annotate_only && TREE_CODE (gnu_expr) == ERROR_MARK) + break; - /* We cannot evaluate the first arm of a COMPOUND_EXPR in the - correct place for this case. */ - gcc_assert (!init); + gnu_expr + = elaborate_reference (gnu_expr, gnat_entity, definition, + &gnu_init); - /* No DECL_EXPR will be created so the expression needs to be + /* No DECL_EXPR might be created so the expression needs to be marked manually because it will likely be shared. */ if (global_bindings_p ()) - MARK_VISITED (gnu_decl); + MARK_VISITED (gnu_expr); /* This assertion will fail if the renamed object isn't aligned enough as to make it possible to honor the alignment set on the renaming. */ if (align) { - unsigned int ralign = DECL_P (gnu_decl) - ? DECL_ALIGN (gnu_decl) - : TYPE_ALIGN (TREE_TYPE (gnu_decl)); + const unsigned int ralign + = DECL_P (gnu_expr) + ? DECL_ALIGN (gnu_expr) + : TYPE_ALIGN (TREE_TYPE (gnu_expr)); gcc_assert (ralign >= align); } /* The expression might not be a DECL so save it manually. */ + gnu_decl = gnu_expr; save_gnu_tree (gnat_entity, gnu_decl, true); saved = true; annotate_object (gnat_entity, gnu_type, NULL_TREE, false); - break; - } - /* Case 3: otherwise, make a constant pointer to the object we - are renaming and attach the object to the pointer after it is - elaborated. The object will be referenced directly instead - of indirectly via the pointer to avoid aliasing problems with - non-addressable entities. The pointer is called a "renaming" - pointer in this case. Note that we also need to preserve the - volatility of the renamed object through the indirection. */ - else - { - tree init = NULL_TREE; + /* If this is only a reference to the entity, we are done. */ + if (!definition) + break; - if (TREE_THIS_VOLATILE (gnu_expr) && !TYPE_VOLATILE (gnu_type)) - gnu_type - = change_qualified_type (gnu_type, TYPE_QUAL_VOLATILE); - gnu_type = build_reference_type (gnu_type); - used_by_ref = true; - const_flag = true; - volatile_flag = false; - inner_const_flag = TREE_READONLY (gnu_expr); - gnu_size = NULL_TREE; + /* Otherwise, emit the initialization statement, if any. */ + if (gnu_init) + add_stmt (gnu_init); - gnu_renamed_obj - = elaborate_reference (gnu_expr, gnat_entity, definition, - &init); + /* If it needs to be materialized for debugging purposes, build + the entity as indirect reference to the renamed object. */ + if (Materialize_Entity (gnat_entity)) + { + gnu_type = build_reference_type (gnu_type); + const_flag = true; + volatile_flag = false; - /* The expression needs to be marked manually because it will - 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 (gnu_renamed_obj); + gnu_expr = build_unary_op (ADDR_EXPR, gnu_type, gnu_expr); - if (type_annotate_only - && TREE_CODE (gnu_renamed_obj) == ERROR_MARK) - gnu_expr = NULL_TREE; - else - { - gnu_expr - = build_unary_op (ADDR_EXPR, gnu_type, gnu_renamed_obj); - if (init) - gnu_expr - = build_compound_expr (TREE_TYPE (gnu_expr), init, - gnu_expr); + create_var_decl (gnu_entity_name, gnu_ext_name, + TREE_TYPE (gnu_expr), gnu_expr, + const_flag, Is_Public (gnat_entity), + imported_p, static_flag, volatile_flag, + artificial_p, debug_info_p, attr_list, + gnat_entity, false); } + + /* Otherwise, instantiate the SAVE_EXPRs if needed. */ + else if (TREE_SIDE_EFFECTS (gnu_expr)) + add_stmt (build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr)); + + break; } } @@ -1538,7 +1520,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, !gnu_renamed_obj); + gnat_entity, true); 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); @@ -1566,10 +1548,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) else if (kind == E_Loop_Parameter) DECL_LOOP_PARM_P (gnu_decl) = 1; - /* If this is a renaming pointer, attach the renamed object to it. */ - 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 or need to have a true variable to represent it: diff --git a/gcc/ada/gcc-interface/misc.c b/gcc/ada/gcc-interface/misc.c index f360ad4..3999f9c 100644 --- a/gcc/ada/gcc-interface/misc.c +++ b/gcc/ada/gcc-interface/misc.c @@ -467,9 +467,6 @@ gnat_print_decl (FILE *file, tree node, int indent) if (DECL_LOOP_PARM_P (node)) print_node (file, "induction var", DECL_INDUCTION_VAR (node), indent + 4); - else - print_node (file, "renamed object", DECL_RENAMED_OBJECT (node), - indent + 4); break; default: diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index a64b6d0..c32bdb9 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -1249,25 +1249,16 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p) true))) gnu_result = DECL_INITIAL (gnu_result); - /* If it's a renaming pointer, get to the renamed object. */ - if (TREE_CODE (gnu_result) == VAR_DECL - && !DECL_LOOP_PARM_P (gnu_result) - && DECL_RENAMED_OBJECT (gnu_result)) - gnu_result = DECL_RENAMED_OBJECT (gnu_result); - - /* Otherwise, do the final dereference. */ - else - { - gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result); + /* Do the final dereference. */ + gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result); - if ((TREE_CODE (gnu_result) == INDIRECT_REF - || TREE_CODE (gnu_result) == UNCONSTRAINED_ARRAY_REF) - && No (Address_Clause (gnat_entity))) - TREE_THIS_NOTRAP (gnu_result) = 1; + if ((TREE_CODE (gnu_result) == INDIRECT_REF + || TREE_CODE (gnu_result) == UNCONSTRAINED_ARRAY_REF) + && No (Address_Clause (gnat_entity))) + TREE_THIS_NOTRAP (gnu_result) = 1; - if (read_only) - TREE_READONLY (gnu_result) = 1; - } + if (read_only) + TREE_READONLY (gnu_result) = 1; } /* If we have a constant declaration and its initializer, try to return the @@ -6543,31 +6534,19 @@ gnat_to_gnu (Node_Id gnat_node) && (Is_Array_Type (Etype (gnat_temp)) || Is_Record_Type (Etype (gnat_temp)) || Is_Concurrent_Type (Etype (gnat_temp))))) - { - tree gnu_temp - = gnat_to_gnu_entity (gnat_temp, - gnat_to_gnu (Renamed_Object (gnat_temp)), - true); - /* See case 2 of renaming in gnat_to_gnu_entity. */ - if (TREE_SIDE_EFFECTS (gnu_temp)) - gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_temp); - } + gnat_to_gnu_entity (gnat_temp, + gnat_to_gnu (Renamed_Object (gnat_temp)), + true); break; case N_Exception_Renaming_Declaration: gnat_temp = Defining_Entity (gnat_node); gnu_result = alloc_stmt_list (); - /* See the above case for the rationale. */ if (Present (Renamed_Entity (gnat_temp))) - { - tree gnu_temp - = gnat_to_gnu_entity (gnat_temp, - gnat_to_gnu (Renamed_Entity (gnat_temp)), - true); - if (TREE_SIDE_EFFECTS (gnu_temp)) - gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_temp); - } + gnat_to_gnu_entity (gnat_temp, + gnat_to_gnu (Renamed_Entity (gnat_temp)), + true); break; case N_Subprogram_Renaming_Declaration: -- cgit v1.1 From ce36abee27776e8cf8eee220b6acab45a53fe61f Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Tue, 23 Jun 2020 18:06:42 +0200 Subject: Minor tweak to elaborate_expression_1 gcc/ada/ChangeLog: * gcc-interface/decl.c (elaborate_expression_1): When GNAT encodings are not used, do not create a variable for debug info purposes if the expression is itself a user-declared variable. --- gcc/ada/gcc-interface/decl.c | 17 +++++++++++++---- 1 file changed, 13 insertions(+), 4 deletions(-) (limited to 'gcc/ada/gcc-interface') diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index 270710b..cad06a4 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -6823,6 +6823,18 @@ elaborate_expression_1 (tree gnu_expr, Entity_Id gnat_entity, const char *s, && Nkind (Associated_Node_For_Itype (gnat_entity)) == N_Loop_Parameter_Specification)); + /* If the GNAT encodings are not used, we don't need a variable for debug + info purposes if the expression is a constant or another variable, but + we need to be careful because we do not generate debug info for external + variables so DECL_IGNORED_P is not stable across units. */ + if (need_debug + && gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL + && (TREE_CONSTANT (gnu_expr) + || (!expr_public_p + && DECL_P (gnu_expr) + && !DECL_IGNORED_P (gnu_expr)))) + need_debug = false; + /* Now create it, possibly only for debugging purposes. */ if (use_variable || need_debug) { @@ -6843,10 +6855,7 @@ elaborate_expression_1 (tree gnu_expr, Entity_Id gnat_entity, const char *s, variable only if the variable is used by the generated code. Returning the variable ensures the caller will use it in generated code. Note that there is no need for a location if the debug info - contains an integer constant. - TODO: when the encoding-based debug scheme is dropped, move this - condition to the top-level IF block: we will not need to create a - variable anymore in such cases, then. */ + contains an integer constant. */ if (use_variable || (need_debug && !TREE_CONSTANT (gnu_expr))) return gnu_decl; } -- cgit v1.1 From b523ee1f4b139532ecffb2bf707e65cfc5a837fe Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Tue, 23 Jun 2020 18:14:12 +0200 Subject: Emit debug info for integral variables first This makes it possible for global dynamic types to reference the DIE of these integral variables. gcc/ada/ChangeLog: * gcc-interface/utils.c (gnat_write_global_declarations): Output integral global variables first and the imported functions later. --- gcc/ada/gcc-interface/utils.c | 42 +++++++++++++++++++++++++----------------- 1 file changed, 25 insertions(+), 17 deletions(-) (limited to 'gcc/ada/gcc-interface') diff --git a/gcc/ada/gcc-interface/utils.c b/gcc/ada/gcc-interface/utils.c index 7adc313..a96fde6 100644 --- a/gcc/ada/gcc-interface/utils.c +++ b/gcc/ada/gcc-interface/utils.c @@ -5880,7 +5880,16 @@ gnat_write_global_declarations (void) } } - /* Output debug information for all global type declarations first. This + /* First output the integral global variables, so that they can be referenced + as bounds by the global dynamic types. Skip external variables, unless we + really need to emit debug info for them:, e.g. imported variables. */ + FOR_EACH_VEC_SAFE_ELT (global_decls, i, iter) + if (TREE_CODE (iter) == VAR_DECL + && INTEGRAL_TYPE_P (TREE_TYPE (iter)) + && (!DECL_EXTERNAL (iter) || !DECL_IGNORED_P (iter))) + rest_of_decl_compilation (iter, true, 0); + + /* Now output debug information for the global type declarations. This ensures that global types whose compilation hasn't been finalized yet, for example pointers to Taft amendment types, have their compilation finalized in the right context. */ @@ -5888,30 +5897,29 @@ gnat_write_global_declarations (void) if (TREE_CODE (iter) == TYPE_DECL && !DECL_IGNORED_P (iter)) debug_hooks->type_decl (iter, false); - /* Output imported functions. */ + /* Then output the other global variables. We need to do that after the + information for global types is emitted so that they are finalized. */ FOR_EACH_VEC_SAFE_ELT (global_decls, i, iter) - if (TREE_CODE (iter) == FUNCTION_DECL - && DECL_EXTERNAL (iter) - && DECL_INITIAL (iter) == NULL - && !DECL_IGNORED_P (iter) - && DECL_FUNCTION_IS_DEF (iter)) - debug_hooks->early_global_decl (iter); + if (TREE_CODE (iter) == VAR_DECL + && !INTEGRAL_TYPE_P (TREE_TYPE (iter)) + && (!DECL_EXTERNAL (iter) || !DECL_IGNORED_P (iter))) + rest_of_decl_compilation (iter, true, 0); - /* Output global constants. */ + /* Output debug information for the global constants. */ FOR_EACH_VEC_SAFE_ELT (global_decls, i, iter) if (TREE_CODE (iter) == CONST_DECL && !DECL_IGNORED_P (iter)) debug_hooks->early_global_decl (iter); - /* Then output the global variables. We need to do that after the debug - information for global types is emitted so that they are finalized. Skip - external global variables, unless we need to emit debug info for them: - this is useful for imported variables, for instance. */ + /* Output it for the imported functions. */ FOR_EACH_VEC_SAFE_ELT (global_decls, i, iter) - if (TREE_CODE (iter) == VAR_DECL - && (!DECL_EXTERNAL (iter) || !DECL_IGNORED_P (iter))) - rest_of_decl_compilation (iter, true, 0); + if (TREE_CODE (iter) == FUNCTION_DECL + && DECL_EXTERNAL (iter) + && DECL_INITIAL (iter) == NULL + && !DECL_IGNORED_P (iter) + && DECL_FUNCTION_IS_DEF (iter)) + debug_hooks->early_global_decl (iter); - /* Output the imported modules/declarations. In GNAT, these are only + /* Output it for the imported modules/declarations. In GNAT, these are only materializing subprogram. */ FOR_EACH_VEC_SAFE_ELT (global_decls, i, iter) if (TREE_CODE (iter) == IMPORTED_DECL && !DECL_IGNORED_P (iter)) -- cgit v1.1 From d63fbcf80081d6fc6b746667fcacc8eb6e34f306 Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Tue, 23 Jun 2020 18:33:28 +0200 Subject: Fix memory corruption with vector and variant record The problem is that Has_Constrained_Partial_View must be tested on the base type of the designated type of an allocator. gcc/ada/ChangeLog: * gcc-interface/trans.c (gnat_to_gnu) : Minor tweaks. Call Has_Constrained_Partial_View on base type of designated type. --- gcc/ada/gcc-interface/trans.c | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) (limited to 'gcc/ada/gcc-interface') diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index c32bdb9..f74e0e7 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -7154,9 +7154,8 @@ gnat_to_gnu (Node_Id gnat_node) case N_Allocator: { - tree gnu_init = NULL_TREE; - tree gnu_type; - bool ignore_init_type = false; + tree gnu_type, gnu_init; + bool ignore_init_type; gnat_temp = Expression (gnat_node); @@ -7165,15 +7164,22 @@ gnat_to_gnu (Node_Id gnat_node) contains both the type and an initial value for the object. */ if (Nkind (gnat_temp) == N_Identifier || Nkind (gnat_temp) == N_Expanded_Name) - gnu_type = gnat_to_gnu_type (Entity (gnat_temp)); + { + ignore_init_type = false; + gnu_init = NULL_TREE; + gnu_type = gnat_to_gnu_type (Entity (gnat_temp)); + } + else if (Nkind (gnat_temp) == N_Qualified_Expression) { const Entity_Id gnat_desig_type = Designated_Type (Underlying_Type (Etype (gnat_node))); - ignore_init_type = Has_Constrained_Partial_View (gnat_desig_type); - gnu_init = gnat_to_gnu (Expression (gnat_temp)); + /* The flag is effectively only set on the base types. */ + ignore_init_type + = Has_Constrained_Partial_View (Base_Type (gnat_desig_type)); + gnu_init = gnat_to_gnu (Expression (gnat_temp)); gnu_init = maybe_unconstrained_array (gnu_init); gigi_checking_assert (!Do_Range_Check (Expression (gnat_temp))); -- cgit v1.1 From 855bb998c937d4b1c86a394daea8844fe87eb387 Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Tue, 23 Jun 2020 18:34:42 +0200 Subject: Remove superfluous space gcc/ada/ChangeLog: * gcc-interface/utils2.c (build_binary_op): Remove space. --- gcc/ada/gcc-interface/utils2.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'gcc/ada/gcc-interface') diff --git a/gcc/ada/gcc-interface/utils2.c b/gcc/ada/gcc-interface/utils2.c index 364440b..c8a2d7c 100644 --- a/gcc/ada/gcc-interface/utils2.c +++ b/gcc/ada/gcc-interface/utils2.c @@ -972,7 +972,7 @@ build_binary_op (enum tree_code op_code, tree result_type, && (((TREE_CODE (restype) == TREE_CODE (operand_type (result)) && TYPE_MODE (restype) - == TYPE_MODE (operand_type (result)))) + == TYPE_MODE (operand_type (result)))) || TYPE_ALIGN_OK (restype)))) result = TREE_OPERAND (result, 0); -- cgit v1.1 From 6153cfd7a342f131d347de1aea87f352f3ccd4e7 Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Thu, 2 Jul 2020 10:26:49 +0200 Subject: Reject components in extensions overlapping with the parent Such problematic components can be specified by means of a component clause but they cannot be fully supported by the type system. They had initially been forbidden, then we decided to accept them by working around the type system, but this is very fragile and, for example, any static aggregate is guaranteed to trigger an ICE with the current implementation. We now reject them again, except if the -gnatd.K switch is passed. gcc/ada/ChangeLog: * debug.adb (d.K): Document new usage. * fe.h (Debug_Flag_Dot_KK): Declare. * gcc-interface/decl.c (gnat_to_gnu_field): Give an error when the component overlaps with the parent subtype, except with -gnatd.K. --- gcc/ada/gcc-interface/decl.c | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) (limited to 'gcc/ada/gcc-interface') diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index cad06a4..025714b 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -7234,12 +7234,12 @@ gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed, { Entity_Id gnat_parent = Parent_Subtype (gnat_record_type); - /* Ensure the position does not overlap with the parent subtype, if there - is one. This test is omitted if the parent of the tagged type has a - full rep clause since, in this case, component clauses are allowed to - overlay the space allocated for the parent type and the front-end has - checked that there are no overlapping components. */ - if (Present (gnat_parent) && !Is_Fully_Repped_Tagged_Type (gnat_parent)) + /* Ensure the position doesn't overlap with the parent subtype if there + is one. It would be impossible to build CONSTRUCTORs and accessing + the parent could clobber the component in the extension if directly + done. We accept it with -gnatd.K for the sake of compatibility. */ + if (Present (gnat_parent) + && !(Debug_Flag_Dot_KK && Is_Fully_Repped_Tagged_Type (gnat_parent))) { tree gnu_parent = gnat_to_gnu_type (gnat_parent); -- cgit v1.1