diff options
Diffstat (limited to 'gcc/ada/gcc-interface')
| -rw-r--r-- | gcc/ada/gcc-interface/Makefile.in | 30 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/decl.cc | 37 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/trans.cc | 79 |
3 files changed, 84 insertions, 62 deletions
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..903ec84 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 (); @@ -9690,6 +9697,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..e02804b 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); @@ -4876,6 +4876,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 +4927,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 +5053,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 +7590,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 +7612,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 +7638,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 +8591,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 +10379,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 +10437,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 +10498,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 +10518,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 +10555,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: |