For single entry protected objects, the entry was served (in case of pending
call and when compiled without checks) after a function call. This is useless,
and not coherent with code generated without -gnatp.
The following program displays 'Barrier called' only three times:
gnatmake -gnatp main
./main
Barrier called
Barrier called
Barrier called
package prot is
protected P is
procedure proc;
function fun return integer;
entry en;
procedure release;
private
released : boolean := false;
end p;
end prot;
with ada.text_io; use ada.text_io;
package body prot is
function Barrier return boolean is
begin
put_line ("Barrier called");
return false;
end Barrier;
protected body P is
procedure proc
is
begin
null;
end proc;
function fun return integer is
begin
return 1;
end fun;
procedure release is
begin
released := true;
end release;
entry en when Barrier or else released is
begin
null;
end en;
end p;
task T;
task body T is
begin
P.en;
end T;
end prot;
with prot;
procedure main is
v : integer;
begin
delay 1.0;
v := prot.p.fun;
prot.p.release;
end;
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-01-27 Tristan Gingold <ging...@adacore.com>
* exp_ch7.adb (Build_Cleanup_Statements): Call
Build_Protected_Subprogram_Call_Cleanup to insert the cleanup
for protected body.
* exp_ch9.adb (Build_Protected_Subprogram_Body): Likewise.
Remove Service_Name variable.
(Build_Protected_SUbprogam_Call_Cleanup): New procedure that
factorize code from the above subprograms.
* exp_ch9.ads (Build_Protected_Subprogram_Call_Cleanup): New procedure.
Index: exp_ch7.adb
===================================================================
--- exp_ch7.adb (revision 207140)
+++ exp_ch7.adb (working copy)
@@ -511,7 +511,6 @@
declare
Spec : constant Node_Id := Parent (Corresponding_Spec (N));
Conc_Typ : Entity_Id;
- Nam : Node_Id;
Param : Node_Id;
Param_Typ : Entity_Id;
@@ -532,81 +531,15 @@
pragma Assert (Present (Param));
- -- If the associated protected object has entries, a protected
- -- procedure has to service entry queues. In this case generate:
+ -- Historical note: In earlier versions of GNAT, there was code
+ -- at this point to generate stuff to service entry queues. But
+ -- that was wrong thinking. This was useless and resulted in
+ -- incoherencies between code generated with and without -gnatp.
- -- Service_Entries (_object._object'Access);
+ -- All that is needed at this stage is a normal cleanup call
- if Nkind (Specification (N)) = N_Procedure_Specification
- and then Has_Entries (Conc_Typ)
- then
- case Corresponding_Runtime_Package (Conc_Typ) is
- when System_Tasking_Protected_Objects_Entries =>
- Nam := New_Reference_To (RTE (RE_Service_Entries), Loc);
-
- when System_Tasking_Protected_Objects_Single_Entry =>
- Nam := New_Reference_To (RTE (RE_Service_Entry), Loc);
-
- when others =>
- raise Program_Error;
- end case;
-
- Append_To (Stmts,
- Make_Procedure_Call_Statement (Loc,
- Name => Nam,
- Parameter_Associations => New_List (
- Make_Attribute_Reference (Loc,
- Prefix =>
- Make_Selected_Component (Loc,
- Prefix => New_Reference_To (
- Defining_Identifier (Param), Loc),
- Selector_Name =>
- Make_Identifier (Loc, Name_uObject)),
- Attribute_Name => Name_Unchecked_Access))));
-
- else
- -- Generate:
- -- Unlock (_object._object'Access);
-
- case Corresponding_Runtime_Package (Conc_Typ) is
- when System_Tasking_Protected_Objects_Entries =>
- Nam := New_Reference_To (RTE (RE_Unlock_Entries), Loc);
-
- when System_Tasking_Protected_Objects_Single_Entry =>
- Nam := New_Reference_To (RTE (RE_Unlock_Entry), Loc);
-
- when System_Tasking_Protected_Objects =>
- Nam := New_Reference_To (RTE (RE_Unlock), Loc);
-
- when others =>
- raise Program_Error;
- end case;
-
- Append_To (Stmts,
- Make_Procedure_Call_Statement (Loc,
- Name => Nam,
- Parameter_Associations => New_List (
- Make_Attribute_Reference (Loc,
- Prefix =>
- Make_Selected_Component (Loc,
- Prefix =>
- New_Reference_To
- (Defining_Identifier (Param), Loc),
- Selector_Name =>
- Make_Identifier (Loc, Name_uObject)),
- Attribute_Name => Name_Unchecked_Access))));
- end if;
-
- -- Generate:
- -- Abort_Undefer;
-
- if Abort_Allowed then
- Append_To (Stmts,
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Reference_To (RTE (RE_Abort_Undefer), Loc),
- Parameter_Associations => Empty_List));
- end if;
+ Build_Protected_Subprogram_Call_Cleanup
+ (Specification (N), Conc_Typ, Loc, Stmts);
end;
-- Add a call to Expunge_Unactivated_Tasks for dynamically allocated
Index: exp_ch9.adb
===================================================================
--- exp_ch9.adb (revision 207120)
+++ exp_ch9.adb (working copy)
@@ -4150,7 +4150,6 @@
Sub_Body : Node_Id;
Lock_Name : Node_Id;
Lock_Stmt : Node_Id;
- Service_Name : 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
@@ -4235,15 +4234,12 @@
case Corresponding_Runtime_Package (Pid) is
when System_Tasking_Protected_Objects_Entries =>
Lock_Name := New_Reference_To (RTE (RE_Lock_Entries), Loc);
- Service_Name := New_Reference_To (RTE (RE_Service_Entries), Loc);
when System_Tasking_Protected_Objects_Single_Entry =>
Lock_Name := New_Reference_To (RTE (RE_Lock_Entry), Loc);
- Service_Name := New_Reference_To (RTE (RE_Service_Entry), Loc);
when System_Tasking_Protected_Objects =>
Lock_Name := New_Reference_To (RTE (Lock_Kind), Loc);
- Service_Name := New_Reference_To (RTE (RE_Unlock), Loc);
when others =>
raise Program_Error;
@@ -4282,21 +4278,8 @@
Append (Unprot_Call, Stmts);
end if;
- Append (
- Make_Procedure_Call_Statement (Loc,
- Name => Service_Name,
- Parameter_Associations =>
- New_List (New_Copy_Tree (Object_Parm))),
- Stmts);
+ Build_Protected_Subprogram_Call_Cleanup (Op_Spec, Pid, Loc, Stmts);
- if Abort_Allowed then
- Append (
- Make_Procedure_Call_Statement (Loc,
- Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc),
- Parameter_Associations => Empty_List),
- Stmts);
- end if;
-
if Nkind (Op_Spec) = N_Function_Specification then
Append (Return_Stmt, Stmts);
Append (Make_Block_Statement (Loc,
@@ -4388,6 +4371,91 @@
end if;
end Build_Protected_Subprogram_Call;
+ ---------------------------------------------
+ -- Build_Protected_Subprogram_Call_Cleanup --
+ ---------------------------------------------
+
+ procedure Build_Protected_Subprogram_Call_Cleanup
+ (Op_Spec : Node_Id;
+ Conc_Typ : Node_Id;
+ Loc : Source_Ptr;
+ Stmts : List_Id)
+ is
+ Nam : Node_Id;
+
+ begin
+ -- If the associated protected object has entries, a protected
+ -- procedure has to service entry queues. In this case generate:
+
+ -- Service_Entries (_object._object'Access);
+
+ if Nkind (Op_Spec) = N_Procedure_Specification
+ and then Has_Entries (Conc_Typ)
+ then
+ case Corresponding_Runtime_Package (Conc_Typ) is
+ when System_Tasking_Protected_Objects_Entries =>
+ Nam := New_Reference_To (RTE (RE_Service_Entries), Loc);
+
+ when System_Tasking_Protected_Objects_Single_Entry =>
+ Nam := New_Reference_To (RTE (RE_Service_Entry), Loc);
+
+ when others =>
+ raise Program_Error;
+ end case;
+
+ Append_To (Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name => Nam,
+ Parameter_Associations => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix => Make_Identifier (Loc, Name_uObject),
+ Selector_Name => Make_Identifier (Loc, Name_uObject)),
+ Attribute_Name => Name_Unchecked_Access))));
+
+ else
+ -- Generate:
+ -- Unlock (_object._object'Access);
+
+ case Corresponding_Runtime_Package (Conc_Typ) is
+ when System_Tasking_Protected_Objects_Entries =>
+ Nam := New_Reference_To (RTE (RE_Unlock_Entries), Loc);
+
+ when System_Tasking_Protected_Objects_Single_Entry =>
+ Nam := New_Reference_To (RTE (RE_Unlock_Entry), Loc);
+
+ when System_Tasking_Protected_Objects =>
+ Nam := New_Reference_To (RTE (RE_Unlock), Loc);
+
+ when others =>
+ raise Program_Error;
+ end case;
+
+ Append_To (Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name => Nam,
+ Parameter_Associations => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix => Make_Identifier (Loc, Name_uObject),
+ Selector_Name => Make_Identifier (Loc, Name_uObject)),
+ Attribute_Name => Name_Unchecked_Access))));
+ end if;
+
+ -- Generate:
+ -- Abort_Undefer;
+
+ if Abort_Allowed then
+ Append_To (Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Abort_Undefer), Loc),
+ Parameter_Associations => Empty_List));
+ end if;
+ end Build_Protected_Subprogram_Call_Cleanup;
+
-------------------------
-- Build_Selected_Name --
-------------------------
Index: exp_ch9.ads
===================================================================
--- exp_ch9.ads (revision 207120)
+++ exp_ch9.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2013, 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- --
@@ -112,6 +112,16 @@
-- External is False if the call is to another protected subprogram within
-- the same object.
+ procedure Build_Protected_Subprogram_Call_Cleanup
+ (Op_Spec : Node_Id;
+ Conc_Typ : Node_Id;
+ Loc : Source_Ptr;
+ Stmts : List_Id);
+ -- Append to Stmts the cleanups after a call to a protected subprogram
+ -- whose specification is Op_Spec. Conc_Typ is the concurrent type and Loc
+ -- the sloc for appended statements. The cleanup will either unlock the
+ -- protected object or serve pending entries.
+
procedure Build_Task_Activation_Call (N : Node_Id);
-- This procedure is called for constructs that can be task activators,
-- i.e. task bodies, subprogram bodies, package bodies and blocks. If the
