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