OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[Ada] Do not freeze profiles for dispatch tables

Browse Source 
When static dispatch tables are built for library-level tagged types, the
primitives (the subprogram themselves) are frozen; that's necessary because
their address is taken.  However, their profile, i.e. all the types present
therein, is also frozen, which is not necessary after AI05-019 and is also
inconsistent with the handling of attribute references.

The change also removes a couple of pragma Inline on subprograms that are
too large for inlining to bring any benefit.

gcc/ada/

	* exp_ch3.adb (Expand_N_Object_Declaration): Adjust call to Make_DT.
	* exp_disp.ads (Building_Static_DT): Remove pragma Inline.
	(Building_Static_Secondary_DT): Likewise.
	(Convert_Tag_To_Interface): Likewise.
	(Make_DT): Remove second parameter.
	* exp_disp.adb (Make_DT): Likewise.
	(Check_Premature_Freezing): Delete.
	Pass Do_Freeze_Profile as False in call to Freeze_Entity.
	* freeze.ads (Freezing_Library_Level_Tagged_Type): Delete.
	* freeze.adb (Freeze_Profile): Remove obsolete code.
	(Freeze_Entity): Tweak comment.
This commit is contained in:
Eric Botcazou 2022-04-20 09:54:49 +02:00 committed by Pierre-Marie de Rodat
parent 1ea22318ca
commit 3e93d2926a
5 changed files with 19 additions and 181 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
gcc/ada/exp_ch3.adb
View File

@ -6909,9 +6909,9 @@ package body Exp_Ch3 is
begin
if Is_Concurrent_Type (Base_Typ) then
New_Nodes := Make_DT (Corresponding_Record_Type (Base_Typ), N);
New_Nodes := Make_DT (Corresponding_Record_Type (Base_Typ));
else
New_Nodes := Make_DT (Base_Typ, N);
New_Nodes := Make_DT (Base_Typ);
end if;
Insert_List_Before (N, New_Nodes);

160
gcc/ada/exp_disp.adb
View File

@ -3660,7 +3660,7 @@ package body Exp_Disp is
-- replaced by gotos which jump to the end of the routine and restore the
-- Ghost mode.
function Make_DT (Typ : Entity_Id; N : Node_Id := Empty) return List_Id is
function Make_DT (Typ : Entity_Id) return List_Id is
Loc : constant Source_Ptr := Sloc (Typ);
Max_Predef_Prims : constant Int :=
@ -3678,23 +3678,6 @@ package body Exp_Disp is
-- offset to the components that reference secondary dispatch tables.
-- Used to compute the offset of components located at fixed position.
procedure Check_Premature_Freezing
(Subp : Entity_Id;
Tagged_Type : Entity_Id;
Typ : Entity_Id);
-- Verify that all untagged types in the profile of a subprogram are
-- frozen at the point the subprogram is frozen. This enforces the rule
-- on RM 13.14 (14) as modified by AI05-019. At the point a subprogram
-- is frozen, enough must be known about it to build the activation
-- record for it, which requires at least that the size of all
-- parameters be known. Controlling arguments are by-reference,
-- and therefore the rule only applies to untagged types. Typical
-- violation of the rule involves an object declaration that freezes a
-- tagged type, when one of its primitive operations has a type in its
-- profile whose full view has not been analyzed yet. More complex cases
-- involve composite types that have one private unfrozen subcomponent.
-- Move this check to sem???
procedure Export_DT (Typ : Entity_Id; DT : Entity_Id; Index : Nat := 0);
-- Export the dispatch table DT of tagged type Typ. Required to generate
-- forward references and statically allocate the table. For primary
@ -3733,103 +3716,6 @@ package body Exp_Disp is
function Number_Of_Predefined_Prims (Typ : Entity_Id) return Nat;
-- Returns the number of predefined primitives of Typ
------------------------------
-- Check_Premature_Freezing --
------------------------------
procedure Check_Premature_Freezing
(Subp : Entity_Id;
Tagged_Type : Entity_Id;
Typ : Entity_Id)
is
Comp : Entity_Id;
function Is_Actual_For_Formal_Incomplete_Type
(T : Entity_Id) return Boolean;
-- In Ada 2012, if a nested generic has an incomplete formal type,
-- the actual may be (and usually is) a private type whose completion
-- appears later. It is safe to build the dispatch table in this
-- case, gigi will have full views available.
------------------------------------------
-- Is_Actual_For_Formal_Incomplete_Type --
------------------------------------------
function Is_Actual_For_Formal_Incomplete_Type
(T : Entity_Id) return Boolean
is
Gen_Par : Entity_Id;
F : Node_Id;
begin
if not Is_Generic_Instance (Current_Scope)
or else not Used_As_Generic_Actual (T)
then
return False;
else
Gen_Par := Generic_Parent (Parent (Current_Scope));
end if;
F :=
First
(Generic_Formal_Declarations
(Unit_Declaration_Node (Gen_Par)));
while Present (F) loop
if Ekind (Defining_Identifier (F)) = E_Incomplete_Type then
return True;
end if;
Next (F);
end loop;
return False;
end Is_Actual_For_Formal_Incomplete_Type;
-- Start of processing for Check_Premature_Freezing
begin
-- Note that if the type is a (subtype of) a generic actual, the
-- actual will have been frozen by the instantiation.
if Present (N)
and then Is_Private_Type (Typ)
and then No (Full_View (Typ))
and then not Has_Private_Declaration (Typ)
and then not Is_Generic_Type (Typ)
and then not Is_Tagged_Type (Typ)
and then not Is_Frozen (Typ)
and then not Is_Generic_Actual_Type (Typ)
then
Error_Msg_Sloc := Sloc (Subp);
Error_Msg_NE
("declaration must appear after completion of type &", N, Typ);
Error_Msg_NE
("\which is an untagged type in the profile of "
& "primitive operation & declared#", N, Subp);
else
Comp := Private_Component (Typ);
if not Is_Tagged_Type (Typ)
and then Present (Comp)
and then not Is_Frozen (Comp)
and then not Has_Private_Declaration (Comp)
and then not Is_Actual_For_Formal_Incomplete_Type (Comp)
then
Error_Msg_Sloc := Sloc (Subp);
Error_Msg_NE
("declaration must appear after completion of type &",
N, Comp);
Error_Msg_Node_2 := Subp;
Error_Msg_Name_1 := Chars (Tagged_Type);
Error_Msg_NE
("\which is a component of untagged type& in the profile "
& "of primitive & of type % that is frozen by the "
& "declaration", N, Typ);
end if;
end if;
end Check_Premature_Freezing;
---------------
-- Export_DT --
---------------
@ -4584,55 +4470,31 @@ package body Exp_Disp is
end if;
-- Ensure that all the primitives are frozen. This is only required when
-- building static dispatch tables --- the primitives must be frozen to
-- be referenced (otherwise we have problems with the backend). It is
-- building static dispatch tables: the primitives must be frozen to be
-- referenced, otherwise we have problems with the back end. But this is
-- not a requirement with nonstatic dispatch tables because in this case
-- we generate now an empty dispatch table; the extra code required to
-- register the primitives in the slots will be generated later --- when
-- each primitive is frozen (see Freeze_Subprogram).
-- we generate an empty dispatch table at this point and the extra code
-- required to register the primitives in their slot will be generated
-- later, when each primitive is frozen (see Freeze_Subprogram).
if Building_Static_DT (Typ) then
declare
Saved_FLLTT : constant Boolean :=
Freezing_Library_Level_Tagged_Type;
Formal : Entity_Id;
Frnodes : List_Id;
F_List : List_Id;
Prim : Entity_Id;
Prim_Elmt : Elmt_Id;
begin
Freezing_Library_Level_Tagged_Type := True;
Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
while Present (Prim_Elmt) loop
Prim := Node (Prim_Elmt);
Frnodes := Freeze_Entity (Prim, Typ);
Prim := Node (Prim_Elmt);
F_List := Freeze_Entity (Prim, Typ, Do_Freeze_Profile => False);
-- We disable this check for abstract subprograms, given that
-- they cannot be called directly and thus the state of their
-- untagged formals is of no concern. The RM is unclear in any
-- case concerning the need for this check, and this topic may
-- go back to the ARG.
if not Is_Abstract_Subprogram (Prim) then
Formal := First_Formal (Prim);
while Present (Formal) loop
Check_Premature_Freezing (Prim, Typ, Etype (Formal));
Next_Formal (Formal);
end loop;
Check_Premature_Freezing (Prim, Typ, Etype (Prim));
end if;
if Present (Frnodes) then
Append_List_To (Result, Frnodes);
if Present (F_List) then
Append_List_To (Result, F_List);
end if;
Next_Elmt (Prim_Elmt);
end loop;
Freezing_Library_Level_Tagged_Type := Saved_FLLTT;
end;
end if;

10
gcc/ada/exp_disp.ads
View File

@ -168,11 +168,9 @@ package Exp_Disp is
-- Generate checks required on dispatching calls
function Building_Static_DT (Typ : Entity_Id) return Boolean;
pragma Inline (Building_Static_DT);
-- Returns true when building statically allocated dispatch tables
function Building_Static_Secondary_DT (Typ : Entity_Id) return Boolean;
pragma Inline (Building_Static_Secondary_DT);
-- Returns true when building statically allocated secondary dispatch
-- tables
@ -187,7 +185,6 @@ package Exp_Disp is
function Convert_Tag_To_Interface
(Typ : Entity_Id; Expr : Node_Id) return Node_Id;
pragma Inline (Convert_Tag_To_Interface);
-- This function is used in class-wide interface conversions; the expanded
-- code generated to convert a tagged object to a class-wide interface type
-- involves referencing the tag component containing the secondary dispatch
@ -256,11 +253,8 @@ package Exp_Disp is
function Is_Expanded_Dispatching_Call (N : Node_Id) return Boolean;
-- Returns true if N is the expanded code of a dispatching call
function Make_DT (Typ : Entity_Id; N : Node_Id := Empty) return List_Id;
-- Expand the declarations for the Dispatch Table. The node N is the
-- declaration that forces the generation of the table. It is used to place
-- error messages when the declaration leads to the freezing of a given
-- primitive operation that has an incomplete non- tagged formal.
function Make_DT (Typ : Entity_Id) return List_Id;
-- Expand the declarations for the Dispatch Table of Typ
function Make_Disp_Asynchronous_Select_Body
(Typ : Entity_Id) return Node_Id;

20
gcc/ada/freeze.adb
View File

@ -4631,9 +4631,7 @@ package body Freeze is
Result := No_List;
return False;
elsif not After_Last_Declaration
and then not Freezing_Library_Level_Tagged_Type
then
elsif not After_Last_Declaration then
Error_Msg_NE
("type & must be fully defined before this point",
N,
@ -4751,17 +4749,6 @@ package body Freeze is
if Is_Access_Type (F_Type) then
F_Type := Designated_Type (F_Type);
end if;
-- If the formal is an anonymous_access_to_subprogram
-- freeze the subprogram type as well, to prevent
-- scope anomalies in gigi, because there is no other
-- clear point at which it could be frozen.
if Is_Itype (Etype (Formal))
and then Ekind (F_Type) = E_Subprogram_Type
then
Freeze_And_Append (F_Type, N, Result);
end if;
end if;
Next_Formal (Formal);
@ -6490,9 +6477,10 @@ package body Freeze is
-- In Ada 2012, freezing a subprogram does not always freeze the
-- corresponding profile (see AI05-019). An attribute reference
-- is not a freezing point of the profile. Flag Do_Freeze_Profile
-- is not a freezing point of the profile. Similarly, we do not
-- freeze the profile of primitives of a library-level tagged type
-- when we are building its dispatch table. Flag Do_Freeze_Profile
-- indicates whether the profile should be frozen now.
-- Other constructs that should not freeze ???
-- This processing doesn't apply to internal entities (see below)

6
gcc/ada/freeze.ads
View File

@ -120,12 +120,6 @@ package Freeze is
-- where the freeze node is preallocated at the point of declaration, so
-- that the First_Subtype_Link field can be set.
Freezing_Library_Level_Tagged_Type : Boolean := False;
-- Flag used to indicate that we are freezing the primitives of a library
-- level tagged type. Used to disable checks on premature freezing.
-- More documentation needed??? why is this flag needed? what are these
-- checks? why do they need disabling in some cases?
-----------------
-- Subprograms --
-----------------