diff options
Diffstat (limited to 'gcc/ada/gcc-interface')
| -rw-r--r-- | gcc/ada/gcc-interface/Make-lang.in | 2 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/Makefile.in | 30 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/decl.cc | 64 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/trans.cc | 108 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/utils.cc | 4 |
5 files changed, 137 insertions, 71 deletions
diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index 1c93816..bbbd697 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -1096,7 +1096,7 @@ check-ada-subtargets: check-acats-subtargets check-gnat-subtargets # No ada-specific selftests selftest-ada: -ACATSDIR = $(TESTSUITEDIR)/ada/acats-2 +ACATSDIR = $(TESTSUITEDIR)/ada/acats-4 ACATSCMD = run_acats.sh check_acats_numbers0:=1 2 3 4 5 6 7 8 9 diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in index 3557b46..8615b59 100644 --- a/gcc/ada/gcc-interface/Makefile.in +++ b/gcc/ada/gcc-interface/Makefile.in @@ -840,35 +840,6 @@ gnatlib-shared: PICFLAG_FOR_TARGET="$(PICFLAG_FOR_TARGET)" \ $(GNATLIB_SHARED) -# When building a SJLJ runtime for VxWorks, we need to ensure that the extra -# linker options needed for ZCX are not passed to prevent the inclusion of -# useless objects and potential troubles from the presence of extra symbols -# and references in some configurations. The inhibition is performed by -# commenting the pragma instead of deleting the line, as the latter might -# result in getting multiple blank lines, hence possible style check errors. -gnatlib-sjlj: - $(MAKE) $(FLAGS_TO_PASS) \ - EH_MECHANISM="" \ - MULTISUBDIR="$(MULTISUBDIR)" \ - THREAD_KIND="$(THREAD_KIND)" \ - LN_S="$(LN_S)" \ - ../stamp-gnatlib1-$(RTSDIR) - sed \ - -e 's/Frontend_Exceptions.*/Frontend_Exceptions : constant Boolean := True;/' \ - -e 's/ZCX_By_Default.*/ZCX_By_Default : constant Boolean := False;/' \ - $(RTSDIR)/system.ads > $(RTSDIR)/s.ads - $(MV) $(RTSDIR)/s.ads $(RTSDIR)/system.ads - $(MAKE) $(FLAGS_TO_PASS) \ - EH_MECHANISM="" \ - GNATLIBFLAGS="$(GNATLIBFLAGS)" \ - GNATLIBCFLAGS="$(GNATLIBCFLAGS)" \ - GNATLIBCFLAGS_FOR_C="$(GNATLIBCFLAGS_FOR_C)" \ - FORCE_DEBUG_ADAFLAGS="$(FORCE_DEBUG_ADAFLAGS)" \ - MULTISUBDIR="$(MULTISUBDIR)" \ - THREAD_KIND="$(THREAD_KIND)" \ - LN_S="$(LN_S)" \ - gnatlib - gnatlib-zcx: $(MAKE) $(FLAGS_TO_PASS) \ EH_MECHANISM="-gcc" \ @@ -877,7 +848,6 @@ gnatlib-zcx: LN_S="$(LN_S)" \ ../stamp-gnatlib1-$(RTSDIR) sed \ - -e 's/Frontend_Exceptions.*/Frontend_Exceptions : constant Boolean := False;/' \ -e 's/ZCX_By_Default.*/ZCX_By_Default : constant Boolean := True;/' \ $(RTSDIR)/system.ads > $(RTSDIR)/s.ads $(MV) $(RTSDIR)/s.ads $(RTSDIR)/system.ads diff --git a/gcc/ada/gcc-interface/decl.cc b/gcc/ada/gcc-interface/decl.cc index 972607a..86cbf5b 100644 --- a/gcc/ada/gcc-interface/decl.cc +++ b/gcc/ada/gcc-interface/decl.cc @@ -4502,7 +4502,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) if (Known_Esize (gnat_entity)) gnu_size = validate_size (Esize (gnat_entity), gnu_type, gnat_entity, - VAR_DECL, false, false, size_s, type_s); + VAR_DECL, false, false, NULL, NULL); /* ??? The test on Has_Size_Clause must be removed when "unknown" is no longer represented as Uint_0 (i.e. Use_New_Unknown_Rep). */ @@ -5444,7 +5444,7 @@ gnat_to_gnu_component_type (Entity_Id gnat_array, bool definition, const bool is_bit_packed = Is_Bit_Packed_Array (gnat_array); tree gnu_type = gnat_to_gnu_type (gnat_type); tree gnu_comp_size; - bool has_packed_components; + bool has_packed_component; unsigned int max_align; /* If an alignment is specified, use it as a cap on the component type @@ -5465,16 +5465,22 @@ gnat_to_gnu_component_type (Entity_Id gnat_array, bool definition, && !TYPE_FAT_POINTER_P (gnu_type) && tree_fits_uhwi_p (TYPE_SIZE (gnu_type))) { - gnu_type = make_packable_type (gnu_type, false, max_align); - has_packed_components = true; + tree gnu_packable_type = make_packable_type (gnu_type, false, max_align); + if (gnu_packable_type != gnu_type) + { + gnu_type = gnu_packable_type; + has_packed_component = true; + } + else + has_packed_component = false; } else - has_packed_components = is_bit_packed; + has_packed_component = is_bit_packed; /* Get and validate any specified Component_Size. */ gnu_comp_size = validate_size (Component_Size (gnat_array), gnu_type, gnat_array, - has_packed_components ? TYPE_DECL : VAR_DECL, true, + has_packed_component ? TYPE_DECL : VAR_DECL, true, Has_Component_Size_Clause (gnat_array), NULL, NULL); /* If the component type is a RECORD_TYPE that has a self-referential size, @@ -6016,7 +6022,8 @@ gnat_to_gnu_profile_type (Entity_Id gnat_type) return gnu_type; } -/* Return true if TYPE contains only integral data, recursively if need be. */ +/* Return true if TYPE contains only integral data, recursively if need be. + (integral data is to be understood as not floating-point data here). */ static bool type_contains_only_integral_data (tree type) @@ -6036,7 +6043,7 @@ type_contains_only_integral_data (tree type) return type_contains_only_integral_data (TREE_TYPE (type)); default: - return INTEGRAL_TYPE_P (type); + return INTEGRAL_TYPE_P (type) || POINTER_TYPE_P (type); } gcc_unreachable (); @@ -6414,6 +6421,33 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition, since structures are incomplete for the back-end. */ else if (Convention (gnat_subprog) != Convention_Stubbed) { + /* If we have two entries that may be returned in integer registers, + the larger has power-of-2 size and the smaller is integer, then + extend the smaller to this power-of-2 size to get a return type + with power-of-2 size and no holes, again to speed up accesses. */ + if (list_length (gnu_cico_field_list) == 2 + && gnu_cico_only_integral_type) + { + tree typ1 = TREE_TYPE (gnu_cico_field_list); + tree typ2 = TREE_TYPE (DECL_CHAIN (gnu_cico_field_list)); + if (TREE_CODE (typ1) == INTEGER_TYPE + && integer_pow2p (TYPE_SIZE (typ2)) + && compare_tree_int (TYPE_SIZE (typ2), + MAX_FIXED_MODE_SIZE) <= 0 + && tree_int_cst_lt (TYPE_SIZE (typ1), TYPE_SIZE (typ2))) + TREE_TYPE (gnu_cico_field_list) + = gnat_type_for_size (TREE_INT_CST_LOW (TYPE_SIZE (typ2)), + TYPE_UNSIGNED (typ1)); + else if (TREE_CODE (typ2) == INTEGER_TYPE + && integer_pow2p (TYPE_SIZE (typ1)) + && compare_tree_int (TYPE_SIZE (typ1), + MAX_FIXED_MODE_SIZE) <= 0 + && tree_int_cst_lt (TYPE_SIZE (typ2), TYPE_SIZE (typ1))) + TREE_TYPE (DECL_CHAIN (gnu_cico_field_list)) + = gnat_type_for_size (TREE_INT_CST_LOW (TYPE_SIZE (typ1)), + TYPE_UNSIGNED (typ2)); + } + finish_record_type (gnu_cico_return_type, nreverse (gnu_cico_field_list), 0, false); @@ -9690,6 +9724,20 @@ validate_size (Uint uint_size, tree gnu_type, Entity_Id gnat_object, return NULL_TREE; } + /* The size of stand-alone objects is always a multiple of the alignment, + but that's already enforced for elementary types by the front-end. */ + if (kind == VAR_DECL + && !component_p + && RECORD_OR_UNION_TYPE_P (gnu_type) + && !TYPE_FAT_POINTER_P (gnu_type) + && !integer_zerop (size_binop (TRUNC_MOD_EXPR, size, + bitsize_int (TYPE_ALIGN (gnu_type))))) + { + post_error_ne_num ("size for& must be multiple of alignment ^", + gnat_error_node, gnat_object, TYPE_ALIGN (gnu_type)); + return NULL_TREE; + } + return size; } diff --git a/gcc/ada/gcc-interface/trans.cc b/gcc/ada/gcc-interface/trans.cc index 23fc814..a7254fe 100644 --- a/gcc/ada/gcc-interface/trans.cc +++ b/gcc/ada/gcc-interface/trans.cc @@ -257,7 +257,7 @@ static tree emit_check (tree, tree, int, Node_Id); static tree build_unary_op_trapv (enum tree_code, tree, tree, Node_Id); static tree build_binary_op_trapv (enum tree_code, tree, tree, tree, Node_Id); static tree convert_with_check (Entity_Id, tree, bool, bool, Node_Id); -static bool addressable_p (tree, tree); +static bool addressable_p (tree, tree, bool); static bool aliasable_p (tree, tree); static tree assoc_to_constructor (Entity_Id, Node_Id, tree); static tree pos_to_constructor (Node_Id, tree); @@ -4049,7 +4049,7 @@ Subprogram_Body_to_gnu (Node_Id gnat_node) tree gnu_decl; /* Skip any entries that have been already filled in; they must - correspond to In Out parameters. */ + correspond to In Out parameters or previous Out parameters. */ while (gnu_cico_entry && TREE_VALUE (gnu_cico_entry)) gnu_cico_entry = TREE_CHAIN (gnu_cico_entry); @@ -4059,11 +4059,22 @@ Subprogram_Body_to_gnu (Node_Id gnat_node) if (DECL_BY_REF_P (gnu_decl)) gnu_decl = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_decl); - /* Do any needed references for padded types. */ - TREE_VALUE (gnu_cico_entry) - = convert (TREE_TYPE (TREE_PURPOSE (gnu_cico_entry)), gnu_decl); + TREE_VALUE (gnu_cico_entry) = gnu_decl; } + + /* Finally, ensure type consistency between TREE_PURPOSE and TREE_VALUE + so that the assignment of the latter to the former can be done. */ + tree gnu_cico_entry = gnu_cico_list; + while (gnu_cico_entry) + { + if (!VOID_TYPE_P (TREE_VALUE (gnu_cico_entry))) + TREE_VALUE (gnu_cico_entry) + = convert (TREE_TYPE (TREE_PURPOSE (gnu_cico_entry)), + TREE_VALUE (gnu_cico_entry)); + gnu_cico_entry = TREE_CHAIN (gnu_cico_entry); + } } + else vec_safe_push (gnu_return_label_stack, NULL_TREE); @@ -4161,9 +4172,13 @@ Subprogram_Body_to_gnu (Node_Id gnat_node) } } - /* Otherwise, if this is a procedure or a function which does not return - by invisible reference, we can do a direct block-copy out. */ - else + /* Otherwise, if this is a procedure or a function that does not return + by invisible reference, we can do a direct block-copy out, but we do + not need to do it for a null initialization procedure when the _Init + parameter is not passed in since we would copy uninitialized bits. */ + else if (!(Is_Null_Init_Proc (gnat_subprog) + && list_length (gnu_cico_list) == 1 + && TREE_CODE (TREE_VALUE (gnu_cico_list)) == VAR_DECL)) { tree gnu_retval; @@ -4876,6 +4891,8 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, tree gnu_formal = present_gnu_tree (gnat_formal) ? get_gnu_tree (gnat_formal) : NULL_TREE; tree gnu_actual_type = gnat_to_gnu_type (Etype (gnat_actual)); + const bool is_init_proc + = Is_Entity_Name (gnat_subprog) && Is_Init_Proc (Entity (gnat_subprog)); const bool in_param = (Ekind (gnat_formal) == E_In_Parameter); const bool is_true_formal_parm = gnu_formal && TREE_CODE (gnu_formal) == PARM_DECL; @@ -4925,7 +4942,7 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, copy to avoid breaking strict aliasing rules. */ if (is_by_ref_formal_parm && (gnu_name_type = gnat_to_gnu_type (Etype (gnat_name))) - && (!addressable_p (gnu_name, gnu_name_type) + && (!addressable_p (gnu_name, gnu_name_type, is_init_proc) || (node_is_type_conversion (gnat_actual) && (aliasing = !aliasable_p (gnu_name, gnu_actual_type))))) { @@ -5051,9 +5068,7 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, /* Do not initialize it for the _Init parameter of an initialization procedure since no data is meant to be passed in. */ - if (Ekind (gnat_formal) == E_Out_Parameter - && Is_Entity_Name (gnat_subprog) - && Is_Init_Proc (Entity (gnat_subprog))) + if (Ekind (gnat_formal) == E_Out_Parameter && is_init_proc) gnu_name = gnu_temp = create_temporary ("A", TREE_TYPE (gnu_name)); /* Initialize it on the fly like for an implicit temporary in the @@ -7590,6 +7605,10 @@ gnat_to_gnu (Node_Id gnat_node) case N_Allocator: { + const Entity_Id gnat_desig_type + = Designated_Type (Underlying_Type (Etype (gnat_node))); + const Entity_Id gnat_pool = Storage_Pool (gnat_node); + tree gnu_type, gnu_init; bool ignore_init_type; @@ -7608,9 +7627,6 @@ gnat_to_gnu (Node_Id gnat_node) 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)); @@ -7637,11 +7653,24 @@ gnat_to_gnu (Node_Id gnat_node) else gcc_unreachable (); - gnu_result_type = get_unpadded_type (Etype (gnat_node)); + /* If this is an array allocated with its bounds, use the thin pointer + as the result type to trigger the machinery in build_allocator, but + make sure not to do it for allocations on the return and secondary + stacks (see build_call_alloc_dealloc_proc for more details). */ + if (Is_Constr_Array_Subt_With_Bounds (gnat_desig_type) + && Is_Record_Type (Underlying_Type (Etype (gnat_pool))) + && !type_annotate_only) + { + tree gnu_array = gnat_to_gnu_type (Base_Type (gnat_desig_type)); + gnu_result_type + = build_pointer_type (TYPE_OBJECT_RECORD_TYPE (gnu_array)); + } + else + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + return build_allocator (gnu_type, gnu_init, gnu_result_type, Procedure_To_Call (gnat_node), - Storage_Pool (gnat_node), gnat_node, - ignore_init_type); + gnat_pool, gnat_node, ignore_init_type); } break; @@ -8577,6 +8606,18 @@ gnat_to_gnu (Node_Id gnat_node) (void) gnat_to_gnu_entity (gnat_desig_type, NULL_TREE, false); gnu_ptr = gnat_to_gnu (gnat_temp); + + /* If this is an array allocated with its bounds, first convert to + the thin pointer to trigger the special machinery below. */ + if (Is_Constr_Array_Subt_With_Bounds (gnat_desig_type)) + { + tree gnu_array = gnat_to_gnu_type (Base_Type (gnat_desig_type)); + gnu_ptr + = convert (build_pointer_type + (TYPE_OBJECT_RECORD_TYPE (gnu_array)), + gnu_ptr); + } + gnu_ptr_type = TREE_TYPE (gnu_ptr); /* If this is a thin pointer, we must first dereference it to create @@ -10353,7 +10394,8 @@ convert_with_check (Entity_Id gnat_type, tree gnu_expr, bool overflow_p, unless it is an expression involving computation or if it involves a reference to a bitfield or to an object not sufficiently aligned for its type. If GNU_TYPE is non-null, return true only if GNU_EXPR can - be directly addressed as an object of this type. + be directly addressed as an object of this type. COMPG is true when + the predicate is invoked for compiler-generated code. *** Notes on addressability issues in the Ada compiler *** @@ -10410,7 +10452,7 @@ convert_with_check (Entity_Id gnat_type, tree gnu_expr, bool overflow_p, generated to connect everything together. */ static bool -addressable_p (tree gnu_expr, tree gnu_type) +addressable_p (tree gnu_expr, tree gnu_type, bool compg) { /* For an integral type, the size of the actual type of the object may not be greater than that of the expected type, otherwise an indirect access @@ -10471,13 +10513,13 @@ addressable_p (tree gnu_expr, tree gnu_type) case COMPOUND_EXPR: /* The address of a compound expression is that of its 2nd operand. */ - return addressable_p (TREE_OPERAND (gnu_expr, 1), gnu_type); + return addressable_p (TREE_OPERAND (gnu_expr, 1), gnu_type, compg); case COND_EXPR: /* We accept &COND_EXPR as soon as both operands are addressable and expect the outcome to be the address of the selected operand. */ - return (addressable_p (TREE_OPERAND (gnu_expr, 1), NULL_TREE) - && addressable_p (TREE_OPERAND (gnu_expr, 2), NULL_TREE)); + return (addressable_p (TREE_OPERAND (gnu_expr, 1), NULL_TREE, compg) + && addressable_p (TREE_OPERAND (gnu_expr, 2), NULL_TREE, compg)); case COMPONENT_REF: return (((!DECL_BIT_FIELD (TREE_OPERAND (gnu_expr, 1)) @@ -10491,23 +10533,26 @@ addressable_p (tree gnu_expr, tree gnu_type) && (DECL_ALIGN (TREE_OPERAND (gnu_expr, 1)) >= default_field_alignment (TREE_OPERAND (gnu_expr, 1), TREE_TYPE (gnu_expr)) - /* We do not enforce this on strict-alignment platforms for - internal fields in order to keep supporting misalignment - of tagged types in legacy code. */ + /* But this was historically not enforced for targets that + do not require strict alignment, so we keep not doing + it for 1) internal fields in order to keep supporting + misalignment of tagged types and 2) compiler-generated + code in order to avoid creating useless temporaries. */ || (!STRICT_ALIGNMENT - && DECL_INTERNAL_P (TREE_OPERAND (gnu_expr, 1))))) + && (DECL_INTERNAL_P (TREE_OPERAND (gnu_expr, 1)) + || compg)))) /* The field of a padding record is always addressable. */ || TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))) - && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE)); + && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE, compg)); case ARRAY_REF: case ARRAY_RANGE_REF: case REALPART_EXPR: case IMAGPART_EXPR: case NOP_EXPR: - return addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE); + return addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE, compg); case CONVERT_EXPR: return (AGGREGATE_TYPE_P (TREE_TYPE (gnu_expr)) - && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE)); + && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE, compg)); case VIEW_CONVERT_EXPR: { @@ -10525,7 +10570,8 @@ addressable_p (tree gnu_expr, tree gnu_type) || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT || TYPE_ALIGN_OK (type) || TYPE_ALIGN_OK (inner_type)))) - && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE)); + && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE, + compg)); } default: diff --git a/gcc/ada/gcc-interface/utils.cc b/gcc/ada/gcc-interface/utils.cc index 23737c3..7324bee 100644 --- a/gcc/ada/gcc-interface/utils.cc +++ b/gcc/ada/gcc-interface/utils.cc @@ -1225,7 +1225,6 @@ make_packable_type (tree type, bool in_record, unsigned int max_align) Note that we rely on the pointer equality created here for TYPE_NAME to look through conversions in various places. */ TYPE_NAME (new_type) = TYPE_NAME (type); - TYPE_PACKED (new_type) = 1; TYPE_JUSTIFIED_MODULAR_P (new_type) = TYPE_JUSTIFIED_MODULAR_P (type); TYPE_CONTAINS_TEMPLATE_P (new_type) = TYPE_CONTAINS_TEMPLATE_P (type); TYPE_REVERSE_STORAGE_ORDER (new_type) = TYPE_REVERSE_STORAGE_ORDER (type); @@ -1240,6 +1239,8 @@ make_packable_type (tree type, bool in_record, unsigned int max_align) new_size = ceil_pow2 (size); new_align = MIN (new_size, BIGGEST_ALIGNMENT); SET_TYPE_ALIGN (new_type, new_align); + /* build_aligned_type needs to be able to adjust back the alignment. */ + TYPE_PACKED (new_type) = 0; } else { @@ -1261,6 +1262,7 @@ make_packable_type (tree type, bool in_record, unsigned int max_align) if (max_align > 0 && new_align > max_align) new_align = max_align; SET_TYPE_ALIGN (new_type, MIN (align, new_align)); + TYPE_PACKED (new_type) = 1; } TYPE_USER_ALIGN (new_type) = 1; |