gcc/ada/libgnarl/s-tasque.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                  GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS                --
   4 --                                                                          --
   5 --                 S Y S T E M . T A S K I N G . Q U E U I N G              --
   6 --                                                                          --
   7 --                                  B o d y                                 --
   8 --                                                                          --
   9 --         Copyright (C) 1992-2024, 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 --  This version of the body implements queueing policy according to the policy
  33 --  specified by the pragma Queuing_Policy. When no such pragma is specified
  34 --  FIFO policy is used as default.
  35
  36 with System.Task_Primitives.Operations;
  37 with System.Tasking.Initialization;
  38
  39 package body System.Tasking.Queuing is
  40
  41    use Task_Primitives.Operations;
  42    use Protected_Objects;
  43    use Protected_Objects.Entries;
  44
  45    --  Entry Queues implemented as doubly linked list
  46
  47    Queuing_Policy : constant Character;
  48    pragma Import (C, Queuing_Policy, "__gl_queuing_policy");
  49
  50    Priority_Queuing : constant Boolean := Queuing_Policy = 'P';
  51
  52    procedure Send_Program_Error
  53      (Self_ID    : Task_Id;
  54       Entry_Call : Entry_Call_Link);
  55    --  Raise Program_Error in the caller of the specified entry call
  56
  57    function Check_Queue (E : Entry_Queue) return Boolean;
  58    --  Check the validity of E.
  59    --  Return True if E is valid, raise Assert_Failure if assertions are
  60    --  enabled and False otherwise.
  61
  62    -----------------------------
  63    -- Broadcast_Program_Error --
  64    -----------------------------
  65
  66    procedure Broadcast_Program_Error
  67      (Self_ID      : Task_Id;
  68       Object       : Protection_Entries_Access;
  69       Pending_Call : Entry_Call_Link)
  70    is
  71       Entry_Call : Entry_Call_Link;
  72    begin
  73       if Pending_Call /= null then
  74          Send_Program_Error (Self_ID, Pending_Call);
  75       end if;
  76
  77       for E in Object.Entry_Queues'Range loop
  78          Dequeue_Head (Object.Entry_Queues (E), Entry_Call);
  79
  80          while Entry_Call /= null loop
  81             pragma Assert (Entry_Call.Mode /= Conditional_Call);
  82
  83             Send_Program_Error (Self_ID, Entry_Call);
  84             Dequeue_Head (Object.Entry_Queues (E), Entry_Call);
  85          end loop;
  86       end loop;
  87    end Broadcast_Program_Error;
  88
  89    -----------------
  90    -- Check_Queue --
  91    -----------------
  92
  93    function Check_Queue (E : Entry_Queue) return Boolean is
  94       Valid   : Boolean := True;
  95       C, Prev : Entry_Call_Link;
  96
  97    begin
  98       if E.Head = null then
  99          if E.Tail /= null then
 100             Valid := False;
 101             pragma Assert (Valid);
 102          end if;
 103       else
 104          if E.Tail = null
 105            or else E.Tail.Next /= E.Head
 106          then
 107             Valid := False;
 108             pragma Assert (Valid);
 109
 110          else
 111             C := E.Head;
 112
 113             loop
 114                Prev := C;
 115                C := C.Next;
 116
 117                if C = null then
 118                   Valid := False;
 119                   pragma Assert (Valid);
 120                   exit;
 121                end if;
 122
 123                if Prev /= C.Prev then
 124                   Valid := False;
 125                   pragma Assert (Valid);
 126                   exit;
 127                end if;
 128
 129                exit when C = E.Head;
 130             end loop;
 131
 132             if Prev /= E.Tail then
 133                Valid := False;
 134                pragma Assert (Valid);
 135             end if;
 136          end if;
 137       end if;
 138
 139       return Valid;
 140    end Check_Queue;
 141
 142    -------------------
 143    -- Count_Waiting --
 144    -------------------
 145
 146    --  Return number of calls on the waiting queue of E
 147
 148    function Count_Waiting (E : Entry_Queue) return Natural is
 149       Count   : Natural;
 150       Temp    : Entry_Call_Link;
 151
 152    begin
 153       pragma Assert (Check_Queue (E));
 154
 155       Count := 0;
 156
 157       if E.Head /= null then
 158          Temp := E.Head;
 159
 160          loop
 161             Count := Count + 1;
 162             exit when E.Tail = Temp;
 163             Temp := Temp.Next;
 164          end loop;
 165       end if;
 166
 167       return Count;
 168    end Count_Waiting;
 169
 170    -------------
 171    -- Dequeue --
 172    -------------
 173
 174    --  Dequeue call from entry_queue E
 175
 176    procedure Dequeue (E : in out Entry_Queue; Call : Entry_Call_Link) is
 177    begin
 178       pragma Assert (Check_Queue (E));
 179       pragma Assert (Call /= null);
 180
 181       --  If empty queue, simply return
 182
 183       if E.Head = null then
 184          return;
 185       end if;
 186
 187       pragma Assert (Call.Prev /= null);
 188       pragma Assert (Call.Next /= null);
 189
 190       Call.Prev.Next := Call.Next;
 191       Call.Next.Prev := Call.Prev;
 192
 193       if E.Head = Call then
 194
 195          --  Case of one element
 196
 197          if E.Tail = Call then
 198             E.Head := null;
 199             E.Tail := null;
 200
 201          --  More than one element
 202
 203          else
 204             E.Head := Call.Next;
 205          end if;
 206
 207       elsif E.Tail = Call then
 208          E.Tail := Call.Prev;
 209       end if;
 210
 211       --  Successfully dequeued
 212
 213       Call.Prev := null;
 214       Call.Next := null;
 215       pragma Assert (Check_Queue (E));
 216    end Dequeue;
 217
 218    ------------------
 219    -- Dequeue_Call --
 220    ------------------
 221
 222    procedure Dequeue_Call (Entry_Call : Entry_Call_Link) is
 223       Called_PO : Protection_Entries_Access;
 224
 225    begin
 226       pragma Assert (Entry_Call /= null);
 227
 228       if Entry_Call.Called_Task /= null then
 229          Dequeue
 230            (Entry_Call.Called_Task.Entry_Queues
 231              (Task_Entry_Index (Entry_Call.E)),
 232            Entry_Call);
 233
 234       else
 235          Called_PO := To_Protection (Entry_Call.Called_PO);
 236          Dequeue (Called_PO.Entry_Queues
 237              (Protected_Entry_Index (Entry_Call.E)),
 238            Entry_Call);
 239       end if;
 240    end Dequeue_Call;
 241
 242    ------------------
 243    -- Dequeue_Head --
 244    ------------------
 245
 246    --  Remove and return the head of entry_queue E
 247
 248    procedure Dequeue_Head
 249      (E    : in out Entry_Queue;
 250       Call : out Entry_Call_Link)
 251    is
 252       Temp : Entry_Call_Link;
 253
 254    begin
 255       pragma Assert (Check_Queue (E));
 256       --  If empty queue, return null pointer
 257
 258       if E.Head = null then
 259          Call := null;
 260          return;
 261       end if;
 262
 263       Temp := E.Head;
 264
 265       --  Case of one element
 266
 267       if E.Head = E.Tail then
 268          E.Head := null;
 269          E.Tail := null;
 270
 271       --  More than one element
 272
 273       else
 274          pragma Assert (Temp /= null);
 275          pragma Assert (Temp.Next /= null);
 276          pragma Assert (Temp.Prev /= null);
 277
 278          E.Head := Temp.Next;
 279          Temp.Prev.Next := Temp.Next;
 280          Temp.Next.Prev := Temp.Prev;
 281       end if;
 282
 283       --  Successfully dequeued
 284
 285       Temp.Prev := null;
 286       Temp.Next := null;
 287       Call := Temp;
 288       pragma Assert (Check_Queue (E));
 289    end Dequeue_Head;
 290
 291    -------------
 292    -- Enqueue --
 293    -------------
 294
 295    --  Enqueue call at the end of entry_queue E, for FIFO queuing policy.
 296    --  Enqueue call priority ordered, FIFO at same priority level, for
 297    --  Priority queuing policy.
 298
 299    procedure Enqueue (E : in out Entry_Queue; Call : Entry_Call_Link) is
 300       Temp : Entry_Call_Link := E.Head;
 301
 302    begin
 303       pragma Assert (Check_Queue (E));
 304       pragma Assert (Call /= null);
 305
 306       --  Priority Queuing
 307
 308       if Priority_Queuing then
 309          if Temp = null then
 310             Call.Prev := Call;
 311             Call.Next := Call;
 312             E.Head := Call;
 313             E.Tail := Call;
 314
 315          else
 316             loop
 317                --  Find the entry that the new guy should precede
 318
 319                exit when Call.Prio > Temp.Prio;
 320                Temp := Temp.Next;
 321
 322                if Temp = E.Head then
 323                   Temp := null;
 324                   exit;
 325                end if;
 326             end loop;
 327
 328             if Temp = null then
 329                --  Insert at tail
 330
 331                Call.Prev := E.Tail;
 332                Call.Next := E.Head;
 333                E.Tail := Call;
 334
 335             else
 336                Call.Prev := Temp.Prev;
 337                Call.Next := Temp;
 338
 339                --  Insert at head
 340
 341                if Temp = E.Head then
 342                   E.Head := Call;
 343                end if;
 344             end if;
 345
 346             pragma Assert (Call.Prev /= null);
 347             pragma Assert (Call.Next /= null);
 348
 349             Call.Prev.Next := Call;
 350             Call.Next.Prev := Call;
 351          end if;
 352
 353          pragma Assert (Check_Queue (E));
 354          return;
 355       end if;
 356
 357       --  FIFO Queuing
 358
 359       if E.Head = null then
 360          E.Head := Call;
 361       else
 362          E.Tail.Next := Call;
 363          Call.Prev   := E.Tail;
 364       end if;
 365
 366       E.Head.Prev := Call;
 367       E.Tail      := Call;
 368       Call.Next   := E.Head;
 369       pragma Assert (Check_Queue (E));
 370    end Enqueue;
 371
 372    ------------------
 373    -- Enqueue_Call --
 374    ------------------
 375
 376    procedure Enqueue_Call (Entry_Call : Entry_Call_Link) is
 377       Called_PO : Protection_Entries_Access;
 378
 379    begin
 380       pragma Assert (Entry_Call /= null);
 381
 382       if Entry_Call.Called_Task /= null then
 383          Enqueue
 384            (Entry_Call.Called_Task.Entry_Queues
 385               (Task_Entry_Index (Entry_Call.E)),
 386            Entry_Call);
 387
 388       else
 389          Called_PO := To_Protection (Entry_Call.Called_PO);
 390          Enqueue (Called_PO.Entry_Queues
 391              (Protected_Entry_Index (Entry_Call.E)),
 392            Entry_Call);
 393       end if;
 394    end Enqueue_Call;
 395
 396    ----------
 397    -- Head --
 398    ----------
 399
 400    --  Return the head of entry_queue E
 401
 402    function Head (E : Entry_Queue) return Entry_Call_Link is
 403    begin
 404       pragma Assert (Check_Queue (E));
 405       return E.Head;
 406    end Head;
 407
 408    -------------
 409    -- Onqueue --
 410    -------------
 411
 412    --  Return True if Call is on any entry_queue at all
 413
 414    function Onqueue (Call : Entry_Call_Link) return Boolean is
 415    begin
 416       pragma Assert (Call /= null);
 417
 418       --  Utilize the fact that every queue is circular, so if Call
 419       --  is on any queue at all, Call.Next must NOT be null.
 420
 421       return Call.Next /= null;
 422    end Onqueue;
 423
 424    --------------------------------
 425    -- Requeue_Call_With_New_Prio --
 426    --------------------------------
 427
 428    procedure Requeue_Call_With_New_Prio
 429      (Entry_Call : Entry_Call_Link; Prio : System.Any_Priority) is
 430    begin
 431       pragma Assert (Entry_Call /= null);
 432
 433       --  Perform a queue reordering only when the policy being used is the
 434       --  Priority Queuing.
 435
 436       if Priority_Queuing then
 437          if Onqueue (Entry_Call) then
 438             Dequeue_Call (Entry_Call);
 439             Entry_Call.Prio := Prio;
 440             Enqueue_Call (Entry_Call);
 441          end if;
 442       end if;
 443    end Requeue_Call_With_New_Prio;
 444
 445    ---------------------------------
 446    -- Select_Protected_Entry_Call --
 447    ---------------------------------
 448
 449    --  Select an entry of a protected object. Selection depends on the
 450    --  queuing policy being used.
 451
 452    procedure Select_Protected_Entry_Call
 453      (Self_ID : Task_Id;
 454       Object  : Protection_Entries_Access;
 455       Call    : out Entry_Call_Link)
 456    is
 457       Entry_Call  : Entry_Call_Link;
 458       Temp_Call   : Entry_Call_Link;
 459       Entry_Index : Protected_Entry_Index := Null_Entry; -- stop warning
 460
 461    begin
 462       Entry_Call := null;
 463
 464       begin
 465          --  Priority queuing case
 466
 467          if Priority_Queuing then
 468             for J in Object.Entry_Queues'Range loop
 469                Temp_Call := Head (Object.Entry_Queues (J));
 470
 471                if Temp_Call /= null
 472                  and then
 473                    Object.Entry_Bodies
 474                      (Object.Find_Body_Index
 475                        (Object.Compiler_Info, J)).
 476                           Barrier (Object.Compiler_Info, J)
 477                then
 478                   if Entry_Call = null
 479                     or else Entry_Call.Prio < Temp_Call.Prio
 480                   then
 481                      Entry_Call := Temp_Call;
 482                      Entry_Index := J;
 483                   end if;
 484                end if;
 485             end loop;
 486
 487          --  FIFO queueing case
 488
 489          else
 490             for J in Object.Entry_Queues'Range loop
 491                Temp_Call := Head (Object.Entry_Queues (J));
 492
 493                if Temp_Call /= null
 494                  and then
 495                    Object.Entry_Bodies
 496                      (Object.Find_Body_Index
 497                        (Object.Compiler_Info, J)).
 498                           Barrier (Object.Compiler_Info, J)
 499                then
 500                   Entry_Call := Temp_Call;
 501                   Entry_Index := J;
 502                   exit;
 503                end if;
 504             end loop;
 505          end if;
 506
 507       exception
 508          when others =>
 509             Broadcast_Program_Error (Self_ID, Object, null);
 510       end;
 511
 512       --  If a call was selected, dequeue it and return it for service
 513
 514       if Entry_Call /= null then
 515          Temp_Call := Entry_Call;
 516          Dequeue_Head (Object.Entry_Queues (Entry_Index), Entry_Call);
 517          pragma Assert (Temp_Call = Entry_Call);
 518       end if;
 519
 520       Call := Entry_Call;
 521    end Select_Protected_Entry_Call;
 522
 523    ----------------------------
 524    -- Select_Task_Entry_Call --
 525    ----------------------------
 526
 527    --  Select an entry for rendezvous. Selection depends on the queuing policy
 528    --  being used.
 529
 530    procedure Select_Task_Entry_Call
 531      (Acceptor         : Task_Id;
 532       Open_Accepts     : Accept_List_Access;
 533       Call             : out Entry_Call_Link;
 534       Selection        : out Select_Index;
 535       Open_Alternative : out Boolean)
 536    is
 537       Entry_Call  : Entry_Call_Link;
 538       Temp_Call   : Entry_Call_Link;
 539       Entry_Index : Task_Entry_Index := Task_Entry_Index'First;
 540       Temp_Entry  : Task_Entry_Index;
 541
 542    begin
 543       Open_Alternative := False;
 544       Entry_Call       := null;
 545       Selection        := No_Rendezvous;
 546
 547       if Priority_Queuing then
 548          --  Priority queueing case
 549
 550          for J in Open_Accepts'Range loop
 551             Temp_Entry := Open_Accepts (J).S;
 552
 553             if Temp_Entry /= Null_Task_Entry then
 554                Open_Alternative := True;
 555                Temp_Call := Head (Acceptor.Entry_Queues (Temp_Entry));
 556
 557                if Temp_Call /= null
 558                  and then (Entry_Call = null
 559                    or else Entry_Call.Prio < Temp_Call.Prio)
 560                then
 561                   Entry_Call  := Head (Acceptor.Entry_Queues (Temp_Entry));
 562                   Entry_Index := Temp_Entry;
 563                   Selection := J;
 564                end if;
 565             end if;
 566          end loop;
 567
 568       else
 569          --  FIFO Queuing case
 570
 571          for J in Open_Accepts'Range loop
 572             Temp_Entry := Open_Accepts (J).S;
 573
 574             if Temp_Entry /= Null_Task_Entry then
 575                Open_Alternative := True;
 576                Temp_Call := Head (Acceptor.Entry_Queues (Temp_Entry));
 577
 578                if Temp_Call /= null then
 579                   Entry_Call := Head (Acceptor.Entry_Queues (Temp_Entry));
 580                   Entry_Index := Temp_Entry;
 581                   Selection := J;
 582                   exit;
 583                end if;
 584             end if;
 585          end loop;
 586       end if;
 587
 588       if Entry_Call /= null then
 589          Dequeue_Head (Acceptor.Entry_Queues (Entry_Index), Entry_Call);
 590
 591          --  Guard is open
 592       end if;
 593
 594       Call := Entry_Call;
 595    end Select_Task_Entry_Call;
 596
 597    ------------------------
 598    -- Send_Program_Error --
 599    ------------------------
 600
 601    procedure Send_Program_Error
 602      (Self_ID    : Task_Id;
 603       Entry_Call : Entry_Call_Link)
 604    is
 605       Caller : Task_Id;
 606    begin
 607       Caller := Entry_Call.Self;
 608       Entry_Call.Exception_To_Raise := Program_Error'Identity;
 609       Write_Lock (Caller);
 610       Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
 611       Unlock (Caller);
 612    end Send_Program_Error;
 613
 614 end System.Tasking.Queuing;