[Ada] Static allocation of the TSD record

Arnaud Charlet charlet@adacore.com
Thu Sep 27 14:52:00 GMT 2007


Tested on i686-linux, committed on trunk

After this patch the compiler generates code that places the Type
Specific Data record associated with library level tagged types
in read-only memory.

2007-09-26  Javier Miranda  <miranda@adacore.com>
	    Eric Botcazou  <ebotcazou@adacore.com>

	* a-tags.adb: 
	(Get_HT_Link/Set_HT_Link): Updated to handle the additional level of
	 indirection added to the HT_Link component of the TSD. This is required
	 to statically allocate the TSD.

	* a-tags.ads: 
	Minor reordering of the declarations in the private part. Required to
	add a level of indirection to the contents of the TSD component HT_Link.
	This is required to statically allocate the TSD.

	* decl.c (gnat_to_gnu_entity) <object>: Do not exclude objects with
	Is_Statically_Allocated set from constant objects.
	Do not make exported constants created by the compiler volatile.
	(gnat_to_gnu_param): Do not treat an IN parameter whose address is taken
	as read-only.

	* trans.c (Identifier_to_gnu): For constants, unshare initializers
	before returning them.

	* exp_disp.ads, exp_disp.adb (Building_Static_DT): Spec moved to the
	public part of the package.
	(Make_DT): Move HT_Link component out of the TSD record. For this
	purpose Make_DT now declares a separate object that stores the
	HT_Link value, and initializes the TSD component with the address
	of this new object. The addition of this level of indirection is
	required to statically allocate the TSD because the TSD cannot
	have variable components.
	(Expand_Interface_Conversion): Improve the expanded code.
	(Expand_Interface_Thunk): Set Is_Thunk in the thunk entity.

	* sem_disp.adb (Check_Dispatching_Operation): In case of a body
	declaring a primitive operation ---allowed by RM 3.9.2 (13.e/2)---,
	if we are building static dispatch tables then we must not generate
	extra code to register the primitive because the dispatch table will
	be built at the end of the library package; otherwise we notify that
	we cannot build the static dispatch table.

-------------- next part --------------
Index: a-tags.adb
===================================================================
--- a-tags.adb	(revision 128777)
+++ a-tags.adb	(working copy)
@@ -279,7 +279,7 @@ package body Ada.Tags is
          TSD     : constant Type_Specific_Data_Ptr :=
                      To_Type_Specific_Data_Ptr (TSD_Ptr.all);
       begin
-         return TSD.HT_Link;
+         return TSD.HT_Link.all;
       end Get_HT_Link;
 
       ----------
@@ -304,7 +304,7 @@ package body Ada.Tags is
          TSD     : constant Type_Specific_Data_Ptr :=
                      To_Type_Specific_Data_Ptr (TSD_Ptr.all);
       begin
-         TSD.HT_Link := Next;
+         TSD.HT_Link.all := Next;
       end Set_HT_Link;
 
    end HTable_Subprograms;
Index: a-tags.ads
===================================================================
--- a-tags.ads	(revision 128777)
+++ a-tags.ads	(working copy)
@@ -218,6 +218,26 @@ private
    --  type. This construct is used in the handling of dispatching triggers
    --  in select statements.
 
+   type Address_Array is array (Positive range <>) of System.Address;
+
+   subtype Dispatch_Table is Address_Array (1 .. 1);
+   --  Used by GDB to identify the _tags and traverse the run-time structure
+   --  associated with tagged types. For compatibility with older versions of
+   --  gdb, its name must not be changed.
+
+   type Tag is access all Dispatch_Table;
+   pragma No_Strict_Aliasing (Tag);
+
+   type Interface_Tag is access all Dispatch_Table;
+
+   No_Tag : constant Tag := null;
+
+   --  The expander ensures that Tag objects reference the Prims_Ptr component
+   --  of the wrapper.
+
+   type Tag_Ptr is access all Tag;
+   pragma No_Strict_Aliasing (Tag_Ptr);
+
    type Tag_Table is array (Natural range <>) of Tag;
 
    type Type_Specific_Data (Idepth : Natural) is record
@@ -237,7 +257,7 @@ private
 
       Expanded_Name : Cstring_Ptr;
       External_Tag  : Cstring_Ptr;
-      HT_Link       : Tag;
+      HT_Link       : Tag_Ptr;
       --  Components used to support to the Ada.Tags subprograms in RM 3.9
 
       --  Note: Expanded_Name is referenced by GDB to determine the actual name
@@ -291,8 +311,6 @@ private
       TK_Tagged,
       TK_Task);
 
-   type Address_Array is array (Positive range <>) of System.Address;
-
    type Dispatch_Table_Wrapper (Num_Prims : Natural) is record
       Signature     : Signature_Kind;
       Tag_Kind      : Tagged_Kind;
@@ -315,24 +333,6 @@ private
       --  actual array size, allocates the Dispatch_Table record accordingly.
    end record;
 
-   subtype Dispatch_Table is Address_Array (1 .. 1);
-   --  Used by GDB to identify the _tags and traverse the run-time structure
-   --  associated with tagged types. For compatibility with older versions of
-   --  gdb, its name must not be changed.
-
-   type Tag is access all Dispatch_Table;
-   pragma No_Strict_Aliasing (Tag);
-
-   type Interface_Tag is access all Dispatch_Table;
-
-   No_Tag : constant Tag := null;
-
-   --  The expander ensures that Tag objects reference the Prims_Ptr component
-   --  of the wrapper.
-
-   type Tag_Ptr is access all Tag;
-   pragma No_Strict_Aliasing (Tag_Ptr);
-
    type Dispatch_Table_Ptr is access all Dispatch_Table_Wrapper;
    pragma No_Strict_Aliasing (Dispatch_Table_Ptr);
 
Index: decl.c
===================================================================
--- decl.c	(revision 128777)
+++ decl.c	(working copy)
@@ -500,7 +500,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
 	bool used_by_ref = false;
 	bool const_flag
 	  = ((kind == E_Constant || kind == E_Variable)
-	     && !Is_Statically_Allocated (gnat_entity)
 	     && Is_True_Constant (gnat_entity)
 	     && (((Nkind (Declaration_Node (gnat_entity))
 		   == N_Object_Declaration)
@@ -732,7 +731,11 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
 	   the object volatile.  We also interpret 13.3(19) conservatively
 	   and disallow any optimizations for an object covered by it.  */
 	if ((Treat_As_Volatile (gnat_entity)
-	     || Is_Exported (gnat_entity)
+	     || (Is_Exported (gnat_entity)
+		 /* Exclude exported constants created by the compiler,
+		    which should boil down to static dispatch tables and
+		    make it possible to put them in read-only memory. ??*/
+		 && (Comes_From_Source (gnat_entity) || !const_flag))
 	     || Is_Imported (gnat_entity)
 	     || Present (Address_Clause (gnat_entity)))
 	    && !TYPE_VOLATILE (gnu_type))
@@ -4447,6 +4450,8 @@ gnat_to_gnu_param (Entity_Id gnat_param,
   tree gnu_param_name = get_entity_name (gnat_param);
   tree gnu_param_type = gnat_to_gnu_type (Etype (gnat_param));
   bool in_param = (Ekind (gnat_param) == E_In_Parameter);
+  /* The parameter can be indirectly modified if its address is taken.  */
+  bool ro_param = in_param && !Address_Taken (gnat_param);
   bool by_return = false, by_component_ptr = false, by_ref = false;
   tree gnu_param;
 
@@ -4473,11 +4478,11 @@ gnat_to_gnu_param (Entity_Id gnat_param,
 	gnu_param_type = unpadded_type;
     }
 
-  /* If this is an IN parameter, it is read-only, so make a variant of the
-     type that is read-only.  ??? However, if this is an unconstrained array,
-     that type can be very complex, so skip it for now.  Likewise for any
-     other self-referential type.  */
-  if (in_param
+  /* If this is a read-only parameter, make a variant of the type that is
+     read-only.  ??? However, if this is an unconstrained array, that type
+     can be very complex, so skip it for now.  Likewise for any other
+     self-referential type.  */
+  if (ro_param
       && TREE_CODE (gnu_param_type) != UNCONSTRAINED_ARRAY_TYPE
       && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_param_type)))
     gnu_param_type = build_qualified_type (gnu_param_type,
@@ -4511,7 +4516,7 @@ gnat_to_gnu_param (Entity_Id gnat_param,
       by_component_ptr = true;
       gnu_param_type = TREE_TYPE (gnu_param_type);
 
-      if (in_param)
+      if (ro_param)
 	gnu_param_type = build_qualified_type (gnu_param_type,
 					       (TYPE_QUALS (gnu_param_type)
 						| TYPE_QUAL_CONST));
@@ -4584,12 +4589,12 @@ gnat_to_gnu_param (Entity_Id gnat_param,
     return gnu_param_type;
 
   gnu_param = create_param_decl (gnu_param_name, gnu_param_type,
-				 by_ref || by_component_ptr || in_param);
+				 ro_param || by_ref || by_component_ptr);
   DECL_BY_REF_P (gnu_param) = by_ref;
   DECL_BY_COMPONENT_PTR_P (gnu_param) = by_component_ptr;
   DECL_BY_DESCRIPTOR_P (gnu_param) = (mech == By_Descriptor);
   DECL_POINTS_TO_READONLY_P (gnu_param)
-    = (in_param && (by_ref || by_component_ptr));
+    = (ro_param && (by_ref || by_component_ptr));
 
   /* If no Mechanism was specified, indicate what we're using, then
      back-annotate it.  */
Index: trans.c
===================================================================
--- trans.c	(revision 128777)
+++ trans.c	(working copy)
@@ -626,7 +626,7 @@ Identifier_to_gnu (Node_Id gnat_node, tr
 			       Is_Aliased (gnat_temp));
 
       if (!object || !parent_requires_lvalue)
-	gnu_result = DECL_INITIAL (gnu_result);
+	gnu_result = unshare_expr (DECL_INITIAL (gnu_result));
     }
 
   *gnu_result_type_p = gnu_result_type;
Index: exp_disp.ads
===================================================================
--- exp_disp.ads	(revision 128777)
+++ exp_disp.ads	(working copy)
@@ -164,6 +164,10 @@ package Exp_Disp is
    --    Exp_Disp.Default_Prim_Op_Position - indirect use
    --    Exp_Disp.Set_All_DT_Position      - direct   use
 
+   function Building_Static_DT (Typ : Entity_Id) return Boolean;
+   pragma Inline (Building_Static_DT);
+   --  Returns true when building statically allocated dispatch tables
+
    procedure Build_Static_Dispatch_Tables (N : Node_Id);
    --  N is a library level package declaration or package body. Build the
    --  static dispatch table of the tagged types defined at library level. In
Index: exp_disp.adb
===================================================================
--- exp_disp.adb	(revision 128777)
+++ exp_disp.adb	(working copy)
@@ -66,10 +66,6 @@ package body Exp_Disp is
    -- Local Subprograms --
    -----------------------
 
-   function Building_Static_DT (Typ : Entity_Id) return Boolean;
-   pragma Inline (Building_Static_DT);
-   --  Returns true when building statically allocated dispatch tables
-
    function Default_Prim_Op_Position (E : Entity_Id) return Uint;
    --  Ada 2005 (AI-251): Returns the fixed position in the dispatch table
    --  of the default primitive operations.
@@ -104,7 +100,13 @@ package body Exp_Disp is
    function Building_Static_DT (Typ : Entity_Id) return Boolean is
    begin
       return Static_Dispatch_Tables
-               and then Is_Library_Level_Tagged_Type (Typ);
+        and then Is_Library_Level_Tagged_Type (Typ)
+
+         --  If the type is derived from a CPP class we cannot statically
+         --  build the dispatch tables because we must inherit primitives
+         --  from the CPP side.
+
+        and then not Is_CPP_Class (Root_Type (Typ));
    end Building_Static_DT;
 
    ----------------------------------
@@ -742,7 +744,7 @@ package body Exp_Disp is
          Operand_Typ := Base_Type (Corresponding_Record_Type (Operand_Typ));
       end if;
 
-      --  Handle access types to interfaces
+      --  Handle access to class-wide interface types
 
       if Is_Access_Type (Iface_Typ) then
          Iface_Typ := Etype (Directly_Designated_Type (Iface_Typ));
@@ -881,11 +883,9 @@ package body Exp_Disp is
          --     end Func;
 
          declare
-            Decls        : List_Id;
             Desig_Typ    : Entity_Id;
             Fent         : Entity_Id;
             New_Typ_Decl : Node_Id;
-            New_Obj_Decl : Node_Id;
             Stats        : List_Id;
 
          begin
@@ -895,6 +895,10 @@ package body Exp_Disp is
                Desig_Typ := Directly_Designated_Type (Desig_Typ);
             end if;
 
+            if Is_Concurrent_Type (Desig_Typ) then
+               Desig_Typ := Base_Type (Corresponding_Record_Type (Desig_Typ));
+            end if;
+
             New_Typ_Decl :=
               Make_Full_Type_Declaration (Loc,
                 Defining_Identifier =>
@@ -907,22 +911,6 @@ package body Exp_Disp is
                     Subtype_Indication     =>
                       New_Reference_To (Desig_Typ, Loc)));
 
-            New_Obj_Decl :=
-              Make_Object_Declaration (Loc,
-                Defining_Identifier =>
-                  Make_Defining_Identifier (Loc,
-                    New_Internal_Name ('S')),
-                Constant_Present => True,
-                Object_Definition =>
-                  New_Reference_To (Defining_Identifier (New_Typ_Decl), Loc),
-                Expression =>
-                  Unchecked_Convert_To (Defining_Identifier (New_Typ_Decl),
-                    Make_Identifier (Loc, Name_uO)));
-
-            Decls := New_List (
-              New_Typ_Decl,
-              New_Obj_Decl);
-
             Stats := New_List (
               Make_Simple_Return_Statement (Loc,
                 Unchecked_Convert_To (Etype (N),
@@ -930,9 +918,9 @@ package body Exp_Disp is
                     Prefix =>
                       Make_Selected_Component (Loc,
                         Prefix =>
-                          New_Reference_To
-                            (Defining_Identifier (New_Obj_Decl),
-                             Loc),
+                          Unchecked_Convert_To
+                            (Defining_Identifier (New_Typ_Decl),
+                             Make_Identifier (Loc, Name_uO)),
                         Selector_Name =>
                           New_Occurrence_Of (Iface_Tag, Loc)),
                     Attribute_Name => Name_Address))));
@@ -975,7 +963,7 @@ package body Exp_Disp is
                     Result_Definition =>
                       New_Reference_To (Etype (N), Loc)),
 
-                Declarations => Decls,
+                Declarations => New_List (New_Typ_Decl),
 
                 Handled_Statement_Sequence =>
                   Make_Handled_Sequence_Of_Statements (Loc, Stats));
@@ -991,20 +979,17 @@ package body Exp_Disp is
 
             if Is_Access_Type (Etype (Expression (N))) then
 
-               --  Generate: Operand_Typ!(Expression.all)'Address
+               --  Generate: Func (Address!(Expression))
 
                Rewrite (N,
                  Make_Function_Call (Loc,
                    Name => New_Reference_To (Fent, Loc),
                    Parameter_Associations => New_List (
-                     Make_Attribute_Reference (Loc,
-                       Prefix  => Unchecked_Convert_To (Operand_Typ,
-                                    Make_Explicit_Dereference (Loc,
-                                      Relocate_Node (Expression (N)))),
-                       Attribute_Name => Name_Address))));
+                     Unchecked_Convert_To (RTE (RE_Address),
+                       Relocate_Node (Expression (N))))));
 
             else
-               --  Generate: Operand_Typ!(Expression)'Address
+               --  Generate: Func (Operand_Typ!(Expression)'Address)
 
                Rewrite (N,
                  Make_Function_Call (Loc,
@@ -1409,6 +1394,8 @@ package body Exp_Disp is
         Make_Defining_Identifier (Loc,
           Chars => New_Internal_Name ('T'));
 
+      Set_Is_Thunk (Thunk_Id);
+
       if Ekind (Target) = E_Procedure then
          Thunk_Code :=
            Make_Subprogram_Body (Loc,
@@ -3064,6 +3051,8 @@ package body Exp_Disp is
                             New_External_Name (Tname, 'T', Suffix_Index => -1);
       Name_Exname       : constant Name_Id :=
                             New_External_Name (Tname, 'E', Suffix_Index => -1);
+      Name_HT_Link      : constant Name_Id :=
+                            New_External_Name (Tname, 'H', Suffix_Index => -1);
       Name_Predef_Prims : constant Name_Id :=
                             New_External_Name (Tname, 'R', Suffix_Index => -1);
       Name_SSD          : constant Name_Id :=
@@ -3077,6 +3066,8 @@ package body Exp_Disp is
                        Make_Defining_Identifier (Loc, Name_DT);
       Exname       : constant Entity_Id :=
                        Make_Defining_Identifier (Loc, Name_Exname);
+      HT_Link      : constant Entity_Id :=
+                       Make_Defining_Identifier (Loc, Name_HT_Link);
       Predef_Prims : constant Entity_Id :=
                        Make_Defining_Identifier (Loc, Name_Predef_Prims);
       SSD          : constant Entity_Id :=
@@ -3213,6 +3204,7 @@ package body Exp_Disp is
       Set_Is_Statically_Allocated (DT);
       Set_Is_Statically_Allocated (SSD);
       Set_Is_Statically_Allocated (TSD);
+      Set_Is_Statically_Allocated (Predef_Prims);
 
       --  Generate code to define the boolean that controls registration, in
       --  order to avoid multiple registrations for tagged types defined in
@@ -3353,6 +3345,15 @@ package body Exp_Disp is
       Set_Is_Statically_Allocated (Exname);
       Set_Is_True_Constant (Exname);
 
+      --  Declare the object used by Ada.Tags.Register_Tag
+
+      if RTE_Available (RE_Register_Tag) then
+         Append_To (Result,
+           Make_Object_Declaration (Loc,
+             Defining_Identifier => HT_Link,
+             Object_Definition   => New_Reference_To (RTE (RE_Tag), Loc)));
+      end if;
+
       --  Generate code to create the storage for the type specific data object
       --  with enough space to store the tags of the ancestors plus the tags
       --  of all the implemented interfaces (as described in a-tags.adb).
@@ -3362,7 +3363,7 @@ package body Exp_Disp is
       --            Access_Level       => Type_Access_Level (Typ),
       --            Expanded_Name      => Cstring_Ptr!(Exname'Address))
       --            External_Tag       => Cstring_Ptr!(Exname'Address))
-      --            HT_Link            => null,
+      --            HT_Link            => HT_Link'Address,
       --            Transportable      => <<boolean-value>>,
       --            RC_Offset          => <<integer-value>>,
       --            [ Interfaces_Table  => <<access-value>> ]
@@ -3590,9 +3591,17 @@ package body Exp_Disp is
 
       --  HT_Link
 
-      Append_To (TSD_Aggr_List,
-        Unchecked_Convert_To (RTE (RE_Tag),
-          New_Reference_To (RTE (RE_Null_Address), Loc)));
+      if RTE_Available (RE_Register_Tag) then
+         Append_To (TSD_Aggr_List,
+           Unchecked_Convert_To (RTE (RE_Tag_Ptr),
+             Make_Attribute_Reference (Loc,
+               Prefix => New_Reference_To (HT_Link, Loc),
+               Attribute_Name => Name_Address)));
+      else
+         Append_To (TSD_Aggr_List,
+           Unchecked_Convert_To (RTE (RE_Tag_Ptr),
+             New_Reference_To (RTE (RE_Null_Address), Loc)));
+      end if;
 
       --  Transportable: Set for types that can be used in remote calls
       --  with respect to E.4(18) legality rules.
@@ -4734,9 +4743,7 @@ package body Exp_Disp is
       --  Import the forward declaration of the Dispatch Table wrapper record
       --  (Make_DT will take care of its exportation)
 
-      if Building_Static_DT (Typ)
-        and then not Is_CPP_Class (Typ)
-      then
+      if Building_Static_DT (Typ) then
          DT := Make_Defining_Identifier (Loc,
                  New_External_Name (Tname, 'T'));
 
@@ -4746,9 +4753,6 @@ package body Exp_Disp is
 
          Set_Is_Imported (DT);
 
-         --  Set_Is_True_Constant (DT);
-         --  Why is the above commented out???
-
          --  The scope must be set now to call Get_External_Name
 
          Set_Scope (DT, Current_Scope);
@@ -4840,6 +4844,7 @@ package body Exp_Disp is
          end if;
 
          Set_Is_True_Constant (DT_Ptr);
+         Set_Is_Statically_Allocated (DT_Ptr);
       end if;
 
       pragma Assert (No (Access_Disp_Table (Typ)));
Index: sem_disp.adb
===================================================================
--- sem_disp.adb	(revision 128777)
+++ sem_disp.adb	(working copy)
@@ -740,9 +740,27 @@ package body Sem_Disp is
                         Set_DT_Position (Subp, DT_Position (Old_Subp));
 
                         if not Restriction_Active (No_Dispatching_Calls) then
-                           Register_Primitive (Sloc (Subp_Body),
-                             Prim    => Subp,
-                             Ins_Nod => Subp_Body);
+                           if Building_Static_DT (Tagged_Type) then
+
+                              --  If the static dispatch table has not been
+                              --  built then there is nothing else to do now;
+                              --  otherwise we notify that we cannot build the
+                              --  static dispatch table.
+
+                              if Has_Dispatch_Table (Tagged_Type) then
+                                 Error_Msg_N
+                                   ("overriding of& is too late for building" &
+                                    " static dispatch tables!", Subp);
+                                 Error_Msg_N
+                                   ("\spec should appear immediately after" &
+                                    " the type!", Subp);
+                              end if;
+
+                           else
+                              Register_Primitive (Sloc (Subp_Body),
+                                Prim    => Subp,
+                                Ins_Nod => Subp_Body);
+                           end if;
                         end if;
                      end if;
                   end if;
@@ -789,6 +807,7 @@ package body Sem_Disp is
 
       if Present (Old_Subp) then
          Check_Subtype_Conformant (Subp, Old_Subp);
+
          if (Chars (Subp) = Name_Initialize
            or else Chars (Subp) = Name_Adjust
            or else Chars (Subp) = Name_Finalize)


More information about the Gcc-patches mailing list