with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
with GNAT_CUDA; use GNAT_CUDA;
+with Inline; use Inline;
with Lib; use Lib;
with Nlists; use Nlists;
with Nmake; use Nmake;
-- conversion to the class-wide type in the case where the operation is
-- abstract.
+ function Finalize_Address_For_Node (Node : Entity_Id) return Entity_Id
+ renames Einfo.Entities.Finalization_Master_Node;
+ -- Return the Finalize_Address primitive for the object that has been
+ -- attached to a finalization Master_Node.
+
function Make_Call
(Loc : Source_Ptr;
Proc_Id : Entity_Id;
-- [Deep_]Finalize (Acc_Typ (V).all);
-- end;
+ procedure Set_Finalize_Address_For_Node (Node, Fin_Id : Entity_Id)
+ renames Einfo.Entities.Set_Finalization_Master_Node;
+ -- Set the Finalize_Address primitive for the object that has been
+ -- attached to a finalization Master_Node.
+
----------------------------------
-- Attach_Object_To_Master_Node --
----------------------------------
Attribute_Name => Name_Unrestricted_Access),
New_Occurrence_Of (Master_Node, Loc)));
+ Set_Finalize_Address_For_Node (Master_Node, Fin_Id);
+
Insert_After_And_Analyze
(Master_Node_Ins, Master_Node_Attach, Suppress => All_Checks);
end Attach_Object_To_Master_Node;
Finalizer_Stmts : List_Id := No_List;
-- The statement list of the finalizer body
+ Has_Strict_Ctrl_Objs : Boolean := False;
+ -- A general flag which indicates whether N has at least one controlled
+ -- object with strict semantics for finalization.
+
Has_Tagged_Types : Boolean := False;
-- A general flag which indicates whether N has at least one library-
-- level tagged type declaration.
begin
pragma Assert (Present (Decls));
- -- If the context contains controlled objects, then we create the
- -- finalization master, unless there is a single such object: in
- -- this common case, we'll directly finalize the object.
+ -- If the context contains controlled objects with strict semantics
+ -- for finalization, then we create the finalization master, unless
+ -- there is a single such object: in this common case, we'll directly
+ -- finalize the object.
- if Has_Ctrl_Objs then
+ if Has_Strict_Ctrl_Objs then
if Count > 1 then
if For_Package_Spec then
Master_Name :=
-- The default name is _finalizer
else
- -- Generation of a finalization procedure exclusively for 'Old
- -- interally generated constants requires different name since
- -- there will need to be multiple finalization routines in the
- -- same scope. See Build_Finalizer for details.
-
Fin_Id :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Name_uFinalizer));
+ -- The visibility semantics of At_End handlers force a strange
+ -- separation of spec and body for stack-related finalizers:
+
+ -- declare : Enclosing_Scope
+ -- procedure _finalizer;
+ -- begin
+ -- <controlled objects>
+ -- procedure _finalizer is
+ -- ...
+ -- at end
+ -- _finalizer;
+ -- end;
+
+ -- Both spec and body are within the same construct and scope, but
+ -- the body is part of the handled sequence of statements. This
+ -- placement confuses the elaboration mechanism on targets where
+ -- At_End handlers are expanded into "when all others" handlers:
+
+ -- exception
+ -- when all others =>
+ -- _finalizer; -- appears to require elab checks
+ -- at end
+ -- _finalizer;
+ -- end;
+
+ -- Since the compiler guarantees that the body of a _finalizer is
+ -- always inserted in the same construct where the At_End handler
+ -- resides, there is no need for elaboration checks.
+
+ Set_Kill_Elaboration_Checks (Fin_Id);
+
-- Inlining the finalizer produces a substantial speedup at -O2.
-- It is inlined by default at -O3. Either way, it is called
-- exactly twice (once on the normal path, and once for
-- Abort_Undefer; -- Added if abort is allowed
-- end Fin_Id;
- -- If there are controlled objects to be finalized, generate:
+ -- If there are strict controlled objects to be finalized, generate:
-- procedure Fin_Id is
-- Abort : constant Boolean := Triggered_By_Abort;
-- <exception propagation>
-- end Fin_Id;
- if Has_Ctrl_Objs and then Count > 1 then
+ -- If there are only controlled objects with relaxed semantics for
+ -- finalization, only the <finalization statements> are generated.
+
+ if Has_Strict_Ctrl_Objs and then Count > 1 then
Fin_Call :=
Make_Procedure_Call_Statement (Loc,
Name =>
-- Raise_From_Controlled_Operation (E);
-- end if;
- if Has_Ctrl_Objs and Exceptions_OK and not For_Package then
+ if Has_Strict_Ctrl_Objs and Exceptions_OK and not For_Package then
Append_To (Finalizer_Stmts,
Build_Raise_Statement (Finalizer_Data));
end if;
-- Non-package case
else
+ -- Insert the spec for the finalizer. The At_End handler must be
+ -- able to call the body which resides in a nested structure.
+
+ -- declare
+ -- procedure Fin_Id; -- Spec
+ -- begin
+ -- <objects and possibly statements>
+ -- procedure Fin_Id is ... -- Body
+ -- <statements>
+ -- at end
+ -- Fin_Id; -- At_End handler
+ -- end;
+
pragma Assert (Present (Decls));
Append_To (Decls, Fin_Spec);
- Append_To (Decls, Fin_Body);
+
+ -- When the finalizer acts solely as a cleanup routine, the body
+ -- is inserted right after the spec.
+
+ if Acts_As_Clean and not Has_Ctrl_Objs then
+ Insert_After (Fin_Spec, Fin_Body);
+
+ -- In other cases the body is inserted after the last statement
+
+ else
+ -- Manually freeze the spec. This is somewhat of a hack because
+ -- a subprogram is frozen when its body is seen and the freeze
+ -- node appears right before the body. However, in this case,
+ -- the spec must be frozen earlier since the At_End handler
+ -- must be able to call it.
+ --
+ -- declare
+ -- procedure Fin_Id; -- Spec
+ -- [Fin_Id] -- Freeze node
+ -- begin
+ -- ...
+ -- at end
+ -- Fin_Id; -- At_End handler
+ -- end;
+
+ Ensure_Freeze_Node (Fin_Id);
+ Insert_After (Fin_Spec, Freeze_Node (Fin_Id));
+ Set_Is_Frozen (Fin_Id);
+
+ Append_To (Stmts, Fin_Body);
+ end if;
end if;
Analyze (Fin_Spec, Suppress => All_Checks);
procedure Processing_Actions
(Decl : Node_Id;
- Is_Protected : Boolean := False);
+ Is_Protected : Boolean := False;
+ Strict : Boolean := False);
-- Depending on the mode of operation of Process_Declarations, either
-- increment the controlled object count or process the declaration.
-- The Flag Is_Protected is set when the declaration denotes a simple
- -- protected object.
+ -- protected object. The flag Strict is true when the declaration is
+ -- for a controlled object with strict semantics for finalization.
--------------------------
-- Process_Package_Body --
procedure Processing_Actions
(Decl : Node_Id;
- Is_Protected : Boolean := False)
+ Is_Protected : Boolean := False;
+ Strict : Boolean := False)
is
begin
-- Library-level tagged type
else
if Preprocess then
Count := Count + 1;
+ if Strict then
+ Has_Strict_Ctrl_Objs := True;
+ end if;
else
Process_Object_Declaration (Decl, Is_Protected);
Obj_Id : Entity_Id;
Obj_Typ : Entity_Id;
Pack_Id : Entity_Id;
+ Prev : Node_Id;
Spec : Node_Id;
Typ : Entity_Id;
return;
end if;
- -- Process all declarations in reverse order
+ -- Process all declarations in reverse order and be prepared for them
+ -- to be moved during the processing.
Decl := Last_Non_Pragma (Decls);
while Present (Decl) loop
+ Prev := Prev_Non_Pragma (Decl);
+
-- Library-level tagged types
if Nkind (Decl) = N_Full_Type_Declaration then
and then not Has_Completion (Obj_Id)
and then No (BIP_Initialization_Call (Obj_Id)))
then
- Processing_Actions (Decl);
+ Processing_Actions
+ (Decl, Strict => not Has_Relaxed_Finalization (Obj_Typ));
-- The object is of the form:
-- Obj : Access_Typ := Non_BIP_Function_Call'reference;
(Is_Non_BIP_Func_Call (Expr)
and then not Is_Related_To_Func_Return (Obj_Id)))
then
- Processing_Actions (Decl);
+ Processing_Actions
+ (Decl,
+ Strict => not Has_Relaxed_Finalization
+ (Available_View (Designated_Type (Obj_Typ))));
-- Simple protected objects which use the type System.Tasking.
-- Protected_Objects.Protection to manage their locks should
and then Has_Simple_Protected_Object (Obj_Typ)
and then not Restricted_Profile
then
- Processing_Actions (Decl, Is_Protected => True);
+ Processing_Actions
+ (Decl, Is_Protected => True, Strict => True);
end if;
-- Inspect the freeze node of an access-to-controlled type and
Process_Package_Body (Proper_Body (Unit (Library_Unit (Decl))));
end if;
- Prev_Non_Pragma (Decl);
+ Decl := Prev;
end loop;
end Process_Declarations;
Obj_Typ := Available_View (Designated_Type (Obj_Typ));
end if;
- -- If the object is a Master_Node, then nothing to do, except if it
- -- is the only object, in which case we move its declaration, call
- -- marker (if any) and initialization call, as well as mark it to
- -- avoid double processing.
+ -- If the object is a Master_Node, then nothing to do, unless there
+ -- is no or a single controlled object with strict semantics, in
+ -- which case we move its declaration, call marker (if any) and
+ -- initialization call, and also mark it to avoid double processing.
if Is_RTE (Obj_Typ, RE_Master_Node) then
Master_Node_Id := Obj_Id;
- if Count = 1 then
+ if not Has_Strict_Ctrl_Objs or else Count = 1 then
if Nkind (Next (Decl)) = N_Call_Marker then
Prepend_To (Decls, Remove_Next (Next (Decl)));
end if;
end if;
-- Create the declaration of the Master_Node for the object and
- -- insert it before the declaration of the object itself, except
- -- for the case where it is the only object because it will play
- -- the role of a degenerated master and therefore needs to be
- -- inserted at the same place the master would have been.
+ -- insert it before the declaration of the object itself, unless
+ -- there is no or a single controlled object with strict semantics,
+ -- because it will effectively play the role of a degenerated master
+ -- and therefore needs to be inserted at the same place the master
+ -- would have been.
else pragma Assert (No (Finalization_Master_Node (Obj_Id)));
- -- For one object, use the Sloc the master would have had
+ -- In the latter case, use the Sloc the master would have had
- if Count = 1 then
+ if not Has_Strict_Ctrl_Objs or else Count = 1 then
Master_Node_Loc := Sloc (N);
else
Master_Node_Loc := Loc;
Master_Node_Id, Obj_Id);
Push_Scope (Scope (Obj_Id));
- if Count = 1 then
+ if not Has_Strict_Ctrl_Objs or else Count = 1 then
Prepend_To (Decls, Master_Node_Decl);
else
Insert_Before (Decl, Master_Node_Decl);
-- Now build the attachment call that will initialize the object's
-- Master_Node using the object's address and type's finalization
-- procedure and then attach the Master_Node to the master, unless
- -- there is a single controlled object.
+ -- there is no or a single controlled object with strict semantics.
- if Count = 1 then
+ if not Has_Strict_Ctrl_Objs or else Count = 1 then
-- Finalize_Address is not generated in CodePeer mode because the
-- body contains address arithmetic. So we don't want to generate
-- the attach in this case. Ditto if the object is a Master_Node.
Prefix => New_Occurrence_Of (Fin_Id, Loc),
Attribute_Name => Name_Unrestricted_Access),
New_Occurrence_Of (Master_Node_Id, Loc)));
+
+ Set_Finalize_Address_For_Node (Master_Node_Id, Fin_Id);
end if;
-- We also generate the direct finalization call here
- Fin_Call :=
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Finalize_Object), Loc),
- Parameter_Associations => New_List (
- New_Occurrence_Of (Master_Node_Id, Loc)));
+ Fin_Call := Make_Finalize_Call_For_Node (Loc, Master_Node_Id);
-- For CodePeer, the exception handlers normally generated here
-- generate complex flowgraphs which result in capacity problems.
-- to be live. That is what we are interested in, not what
-- happens after the exception is raised.
- if Exceptions_OK and not CodePeer_Mode then
+ if Has_Strict_Ctrl_Objs
+ and then Exceptions_OK
+ and then not CodePeer_Mode
+ then
Fin_Call :=
Make_Block_Statement (Loc,
Handled_Statement_Sequence =>
-- Then add the finalization call for the object
Insert_After_And_Analyze (Insert_Nod,
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Finalize_Object), Loc),
- Parameter_Associations => New_List (
- New_Occurrence_Of (Master_Node_Id, Loc))));
+ Make_Finalize_Call_For_Node (Loc, Master_Node_Id));
-- Otherwise generate a direct finalization call for the object
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stmts)));
+ -- If the type has relaxed semantics for finalization, the indirect
+ -- calls to Finalize_Address may be turned into direct ones and, in
+ -- this case, inlining them is generally profitable.
+
+ if Has_Relaxed_Finalization (Typ) then
+ Set_Is_Inlined (Proc_Id);
+ end if;
+
Set_TSS (Typ, Proc_Id);
end Make_Finalize_Address_Body;
return New_List (Fin_Block);
end Make_Finalize_Address_Stmts;
+ ---------------------------------
+ -- Make_Finalize_Call_For_Node --
+ ---------------------------------
+
+ function Make_Finalize_Call_For_Node
+ (Loc : Source_Ptr;
+ Node : Entity_Id) return Node_Id
+ is
+ Fin_Id : constant Entity_Id := Finalize_Address_For_Node (Node);
+
+ Fin_Call : Node_Id;
+ Fin_Ref : Node_Id;
+
+ begin
+ -- Finalize_Address is not generated in CodePeer mode because the
+ -- body contains address arithmetic. So we don't want to generate
+ -- the call in this case.
+
+ if CodePeer_Mode then
+ return Make_Null_Statement (Loc);
+ end if;
+
+ -- The Finalize_Address primitive may be missing when the Master_Node
+ -- is written down in the source code for testing purposes.
+
+ if Present (Fin_Id) then
+ Fin_Ref :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Fin_Id, Loc),
+ Attribute_Name => Name_Unrestricted_Access);
+
+ else
+ Fin_Ref :=
+ Make_Selected_Component (Loc,
+ Prefix => New_Occurrence_Of (Node, Loc),
+ Selector_Name => Make_Identifier (Loc, Name_Finalize_Address));
+ end if;
+
+ Fin_Call :=
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Finalize_Object), Loc),
+ Parameter_Associations => New_List (
+ New_Occurrence_Of (Node, Loc),
+ Fin_Ref));
+
+ -- Present Finalize_Address procedure to the back end so that it can
+ -- inline the call to the procedure made by Finalize_Object.
+
+ if Present (Fin_Id) and then Is_Inlined (Fin_Id) then
+ Add_Inlined_Body (Fin_Id, Fin_Call);
+ end if;
+
+ return Fin_Call;
+ end Make_Finalize_Call_For_Node;
+
-------------------------------------
-- Make_Handler_For_Ctrl_Operation --
-------------------------------------
projects / thirdparty / gcc.git / commitdiff
