gcc/ada/libgnarl/s-tposen.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS                  --
   4 --                                                                          --
   5 --             SYSTEM.TASKING.PROTECTED_OBJECTS.SINGLE_ENTRY                --
   6 --                                                                          --
   7 --                                B o d y                                   --
   8 --                                                                          --
   9 --         Copyright (C) 1998-2023, Free Software Foundation, Inc.          --
  10 --                                                                          --
  11 -- GNARL is free software; you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNARL was developed by the GNARL team at Florida State University.       --
  28 -- Extensive contributions were provided by Ada Core Technologies, Inc.     --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 pragma Style_Checks (All_Checks);
  33 --  Turn off subprogram ordering check, since restricted GNARLI subprograms are
  34 --  gathered together at end.
  35
  36 --  This package provides an optimized version of Protected_Objects.Operations
  37 --  and Protected_Objects.Entries making the following assumptions:
  38
  39 --    PO has only one entry
  40 --    There is only one caller at a time (No_Entry_Queue)
  41 --    There is no dynamic priority support (No_Dynamic_Priorities)
  42 --    No Abort Statements
  43 --     (No_Abort_Statements, Max_Asynchronous_Select_Nesting => 0)
  44 --    PO are at library level
  45 --    No Requeue
  46 --    None of the tasks will terminate (no need for finalization)
  47
  48 --  This interface is intended to be used in the ravenscar and restricted
  49 --  profiles, the compiler is responsible for ensuring that the conditions
  50 --  mentioned above are respected, except for the No_Entry_Queue restriction
  51 --  that is checked dynamically in this package, since the check cannot be
  52 --  performed at compile time, and is relatively cheap (see PO_Do_Or_Queue,
  53 --  Service_Entry).
  54
  55 pragma Suppress (All_Checks);
  56 --  Why is this required ???
  57
  58 with Ada.Exceptions;
  59
  60 with System.Task_Primitives.Operations;
  61
  62 package body System.Tasking.Protected_Objects.Single_Entry is
  63
  64    package STPO renames System.Task_Primitives.Operations;
  65
  66    -----------------------
  67    -- Local Subprograms --
  68    -----------------------
  69
  70    procedure Send_Program_Error (Entry_Call : Entry_Call_Link);
  71    pragma Inline (Send_Program_Error);
  72    --  Raise Program_Error in the caller of the specified entry call
  73
  74    --------------------------
  75    -- Entry Calls Handling --
  76    --------------------------
  77
  78    procedure Wakeup_Entry_Caller (Entry_Call : Entry_Call_Link);
  79    pragma Inline (Wakeup_Entry_Caller);
  80    --  This is called at the end of service of an entry call, to abort the
  81    --  caller if he is in an abortable part, and to wake up the caller if he
  82    --  is on Entry_Caller_Sleep. Call it holding the lock of Entry_Call.Self.
  83
  84    procedure Wait_For_Completion (Entry_Call : Entry_Call_Link);
  85    pragma Inline (Wait_For_Completion);
  86    --  This procedure suspends the calling task until the specified entry call
  87    --  has either been completed or cancelled. On exit, the call will not be
  88    --  queued. This waits for calls on protected entries.
  89    --  Call this only when holding Self_ID locked.
  90
  91    procedure Check_Exception
  92      (Self_ID : Task_Id;
  93       Entry_Call : Entry_Call_Link);
  94    pragma Inline (Check_Exception);
  95    --  Raise any pending exception from the Entry_Call. This should be called
  96    --  at the end of every compiler interface procedure that implements an
  97    --  entry call. The caller should not be holding any locks, or there will
  98    --  be deadlock.
  99
 100    procedure PO_Do_Or_Queue
 101      (Object     : Protection_Entry_Access;
 102       Entry_Call : Entry_Call_Link);
 103    --  This procedure executes or queues an entry call, depending on the status
 104    --  of the corresponding barrier. The specified object is assumed locked.
 105
 106    ---------------------
 107    -- Check_Exception --
 108    ---------------------
 109
 110    procedure Check_Exception
 111      (Self_ID    : Task_Id;
 112       Entry_Call : Entry_Call_Link)
 113    is
 114       pragma Warnings (Off, Self_ID);
 115
 116       procedure Internal_Raise (X : Ada.Exceptions.Exception_Id);
 117       pragma Import (C, Internal_Raise, "__gnat_raise_with_msg");
 118
 119       use type Ada.Exceptions.Exception_Id;
 120
 121       E : constant Ada.Exceptions.Exception_Id :=
 122             Entry_Call.Exception_To_Raise;
 123
 124    begin
 125       if E /= Ada.Exceptions.Null_Id then
 126          Internal_Raise (E);
 127       end if;
 128    end Check_Exception;
 129
 130    ------------------------
 131    -- Send_Program_Error --
 132    ------------------------
 133
 134    procedure Send_Program_Error (Entry_Call : Entry_Call_Link) is
 135       Caller : constant Task_Id := Entry_Call.Self;
 136
 137    begin
 138       Entry_Call.Exception_To_Raise := Program_Error'Identity;
 139       STPO.Write_Lock (Caller);
 140       Wakeup_Entry_Caller (Entry_Call);
 141       STPO.Unlock (Caller);
 142    end Send_Program_Error;
 143
 144    -------------------------
 145    -- Wait_For_Completion --
 146    -------------------------
 147
 148    procedure Wait_For_Completion (Entry_Call : Entry_Call_Link) is
 149       Self_Id : constant Task_Id := Entry_Call.Self;
 150    begin
 151       Self_Id.Common.State := Entry_Caller_Sleep;
 152       STPO.Sleep (Self_Id, Entry_Caller_Sleep);
 153       Self_Id.Common.State := Runnable;
 154    end Wait_For_Completion;
 155
 156    -------------------------
 157    -- Wakeup_Entry_Caller --
 158    -------------------------
 159
 160    --  This is called at the end of service of an entry call, to abort the
 161    --  caller if he is in an abortable part, and to wake up the caller if it
 162    --  is on Entry_Caller_Sleep. It assumes that the call is already off-queue.
 163
 164    --  (This enforces the rule that a task must be off-queue if its state is
 165    --  Done or Cancelled.) Call it holding the lock of Entry_Call.Self.
 166
 167    --  The caller is waiting on Entry_Caller_Sleep, in Wait_For_Completion.
 168
 169    procedure Wakeup_Entry_Caller
 170      (Entry_Call : Entry_Call_Link)
 171    is
 172       Caller : constant Task_Id := Entry_Call.Self;
 173    begin
 174       pragma Assert
 175         (Caller.Common.State /= Terminated and then
 176          Caller.Common.State /= Unactivated);
 177       Entry_Call.State := Done;
 178       STPO.Wakeup (Caller, Entry_Caller_Sleep);
 179    end Wakeup_Entry_Caller;
 180
 181    -----------------------
 182    -- Restricted GNARLI --
 183    -----------------------
 184
 185    --------------------------------------------
 186    -- Exceptional_Complete_Single_Entry_Body --
 187    --------------------------------------------
 188
 189    procedure Exceptional_Complete_Single_Entry_Body
 190      (Object : Protection_Entry_Access;
 191       Ex     : Ada.Exceptions.Exception_Id)
 192    is
 193    begin
 194       Object.Call_In_Progress.Exception_To_Raise := Ex;
 195    end Exceptional_Complete_Single_Entry_Body;
 196
 197    ---------------------------------
 198    -- Initialize_Protection_Entry --
 199    ---------------------------------
 200
 201    procedure Initialize_Protection_Entry
 202      (Object           : Protection_Entry_Access;
 203       Ceiling_Priority : Integer;
 204       Compiler_Info    : System.Address;
 205       Entry_Body       : Entry_Body_Access)
 206    is
 207    begin
 208       Initialize_Protection (Object.Common'Access, Ceiling_Priority);
 209
 210       Object.Compiler_Info := Compiler_Info;
 211       Object.Call_In_Progress := null;
 212       Object.Entry_Body := Entry_Body;
 213       Object.Entry_Queue := null;
 214    end Initialize_Protection_Entry;
 215
 216    ----------------
 217    -- Lock_Entry --
 218    ----------------
 219
 220    --  Compiler interface only
 221
 222    --  Do not call this procedure from within the run-time system.
 223
 224    procedure Lock_Entry (Object : Protection_Entry_Access) is
 225    begin
 226       Lock (Object.Common'Access);
 227    end Lock_Entry;
 228
 229    --------------------------
 230    -- Lock_Read_Only_Entry --
 231    --------------------------
 232
 233    --  Compiler interface only
 234
 235    --  Do not call this procedure from within the runtime system
 236
 237    procedure Lock_Read_Only_Entry (Object : Protection_Entry_Access) is
 238    begin
 239       Lock_Read_Only (Object.Common'Access);
 240    end Lock_Read_Only_Entry;
 241
 242    --------------------
 243    -- PO_Do_Or_Queue --
 244    --------------------
 245
 246    procedure PO_Do_Or_Queue
 247      (Object     : Protection_Entry_Access;
 248       Entry_Call : Entry_Call_Link)
 249    is
 250       Barrier_Value : Boolean;
 251
 252    begin
 253       --  When the Action procedure for an entry body returns, it must be
 254       --  completed (having called [Exceptional_]Complete_Entry_Body).
 255
 256       Barrier_Value := Object.Entry_Body.Barrier (Object.Compiler_Info, 1);
 257
 258       if Barrier_Value then
 259          if Object.Call_In_Progress /= null then
 260
 261             --  This violates the No_Entry_Queue restriction, send
 262             --  Program_Error to the caller.
 263
 264             Send_Program_Error (Entry_Call);
 265             return;
 266          end if;
 267
 268          Object.Call_In_Progress := Entry_Call;
 269          Object.Entry_Body.Action
 270            (Object.Compiler_Info, Entry_Call.Uninterpreted_Data, 1);
 271          Object.Call_In_Progress := null;
 272
 273          STPO.Write_Lock (Entry_Call.Self);
 274          Wakeup_Entry_Caller (Entry_Call);
 275          STPO.Unlock (Entry_Call.Self);
 276
 277       else
 278          pragma Assert (Entry_Call.Mode = Simple_Call);
 279
 280          if Object.Entry_Queue /= null then
 281
 282             --  This violates the No_Entry_Queue restriction, send
 283             --  Program_Error to the caller.
 284
 285             Send_Program_Error (Entry_Call);
 286             return;
 287          else
 288             Object.Entry_Queue := Entry_Call;
 289          end if;
 290
 291       end if;
 292
 293    exception
 294       when others =>
 295          Send_Program_Error (Entry_Call);
 296    end PO_Do_Or_Queue;
 297
 298    ---------------------------
 299    -- Protected_Count_Entry --
 300    ---------------------------
 301
 302    function Protected_Count_Entry (Object : Protection_Entry) return Natural is
 303    begin
 304       if Object.Entry_Queue /= null then
 305          return 1;
 306       else
 307          return 0;
 308       end if;
 309    end Protected_Count_Entry;
 310
 311    ---------------------------------
 312    -- Protected_Single_Entry_Call --
 313    ---------------------------------
 314
 315    procedure Protected_Single_Entry_Call
 316      (Object             : Protection_Entry_Access;
 317       Uninterpreted_Data : System.Address)
 318    is
 319       Self_Id    : constant Task_Id := STPO.Self;
 320       Entry_Call : Entry_Call_Record renames
 321         Self_Id.Entry_Calls (Self_Id.Entry_Calls'First);
 322    begin
 323       --  If pragma Detect_Blocking is active then Program_Error must be
 324       --  raised if this potentially blocking operation is called from a
 325       --  protected action.
 326
 327       if Detect_Blocking
 328         and then Self_Id.Common.Protected_Action_Nesting > 0
 329       then
 330          raise Program_Error with "potentially blocking operation";
 331       end if;
 332
 333       Lock_Entry (Object);
 334
 335       Entry_Call.Mode := Simple_Call;
 336       Entry_Call.State := Now_Abortable;
 337       Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
 338       Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
 339
 340       PO_Do_Or_Queue (Object, Entry_Call'Access);
 341       Unlock_Entry (Object);
 342
 343       --  The call is either `Done' or not. It cannot be cancelled since there
 344       --  is no ATC construct.
 345
 346       pragma Assert (Entry_Call.State /= Cancelled);
 347
 348       --  Note that we need to acquire Self_Id's lock before checking the value
 349       --  of Entry_Call.State, even though the latter is specified as atomic
 350       --  with a pragma. If we didn't, another task could execute the entry on
 351       --  our behalf right between the check of Entry_Call.State and the call
 352       --  to Wait_For_Completion, and that would cause a deadlock.
 353
 354       STPO.Write_Lock (Self_Id);
 355       if Entry_Call.State /= Done then
 356          Wait_For_Completion (Entry_Call'Access);
 357       end if;
 358       STPO.Unlock (Self_Id);
 359
 360       Check_Exception (Self_Id, Entry_Call'Access);
 361    end Protected_Single_Entry_Call;
 362
 363    -----------------------------------
 364    -- Protected_Single_Entry_Caller --
 365    -----------------------------------
 366
 367    function Protected_Single_Entry_Caller
 368      (Object : Protection_Entry) return Task_Id
 369    is
 370    begin
 371       return Object.Call_In_Progress.Self;
 372    end Protected_Single_Entry_Caller;
 373
 374    -------------------
 375    -- Service_Entry --
 376    -------------------
 377
 378    procedure Service_Entry (Object : Protection_Entry_Access) is
 379       Entry_Call : constant Entry_Call_Link := Object.Entry_Queue;
 380       Caller     : Task_Id;
 381
 382    begin
 383       if Entry_Call /= null
 384         and then Object.Entry_Body.Barrier (Object.Compiler_Info, 1)
 385       then
 386          Object.Entry_Queue := null;
 387
 388          if Object.Call_In_Progress /= null then
 389
 390             --  Violation of No_Entry_Queue restriction, raise exception
 391
 392             Send_Program_Error (Entry_Call);
 393             Unlock_Entry (Object);
 394             return;
 395          end if;
 396
 397          Object.Call_In_Progress := Entry_Call;
 398          Object.Entry_Body.Action
 399            (Object.Compiler_Info, Entry_Call.Uninterpreted_Data, 1);
 400          Object.Call_In_Progress := null;
 401          Caller := Entry_Call.Self;
 402          Unlock_Entry (Object);
 403
 404          STPO.Write_Lock (Caller);
 405          Wakeup_Entry_Caller (Entry_Call);
 406          STPO.Unlock (Caller);
 407
 408       else
 409          --  Just unlock the entry
 410
 411          Unlock_Entry (Object);
 412       end if;
 413
 414    exception
 415       when others =>
 416          Send_Program_Error (Entry_Call);
 417          Unlock_Entry (Object);
 418    end Service_Entry;
 419
 420    ------------------
 421    -- Unlock_Entry --
 422    ------------------
 423
 424    procedure Unlock_Entry (Object : Protection_Entry_Access) is
 425    begin
 426       Unlock (Object.Common'Access);
 427    end Unlock_Entry;
 428
 429 end System.Tasking.Protected_Objects.Single_Entry;