is
Actuals : List_Id;
Proc_To_Call : Entity_Id;
+ Except : Node_Id;
+ Stmts : List_Id;
begin
- pragma Assert (Present (Data.E_Id));
pragma Assert (Present (Data.Raised_Id));
- -- Generate:
- -- Get_Current_Excep.all.all
+ if Exception_Extra_Info
+ or else (For_Library and not Restricted_Profile)
+ then
+ if Exception_Extra_Info then
+
+ -- Generate:
+
+ -- Get_Current_Excep.all
+
+ Except :=
+ Make_Function_Call (Data.Loc,
+ Name =>
+ Make_Explicit_Dereference (Data.Loc,
+ Prefix =>
+ New_Reference_To
+ (RTE (RE_Get_Current_Excep), Data.Loc)));
+
+ else
+ -- Generate:
+
+ -- null
+
+ Except := Make_Null (Data.Loc);
+ end if;
- Actuals := New_List (
- Make_Explicit_Dereference (Data.Loc,
- Prefix =>
- Make_Function_Call (Data.Loc,
- Name =>
- Make_Explicit_Dereference (Data.Loc,
- Prefix =>
- New_Reference_To (RTE (RE_Get_Current_Excep),
- Data.Loc)))));
+ if For_Library and then not Restricted_Profile then
+ Proc_To_Call := RTE (RE_Save_Library_Occurrence);
+ Actuals := New_List (Except);
- if For_Library and then not Restricted_Profile then
- Proc_To_Call := RTE (RE_Save_Library_Occurrence);
+ else
+ Proc_To_Call := RTE (RE_Save_Occurrence);
+
+ -- The dereference occurs only when Exception_Extra_Info is true,
+ -- and therefore Except is not null.
+
+ Actuals :=
+ New_List (
+ New_Reference_To (Data.E_Id, Data.Loc),
+ Make_Explicit_Dereference (Data.Loc, Except));
+ end if;
+
+ -- Generate:
+
+ -- when others =>
+ -- if not Raised_Id then
+ -- Raised_Id := True;
+
+ -- Save_Occurrence (E_Id, Get_Current_Excep.all.all);
+ -- or
+ -- Save_Library_Occurrence (Get_Current_Excep.all);
+ -- end if;
+
+ Stmts :=
+ New_List (
+ Make_If_Statement (Data.Loc,
+ Condition =>
+ Make_Op_Not (Data.Loc,
+ Right_Opnd => New_Reference_To (Data.Raised_Id, Data.Loc)),
+
+ Then_Statements => New_List (
+ Make_Assignment_Statement (Data.Loc,
+ Name => New_Reference_To (Data.Raised_Id, Data.Loc),
+ Expression => New_Reference_To (Standard_True, Data.Loc)),
+
+ Make_Procedure_Call_Statement (Data.Loc,
+ Name =>
+ New_Reference_To (Proc_To_Call, Data.Loc),
+ Parameter_Associations => Actuals))));
else
- Proc_To_Call := RTE (RE_Save_Occurrence);
- Prepend_To (Actuals, New_Reference_To (Data.E_Id, Data.Loc));
+ -- Generate:
+
+ -- Raised_Id := True;
+
+ Stmts := New_List (
+ Make_Assignment_Statement (Data.Loc,
+ Name => New_Reference_To (Data.Raised_Id, Data.Loc),
+ Expression => New_Reference_To (Standard_True, Data.Loc)));
end if;
-- Generate:
- -- when others =>
- -- if not Raised_Id then
- -- Raised_Id := True;
- -- Save_Occurrence (E_Id, Get_Current_Excep.all.all);
- -- or
- -- Save_Library_Occurrence (Get_Current_Excep.all.all);
- -- end if;
+ -- when others =>
return
Make_Exception_Handler (Data.Loc,
- Exception_Choices =>
- New_List (Make_Others_Choice (Data.Loc)),
- Statements => New_List (
- Make_If_Statement (Data.Loc,
- Condition =>
- Make_Op_Not (Data.Loc,
- Right_Opnd => New_Reference_To (Data.Raised_Id, Data.Loc)),
-
- Then_Statements => New_List (
- Make_Assignment_Statement (Data.Loc,
- Name => New_Reference_To (Data.Raised_Id, Data.Loc),
- Expression => New_Reference_To (Standard_True, Data.Loc)),
-
- Make_Procedure_Call_Statement (Data.Loc,
- Name =>
- New_Reference_To (Proc_To_Call, Data.Loc),
- Parameter_Associations => Actuals)))));
+ Exception_Choices => New_List (Make_Others_Choice (Data.Loc)),
+ Statements => Stmts);
end Build_Exception_Handler;
-------------------------------
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);
end if;
-- Step 2: Creation of the finalizer specification
Append_To (Finalizer_Stmts, Label);
- -- The local exception does not need to be reraised for library-
- -- level finalizers. Generate:
- --
- -- if Raised and then not Abort then
- -- Raise_From_Controlled_Operation (E);
- -- end if;
-
- if not For_Package
- and then Exceptions_OK
- then
- Append_To (Finalizer_Stmts,
- Build_Raise_Statement (Finalizer_Data));
- end if;
-
-- Create the jump block which controls the finalization flow
-- depending on the value of the state counter.
Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc)));
end if;
+ -- The local exception does not need to be reraised for library-level
+ -- finalizers. Note that this action must be carried out after object
+ -- clean up, secondary stack release and abort undeferral. Generate:
+
+ -- if Raised and then not Abort then
+ -- Raise_From_Controlled_Operation (E);
+ -- end if;
+
+ if Has_Ctrl_Objs
+ and then Exceptions_OK
+ and then not For_Package
+ then
+ Append_To (Finalizer_Stmts,
+ Build_Raise_Statement (Finalizer_Data));
+ end if;
+
-- Generate:
-- procedure Fin_Id is
-- Abort : constant Boolean := Triggered_By_Abort;
-- <finalization statements> -- Added if Has_Ctrl_Objs
-- <stack release> -- Added if Mark_Id exists
-- Abort_Undefer; -- Added if abort is allowed
+ -- <exception propagation> -- Added if Has_Ctrl_Objs
-- end Fin_Id;
-- Create the body of the finalizer
and then Needs_Finalization (Obj_Typ)
and then not (Ekind (Obj_Id) = E_Constant
and then not Has_Completion (Obj_Id))
- and then not Is_Tag_To_CW_Conversion (Obj_Id)
+ and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id)
then
Processing_Actions;
-- Obj : Access_Typ := Non_BIP_Function_Call'reference;
-- Obj : Access_Typ :=
- -- BIP_Function_Call
- -- (..., BIPaccess => null, ...)'reference;
+ -- BIP_Function_Call (BIPalloc => 2, ...)'reference;
elsif Is_Access_Type (Obj_Typ)
and then Needs_Finalization
(Available_View (Designated_Type (Obj_Typ)))
and then Present (Expr)
and then
- (Is_Null_Access_BIP_Func_Call (Expr)
+ (Is_Secondary_Stack_BIP_Func_Call (Expr)
or else
(Is_Non_BIP_Func_Call (Expr)
and then not Is_Related_To_Func_Return (Obj_Id)))
-- Specific cases of object renamings
- elsif Nkind (Decl) = N_Object_Renaming_Declaration
- and then Nkind (Name (Decl)) = N_Explicit_Dereference
- and then Nkind (Prefix (Name (Decl))) = N_Identifier
- then
+ elsif Nkind (Decl) = N_Object_Renaming_Declaration then
Obj_Id := Defining_Identifier (Decl);
Obj_Typ := Base_Type (Etype (Obj_Id));
and then Present (Return_Flag_Or_Transient_Decl (Obj_Id))
then
Processing_Actions (Has_No_Init => True);
+
+ -- Detect a case where a source object has been initialized by
+ -- a controlled function call or another object which was later
+ -- rewritten as a class-wide conversion of Ada.Tags.Displace.
+
+ -- Obj1 : CW_Type := Src_Obj;
+ -- Obj2 : CW_Type := Function_Call (...);
+
+ -- Obj1 : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
+ -- Tmp : ... := Function_Call (...)'reference;
+ -- Obj2 : CW_Type renames (... Ada.Tags.Displace (Tmp));
+
+ elsif Is_Displacement_Of_Object_Or_Function_Result (Obj_Id) then
+ Processing_Actions (Has_No_Init => True);
end if;
-- Inspect the freeze node of an access-to-controlled type and
-- Determine whether N denotes the protected version of a subprogram
-- which belongs to a protected type.
- Loc : constant Source_Ptr := No_Location;
- HSS : Node_Id := Handled_Statement_Sequence (N);
+ Loc : constant Source_Ptr := Sloc (N);
+ HSS : Node_Id;
begin
-- Do not perform this expansion in Alfa mode because we do not create
-- The At_End handler should have been assimilated by the finalizer
+ HSS := Handled_Statement_Sequence (N);
pragma Assert (No (At_End_Proc (HSS)));
-- If the construct to be cleaned up is a protected subprogram body, the
return;
end if;
- Data.Abort_Id := Make_Temporary (Loc, 'A');
- Data.E_Id := Make_Temporary (Loc, 'E');
Data.Raised_Id := Make_Temporary (Loc, 'R');
-- In certain scenarios, finalization can be triggered by an abort. If
and then VM_Target = No_VM
and then not For_Package
then
+ Data.Abort_Id := Make_Temporary (Loc, 'A');
+
A_Expr := New_Reference_To (RTE (RE_Triggered_By_Abort), Loc);
- -- No abort, .NET/JVM or library-level finalizers
+ -- Generate:
+
+ -- Abort_Id : constant Boolean := <A_Expr>;
+
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Data.Abort_Id,
+ Constant_Present => True,
+ Object_Definition => New_Reference_To (Standard_Boolean, Loc),
+ Expression => A_Expr));
else
- A_Expr := New_Reference_To (Standard_False, Loc);
+ -- No abort, .NET/JVM or library-level finalizers
+
+ Data.Abort_Id := Empty;
end if;
- -- Generate:
- -- Abort_Id : constant Boolean := <A_Expr>;
+ if Exception_Extra_Info then
+ Data.E_Id := Make_Temporary (Loc, 'E');
- Append_To (Decls,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Data.Abort_Id,
- Constant_Present => True,
- Object_Definition => New_Reference_To (Standard_Boolean, Loc),
- Expression => A_Expr));
+ -- Generate:
- -- Generate:
- -- E_Id : Exception_Occurrence;
+ -- E_Id : Exception_Occurrence;
- E_Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Data.E_Id,
- Object_Definition =>
- New_Reference_To (RTE (RE_Exception_Occurrence), Loc));
- Set_No_Initialization (E_Decl);
+ E_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Data.E_Id,
+ Object_Definition =>
+ New_Reference_To (RTE (RE_Exception_Occurrence), Loc));
+ Set_No_Initialization (E_Decl);
+
+ Append_To (Decls, E_Decl);
- Append_To (Decls, E_Decl);
+ else
+ Data.E_Id := Empty;
+ end if;
-- Generate:
+
-- Raised_Id : Boolean := False;
Append_To (Decls,
(Data : Finalization_Exception_Data) return Node_Id
is
Stmt : Node_Id;
+ Expr : Node_Id;
begin
-- Standard run-time and .NET/JVM targets use the specialized routine
-- Raise_From_Controlled_Operation.
- if RTE_Available (RE_Raise_From_Controlled_Operation) then
+ if Exception_Extra_Info
+ and then RTE_Available (RE_Raise_From_Controlled_Operation)
+ then
Stmt :=
Make_Procedure_Call_Statement (Data.Loc,
Name =>
end if;
-- Generate:
+
+ -- Raised_Id and then not Abort_Id
+ -- <or>
+ -- Raised_Id
+
+ Expr := New_Reference_To (Data.Raised_Id, Data.Loc);
+
+ if Present (Data.Abort_Id) then
+ Expr := Make_And_Then (Data.Loc,
+ Left_Opnd => Expr,
+ Right_Opnd =>
+ Make_Op_Not (Data.Loc,
+ Right_Opnd => New_Reference_To (Data.Abort_Id, Data.Loc)));
+ end if;
+
+ -- Generate:
+
-- if Raised_Id and then not Abort_Id then
-- Raise_From_Controlled_Operation (E_Id);
-- <or>
return
Make_If_Statement (Data.Loc,
- Condition =>
- Make_And_Then (Data.Loc,
- Left_Opnd => New_Reference_To (Data.Raised_Id, Data.Loc),
- Right_Opnd =>
- Make_Op_Not (Data.Loc,
- Right_Opnd => New_Reference_To (Data.Abort_Id, Data.Loc))),
-
+ Condition => Expr,
Then_Statements => New_List (Stmt));
end Build_Raise_Statement;
and then VM_Target = No_VM;
Actions_Required : constant Boolean :=
- Requires_Cleanup_Actions (N)
+ Requires_Cleanup_Actions (N, True)
or else Is_Asynchronous_Call
or else Is_Master
or else Is_Protected_Body
Last_Object : Node_Id;
Related_Node : Node_Id)
is
- Requires_Hooking : constant Boolean :=
- Nkind_In (N, N_Function_Call,
- N_Procedure_Call_Statement);
+ function Requires_Hooking return Boolean;
+ -- Determine whether the context requires transient variable export
+ -- to the outer finalizer. This scenario arises when the context may
+ -- raise an exception.
+
+ ----------------------
+ -- Requires_Hooking --
+ ----------------------
+
+ function Requires_Hooking return Boolean is
+ begin
+ -- The context is either a procedure or function call or an object
+ -- declaration initialized by a function call. In all these cases,
+ -- the calls might raise an exception.
+
+ return Nkind (N) in N_Subprogram_Call
+ or else (Nkind (N) = N_Object_Declaration
+ and then Nkind (Expression (N)) = N_Function_Call);
+ end Requires_Hooking;
+
+ -- Local variables
+ Must_Hook : constant Boolean := Requires_Hooking;
Built : Boolean := False;
Desig_Typ : Entity_Id;
Fin_Block : Node_Id;
-- enclosing sequence of statements where their corresponding
-- "hooks" are picked up by the finalization machinery.
- if Requires_Hooking then
+ if Must_Hook then
declare
Expr : Node_Id;
Ptr_Id : Entity_Id;
-- Generate:
-- Temp := null;
- if Requires_Hooking then
+ if Must_Hook then
Append_To (Stmts,
Make_Assignment_Statement (Loc,
Name => New_Reference_To (Temp_Id, Loc),
begin
return
Is_Protected_Type (T)
+ and then not Uses_Lock_Free (T)
and then not Has_Entries (T)
and then Is_RTE (Find_Protection_Type (T), RE_Protection);
end Is_Simple_Protected_Type;
git://gcc.gnu.org / gcc.git / blobdiff