Patchwork [Ada] Store the value of 'alignment of tagged types in the TSD

login
register
mail settings
Submitter Arnaud Charlet
Date Dec. 12, 2011, noon
Message ID <20111212120006.GA8185@adacore.com>
Download mbox | patch
Permalink /patch/130732/
State New
Headers show

Comments

Arnaud Charlet - Dec. 12, 2011, noon
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  <miranda@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.

Patch

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,