[Ada] Add restrictions to the use of s-tposen

Arnaud Charlet charlet@adacore.com
Fri Jan 31 15:56:00 GMT 2014


The package s-tposen is used to implement protected objects (with one entry)
in the ravenscar profile. In fact, only a subset of the ravenscar profile
is required to trigger the use of this package (instead of s-tpoben). This
patch adds a restriction to the triggering conditions, in order to simplify
the implementation and the interface of s-tposen.
No functional change.

Tested on x86_64-pc-linux-gnu, committed on trunk

2014-01-31  Tristan Gingold  <gingold@adacore.com>

	* exp_util.adb (Corresponding_Runtime_Package): Restrict the
	use of System_Tasking_Protected_Objects_Single_Entry.
	* exp_ch9.adb (Build_Simple_Entry_Call): Remove Mode parameter
	of Protected_Single_Entry_Call.
	(Expand_N_Timed_Entry_Call): Remove single_entry case.
	* exp_disp.adb (Make_Disp_Asynchronous_Select_Body): Remove
	single_entry case.
	(Make_Disp_Timed_Select_Body): Likewise.
	* rtsfind.ads (RE_Timed_Protected_Single_Entry_Call): Remove.
	* s-tposen.adb (Send_Program_Error, PO_Do_Or_Queue): Remove
	Self_Id parameter.
	(Wakeup_Entry_Caller): Remove Self_ID and New_State parameters.
	(Wait_For_Completion_With_Timeout): Remove.
	(Protected_Single_Entry_Call): Remove Mode parameter
	(always Simple_Call).
	(Service_Entry): Remove Self_Id constant (not used anymore).
	(Timed_Protected_Single_Entry_Call): Remove.
	* s-tposen.ads (Timed_Protected_Single_Entry_Call): Remove.
	(Protected_Single_Entry_Call): Remove Mode parameter.

-------------- next part --------------
Index: exp_util.adb
===================================================================
--- exp_util.adb	(revision 207348)
+++ exp_util.adb	(working copy)
@@ -1646,6 +1646,7 @@
          then
             if Abort_Allowed
               or else Restriction_Active (No_Entry_Queue) = False
+              or else Restriction_Active (No_Select_Statements) = False
               or else Number_Entries (Typ) > 1
               or else (Has_Attach_Handler (Typ)
                         and then not Restricted_Profile)
Index: exp_ch9.adb
===================================================================
--- exp_ch9.adb	(revision 207348)
+++ exp_ch9.adb	(working copy)
@@ -4682,12 +4682,10 @@
          --  family index expressions are evaluated before the entry
          --  parameters.
 
-         if Abort_Allowed
-           or else Restriction_Active (No_Entry_Queue) = False
-           or else not Is_Protected_Type (Conctyp)
-           or else Number_Entries (Conctyp) > 1
-           or else (Has_Attach_Handler (Conctyp)
-                     and then not Restricted_Profile)
+         if not Is_Protected_Type (Conctyp)
+           or else
+             Corresponding_Runtime_Package (Conctyp) =
+               System_Tasking_Protected_Objects_Entries
          then
             X := Make_Defining_Identifier (Loc, Name_uX);
 
@@ -4902,8 +4900,7 @@
                when System_Tasking_Protected_Objects_Single_Entry =>
                   --     Protected_Single_Entry_Call (
                   --       Object => po._object'Access,
-                  --       Uninterpreted_Data => P'Address;
-                  --       Mode => Simple_Call);
+                  --       Uninterpreted_Data => P'Address);
 
                   Call :=
                     Make_Procedure_Call_Statement (Loc,
@@ -4914,8 +4911,7 @@
                         Make_Attribute_Reference (Loc,
                           Attribute_Name => Name_Unchecked_Access,
                           Prefix         => Parm1),
-                        Parm3,
-                        New_Reference_To (RTE (RE_Simple_Call), Loc)));
+                        Parm3));
 
                when others =>
                   raise Program_Error;
@@ -12481,24 +12477,6 @@
                           (RTE (RE_Timed_Protected_Entry_Call), Loc),
                       Parameter_Associations => Params));
 
-               when System_Tasking_Protected_Objects_Single_Entry =>
-                  Param := First (Params);
-                  while Present (Param)
-                    and then not
-                      Is_RTE (Etype (Param), RE_Protected_Entry_Index)
-                  loop
-                     Next (Param);
-                  end loop;
-
-                  Remove (Param);
-
-                  Rewrite (Call,
-                    Make_Procedure_Call_Statement (Loc,
-                      Name =>
-                        New_Reference_To
-                          (RTE (RE_Timed_Protected_Single_Entry_Call), Loc),
-                      Parameter_Associations => Params));
-
                when others =>
                   raise Program_Error;
             end case;
Index: rtsfind.ads
===================================================================
--- rtsfind.ads	(revision 207348)
+++ rtsfind.ads	(working copy)
@@ -1750,7 +1750,6 @@
      RE_Exceptional_Complete_Single_Entry_Body,
      RE_Protected_Count_Entry,           -- Protected_Objects.Single_Entry
      RE_Protected_Single_Entry_Caller,   -- Protected_Objects.Single_Entry
-     RE_Timed_Protected_Single_Entry_Call,
 
      RE_Protected_Entry_Index,           -- System.Tasking.Protected_Objects
      RE_Entry_Body,                      -- System.Tasking.Protected_Objects
@@ -3062,8 +3061,6 @@
        System_Tasking_Protected_Objects_Single_Entry,
      RE_Protected_Single_Entry_Caller    =>
        System_Tasking_Protected_Objects_Single_Entry,
-     RE_Timed_Protected_Single_Entry_Call =>
-       System_Tasking_Protected_Objects_Single_Entry,
 
      RE_Protected_Entry_Index            => System_Tasking_Protected_Objects,
      RE_Entry_Body                       => System_Tasking_Protected_Objects,
Index: exp_disp.adb
===================================================================
--- exp_disp.adb	(revision 207348)
+++ exp_disp.adb	(working copy)
@@ -2337,30 +2337,6 @@
 
                           New_Reference_To (Com_Block, Loc)))); -- comm block
 
-               when System_Tasking_Protected_Objects_Single_Entry =>
-
-                  --  Generate:
-                  --    procedure Protected_Single_Entry_Call
-                  --      (Object              : Protection_Entry_Access;
-                  --       Uninterpreted_Data  : System.Address;
-                  --       Mode                : Call_Modes);
-
-                  Append_To (Stmts,
-                    Make_Procedure_Call_Statement (Loc,
-                      Name =>
-                        New_Reference_To
-                          (RTE (RE_Protected_Single_Entry_Call), Loc),
-                      Parameter_Associations =>
-                        New_List (
-                          Obj_Ref,
-
-                          Make_Attribute_Reference (Loc,
-                            Prefix         => Make_Identifier (Loc, Name_uP),
-                            Attribute_Name => Name_Address),
-
-                            New_Reference_To
-                             (RTE (RE_Asynchronous_Call), Loc))));
-
                when others =>
                   raise Program_Error;
             end case;
@@ -3569,29 +3545,6 @@
                           Make_Identifier (Loc, Name_uM),   --  delay mode
                           Make_Identifier (Loc, Name_uF)))); --  status flag
 
-               when System_Tasking_Protected_Objects_Single_Entry =>
-                  --  Generate:
-
-                  --   Timed_Protected_Single_Entry_Call
-                  --     (T._object'access, P, D, M, F);
-
-                  --  where T is the protected object, P is the wrapped
-                  --  parameters, D is the delay amount, M is the delay mode, F
-                  --  is the status flag.
-
-                  Append_To (Stmts,
-                    Make_Procedure_Call_Statement (Loc,
-                      Name =>
-                        New_Reference_To
-                          (RTE (RE_Timed_Protected_Single_Entry_Call), Loc),
-                      Parameter_Associations =>
-                        New_List (
-                          Obj_Ref,
-                          Make_Identifier (Loc, Name_uP),   --  parameter block
-                          Make_Identifier (Loc, Name_uD),   --  delay
-                          Make_Identifier (Loc, Name_uM),   --  delay mode
-                          Make_Identifier (Loc, Name_uF)))); --  status flag
-
                when others =>
                   raise Program_Error;
             end case;
Index: s-tposen.adb
===================================================================
--- s-tposen.adb	(revision 207348)
+++ s-tposen.adb	(working copy)
@@ -74,9 +74,7 @@
    -- Local Subprograms --
    -----------------------
 
-   procedure Send_Program_Error
-     (Self_Id    : Task_Id;
-      Entry_Call : Entry_Call_Link);
+   procedure Send_Program_Error (Entry_Call : Entry_Call_Link);
    pragma Inline (Send_Program_Error);
    --  Raise Program_Error in the caller of the specified entry call
 
@@ -84,19 +82,12 @@
    -- Entry Calls Handling --
    --------------------------
 
-   procedure Wakeup_Entry_Caller
-     (Self_ID    : Task_Id;
-      Entry_Call : Entry_Call_Link;
-      New_State  : Entry_Call_State);
+   procedure Wakeup_Entry_Caller (Entry_Call : Entry_Call_Link);
    pragma Inline (Wakeup_Entry_Caller);
    --  This is called at the end of service of an entry call,
    --  to abort the caller if he is in an abortable part, and
    --  to wake up the caller if he is on Entry_Caller_Sleep.
    --  Call it holding the lock of Entry_Call.Self.
-   --
-   --  Timed_Call or Simple_Call:
-   --    The caller is waiting on Entry_Caller_Sleep, in
-   --    Wait_For_Completion, or Wait_For_Completion_With_Timeout.
 
    procedure Wait_For_Completion (Entry_Call : Entry_Call_Link);
    pragma Inline (Wait_For_Completion);
@@ -105,13 +96,6 @@
    --  queued. This waits for calls on protected entries.
    --  Call this only when holding Self_ID locked.
 
-   procedure Wait_For_Completion_With_Timeout
-     (Entry_Call  : Entry_Call_Link;
-      Wakeup_Time : Duration;
-      Mode        : Delay_Modes);
-   --  Same as Wait_For_Completion but it waits for a timeout with the value
-   --  specified in Wakeup_Time as well.
-
    procedure Check_Exception
      (Self_ID : Task_Id;
       Entry_Call : Entry_Call_Link);
@@ -122,8 +106,7 @@
    --  The caller should not be holding any locks, or there will be deadlock.
 
    procedure PO_Do_Or_Queue
-     (Self_Id    : Task_Id;
-      Object     : Protection_Entry_Access;
+     (Object     : Protection_Entry_Access;
       Entry_Call : Entry_Call_Link);
    --  This procedure executes or queues an entry call, depending
    --  on the status of the corresponding barrier. It assumes that the
@@ -157,9 +140,7 @@
    -- Send_Program_Error --
    ------------------------
 
-   procedure Send_Program_Error
-     (Self_Id    : Task_Id;
-      Entry_Call : Entry_Call_Link)
+   procedure Send_Program_Error (Entry_Call : Entry_Call_Link)
    is
       Caller : constant Task_Id := Entry_Call.Self;
    begin
@@ -170,7 +151,7 @@
       end if;
 
       STPO.Write_Lock (Caller);
-      Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
+      Wakeup_Entry_Caller (Entry_Call);
       STPO.Unlock (Caller);
 
       if Single_Lock then
@@ -190,51 +171,6 @@
       Self_Id.Common.State := Runnable;
    end Wait_For_Completion;
 
-   --------------------------------------
-   -- Wait_For_Completion_With_Timeout --
-   --------------------------------------
-
-   procedure Wait_For_Completion_With_Timeout
-     (Entry_Call  : Entry_Call_Link;
-      Wakeup_Time : Duration;
-      Mode        : Delay_Modes)
-   is
-      Self_Id  : constant Task_Id := Entry_Call.Self;
-      Timedout : Boolean;
-
-      Yielded  : Boolean;
-      pragma Unreferenced (Yielded);
-
-      use type Ada.Exceptions.Exception_Id;
-
-   begin
-      --  This procedure waits for the entry call to be served, with a timeout.
-      --  It tries to cancel the call if the timeout expires before the call is
-      --  served.
-
-      --  If we wake up from the timed sleep operation here, it may be for the
-      --  following possible reasons:
-
-      --  1) The entry call is done being served.
-      --  2) The timeout has expired (Timedout = True)
-
-      --  Once the timeout has expired we may need to continue to wait if the
-      --  call is already being serviced. In that case, we want to go back to
-      --  sleep, but without any timeout. The variable Timedout is used to
-      --  control this. If the Timedout flag is set, we do not need to Sleep
-      --  with a timeout. We just sleep until we get a wakeup for some status
-      --  change.
-
-      pragma Assert (Entry_Call.Mode = Timed_Call);
-      Self_Id.Common.State := Entry_Caller_Sleep;
-
-      STPO.Timed_Sleep
-        (Self_Id, Wakeup_Time, Mode, Entry_Caller_Sleep, Timedout, Yielded);
-
-      Entry_Call.State := (if Timedout then Cancelled else Done);
-      Self_Id.Common.State := Runnable;
-   end Wait_For_Completion_With_Timeout;
-
    -------------------------
    -- Wakeup_Entry_Caller --
    -------------------------
@@ -246,31 +182,18 @@
    --  (This enforces the rule that a task must be off-queue if its state is
    --  Done or Cancelled.) Call it holding the lock of Entry_Call.Self.
 
-   --  Timed_Call or Simple_Call:
-   --    The caller is waiting on Entry_Caller_Sleep, in
-   --    Wait_For_Completion, or Wait_For_Completion_With_Timeout.
+   --  The caller is waiting on Entry_Caller_Sleep, in Wait_For_Completion.
 
-   --  Conditional_Call:
-   --    The caller might be in Wait_For_Completion,
-   --    waiting for a rendezvous (possibly requeued without abort)
-   --    to complete.
-
    procedure Wakeup_Entry_Caller
-     (Self_ID    : Task_Id;
-      Entry_Call : Entry_Call_Link;
-      New_State  : Entry_Call_State)
+     (Entry_Call : Entry_Call_Link)
    is
-      pragma Warnings (Off, Self_ID);
-
       Caller : constant Task_Id := Entry_Call.Self;
-
    begin
-      pragma Assert (New_State = Done or else New_State = Cancelled);
       pragma Assert
         (Caller.Common.State /= Terminated and then
          Caller.Common.State /= Unactivated);
 
-      Entry_Call.State := New_State;
+      Entry_Call.State := Done;
       STPO.Wakeup (Caller, Entry_Caller_Sleep);
    end Wakeup_Entry_Caller;
 
@@ -338,8 +261,7 @@
    --------------------
 
    procedure PO_Do_Or_Queue
-     (Self_Id    : Task_Id;
-      Object     : Protection_Entry_Access;
+     (Object     : Protection_Entry_Access;
       Entry_Call : Entry_Call_Link)
    is
       Barrier_Value : Boolean;
@@ -356,7 +278,7 @@
             --  This violates the No_Entry_Queue restriction, send
             --  Program_Error to the caller.
 
-            Send_Program_Error (Self_Id, Entry_Call);
+            Send_Program_Error (Entry_Call);
             return;
          end if;
 
@@ -370,45 +292,32 @@
          end if;
 
          STPO.Write_Lock (Entry_Call.Self);
-         Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
+         Wakeup_Entry_Caller (Entry_Call);
          STPO.Unlock (Entry_Call.Self);
 
          if Single_Lock then
             STPO.Unlock_RTS;
          end if;
 
-      elsif Entry_Call.Mode /= Conditional_Call then
+      else
+         pragma Assert (Entry_Call.Mode = Simple_Call);
+
          if Object.Entry_Queue /= null then
 
             --  This violates the No_Entry_Queue restriction, send
             --  Program_Error to the caller.
 
-            Send_Program_Error (Self_Id, Entry_Call);
+            Send_Program_Error (Entry_Call);
             return;
          else
             Object.Entry_Queue := Entry_Call;
          end if;
 
-      else
-         --  Conditional_Call
-
-         if Single_Lock then
-            STPO.Lock_RTS;
-         end if;
-
-         STPO.Write_Lock (Entry_Call.Self);
-         Wakeup_Entry_Caller (Self_Id, Entry_Call, Cancelled);
-         STPO.Unlock (Entry_Call.Self);
-
-         if Single_Lock then
-            STPO.Unlock_RTS;
-         end if;
       end if;
 
    exception
       when others =>
-         Send_Program_Error
-           (Self_Id, Entry_Call);
+         Send_Program_Error (Entry_Call);
    end PO_Do_Or_Queue;
 
    ----------------------------
@@ -430,8 +339,7 @@
 
    procedure Protected_Single_Entry_Call
      (Object             : Protection_Entry_Access;
-      Uninterpreted_Data : System.Address;
-      Mode               : Call_Modes)
+      Uninterpreted_Data : System.Address)
    is
       Self_Id    : constant Task_Id := STPO.Self;
       Entry_Call : Entry_Call_Record renames Self_Id.Entry_Calls (1);
@@ -448,12 +356,12 @@
 
       Lock_Entry (Object);
 
-      Entry_Call.Mode := Mode;
+      Entry_Call.Mode := Simple_Call;
       Entry_Call.State := Now_Abortable;
       Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
       Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
 
-      PO_Do_Or_Queue (Self_Id, Object, Entry_Call'Access);
+      PO_Do_Or_Queue (Object, Entry_Call'Access);
       Unlock_Entry (Object);
 
       --  The call is either `Done' or not. It cannot be cancelled since there
@@ -493,7 +401,6 @@
    -------------------
 
    procedure Service_Entry (Object : Protection_Entry_Access) is
-      Self_Id    : constant Task_Id := STPO.Self;
       Entry_Call : constant Entry_Call_Link := Object.Entry_Queue;
       Caller     : Task_Id;
 
@@ -507,7 +414,7 @@
 
             --  Violation of No_Entry_Queue restriction, raise exception
 
-            Send_Program_Error (Self_Id, Entry_Call);
+            Send_Program_Error (Entry_Call);
             Unlock_Entry (Object);
             return;
          end if;
@@ -524,7 +431,7 @@
          end if;
 
          STPO.Write_Lock (Caller);
-         Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
+         Wakeup_Entry_Caller (Entry_Call);
          STPO.Unlock (Caller);
 
          if Single_Lock then
@@ -539,79 +446,10 @@
 
    exception
       when others =>
-         Send_Program_Error (Self_Id, Entry_Call);
+         Send_Program_Error (Entry_Call);
          Unlock_Entry (Object);
    end Service_Entry;
 
-   ---------------------------------------
-   -- Timed_Protected_Single_Entry_Call --
-   ---------------------------------------
-
-   --  Compiler interface only (do not call from within the RTS)
-
-   procedure Timed_Protected_Single_Entry_Call
-     (Object                : Protection_Entry_Access;
-      Uninterpreted_Data    : System.Address;
-      Timeout               : Duration;
-      Mode                  : Delay_Modes;
-      Entry_Call_Successful : out Boolean)
-   is
-      Self_Id           : constant Task_Id  := STPO.Self;
-      Entry_Call        : Entry_Call_Record renames Self_Id.Entry_Calls (1);
-
-   begin
-      --  If pragma Detect_Blocking is active then Program_Error must be
-      --  raised if this potentially blocking operation is called from a
-      --  protected action.
-
-      if Detect_Blocking
-        and then Self_Id.Common.Protected_Action_Nesting > 0
-      then
-         raise Program_Error with "potentially blocking operation";
-      end if;
-
-      Lock (Object.Common'Access);
-
-      Entry_Call.Mode := Timed_Call;
-      Entry_Call.State := Now_Abortable;
-      Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
-      Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
-
-      PO_Do_Or_Queue (Self_Id, Object, Entry_Call'Access);
-      Unlock_Entry (Object);
-
-      --  Try to avoid waiting for completed calls.
-      --  The call is either `Done' or not. It cannot be cancelled since there
-      --  is no ATC construct and the timed wait has not started yet.
-
-      pragma Assert (Entry_Call.State /= Cancelled);
-
-      if Entry_Call.State = Done then
-         Check_Exception (Self_Id, Entry_Call'Access);
-         Entry_Call_Successful := True;
-         return;
-      end if;
-
-      if Single_Lock then
-         STPO.Lock_RTS;
-      else
-         STPO.Write_Lock (Self_Id);
-      end if;
-
-      Wait_For_Completion_With_Timeout (Entry_Call'Access, Timeout, Mode);
-
-      if Single_Lock then
-         STPO.Unlock_RTS;
-      else
-         STPO.Unlock (Self_Id);
-      end if;
-
-      pragma Assert (Entry_Call.State >= Done);
-
-      Check_Exception (Self_Id, Entry_Call'Access);
-      Entry_Call_Successful := Entry_Call.State = Done;
-   end Timed_Protected_Single_Entry_Call;
-
    ------------------
    -- Unlock_Entry --
    ------------------
Index: s-tposen.ads
===================================================================
--- s-tposen.ads	(revision 207348)
+++ s-tposen.ads	(working copy)
@@ -225,8 +225,7 @@
 
    procedure Protected_Single_Entry_Call
      (Object              : Protection_Entry_Access;
-      Uninterpreted_Data  : System.Address;
-      Mode                : Call_Modes);
+      Uninterpreted_Data  : System.Address);
    --  Make a protected entry call to the specified object
    --
    --  Pend a protected entry call on the protected object represented by
@@ -237,19 +236,7 @@
    --      This will be returned by Next_Entry_Call when this call is serviced.
    --      It can be used by the compiler to pass information between the
    --      caller and the server, in particular entry parameters.
-   --
-   --    Mode
-   --      The kind of call to be pended
 
-   procedure Timed_Protected_Single_Entry_Call
-     (Object                : Protection_Entry_Access;
-      Uninterpreted_Data    : System.Address;
-      Timeout               : Duration;
-      Mode                  : Delay_Modes;
-      Entry_Call_Successful : out Boolean);
-   --  Same as the Protected_Entry_Call but with time-out specified.
-   --  This routine is used to implement timed entry calls.
-
    procedure Exceptional_Complete_Single_Entry_Body
      (Object : Protection_Entry_Access;
       Ex     : Ada.Exceptions.Exception_Id);


More information about the Gcc-patches mailing list