gcc/ada/s-tasque.adb

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