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