[Ada] Do not service entries after a protected function call (with -gnatp).

Arnaud Charlet charlet@adacore.com
Mon Jan 27 16:52:00 GMT 2014


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  <gingold@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.

-------------- next part --------------
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


More information about the Gcc-patches mailing list