This patch removes primitive 'alignment to tagged types. This value
is now stored in the Type Specific Data record associated with each
tagged type since it is information known at compile-time.
Tested on x86_64-pc-linux-gnu, committed on trunk
2011-12-12 Javier Miranda <mira...@adacore.com>
* a-tags.ads (Alignment): New TSD field.
(Max_Predef_Prims): Value lowered to 15 (or 9 in case of
configurable runtime) Update documentation of predefined
primitives since Alignment has been removed.
* exp_disp.ads Update documentation of slots of dispatching
primitives.
* exp_disp.adb (Default_Prim_Op_Position): Update slot
values since alignment is no longer a predefined primitive.
(Is_Predefined_Dispatch_Operation): Remove _alignment.
(Is_Predefined_Internal_Operation): Remove _alignment.
(Make_DT): Update static test on the value stored in a-tags.ads
for Max_Predef_Prims; store the value of 'alignment in the TSD.
* exp_atag.ads, exp_atag.adb (Build_Get_Alignment): New subprogram
that retrieves the alignment from the TSD
* exp_util.adb (Build_Allocated_Deallocate_Proc): For deallocation
of class-wide types obtain the value of alignment from the TSD.
* exp_attr.adb (Expand_N_Attribute_Reference): For 'alignment
applied to a class-wide type invoke Build_Get_Alignment to
generate code which retrieves the value of the alignment from
the TSD.
* rtsfind.ads (RE_Alignment): New Ada.Tags entity
* sem_ch13.adb (Analyze_Attribute_Definition_Clause): For tagged
types if the value of the alignment is bigger than the Maximum
alignment then set the value of the alignment to the Maximum
alignment and report a warning.
* exp_ch3.adb (Make_Predefined_Primitive_Specs): Do not generate
spec of _alignment.
(Predefined_Primitive_Bodies): Do not generate body of _alignment.
Index: exp_atag.adb
===================================================================
--- exp_atag.adb (revision 182223)
+++ exp_atag.adb (working copy)
@@ -289,6 +289,25 @@
(RTE_Record_Component (RE_Access_Level), Loc));
end Build_Get_Access_Level;
+ -------------------------
+ -- Build_Get_Alignment --
+ -------------------------
+
+ function Build_Get_Alignment
+ (Loc : Source_Ptr;
+ Tag_Node : Node_Id) return Node_Id
+ is
+ begin
+ return
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Build_TSD (Loc,
+ Unchecked_Convert_To (RTE (RE_Address), Tag_Node)),
+ Selector_Name =>
+ New_Reference_To
+ (RTE_Record_Component (RE_Alignment), Loc));
+ end Build_Get_Alignment;
+
------------------------------------------
-- Build_Get_Predefined_Prim_Op_Address --
------------------------------------------
Index: exp_atag.ads
===================================================================
--- exp_atag.ads (revision 182223)
+++ exp_atag.ads (working copy)
@@ -66,6 +66,13 @@
--
-- Generates: TSD (Tag).Access_Level
+ function Build_Get_Alignment
+ (Loc : Source_Ptr;
+ Tag_Node : Node_Id) return Node_Id;
+ -- Build code that retrieves the alignment of the tagged type.
+ --
+ -- Generates: TSD (Tag).Alignment
+
procedure Build_Get_Predefined_Prim_Op_Address
(Loc : Source_Ptr;
Position : Uint;
Index: exp_util.adb
===================================================================
--- exp_util.adb (revision 182223)
+++ exp_util.adb (working copy)
@@ -755,8 +755,33 @@
Append_To (Actuals, New_Reference_To (Addr_Id, Loc));
Append_To (Actuals, New_Reference_To (Size_Id, Loc));
- Append_To (Actuals, New_Reference_To (Alig_Id, Loc));
+ if Is_Allocate
+ or else not Is_Class_Wide_Type (Desig_Typ)
+ then
+ Append_To (Actuals, New_Reference_To (Alig_Id, Loc));
+
+ -- For deallocation of class wide types we obtain the value of
+ -- alignment from the Type Specific Record of the deallocated object.
+ -- This is needed because the frontend expansion of class-wide types
+ -- into equivalent types confuses the backend.
+
+ else
+ -- Generate:
+ -- Obj.all'Alignment
+
+ -- ... because 'Alignment applied to class-wide types is expanded
+ -- into the code that reads the value of alignment from the TSD
+ -- (see Expand_N_Attribute_Reference)
+
+ Append_To (Actuals,
+ Unchecked_Convert_To (RTE (RE_Storage_Offset),
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Explicit_Dereference (Loc, Relocate_Node (Expr)),
+ Attribute_Name => Name_Alignment)));
+ end if;
+
-- h) Is_Controlled
-- Generate a run-time check to determine whether a class-wide object
Index: exp_attr.adb
===================================================================
--- exp_attr.adb (revision 182223)
+++ exp_attr.adb (working copy)
@@ -1120,19 +1120,11 @@
elsif Is_Class_Wide_Type (Ptyp) then
- -- No need to do anything else compiling under restriction
- -- No_Dispatching_Calls. During the semantic analysis we
- -- already notified such violation.
-
- if Restriction_Active (No_Dispatching_Calls) then
- return;
- end if;
-
New_Node :=
- Make_Function_Call (Loc,
- Name => New_Reference_To
- (Find_Prim_Op (Ptyp, Name_uAlignment), Loc),
- Parameter_Associations => New_List (Pref));
+ Build_Get_Alignment (Loc,
+ Make_Attribute_Reference (Loc,
+ Prefix => Pref,
+ Attribute_Name => Name_Tag));
if Typ /= Standard_Integer then
Index: a-tags.ads
===================================================================
--- a-tags.ads (revision 182223)
+++ a-tags.ads (working copy)
@@ -98,6 +98,8 @@
-- : primitive ops : +-------------------+
-- | pointers | | access level |
-- +--------------------+ +-------------------+
+ -- | alignment |
+ -- +-------------------+
-- | expanded name |
-- +-------------------+
-- | external tag |
@@ -269,6 +271,7 @@
-- function return, and class-wide stream I/O, the danger of objects
-- outliving their type declaration can be eliminated (Ada 2005: AI-344)
+ Alignment : Natural;
Expanded_Name : Cstring_Ptr;
External_Tag : Cstring_Ptr;
HT_Link : Tag_Ptr;
@@ -545,25 +548,24 @@
procedure Unregister_Tag (T : Tag);
-- Remove a particular tag from the external tag hash table
- Max_Predef_Prims : constant Positive := 16;
+ Max_Predef_Prims : constant Positive := 15;
-- Number of reserved slots for the following predefined ada primitives:
--
-- 1. Size
- -- 2. Alignment,
- -- 3. Read
- -- 4. Write
- -- 5. Input
- -- 6. Output
- -- 7. "="
- -- 8. assignment
- -- 9. deep adjust
- -- 10. deep finalize
- -- 11. async select
- -- 12. conditional select
- -- 13. prim_op kind
- -- 14. task_id
- -- 15. dispatching requeue
- -- 16. timed select
+ -- 2. Read
+ -- 3. Write
+ -- 4. Input
+ -- 5. Output
+ -- 6. "="
+ -- 7. assignment
+ -- 8. deep adjust
+ -- 9. deep finalize
+ -- 10. async select
+ -- 11. conditional select
+ -- 12. prim_op kind
+ -- 13. task_id
+ -- 14. dispatching requeue
+ -- 15. timed select
--
-- The compiler checks that the value here is correct
Index: rtsfind.ads
===================================================================
--- rtsfind.ads (revision 182223)
+++ rtsfind.ads (working copy)
@@ -570,6 +570,7 @@
RE_Unbounded_String, -- Ada.Strings.Unbounded
RE_Access_Level, -- Ada.Tags
+ RE_Alignment, -- Ada.Tags
RE_Address_Array, -- Ada.Tags
RE_Addr_Ptr, -- Ada.Tags
RE_Base_Address, -- Ada.Tags
@@ -1768,6 +1769,7 @@
RE_Unbounded_String => Ada_Strings_Unbounded,
RE_Access_Level => Ada_Tags,
+ RE_Alignment => Ada_Tags,
RE_Address_Array => Ada_Tags,
RE_Addr_Ptr => Ada_Tags,
RE_Base_Address => Ada_Tags,
Index: exp_disp.adb
===================================================================
--- exp_disp.adb (revision 182227)
+++ exp_disp.adb (working copy)
@@ -579,55 +579,52 @@
if Chars (E) = Name_uSize then
return Uint_1;
- elsif Chars (E) = Name_uAlignment then
+ elsif TSS_Name = TSS_Stream_Read then
return Uint_2;
- elsif TSS_Name = TSS_Stream_Read then
+ elsif TSS_Name = TSS_Stream_Write then
return Uint_3;
- elsif TSS_Name = TSS_Stream_Write then
+ elsif TSS_Name = TSS_Stream_Input then
return Uint_4;
- elsif TSS_Name = TSS_Stream_Input then
+ elsif TSS_Name = TSS_Stream_Output then
return Uint_5;
- elsif TSS_Name = TSS_Stream_Output then
+ elsif Chars (E) = Name_Op_Eq then
return Uint_6;
- elsif Chars (E) = Name_Op_Eq then
+ elsif Chars (E) = Name_uAssign then
return Uint_7;
- elsif Chars (E) = Name_uAssign then
+ elsif TSS_Name = TSS_Deep_Adjust then
return Uint_8;
- elsif TSS_Name = TSS_Deep_Adjust then
+ elsif TSS_Name = TSS_Deep_Finalize then
return Uint_9;
- elsif TSS_Name = TSS_Deep_Finalize then
- return Uint_10;
-
-- In VM targets unconditionally allow obtaining the position associated
-- with predefined interface primitives since in these platforms any
-- tagged type has these primitives.
elsif Ada_Version >= Ada_2005 or else not Tagged_Type_Expansion then
if Chars (E) = Name_uDisp_Asynchronous_Select then
- return Uint_11;
+ return Uint_10;
elsif Chars (E) = Name_uDisp_Conditional_Select then
- return Uint_12;
+ return Uint_11;
elsif Chars (E) = Name_uDisp_Get_Prim_Op_Kind then
- return Uint_13;
+ return Uint_12;
elsif Chars (E) = Name_uDisp_Get_Task_Id then
- return Uint_14;
+ return Uint_13;
elsif Chars (E) = Name_uDisp_Requeue then
- return Uint_15;
+ return Uint_14;
elsif Chars (E) = Name_uDisp_Timed_Select then
- return Uint_16;
+ return Uint_15;
end if;
end if;
@@ -1945,7 +1942,6 @@
TSS_Name := TSS_Name_Type (Name_Buffer (Name_Len - TSS_Name'Length + 1
.. Name_Len));
if Chars (E) = Name_uSize
- or else Chars (E) = Name_uAlignment
or else TSS_Name = TSS_Stream_Read
or else TSS_Name = TSS_Stream_Write
or else TSS_Name = TSS_Stream_Input
@@ -1991,7 +1987,6 @@
(Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len));
if Chars (E) = Name_uSize
- or else Chars (E) = Name_uAlignment
or else
(Chars (E) = Name_Op_Eq
and then Etype (First_Formal (E)) = Etype (Last_Formal (E)))
@@ -4513,16 +4508,16 @@
end if;
-- Ensure that the value of Max_Predef_Prims defined in a-tags is
- -- correct. Valid values are 10 under configurable runtime or 16
+ -- correct. Valid values are 9 under configurable runtime or 15
-- with full runtime.
if RTE_Available (RE_Interface_Data) then
- if Max_Predef_Prims /= 16 then
+ if Max_Predef_Prims /= 15 then
Error_Msg_N ("run-time library configuration error", Typ);
return Result;
end if;
else
- if Max_Predef_Prims /= 10 then
+ if Max_Predef_Prims /= 9 then
Error_Msg_N ("run-time library configuration error", Typ);
Error_Msg_CRT ("tagged types", Typ);
return Result;
@@ -4846,6 +4841,7 @@
-- TSD : Type_Specific_Data (I_Depth) :=
-- (Idepth => I_Depth,
-- Access_Level => Type_Access_Level (Typ),
+ -- Alignment => Typ'Alignment,
-- Expanded_Name => Cstring_Ptr!(Exname'Address))
-- External_Tag => Cstring_Ptr!(Exname'Address))
-- HT_Link => HT_Link'Address,
@@ -4895,6 +4891,23 @@
Append_To (TSD_Aggr_List,
Make_Integer_Literal (Loc, Type_Access_Level (Typ)));
+ -- Alignment
+
+ -- For CPP types we cannot rely on the value of 'Alignment provided
+ -- by the backend to initialize this TSD field.
+
+ if Convention (Typ) = Convention_CPP
+ or else Is_CPP_Class (Root_Type (Typ))
+ then
+ Append_To (TSD_Aggr_List,
+ Make_Integer_Literal (Loc, 0));
+ else
+ Append_To (TSD_Aggr_List,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Typ, Loc),
+ Attribute_Name => Name_Alignment));
+ end if;
+
-- Expanded_Name
Append_To (TSD_Aggr_List,
Index: exp_disp.ads
===================================================================
--- exp_disp.ads (revision 182223)
+++ exp_disp.ads (working copy)
@@ -52,65 +52,61 @@
-- type. Constructs of the form Prefix'Size are converted into
-- Prefix._Size.
- -- _Alignment (2) - implementation of the attribute 'Alignment for
- -- any tagged type. Constructs of the form Prefix'Alignment are
- -- converted into Prefix._Alignment.
-
- -- TSS_Stream_Read (3) - implementation of the stream attribute Read
+ -- TSS_Stream_Read (2) - implementation of the stream attribute Read
-- for any tagged type.
- -- TSS_Stream_Write (4) - implementation of the stream attribute Write
+ -- TSS_Stream_Write (3) - implementation of the stream attribute Write
-- for any tagged type.
- -- TSS_Stream_Input (5) - implementation of the stream attribute Input
+ -- TSS_Stream_Input (4) - implementation of the stream attribute Input
-- for any tagged type.
- -- TSS_Stream_Output (6) - implementation of the stream attribute
+ -- TSS_Stream_Output (5) - implementation of the stream attribute
-- Output for any tagged type.
- -- Op_Eq (7) - implementation of the equality operator for any non-
+ -- Op_Eq (6) - implementation of the equality operator for any non-
-- limited tagged type.
- -- _Assign (8) - implementation of the assignment operator for any
+ -- _Assign (7) - implementation of the assignment operator for any
-- non-limited tagged type.
- -- TSS_Deep_Adjust (9) - implementation of the finalization operation
+ -- TSS_Deep_Adjust (8) - implementation of the finalization operation
-- Adjust for any non-limited tagged type.
- -- TSS_Deep_Finalize (10) - implementation of the finalization
+ -- TSS_Deep_Finalize (9) - implementation of the finalization
-- operation Finalize for any non-limited tagged type.
- -- _Disp_Asynchronous_Select (11) - used in the expansion of ATC with
+ -- _Disp_Asynchronous_Select (10) - used in the expansion of ATC with
-- dispatching triggers. Null implementation for limited interfaces,
-- full body generation for types that implement limited interfaces,
-- not generated for the rest of the cases. See Expand_N_Asynchronous_
-- Select in Exp_Ch9 for more information.
- -- _Disp_Conditional_Select (12) - used in the expansion of conditional
+ -- _Disp_Conditional_Select (11) - used in the expansion of conditional
-- selects with dispatching triggers. Null implementation for limited
-- interfaces, full body generation for types that implement limited
-- interfaces, not generated for the rest of the cases. See Expand_N_
-- Conditional_Entry_Call in Exp_Ch9 for more information.
- -- _Disp_Get_Prim_Op_Kind (13) - helper routine used in the expansion
+ -- _Disp_Get_Prim_Op_Kind (12) - helper routine used in the expansion
-- of ATC with dispatching triggers. Null implementation for limited
-- interfaces, full body generation for types that implement limited
-- interfaces, not generated for the rest of the cases.
- -- _Disp_Get_Task_Id (14) - helper routine used in the expansion of
+ -- _Disp_Get_Task_Id (13) - helper routine used in the expansion of
-- Abort, attributes 'Callable and 'Terminated for task interface
-- class-wide types. Full body generation for task types, null
-- implementation for limited interfaces, not generated for the rest
-- of the cases. See Expand_N_Attribute_Reference in Exp_Attr and
-- Expand_N_Abort_Statement in Exp_Ch9 for more information.
- -- _Disp_Requeue (15) - used in the expansion of dispatching requeue
+ -- _Disp_Requeue (14) - used in the expansion of dispatching requeue
-- statements. Null implementation is provided for protected, task
-- and synchronized interfaces. Protected and task types implementing
-- concurrent interfaces receive full bodies. See Expand_N_Requeue_
-- Statement in Exp_Ch9 for more information.
- -- _Disp_Timed_Select (16) - used in the expansion of timed selects
+ -- _Disp_Timed_Select (15) - used in the expansion of timed selects
-- with dispatching triggers. Null implementation for limited
-- interfaces, full body generation for types that implement limited
-- interfaces, not generated for the rest of the cases. See Expand_N_
Index: sem_ch13.adb
===================================================================
--- sem_ch13.adb (revision 182228)
+++ sem_ch13.adb (working copy)
@@ -2495,8 +2495,8 @@
-- Alignment attribute definition clause
when Attribute_Alignment => Alignment : declare
- Align : constant Uint := Get_Alignment_Value (Expr);
-
+ Align : constant Uint := Get_Alignment_Value (Expr);
+ Max_Align : constant Uint := UI_From_Int (Maximum_Alignment);
begin
FOnly := True;
@@ -2511,8 +2511,17 @@
elsif Align /= No_Uint then
Set_Has_Alignment_Clause (U_Ent);
- Set_Alignment (U_Ent, Align);
+ if Is_Tagged_Type (U_Ent)
+ and then Align > Max_Align
+ then
+ Error_Msg_N
+ ("?alignment for & set to Maximum_Aligment", Nam);
+ Set_Alignment (U_Ent, Max_Align);
+ else
+ Set_Alignment (U_Ent, Align);
+ end if;
+
-- For an array type, U_Ent is the first subtype. In that case,
-- also set the alignment of the anonymous base type so that
-- other subtypes (such as the itypes for aggregates of the
Index: exp_ch3.adb
===================================================================
--- exp_ch3.adb (revision 182223)
+++ exp_ch3.adb (working copy)
@@ -250,7 +250,6 @@
-- Dispatching is required in general, since the result of the attribute
-- will vary with the actual object subtype.
--
- -- _alignment provides result of 'Alignment attribute
-- _size provides result of 'Size attribute
-- typSR provides result of 'Read attribute
-- typSW provides result of 'Write attribute
@@ -8156,18 +8155,6 @@
Ret_Type => Standard_Long_Long_Integer));
- -- Spec of _Alignment
-
- Append_To (Res, Predef_Spec_Or_Body (Loc,
- Tag_Typ => Tag_Typ,
- Name => Name_uAlignment,
- Profile => New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
- Parameter_Type => New_Reference_To (Tag_Typ, Loc))),
-
- Ret_Type => Standard_Integer));
-
-- Specs for dispatching stream attributes
declare
@@ -8740,29 +8727,6 @@
end loop;
end if;
- -- Body of _Alignment
-
- Decl := Predef_Spec_Or_Body (Loc,
- Tag_Typ => Tag_Typ,
- Name => Name_uAlignment,
- Profile => New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
- Parameter_Type => New_Reference_To (Tag_Typ, Loc))),
-
- Ret_Type => Standard_Integer,
- For_Body => True);
-
- Set_Handled_Statement_Sequence (Decl,
- Make_Handled_Sequence_Of_Statements (Loc, New_List (
- Make_Simple_Return_Statement (Loc,
- Expression =>
- Make_Attribute_Reference (Loc,
- Prefix => Make_Identifier (Loc, Name_X),
- Attribute_Name => Name_Alignment)))));
-
- Append_To (Res, Decl);
-
-- Body of _Size
Decl := Predef_Spec_Or_Body (Loc,
