exp_disp.ads (Build_VM_TSDs): Build the runtime Type Specific Data record of all…

exp_disp.ads (Build_VM_TSDs): Build the runtime Type Specific Data record of all the tagged types declared...

2011-08-02  Javier Miranda  <miranda@adacore.com>

	* exp_disp.ads (Build_VM_TSDs): Build the runtime Type Specific Data
	record of all the tagged types declared inside library level package
	declarations, library level package bodies or library level subprograms.
	* exp_disp.adb (Make_VM_TSD): New subprogram that builds the TSD
	associated with a given tagged type.
	(Build_VM_TSDs): New subprogram.
	* exp_ch6.adb (Expand_N_Subprogram_Body): Generate TSDs records of main
	compilation units that are subprograms.
	* exp_ch7.adb (Expand_N_Package_Body): Generate TSDs of main
	compilation units that are package bodies.
	(Expand_N_Package_Declaration): Generate TSDs of the main compilation
	units that are a package declaration or a package instantiation.
	* exp_intr.adb (Expand_Dispatching_Constructor_Call): Minor code
	reorganization to improve the error generated by the frontend when the
	function Ada.Tags.Secondary_Tag is not available.
	* rtsfind.ads (RE_Register_TSD): New runtime entity.
	* exp_ch4.adb (Expand_N_Type_Conversion): Minor code cleanup.

From-SVN: r177163

gcc/ada/ChangeLog

 2011-08-02  Javier Miranda  <miranda@adacore.com>
 
+	* exp_disp.ads (Build_VM_TSDs): Build the runtime Type Specific Data
+	record of all the tagged types declared inside library level package
+	declarations, library level package bodies or library level subprograms.
+	* exp_disp.adb (Make_VM_TSD): New subprogram that builds the TSD
+	associated with a given tagged type.
+	(Build_VM_TSDs): New subprogram.
+	* exp_ch6.adb (Expand_N_Subprogram_Body): Generate TSDs records of main
+	compilation units that are subprograms.
+	* exp_ch7.adb (Expand_N_Package_Body): Generate TSDs of main
+	compilation units that are package bodies.
+	(Expand_N_Package_Declaration): Generate TSDs of the main compilation
+	units that are a package declaration or a package instantiation.
+	* exp_intr.adb (Expand_Dispatching_Constructor_Call): Minor code
+	reorganization to improve the error generated by the frontend when the
+	function Ada.Tags.Secondary_Tag is not available.
+	* rtsfind.ads (RE_Register_TSD): New runtime entity.
+	* exp_ch4.adb (Expand_N_Type_Conversion): Minor code cleanup.
+
+2011-08-02  Javier Miranda  <miranda@adacore.com>
+
 	* exp_disp.adb (Make_DT): Generate call to Check_TSD in Ada 2005 mode.
 
 2011-08-02  Robert Dewar  <dewar@adacore.com>

gcc/ada/exp_ch4.adb

@@ -8606,16 +8606,19 @@ package body Exp_Ch4 is
          --  Start of processing for Tagged_Conversion
 
          begin
-            if Is_Access_Type (Target_Type) then
-
             --  Handle entities from the limited view
 
+            if Is_Access_Type (Operand_Type) then
                Actual_Op_Typ :=
                  Available_View (Designated_Type (Operand_Type));
+            else
+               Actual_Op_Typ := Operand_Type;
+            end if;
+
+            if Is_Access_Type (Target_Type) then
                Actual_Targ_Typ :=
                  Available_View (Designated_Type (Target_Type));
             else
-               Actual_Op_Typ   := Operand_Type;
                Actual_Targ_Typ := Target_Type;
             end if;
 

gcc/ada/exp_ch6.adb

@@ -5121,6 +5121,16 @@ package body Exp_Ch6 is
    --  Start of processing for Expand_N_Subprogram_Body
 
    begin
+      --  If this is the main compilation unit and we are generating code for
+      --  VM targets we generate now the Type Specific Data record of all the
+      --  enclosing tagged type declarations
+
+      if not Tagged_Type_Expansion
+        and then Unit (Cunit (Main_Unit)) = N
+      then
+         Build_VM_TSDs (N);
+      end if;
+
       --  Set L to either the list of declarations if present, or to the list
       --  of statements if no declarations are present. This is used to insert
       --  new stuff at the start.

gcc/ada/exp_ch7.adb

@@ -1553,7 +1553,15 @@ package body Exp_Ch7 is
          --  Build dispatch tables of library level tagged types
 
          if Is_Library_Level_Entity (Ent) then
+            if Tagged_Type_Expansion then
                Build_Static_Dispatch_Tables (N);
+
+            --  In VM targets there is no need to build dispatch tables but
+            --  we must generate the corresponding Type Specific Data record
+
+            elsif Unit (Cunit (Main_Unit)) = N then
+               Build_VM_TSDs (N);
+            end if;
          end if;
 
          Build_Task_Activation_Call (N);
@@ -1654,7 +1662,31 @@ package body Exp_Ch7 is
         or else (Is_Generic_Instance (Id)
                    and then Is_Library_Level_Entity (Id))
       then
+         if Tagged_Type_Expansion then
             Build_Static_Dispatch_Tables (N);
+
+         --  In VM targets there is no need to build dispatch tables but
+         --  we must generate the corresponding Type Specific Data record
+
+         elsif Unit (Cunit (Main_Unit)) = N then
+
+            --  Enter the scope of the package because the new declarations
+            --  are appended at the end of the package and must be analyzed
+            --  in that context.
+
+            Push_Scope (Id);
+
+            if Is_Generic_Instance (Main_Unit_Entity) then
+               if Package_Instantiation (Main_Unit_Entity) = N then
+                  Build_VM_TSDs (N);
+               end if;
+
+            else
+               Build_VM_TSDs (N);
+            end if;
+
+            Pop_Scope;
+         end if;
       end if;
 
       --  Note: it is not necessary to worry about generating a subprogram

gcc/ada/exp_disp.adb

@@ -83,6 +83,10 @@ package body Exp_Disp is
    --  Returns true if Prim is not a predefined dispatching primitive but it is
    --  an alias of a predefined dispatching primitive (i.e. through a renaming)
 
+   function Make_VM_TSD (Typ : Entity_Id) return List_Id;
+   --  Build the Type Specific Data record associated with tagged type Typ.
+   --  Invoked only when generating code for VM targets.
+
    function New_Value (From : Node_Id) return Node_Id;
    --  From is the original Expression. New_Value is equivalent to a call
    --  to Duplicate_Subexpr with an explicit dereference when From is an
@@ -465,6 +469,140 @@ package body Exp_Disp is
       end if;
    end Build_Static_Dispatch_Tables;
 
+   -------------------
+   -- Build_VM_TSDs --
+   -------------------
+
+   procedure Build_VM_TSDs (N : Entity_Id) is
+      Target_List : List_Id;
+
+      procedure Build_TSDs (List : List_Id);
+      --  Build the static dispatch table of tagged types found in the list of
+      --  declarations. The generated nodes are added at the end of Target_List
+
+      procedure Build_Package_TSDs (N : Node_Id);
+      --  Build static dispatch tables associated with package declaration N
+
+      ---------------------------
+      -- Build_Dispatch_Tables --
+      ---------------------------
+
+      procedure Build_TSDs (List : List_Id) is
+         D : Node_Id;
+
+      begin
+         D := First (List);
+         while Present (D) loop
+
+            --  Handle nested packages and package bodies recursively. The
+            --  generated code is placed on the Target_List established for
+            --  the enclosing compilation unit.
+
+            if Nkind (D) = N_Package_Declaration then
+               Build_Package_TSDs (D);
+
+            elsif Nkind_In (D, N_Package_Body,
+                               N_Subprogram_Body)
+            then
+               Build_TSDs (Declarations (D));
+
+            elsif Nkind (D) = N_Package_Body_Stub
+              and then Present (Library_Unit (D))
+            then
+               Build_TSDs
+                 (Declarations (Proper_Body (Unit (Library_Unit (D)))));
+
+            --  Handle full type declarations and derivations of library
+            --  level tagged types
+
+            elsif Nkind_In (D, N_Full_Type_Declaration,
+                               N_Derived_Type_Definition)
+              and then Ekind (Defining_Entity (D)) /= E_Record_Subtype
+              and then Is_Tagged_Type (Defining_Entity (D))
+              and then not Is_Private_Type (Defining_Entity (D))
+            then
+               --  Do not generate TSDs for the internal types created for
+               --  a type extension with unknown discriminants. The needed
+               --  information is shared with the source type.
+               --  See Expand_N_Record_Extension.
+
+               if Is_Underlying_Record_View (Defining_Entity (D))
+                 or else
+                  (not Comes_From_Source (Defining_Entity (D))
+                     and then
+                       Has_Unknown_Discriminants (Etype (Defining_Entity (D)))
+                     and then
+                       not Comes_From_Source
+                             (First_Subtype (Defining_Entity (D))))
+               then
+                  null;
+
+               else
+                  Append_List_To (Target_List,
+                    Make_VM_TSD (Defining_Entity (D)));
+               end if;
+            end if;
+
+            Next (D);
+         end loop;
+      end Build_TSDs;
+
+      ------------------------
+      -- Build_Package_TSDs --
+      ------------------------
+
+      procedure Build_Package_TSDs (N : Node_Id) is
+         Spec       : constant Node_Id   := Specification (N);
+         Vis_Decls  : constant List_Id   := Visible_Declarations (Spec);
+         Priv_Decls : constant List_Id   := Private_Declarations (Spec);
+
+      begin
+         if Present (Priv_Decls) then
+            Build_TSDs (Vis_Decls);
+            Build_TSDs (Priv_Decls);
+
+         elsif Present (Vis_Decls) then
+            Build_TSDs (Vis_Decls);
+         end if;
+      end Build_Package_TSDs;
+
+   --  Start of processing for Build_VM_TSDs
+
+   begin
+      if not Expander_Active or else No_Run_Time_Mode then
+         return;
+      end if;
+
+      if Nkind (N) = N_Package_Declaration then
+         declare
+            Spec       : constant Node_Id := Specification (N);
+            Vis_Decls  : constant List_Id := Visible_Declarations (Spec);
+            Priv_Decls : constant List_Id := Private_Declarations (Spec);
+
+         begin
+            Target_List := New_List;
+            Build_Package_TSDs (N);
+            Analyze_List (Target_List);
+
+            if Present (Priv_Decls)
+              and then Is_Non_Empty_List (Priv_Decls)
+            then
+               Append_List (Target_List, Priv_Decls);
+            else
+               Append_List (Target_List, Vis_Decls);
+            end if;
+         end;
+
+      elsif Nkind_In (N, N_Package_Body, N_Subprogram_Body) then
+         if Is_Non_Empty_List (Declarations (N)) then
+            Target_List := New_List;
+            Build_TSDs   (Declarations (N));
+            Analyze_List (Target_List);
+            Append_List  (Target_List, Declarations (N));
+         end if;
+      end if;
+   end Build_VM_TSDs;
+
    ------------------------------
    -- Convert_Tag_To_Interface --
    ------------------------------
@@ -6109,6 +6247,272 @@ package body Exp_Disp is
       return Result;
    end Make_DT;
 
+   -----------------
+   -- Make_VM_TSD --
+   -----------------
+
+   function Make_VM_TSD (Typ : Entity_Id) return List_Id is
+      Loc              : constant Source_Ptr := Sloc (Typ);
+      Result           : constant List_Id := New_List;
+      AI               : Elmt_Id;
+      I_Depth          : Nat := 0;
+      Iface_Table_Node : Node_Id;
+      Num_Ifaces       : Nat := 0;
+      TSD_Aggr_List    : List_Id;
+      Typ_Ifaces       : Elist_Id;
+      TSD_Tags_List    : List_Id;
+
+      Tname    : constant Name_Id := Chars (Typ);
+      Name_TSD : constant Name_Id :=
+                   New_External_Name (Tname, 'B', Suffix_Index => -1);
+      TSD      : constant Entity_Id :=
+                   Make_Defining_Identifier (Loc, Name_TSD);
+   begin
+      --  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.ads).
+
+      --   TSD : Type_Specific_Data (I_Depth) :=
+      --           (Idepth                => I_Depth,
+      --            T                     => T'Tag,
+      --            Access_Level          => Type_Access_Level (Typ),
+      --            HT_Link               => null,
+      --            Type_Is_Abstract      => <<boolean-value>>,
+      --            Type_Is_Library_Level => <<boolean-value>>,
+      --            Interfaces_Table      => <<access-value>>
+      --            Tags_Table            => (0 => Typ'Tag,
+      --                                      1 => Parent'Tag
+      --                                      ...));
+
+      TSD_Aggr_List := New_List;
+
+      --  Idepth: Count ancestors to compute the inheritance depth. For private
+      --  extensions, always go to the full view in order to compute the real
+      --  inheritance depth.
+
+      declare
+         Current_Typ : Entity_Id;
+         Parent_Typ  : Entity_Id;
+
+      begin
+         I_Depth     := 0;
+         Current_Typ := Typ;
+         loop
+            Parent_Typ := Etype (Current_Typ);
+
+            if Is_Private_Type (Parent_Typ) then
+               Parent_Typ := Full_View (Base_Type (Parent_Typ));
+            end if;
+
+            exit when Parent_Typ = Current_Typ;
+
+            I_Depth := I_Depth + 1;
+            Current_Typ := Parent_Typ;
+         end loop;
+      end;
+
+      Append_To (TSD_Aggr_List,
+        Make_Integer_Literal (Loc, I_Depth));
+
+      --  Access_Level
+
+      Append_To (TSD_Aggr_List,
+        Make_Integer_Literal (Loc, Type_Access_Level (Typ)));
+
+      --  HT_Link
+
+      Append_To (TSD_Aggr_List,
+        Make_Null (Loc));
+
+      --  Type_Is_Abstract (Ada 2012: AI05-0173)
+
+      declare
+         Type_Is_Abstract : Entity_Id;
+
+      begin
+         Type_Is_Abstract :=
+           Boolean_Literals (Is_Abstract_Type (Typ));
+
+         Append_To (TSD_Aggr_List,
+            New_Occurrence_Of (Type_Is_Abstract, Loc));
+      end;
+
+      --  Type_Is_Library_Level
+
+      declare
+         Type_Is_Library_Level : Entity_Id;
+
+      begin
+         Type_Is_Library_Level :=
+           Boolean_Literals (Is_Library_Level_Entity (Typ));
+
+         Append_To (TSD_Aggr_List,
+            New_Occurrence_Of (Type_Is_Library_Level, Loc));
+      end;
+
+      --  Interfaces_Table (required for AI-405)
+
+      if RTE_Record_Component_Available (RE_Interfaces_Table) then
+
+         --  Count the number of interface types implemented by Typ
+
+         Collect_Interfaces (Typ, Typ_Ifaces);
+
+         AI := First_Elmt (Typ_Ifaces);
+         while Present (AI) loop
+            Num_Ifaces := Num_Ifaces + 1;
+            Next_Elmt (AI);
+         end loop;
+
+         if Num_Ifaces = 0 then
+            Iface_Table_Node := Make_Null (Loc);
+
+         --  Generate the Interface_Table object
+
+         else
+            declare
+               TSD_Ifaces_List : constant List_Id := New_List;
+               ITable          : Node_Id;
+
+            begin
+               AI := First_Elmt (Typ_Ifaces);
+               while Present (AI) loop
+                  Append_To (TSD_Ifaces_List,
+                     Make_Aggregate (Loc,
+                       Expressions => New_List (
+                         Make_Attribute_Reference (Loc,
+                           Prefix => New_Reference_To (Node (AI), Loc),
+                           Attribute_Name => Name_Tag)
+                        )));
+
+                  Next_Elmt (AI);
+               end loop;
+
+               ITable := Make_Temporary (Loc, 'I');
+
+               Append_To (Result,
+                 Make_Object_Declaration (Loc,
+                   Defining_Identifier => ITable,
+                   Aliased_Present     => True,
+                   Constant_Present    => True,
+                   Object_Definition   =>
+                     Make_Subtype_Indication (Loc,
+                       Subtype_Mark =>
+                         New_Reference_To (RTE (RE_Interface_Data), Loc),
+                       Constraint => Make_Index_Or_Discriminant_Constraint
+                         (Loc,
+                          Constraints => New_List (
+                            Make_Integer_Literal (Loc, Num_Ifaces)))),
+
+                   Expression => Make_Aggregate (Loc,
+                     Expressions => New_List (
+                       Make_Integer_Literal (Loc, Num_Ifaces),
+                       Make_Aggregate (Loc,
+                         Expressions => TSD_Ifaces_List)))));
+
+               Iface_Table_Node :=
+                 Make_Attribute_Reference (Loc,
+                   Prefix         => New_Reference_To (ITable, Loc),
+                   Attribute_Name => Name_Unchecked_Access);
+            end;
+         end if;
+
+         Append_To (TSD_Aggr_List, Iface_Table_Node);
+      end if;
+
+      --  Initialize the table of ancestor tags. In case of interface types
+      --  this table is not needed.
+
+      TSD_Tags_List := New_List;
+
+      --  Fill position 0 with Typ'Tag
+
+      Append_To (TSD_Tags_List,
+        Make_Attribute_Reference (Loc,
+          Prefix => New_Reference_To (Typ, Loc),
+          Attribute_Name => Name_Tag));
+
+      --  Fill the rest of the table with the tags of the ancestors
+
+      declare
+         Current_Typ : Entity_Id;
+         Parent_Typ  : Entity_Id;
+         Pos         : Nat;
+
+      begin
+         Pos := 1;
+         Current_Typ := Typ;
+
+         loop
+            Parent_Typ := Etype (Current_Typ);
+
+            if Is_Private_Type (Parent_Typ) then
+               Parent_Typ := Full_View (Base_Type (Parent_Typ));
+            end if;
+
+            exit when Parent_Typ = Current_Typ;
+
+            Append_To (TSD_Tags_List,
+              Make_Attribute_Reference (Loc,
+                Prefix => New_Reference_To (Parent_Typ, Loc),
+                Attribute_Name => Name_Tag));
+
+            Pos := Pos + 1;
+            Current_Typ := Parent_Typ;
+         end loop;
+
+         pragma Assert (Pos = I_Depth + 1);
+      end;
+
+      Append_To (TSD_Aggr_List,
+        Make_Aggregate (Loc,
+          Expressions => TSD_Tags_List));
+
+      --  Build the TSD object
+
+      Append_To (Result,
+        Make_Object_Declaration (Loc,
+          Defining_Identifier => TSD,
+          Aliased_Present     => True,
+          Constant_Present    => True,
+          Object_Definition   =>
+            Make_Subtype_Indication (Loc,
+              Subtype_Mark => New_Reference_To (
+                RTE (RE_Type_Specific_Data), Loc),
+              Constraint =>
+                Make_Index_Or_Discriminant_Constraint (Loc,
+                  Constraints => New_List (
+                    Make_Integer_Literal (Loc, I_Depth)))),
+
+          Expression => Make_Aggregate (Loc,
+            Expressions => TSD_Aggr_List)));
+
+      --  Generate:
+      --     Check_TSD
+      --       (TSD => TSD'Unrestricted_Access);
+
+      Append_To (Result,
+        Make_Procedure_Call_Statement (Loc,
+          Name => New_Reference_To (RTE (RE_Check_TSD), Loc),
+          Parameter_Associations => New_List (
+            Make_Attribute_Reference (Loc,
+              Prefix => New_Reference_To (TSD, Loc),
+              Attribute_Name => Name_Unrestricted_Access))));
+
+      --  Generate:
+      --     Register_TSD (TSD'Unrestricted_Access);
+
+      Append_To (Result,
+        Make_Procedure_Call_Statement (Loc,
+          Name => New_Reference_To (RTE (RE_Register_TSD), Loc),
+          Parameter_Associations => New_List (
+            Make_Attribute_Reference (Loc,
+              Prefix => New_Reference_To (TSD, Loc),
+              Attribute_Name => Name_Unrestricted_Access))));
+
+      return Result;
+   end Make_VM_TSD;
+
    -------------------------------------
    -- Make_Select_Specific_Data_Table --
    -------------------------------------

gcc/ada/exp_disp.ads

@@ -186,6 +186,11 @@ package Exp_Disp is
    --  bodies they are added to the end of the list of declarations of the
    --  package body.
 
+   procedure Build_VM_TSDs (N : Entity_Id);
+   --  N is a library level package declaration, a library level package body
+   --  or a library level subprogram body. Build the runtime Type Specific
+   --  Data record of all the tagged types declared inside N.
+
    function Convert_Tag_To_Interface
      (Typ : Entity_Id; Expr : Node_Id) return Node_Id;
    pragma Inline (Convert_Tag_To_Interface);

gcc/ada/exp_intr.adb

@@ -234,6 +234,15 @@ package body Exp_Intr is
          if not Is_Ancestor (Etype (Result_Typ), Etype (Tag_Arg),
                              Use_Full_View => True)
          then
+            --  Obtain the reference to the Ada.Tags service before generating
+            --  the Object_Declaration node to ensure that if this service is
+            --  not available in the runtime then we generate a clear error.
+
+            declare
+               Fname : constant Node_Id :=
+                         New_Reference_To (RTE (RE_Secondary_Tag), Loc);
+
+            begin
                pragma Assert (not Is_Interface (Etype (Tag_Arg)));
 
                Iface_Tag :=
@@ -243,7 +252,7 @@ package body Exp_Intr is
                      New_Reference_To (RTE (RE_Tag), Loc),
                    Expression          =>
                      Make_Function_Call (Loc,
-                    Name => New_Reference_To (RTE (RE_Secondary_Tag), Loc),
+                       Name => Fname,
                        Parameter_Associations => New_List (
                          Relocate_Node (Tag_Arg),
                          New_Reference_To
@@ -251,6 +260,7 @@ package body Exp_Intr is
                                                (Etype (Etype (Act_Constr))))),
                             Loc))));
                Insert_Action (N, Iface_Tag);
+            end;
          end if;
       end if;
 

gcc/ada/rtsfind.ads

@@ -607,6 +607,7 @@ package Rtsfind is
      RE_Type_Specific_Data,              -- Ada.Tags
      RE_Register_Interface_Offset,       -- Ada.Tags
      RE_Register_Tag,                    -- Ada.Tags
+     RE_Register_TSD,                    -- Ada.Tags
      RE_Transportable,                   -- Ada.Tags
      RE_Secondary_DT,                    -- Ada.Tags
      RE_Secondary_Tag,                   -- Ada.Tags
@@ -1786,6 +1787,7 @@ package Rtsfind is
      RE_Type_Specific_Data               => Ada_Tags,
      RE_Register_Interface_Offset        => Ada_Tags,
      RE_Register_Tag                     => Ada_Tags,
+     RE_Register_TSD                     => Ada_Tags,
      RE_Transportable                    => Ada_Tags,
      RE_Secondary_DT                     => Ada_Tags,
      RE_Secondary_Tag                    => Ada_Tags,