===================================================================
@@ -4176,37 +4176,37 @@
procedure Expand_Cleanup_Actions (N : Node_Id) is
Scop : constant Entity_Id := Current_Scope;
- Is_Asynchronous_Call : constant Boolean :=
- Nkind (N) = N_Block_Statement
- and then Is_Asynchronous_Call_Block (N);
- Is_Master : constant Boolean :=
- Nkind (N) /= N_Entry_Body
- and then Is_Task_Master (N);
- Is_Protected_Body : constant Boolean :=
- Nkind (N) = N_Subprogram_Body
- and then Is_Protected_Subprogram_Body (N);
- Is_Task_Allocation : constant Boolean :=
- Nkind (N) = N_Block_Statement
- and then Is_Task_Allocation_Block (N);
- Is_Task_Body : constant Boolean :=
- Nkind (Original_Node (N)) = N_Task_Body;
- Needs_Sec_Stack_Mark : constant Boolean :=
- Uses_Sec_Stack (Scop)
- and then
- not Sec_Stack_Needed_For_Return (Scop);
- Needs_Custom_Cleanup : constant Boolean :=
- Nkind (N) = N_Block_Statement
- and then Present (Cleanup_Actions (N));
+ Is_Asynchronous_Call : constant Boolean :=
+ Nkind (N) = N_Block_Statement
+ and then Is_Asynchronous_Call_Block (N);
+ Is_Master : constant Boolean :=
+ Nkind (N) /= N_Entry_Body
+ and then Is_Task_Master (N);
+ Is_Protected_Subp_Body : constant Boolean :=
+ Nkind (N) = N_Subprogram_Body
+ and then Is_Protected_Subprogram_Body (N);
+ Is_Task_Allocation : constant Boolean :=
+ Nkind (N) = N_Block_Statement
+ and then Is_Task_Allocation_Block (N);
+ Is_Task_Body : constant Boolean :=
+ Nkind (Original_Node (N)) = N_Task_Body;
+ Needs_Sec_Stack_Mark : constant Boolean :=
+ Uses_Sec_Stack (Scop)
+ and then
+ not Sec_Stack_Needed_For_Return (Scop);
+ Needs_Custom_Cleanup : constant Boolean :=
+ Nkind (N) = N_Block_Statement
+ and then Present (Cleanup_Actions (N));
- Actions_Required : constant Boolean :=
- Requires_Cleanup_Actions (N, True)
- or else Is_Asynchronous_Call
- or else Is_Master
- or else Is_Protected_Body
- or else Is_Task_Allocation
- or else Is_Task_Body
- or else Needs_Sec_Stack_Mark
- or else Needs_Custom_Cleanup;
+ Actions_Required : constant Boolean :=
+ Requires_Cleanup_Actions (N, True)
+ or else Is_Asynchronous_Call
+ or else Is_Master
+ or else Is_Protected_Subp_Body
+ or else Is_Task_Allocation
+ or else Is_Task_Body
+ or else Needs_Sec_Stack_Mark
+ or else Needs_Custom_Cleanup;
HSS : Node_Id := Handled_Statement_Sequence (N);
Loc : Source_Ptr;
===================================================================
@@ -24,7 +24,6 @@
------------------------------------------------------------------------------
with Atree; use Atree;
-with Checks; use Checks;
with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
@@ -421,9 +420,6 @@
-- the Task_Body_Procedure of Spec_Id. The returned entity denotes formal
-- parameter _E.
- function Is_Exception_Safe (Subprogram : Node_Id) return Boolean;
- -- Tell whether a given subprogram cannot raise an exception
-
function Is_Potentially_Large_Family
(Base_Index : Entity_Id;
Conctyp : Entity_Id;
@@ -3889,30 +3885,28 @@
Pid : Node_Id;
N_Op_Spec : Node_Id) return Node_Id
is
- Loc : constant Source_Ptr := Sloc (N);
- Op_Spec : Node_Id;
- P_Op_Spec : Node_Id;
- Uactuals : List_Id;
- Pformal : Node_Id;
- Unprot_Call : Node_Id;
- Sub_Body : Node_Id;
+ Exc_Safe : constant Boolean := not Might_Raise (N);
+ -- True if N cannot raise an exception
+
+ Loc : constant Source_Ptr := Sloc (N);
+ Op_Spec : constant Node_Id := Specification (N);
+ P_Op_Spec : constant Node_Id :=
+ Build_Protected_Sub_Specification (N, Pid, Protected_Mode);
+
+ Lock_Kind : RE_Id;
Lock_Name : Node_Id;
Lock_Stmt : Node_Id;
+ Object_Parm : Node_Id;
+ Pformal : Node_Id;
R : Node_Id;
Return_Stmt : Node_Id := Empty; -- init to avoid gcc 3 warning
Pre_Stmts : List_Id := No_List; -- init to avoid gcc 3 warning
Stmts : List_Id;
- Object_Parm : Node_Id;
- Exc_Safe : Boolean;
- Lock_Kind : RE_Id;
+ Sub_Body : Node_Id;
+ Uactuals : List_Id;
+ Unprot_Call : Node_Id;
begin
- Op_Spec := Specification (N);
- Exc_Safe := Is_Exception_Safe (N);
-
- P_Op_Spec :=
- Build_Protected_Sub_Specification (N, Pid, Protected_Mode);
-
-- Build a list of the formal parameters of the protected version of
-- the subprogram to use as the actual parameters of the unprotected
-- version.
@@ -13545,103 +13539,6 @@
end if;
end Install_Private_Data_Declarations;
- -----------------------
- -- Is_Exception_Safe --
- -----------------------
-
- function Is_Exception_Safe (Subprogram : Node_Id) return Boolean is
-
- function Has_Side_Effect (N : Node_Id) return Boolean;
- -- Return True whenever encountering a subprogram call or raise
- -- statement of any kind in the sequence of statements
-
- ---------------------
- -- Has_Side_Effect --
- ---------------------
-
- -- What is this doing buried two levels down in exp_ch9. It seems like a
- -- generally useful function, and indeed there may be code duplication
- -- going on here ???
-
- function Has_Side_Effect (N : Node_Id) return Boolean is
- Stmt : Node_Id;
- Expr : Node_Id;
-
- function Is_Call_Or_Raise (N : Node_Id) return Boolean;
- -- Indicate whether N is a subprogram call or a raise statement
-
- ----------------------
- -- Is_Call_Or_Raise --
- ----------------------
-
- function Is_Call_Or_Raise (N : Node_Id) return Boolean is
- begin
- return Nkind_In (N, N_Procedure_Call_Statement,
- N_Function_Call,
- N_Raise_Statement,
- N_Raise_Constraint_Error,
- N_Raise_Program_Error,
- N_Raise_Storage_Error);
- end Is_Call_Or_Raise;
-
- -- Start of processing for Has_Side_Effect
-
- begin
- Stmt := N;
- while Present (Stmt) loop
- if Is_Call_Or_Raise (Stmt) then
- return True;
- end if;
-
- -- An object declaration can also contain a function call or a
- -- raise statement.
-
- if Nkind (Stmt) = N_Object_Declaration then
- Expr := Expression (Stmt);
-
- if Present (Expr) and then Is_Call_Or_Raise (Expr) then
- return True;
- end if;
- end if;
-
- Next (Stmt);
- end loop;
-
- return False;
- end Has_Side_Effect;
-
- -- Start of processing for Is_Exception_Safe
-
- begin
- -- When exceptions can't be propagated, the subprogram returns normally
-
- if No_Exception_Handlers_Set then
- return True;
- end if;
-
- -- If the checks handled by the back end are not disabled, we cannot
- -- ensure that no exception will be raised.
-
- if not Access_Checks_Suppressed (Empty)
- or else not Discriminant_Checks_Suppressed (Empty)
- or else not Range_Checks_Suppressed (Empty)
- or else not Index_Checks_Suppressed (Empty)
- or else Opt.Stack_Checking_Enabled
- then
- return False;
- end if;
-
- if Has_Side_Effect (First (Declarations (Subprogram)))
- or else
- Has_Side_Effect
- (First (Statements (Handled_Statement_Sequence (Subprogram))))
- then
- return False;
- else
- return True;
- end if;
- end Is_Exception_Safe;
-
---------------------------------
-- Is_Potentially_Large_Family --
---------------------------------
===================================================================
@@ -16869,6 +16869,63 @@
Mark_Allocators (Root_Nod);
end Mark_Coextensions;
+ -----------------
+ -- Might_Raise --
+ -----------------
+
+ function Might_Raise (N : Node_Id) return Boolean is
+ Result : Boolean := False;
+
+ function Process (N : Node_Id) return Traverse_Result;
+ -- Set Result to True if we find something that could raise an exception
+
+ -------------
+ -- Process --
+ -------------
+
+ function Process (N : Node_Id) return Traverse_Result is
+ begin
+ if Nkind_In (N, N_Procedure_Call_Statement,
+ N_Function_Call,
+ N_Raise_Statement,
+ N_Raise_Constraint_Error,
+ N_Raise_Program_Error,
+ N_Raise_Storage_Error)
+ then
+ Result := True;
+ return Abandon;
+ else
+ return OK;
+ end if;
+ end Process;
+
+ procedure Set_Result is new Traverse_Proc (Process);
+
+ -- Start of processing for Might_Raise
+
+ begin
+ -- False if exceptions can't be propagated
+
+ if No_Exception_Handlers_Set then
+ return False;
+ end if;
+
+ -- If the checks handled by the back end are not disabled, we cannot
+ -- ensure that no exception will be raised.
+
+ if not Access_Checks_Suppressed (Empty)
+ or else not Discriminant_Checks_Suppressed (Empty)
+ or else not Range_Checks_Suppressed (Empty)
+ or else not Index_Checks_Suppressed (Empty)
+ or else Opt.Stack_Checking_Enabled
+ then
+ return True;
+ end if;
+
+ Set_Result (N);
+ return Result;
+ end Might_Raise;
+
--------------------------------
-- Nearest_Enclosing_Instance --
--------------------------------
===================================================================
@@ -1984,6 +1984,11 @@
-- to guarantee this in all cases. Note that it is more possible to give
-- correct answer if the tree is fully analyzed.
+ function Might_Raise (N : Node_Id) return Boolean;
+ -- True if evaluation of N might raise an exception. This is conservative;
+ -- if we're not sure, we return True. If N is a subprogram body, this is
+ -- about whether execution of that body can raise.
+
function Nearest_Enclosing_Instance (E : Entity_Id) return Entity_Id;
-- Return the entity of the nearest enclosing instance which encapsulates
-- entity E. If no such instance exits, return Empty.
This patch fixes a bug where a protected procedure that propagates an exception can cause deadlock. This can happen if all of these checks are suppressed: Access_Check, Discriminant_Check, Range_Check, Index_Check, and Stack_Check (possibly by -gnatp), and the protected procedure calls something that raises an exception, and that call is not an immediate statement of the protected procedure, and is not a function used to initialize a local variable of the protected procedure. For example, if the call that raises an exception is inside a pragma Debug that is inside the protected procedure, and pragma Debug is enabled by -gnata, the deadlock can occur. The following test must not deadlock, and should run to completion silently. package Debug_Prot is protected Prot is procedure P; entry E; private Ready_Flag : Boolean := True; Internal_State : Boolean := False; end Prot; end Debug_Prot; package body Debug_Prot is protected body Prot is procedure P is procedure transition_check is begin raise Constraint_Error; end transition_check; begin pragma Debug (Transition_Check); Internal_State := True; end P; entry E when Ready_Flag is begin null; end E; end Prot; end Debug_Prot; procedure Debug_Prot.Main is task T1; task T2; task body T1 is begin Prot.P; end T1; task body T2 is begin delay 2.0; Prot.E; end T2; begin null; end Debug_Prot.Main; Tested on x86_64-pc-linux-gnu, committed on trunk 2017-04-28 Bob Duff <duff@adacore.com> * sem_util.ads, sem_util.adb (Might_Raise): New function that replaces Is_Exception_Safe, but has the opposite sense. Is_Exception_Safe was missing various cases -- calls inside a pragma Debug, calls inside an 'if' or assignment statement, etc. Might_Raise now walks the entire subtree looking for things that can raise. * exp_ch9.adb (Is_Exception_Safe): Remove. (Build_Protected_Subprogram_Body): Replace call to Is_Exception_Safe with "not Might_Raise". Misc cleanup (use constants where possible). * exp_ch7.adb: Rename Is_Protected_Body --> Is_Protected_Subp_Body. A protected_body is something different in the grammar.