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