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