exp_disp.adb (Make_DT, [...]): Set attribute Is_Static_Dispatch_Table

2008-03-26  Javier Miranda  <miranda@adacore.com>

	* exp_disp.adb (Make_DT, Make_Secondary_DT): Set attribute
	Is_Static_Dispatch_Table
	(Build_Dispatch_Tables): Replace calls to Exchange_Entities() by calls
	to Exchange_Declarations to exchange the private and full-view. Bug
	found working in this issue.
	(Expand_Dispatching_Call): Propagate the convention of the subprogram
	to the subprogram pointer type.
	(Make_Secondary_DT): Replace generation of Prim'Address by
	Address (Prim'Unrestricted_Access)
	(Make_DT): Replace generation of Prim'Address by
	Address (Prim'Unrestricted_Access)
	(Make_Disp_*_Bodies): When compiling for a restricted profile, use
	simple call form for single entry.
	(Make_DT): Handle new contents of Access_Disp_Table (access to dispatch
	tables of predefined primitives).
	(Make_Secondary_DT): Add support to handle access to dispatch tables of
	predefined primitives.
	(Make_Tags): Add entities to Access_Dispatch_Table associated with
	access to dispatch tables containing predefined primitives.

	* exp_ch6.adb (N_Pragma): Chars field removed, use Chars
	(Pragma_Identifier (..  instead, adjustments throughout to accomodate
	this change.
	(Register_Predefined_DT_Entry): Updated to handle the new contents
	of attribute Access_Disp_Table (pointers to dispatch tables containing
	predefined primitives).

	* exp_util.ads, exp_util.adb (Corresponding_Runtime_Package): New
	subprogram.
	(Find_Interface_ADT): Updated to skip the new contents of attribute
	Access_Dispatch_Table (pointers to dispatch tables containing predefined
	primitives).

	* sem_util.adb (Has_Abstract_Interfaces): Add missing support for
	concurrent types.
	(Set_Convention): Use new function Is_Access_Subprogram_Type
	(Collect_Interfaces_Info): Updated to skip the new contents of attribute
	Access_Dispatch_Table (pointers to dispatch tables containing predefined
	primitives).

	* exp_atag.ads, exp_atag.adb (Build_Inherit_Predefined_Prims): Improve
	expanded code avoiding calls to Build_Predef_Prims.
	(Build_Set_Predefined_Prim_Op_Address): Improve expanded code avoiding
	call to Build_Get_Predefined_Prim_Op_Address.

From-SVN: r133564

gcc/ada/exp_atag.adb

@@ -369,64 +369,32 @@ package body Exp_Atag is
       New_Tag_Node : Node_Id) return Node_Id
    is
    begin
-      if RTE_Available (RE_DT) then
-         return
-           Make_Assignment_Statement (Loc,
-             Name =>
-               Make_Slice (Loc,
-                 Prefix =>
-                   Make_Explicit_Dereference (Loc,
-                     Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
-                       Make_Selected_Component (Loc,
-                         Prefix =>
-                           Build_DT (Loc, New_Tag_Node),
-                         Selector_Name =>
-                           New_Reference_To
-                             (RTE_Record_Component (RE_Predef_Prims), Loc)))),
-                 Discrete_Range => Make_Range (Loc,
-                   Make_Integer_Literal (Loc, Uint_1),
-                   New_Reference_To (RTE (RE_Max_Predef_Prims), Loc))),
-
-             Expression =>
-               Make_Slice (Loc,
-                 Prefix =>
-                   Make_Explicit_Dereference (Loc,
-                     Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
-                       Make_Selected_Component (Loc,
-                         Prefix =>
-                           Build_DT (Loc, Old_Tag_Node),
-                         Selector_Name =>
-                           New_Reference_To
-                             (RTE_Record_Component (RE_Predef_Prims), Loc)))),
-
-                 Discrete_Range =>
-                   Make_Range (Loc,
-                     Low_Bound  => Make_Integer_Literal (Loc, 1),
-                     High_Bound =>
-                       New_Reference_To (RTE (RE_Max_Predef_Prims), Loc))));
-      else
-         return
-           Make_Assignment_Statement (Loc,
-             Name =>
-               Make_Slice (Loc,
-                 Prefix =>
-                   Make_Explicit_Dereference (Loc,
-                     Build_Predef_Prims (Loc, New_Tag_Node)),
-                 Discrete_Range => Make_Range (Loc,
-                   Make_Integer_Literal (Loc, Uint_1),
-                   New_Reference_To (RTE (RE_Max_Predef_Prims), Loc))),
+      return
+        Make_Assignment_Statement (Loc,
+          Name =>
+            Make_Slice (Loc,
+              Prefix =>
+                Make_Explicit_Dereference (Loc,
+                  Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
+                    Make_Explicit_Dereference (Loc,
+                      Unchecked_Convert_To (RTE (RE_Addr_Ptr),
+                        New_Tag_Node)))),
+              Discrete_Range => Make_Range (Loc,
+                Make_Integer_Literal (Loc, Uint_1),
+                New_Reference_To (RTE (RE_Max_Predef_Prims), Loc))),
 
-             Expression =>
-               Make_Slice (Loc,
-                 Prefix =>
-                   Make_Explicit_Dereference (Loc,
-                     Build_Predef_Prims (Loc, Old_Tag_Node)),
-                 Discrete_Range =>
-                   Make_Range (Loc,
-                     Low_Bound  => Make_Integer_Literal (Loc, 1),
-                     High_Bound =>
-                       New_Reference_To (RTE (RE_Max_Predef_Prims), Loc))));
-      end if;
+          Expression =>
+            Make_Slice (Loc,
+              Prefix =>
+                Make_Explicit_Dereference (Loc,
+                  Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
+                    Make_Explicit_Dereference (Loc,
+                      Unchecked_Convert_To (RTE (RE_Addr_Ptr),
+                        Old_Tag_Node)))),
+              Discrete_Range =>
+                Make_Range (Loc,
+                  Make_Integer_Literal (Loc, 1),
+                  New_Reference_To (RTE (RE_Max_Predef_Prims), Loc))));
    end Build_Inherit_Predefined_Prims;
 
    ------------------------
@@ -472,8 +440,15 @@ package body Exp_Atag is
    begin
       return
          Make_Assignment_Statement (Loc,
-           Name       => Build_Get_Predefined_Prim_Op_Address (Loc,
-                           Tag_Node, Position),
+           Name =>
+             Make_Indexed_Component (Loc,
+               Prefix =>
+                 Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
+                   Make_Explicit_Dereference (Loc,
+                     Unchecked_Convert_To (RTE (RE_Addr_Ptr), Tag_Node))),
+               Expressions =>
+                 New_List (Make_Integer_Literal (Loc, Position))),
+
            Expression => Address_Node);
    end Build_Set_Predefined_Prim_Op_Address;
 

gcc/ada/exp_atag.ads

@@ -90,15 +90,16 @@ package Exp_Atag is
    --  Generates: TSD (Tag).Transportable;
 
    function Build_Inherit_Predefined_Prims
-     (Loc              : Source_Ptr;
-      Old_Tag_Node     : Node_Id;
-      New_Tag_Node     : Node_Id) return Node_Id;
+     (Loc          : Source_Ptr;
+      Old_Tag_Node : Node_Id;
+      New_Tag_Node : Node_Id) return Node_Id;
    --  Build code that inherits the predefined primitives of the parent.
    --
    --  Generates: Predefined_DT (New_T).D (All_Predefined_Prims) :=
    --               Predefined_DT (Old_T).D (All_Predefined_Prims);
    --
-   --  Required to build the dispatch tables with the 3.4 backend.
+   --  Required to build non-library level dispatch tables. Also required
+   --  when compiling without static dispatch tables support.
 
    function Build_Inherit_Prims
      (Loc          : Source_Ptr;

gcc/ada/exp_ch6.adb

@@ -3388,7 +3388,7 @@ package body Exp_Ch6 is
          --  not be posting warnings on the inlined body so it is unneeded.
 
          elsif Nkind (N) = N_Pragma
-           and then Chars (N) = Name_Unreferenced
+           and then Pragma_Name (N) = Name_Unreferenced
          then
             Rewrite (N, Make_Null_Statement (Sloc (N)));
             return OK;
@@ -4756,14 +4756,14 @@ package body Exp_Ch6 is
             return;
          end if;
 
-         --  Skip the first access-to-dispatch-table pointer since it leads
-         --  to the primary dispatch table. We are only concerned with the
-         --  secondary dispatch table pointers. Note that the access-to-
-         --  dispatch-table pointer corresponds to the first implemented
-         --  interface retrieved below.
+         --  Skip the first two access-to-dispatch-table pointers since they
+         --  leads to the primary dispatch table (predefined DT and user
+         --  defined DT). We are only concerned with the secondary dispatch
+         --  table pointers. Note that the access-to- dispatch-table pointer
+         --  corresponds to the first implemented interface retrieved below.
 
          Iface_DT_Ptr :=
-           Next_Elmt (First_Elmt (Access_Disp_Table (Tagged_Typ)));
+           Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Tagged_Typ))));
 
          while Present (Iface_DT_Ptr)
             and then Ekind (Node (Iface_DT_Ptr)) = E_Constant
@@ -4776,23 +4776,41 @@ package body Exp_Ch6 is
                  Thunk_Code,
 
                  Build_Set_Predefined_Prim_Op_Address (Loc,
-                   Tag_Node => New_Reference_To (Node (Iface_DT_Ptr), Loc),
+                   Tag_Node =>
+                     New_Reference_To (Node (Next_Elmt (Iface_DT_Ptr)), Loc),
                    Position => DT_Position (Prim),
                    Address_Node =>
-                     Make_Attribute_Reference (Loc,
-                       Prefix         => New_Reference_To (Thunk_Id, Loc),
-                       Attribute_Name => Name_Address)),
+                     Unchecked_Convert_To (RTE (RE_Address),
+                       Make_Attribute_Reference (Loc,
+                         Prefix         => New_Reference_To (Thunk_Id, Loc),
+                         Attribute_Name => Name_Unrestricted_Access))),
 
                  Build_Set_Predefined_Prim_Op_Address (Loc,
-                   Tag_Node => New_Reference_To
-                                 (Node (Next_Elmt (Iface_DT_Ptr)), Loc),
+                   Tag_Node =>
+                     New_Reference_To
+                      (Node (Next_Elmt (Next_Elmt (Next_Elmt (Iface_DT_Ptr)))),
+                       Loc),
                    Position => DT_Position (Prim),
                    Address_Node =>
-                     Make_Attribute_Reference (Loc,
-                       Prefix         => New_Reference_To (Prim, Loc),
-                       Attribute_Name => Name_Address))));
+                     Unchecked_Convert_To (RTE (RE_Address),
+                       Make_Attribute_Reference (Loc,
+                         Prefix         => New_Reference_To (Prim, Loc),
+                         Attribute_Name => Name_Unrestricted_Access)))));
             end if;
 
+            --  Skip the tag of the predefined primitives dispatch table
+
+            Next_Elmt (Iface_DT_Ptr);
+            pragma Assert (Has_Thunks (Node (Iface_DT_Ptr)));
+
+            --  Skip the tag of the no-thunks dispatch table
+
+            Next_Elmt (Iface_DT_Ptr);
+            pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr)));
+
+            --  Skip the tag of the predefined primitives no-thunks dispatch
+            --  table
+
             Next_Elmt (Iface_DT_Ptr);
             pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr)));
 

gcc/ada/exp_util.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2007, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2008, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -948,6 +948,43 @@ package body Exp_Util is
       end if;
    end Component_May_Be_Bit_Aligned;
 
+   -----------------------------------
+   -- Corresponding_Runtime_Package --
+   -----------------------------------
+
+   function Corresponding_Runtime_Package (Typ : Entity_Id) return RTU_Id is
+      Pkg_Id : RTU_Id := RTU_Null;
+
+   begin
+      pragma Assert (Is_Concurrent_Type (Typ));
+
+      if Ekind (Typ) in Protected_Kind then
+         if Has_Entries (Typ)
+           or else Has_Interrupt_Handler (Typ)
+           or else (Has_Attach_Handler (Typ)
+                     and then not Restricted_Profile)
+           or else (Ada_Version >= Ada_05
+                     and then Present (Interface_List (Parent (Typ))))
+         then
+            if Abort_Allowed
+              or else Restriction_Active (No_Entry_Queue) = False
+              or else Number_Entries (Typ) > 1
+              or else (Has_Attach_Handler (Typ)
+                         and then not Restricted_Profile)
+            then
+               Pkg_Id := System_Tasking_Protected_Objects_Entries;
+            else
+               Pkg_Id := System_Tasking_Protected_Objects_Single_Entry;
+            end if;
+
+         else
+            Pkg_Id := System_Tasking_Protected_Objects;
+         end if;
+      end if;
+
+      return Pkg_Id;
+   end Corresponding_Runtime_Package;
+
    -------------------------------
    -- Convert_To_Actual_Subtype --
    -------------------------------
@@ -1384,6 +1421,10 @@ package body Exp_Util is
                   return;
                end if;
 
+               --  Document what is going on here, why four Next's???
+
+               Next_Elmt (ADT);
+               Next_Elmt (ADT);
                Next_Elmt (ADT);
                Next_Elmt (ADT);
                Next_Elmt (AI_Elmt);
@@ -1420,7 +1461,7 @@ package body Exp_Util is
         (not Is_Class_Wide_Type (Typ)
           and then Ekind (Typ) /= E_Incomplete_Type);
 
-      ADT := Next_Elmt (First_Elmt (Access_Disp_Table (Typ)));
+      ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
       pragma Assert (Present (Node (ADT)));
       Find_Secondary_Table (Typ);
       pragma Assert (Found);

gcc/ada/exp_util.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2007, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2008, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -212,43 +212,51 @@ package Exp_Util is
    --  function itself must do its own cleanups.
 
    function Component_May_Be_Bit_Aligned (Comp : Entity_Id) return Boolean;
-   --  This function is in charge of detecting record components that may cause
-   --  trouble in the back end if an attempt is made to assign the component.
-   --  The back end can handle such assignments with no problem if the
-   --  components involved are small (64-bits or less) records or scalar items
-   --  (including bit-packed arrays represented with modular types) or are both
-   --  aligned on a byte boundary (starting on a byte boundary, and occupying
-   --  an integral number of bytes).
+   --  This function is in charge of detecting record components that may
+   --  cause trouble in the back end if an attempt is made to assign the
+   --  component. The back end can handle such assignments with no problem if
+   --  the components involved are small (64-bits or less) records or scalar
+   --  items (including bit-packed arrays represented with modular types) or
+   --  are both aligned on a byte boundary (starting on a byte boundary, and
+   --  occupying an integral number of bytes).
    --
    --  However, problems arise for records larger than 64 bits, or for arrays
    --  (other than bit-packed arrays represented with a modular type) if the
    --  component starts on a non-byte boundary, or does not occupy an integral
-   --  number of bytes (i.e. there are some bits possibly shared with fields at
-   --  the start or beginning of the component). The back end cannot handle
+   --  number of bytes (i.e. there are some bits possibly shared with fields
+   --  at the start or beginning of the component). The back end cannot handle
    --  loading and storing such components in a single operation.
    --
    --  This function is used to detect the troublesome situation. it is
-   --  conservative in the sense that it produces True unless it knows for sure
-   --  that the component is safe (as outlined in the first paragraph above).
-   --  The code generation for record and array assignment checks for trouble
-   --  using this function, and if so the assignment is generated
+   --  conservative in the sense that it produces True unless it knows for
+   --  sure that the component is safe (as outlined in the first paragraph
+   --  above). The code generation for record and array assignment checks for
+   --  trouble using this function, and if so the assignment is generated
    --  component-wise, which the back end is required to handle correctly.
    --
-   --  Note that in GNAT 3, the back end will reject such components anyway, so
-   --  the hard work in checking for this case is wasted in GNAT 3, but it's
-   --  harmless, so it is easier to do it in all cases, rather than
+   --  Note that in GNAT 3, the back end will reject such components anyway,
+   --  so the hard work in checking for this case is wasted in GNAT 3, but
+   --  it is harmless, so it is easier to do it in all cases, rather than
    --  conditionalize it in GNAT 5 or beyond.
 
    procedure Convert_To_Actual_Subtype (Exp : Node_Id);
-   --  The Etype of an expression is the nominal type of the expression, not
-   --  the actual subtype. Often these are the same, but not always. For
-   --  example, a reference to a formal of unconstrained type has the
+   --  The Etype of an expression is the nominal type of the expression,
+   --  not the actual subtype. Often these are the same, but not always.
+   --  For example, a reference to a formal of unconstrained type has the
    --  unconstrained type as its Etype, but the actual subtype is obtained by
    --  applying the actual bounds. This routine is given an expression, Exp,
-   --  and (if necessary), replaces it using Rewrite, with a conversion to the
-   --  actual subtype, building the actual subtype if necessary. If the
+   --  and (if necessary), replaces it using Rewrite, with a conversion to
+   --  the actual subtype, building the actual subtype if necessary. If the
    --  expression is already of the requested type, then it is unchanged.
 
+   function Corresponding_Runtime_Package (Typ : Entity_Id) return RTU_Id;
+   --  Return the id of the runtime package that will provide support for
+   --  concurrent type Typ. Currently only protected types are supported,
+   --  and the returned value is one of the following:
+   --    System_Tasking_Protected_Objects
+   --    System_Tasking_Protected_Objects_Entries
+   --    System_Tasking_Protected_Objects_Single_Entry
+
    function Current_Sem_Unit_Declarations return List_Id;
    --  Return the a place where it is fine to insert declarations for the
    --  current semantic unit. If the unit is a package body, return the

gcc/ada/sem_util.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2007, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2008, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -1386,12 +1386,15 @@ package body Sem_Util is
          ADT : Elmt_Id;
 
       begin
-         ADT := Next_Elmt (First_Elmt (Access_Disp_Table (T)));
+         ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (T))));
          while Present (ADT)
             and then Ekind (Node (ADT)) = E_Constant
             and then Related_Type (Node (ADT)) /= Iface
          loop
-            --  Skip the two secondary dispatch tables of Iface
+            --  Skip the secondary dispatch tables of Iface
+
+            Next_Elmt (ADT);
+            Next_Elmt (ADT);
             Next_Elmt (ADT);
             Next_Elmt (ADT);
          end loop;
@@ -3769,6 +3772,15 @@ package body Sem_Util is
       return Entity_Id (Get_Name_Table_Info (Id));
    end Get_Name_Entity_Id;
 
+   -------------------
+   -- Get_Pragma_Id --
+   -------------------
+
+   function Get_Pragma_Id (N : Node_Id) return Pragma_Id is
+   begin
+      return Get_Pragma_Id (Pragma_Name (N));
+   end Get_Pragma_Id;
+
    ---------------------------
    -- Get_Referenced_Object --
    ---------------------------
@@ -3906,31 +3918,42 @@ package body Sem_Util is
    -----------------------------
 
    function Has_Abstract_Interfaces
-     (Tagged_Type   : Entity_Id;
+     (T             : Entity_Id;
       Use_Full_View : Boolean := True) return Boolean
    is
       Typ : Entity_Id;
 
    begin
-      pragma Assert (Is_Record_Type (Tagged_Type)
-         and then Is_Tagged_Type (Tagged_Type));
+      --  Handle concurrent types
 
-      --  Handle concurrent record types
+      if Is_Concurrent_Type (T) then
+         Typ := Corresponding_Record_Type (T);
+      else
+         Typ := T;
+      end if;
 
-      if Is_Concurrent_Record_Type (Tagged_Type)
-        and then Is_Non_Empty_List (Abstract_Interface_List (Tagged_Type))
+      if not Present (Typ)
+        or else not Is_Tagged_Type (Typ)
       then
-         return True;
+         return False;
       end if;
 
-      Typ := Tagged_Type;
+      pragma Assert (Is_Record_Type (Typ));
 
       --  Handle private types
 
       if Use_Full_View
-        and then Present (Full_View (Tagged_Type))
+        and then Present (Full_View (Typ))
+      then
+         Typ := Full_View (Typ);
+      end if;
+
+      --  Handle concurrent record types
+
+      if Is_Concurrent_Record_Type (Typ)
+        and then Is_Non_Empty_List (Abstract_Interface_List (Typ))
       then
-         Typ := Full_View (Tagged_Type);
+         return True;
       end if;
 
       loop
@@ -3953,7 +3976,7 @@ package body Sem_Util is
             --  Protect the frontend against wrong source with cyclic
             --  derivations
 
-            or else Etype (Typ) = Tagged_Type;
+            or else Etype (Typ) = T;
 
          --  Climb to the ancestor type handling private types
 
@@ -8910,8 +8933,9 @@ package body Sem_Util is
    procedure Set_Convention (E : Entity_Id; Val : Snames.Convention_Id) is
    begin
       Basic_Set_Convention (E, Val);
+
       if Is_Type (E)
-        and then Ekind (Base_Type (E)) in Access_Subprogram_Type_Kind
+        and then Is_Access_Subprogram_Type (Base_Type (E))
         and then Has_Foreign_Convention (E)
       then
          Set_Can_Use_Internal_Rep (E, False);
@@ -8932,6 +8956,93 @@ package body Sem_Util is
       Set_Name_Entity_Id (Chars (E), E);
    end Set_Current_Entity;
 
+   ---------------------------
+   -- Set_Debug_Info_Needed --
+   ---------------------------
+
+   procedure Set_Debug_Info_Needed (T : Entity_Id) is
+
+      procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id);
+      pragma Inline (Set_Debug_Info_Needed_If_Not_Set);
+      --  Used to set debug info in a related node if not set already
+
+      --------------------------------------
+      -- Set_Debug_Info_Needed_If_Not_Set --
+      --------------------------------------
+
+      procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id) is
+      begin
+         if Present (E)
+           and then not Needs_Debug_Info (E)
+         then
+            Set_Debug_Info_Needed (E);
+         end if;
+      end Set_Debug_Info_Needed_If_Not_Set;
+
+   --  Start of processing for Set_Debug_Info_Needed
+
+   begin
+      --  Nothing to do if argument is Empty or has Debug_Info_Off set, which
+      --  indicates that Debug_Info_Needed is never required for the entity.
+
+      if No (T)
+        or else Debug_Info_Off (T)
+      then
+         return;
+      end if;
+
+      --  Set flag in entity itself. Note that we will go through the following
+      --  circuitry even if the flag is already set on T. That's intentional,
+      --  it makes sure that the flag will be set in subsidiary entities.
+
+      Set_Needs_Debug_Info (T);
+
+      --  Set flag on subsidiary entities if not set already
+
+      if Is_Object (T) then
+         Set_Debug_Info_Needed_If_Not_Set (Etype (T));
+
+      elsif Is_Type (T) then
+         Set_Debug_Info_Needed_If_Not_Set (Etype (T));
+
+         if Is_Record_Type (T) then
+            declare
+               Ent : Entity_Id := First_Entity (T);
+            begin
+               while Present (Ent) loop
+                  Set_Debug_Info_Needed_If_Not_Set (Ent);
+                  Next_Entity (Ent);
+               end loop;
+            end;
+
+         elsif Is_Array_Type (T) then
+            Set_Debug_Info_Needed_If_Not_Set (Component_Type (T));
+
+            declare
+               Indx : Node_Id := First_Index (T);
+            begin
+               while Present (Indx) loop
+                  Set_Debug_Info_Needed_If_Not_Set (Etype (Indx));
+                  Indx := Next_Index (Indx);
+               end loop;
+            end;
+
+            if Is_Packed (T) then
+               Set_Debug_Info_Needed_If_Not_Set (Packed_Array_Type (T));
+            end if;
+
+         elsif Is_Access_Type (T) then
+            Set_Debug_Info_Needed_If_Not_Set (Directly_Designated_Type (T));
+
+         elsif Is_Private_Type (T) then
+            Set_Debug_Info_Needed_If_Not_Set (Full_View (T));
+
+         elsif Is_Protected_Type (T) then
+            Set_Debug_Info_Needed_If_Not_Set (Corresponding_Record_Type (T));
+         end if;
+      end if;
+   end Set_Debug_Info_Needed;
+
    ---------------------------------
    -- Set_Entity_With_Style_Check --
    ---------------------------------