diff options
Diffstat (limited to 'gcc-4.4.0/gcc/ada/s-tasque.adb')
| -rw-r--r-- | gcc-4.4.0/gcc/ada/s-tasque.adb | 625 |
1 files changed, 625 insertions, 0 deletions
diff --git a/gcc-4.4.0/gcc/ada/s-tasque.adb b/gcc-4.4.0/gcc/ada/s-tasque.adb new file mode 100644 index 000000000..5116c88c0 --- /dev/null +++ b/gcc-4.4.0/gcc/ada/s-tasque.adb @@ -0,0 +1,625 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . Q U E U I N G -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This version of the body implements queueing policy according to the policy +-- specified by the pragma Queuing_Policy. When no such pragma is specified +-- FIFO policy is used as default. + +with System.Task_Primitives.Operations; +with System.Tasking.Initialization; +with System.Parameters; + +package body System.Tasking.Queuing is + + use Parameters; + use Task_Primitives.Operations; + use Protected_Objects; + use Protected_Objects.Entries; + + -- Entry Queues implemented as doubly linked list + + Queuing_Policy : Character; + pragma Import (C, Queuing_Policy, "__gl_queuing_policy"); + + Priority_Queuing : constant Boolean := Queuing_Policy = 'P'; + + procedure Send_Program_Error + (Self_ID : Task_Id; + Entry_Call : Entry_Call_Link); + -- Raise Program_Error in the caller of the specified entry call + + function Check_Queue (E : Entry_Queue) return Boolean; + -- Check the validity of E. + -- Return True if E is valid, raise Assert_Failure if assertions are + -- enabled and False otherwise. + + ----------------------------- + -- Broadcast_Program_Error -- + ----------------------------- + + procedure Broadcast_Program_Error + (Self_ID : Task_Id; + Object : Protection_Entries_Access; + Pending_Call : Entry_Call_Link; + RTS_Locked : Boolean := False) + is + Entry_Call : Entry_Call_Link; + begin + if Single_Lock and then not RTS_Locked then + Lock_RTS; + end if; + + if Pending_Call /= null then + Send_Program_Error (Self_ID, Pending_Call); + end if; + + for E in Object.Entry_Queues'Range loop + Dequeue_Head (Object.Entry_Queues (E), Entry_Call); + + while Entry_Call /= null loop + pragma Assert (Entry_Call.Mode /= Conditional_Call); + + Send_Program_Error (Self_ID, Entry_Call); + Dequeue_Head (Object.Entry_Queues (E), Entry_Call); + end loop; + end loop; + + if Single_Lock and then not RTS_Locked then + Unlock_RTS; + end if; + end Broadcast_Program_Error; + + ----------------- + -- Check_Queue -- + ----------------- + + function Check_Queue (E : Entry_Queue) return Boolean is + Valid : Boolean := True; + C, Prev : Entry_Call_Link; + + begin + if E.Head = null then + if E.Tail /= null then + Valid := False; + pragma Assert (Valid); + end if; + else + if E.Tail = null + or else E.Tail.Next /= E.Head + then + Valid := False; + pragma Assert (Valid); + + else + C := E.Head; + + loop + Prev := C; + C := C.Next; + + if C = null then + Valid := False; + pragma Assert (Valid); + exit; + end if; + + if Prev /= C.Prev then + Valid := False; + pragma Assert (Valid); + exit; + end if; + + exit when C = E.Head; + end loop; + + if Prev /= E.Tail then + Valid := False; + pragma Assert (Valid); + end if; + end if; + end if; + + return Valid; + end Check_Queue; + + ------------------- + -- Count_Waiting -- + ------------------- + + -- Return number of calls on the waiting queue of E + + function Count_Waiting (E : Entry_Queue) return Natural is + Count : Natural; + Temp : Entry_Call_Link; + + begin + pragma Assert (Check_Queue (E)); + + Count := 0; + + if E.Head /= null then + Temp := E.Head; + + loop + Count := Count + 1; + exit when E.Tail = Temp; + Temp := Temp.Next; + end loop; + end if; + + return Count; + end Count_Waiting; + + ------------- + -- Dequeue -- + ------------- + + -- Dequeue call from entry_queue E + + procedure Dequeue (E : in out Entry_Queue; Call : Entry_Call_Link) is + begin + pragma Assert (Check_Queue (E)); + pragma Assert (Call /= null); + + -- If empty queue, simply return + + if E.Head = null then + return; + end if; + + pragma Assert (Call.Prev /= null); + pragma Assert (Call.Next /= null); + + Call.Prev.Next := Call.Next; + Call.Next.Prev := Call.Prev; + + if E.Head = Call then + + -- Case of one element + + if E.Tail = Call then + E.Head := null; + E.Tail := null; + + -- More than one element + + else + E.Head := Call.Next; + end if; + + elsif E.Tail = Call then + E.Tail := Call.Prev; + end if; + + -- Successfully dequeued + + Call.Prev := null; + Call.Next := null; + pragma Assert (Check_Queue (E)); + end Dequeue; + + ------------------ + -- Dequeue_Call -- + ------------------ + + procedure Dequeue_Call (Entry_Call : Entry_Call_Link) is + Called_PO : Protection_Entries_Access; + + begin + pragma Assert (Entry_Call /= null); + + if Entry_Call.Called_Task /= null then + Dequeue + (Entry_Call.Called_Task.Entry_Queues + (Task_Entry_Index (Entry_Call.E)), + Entry_Call); + + else + Called_PO := To_Protection (Entry_Call.Called_PO); + Dequeue (Called_PO.Entry_Queues + (Protected_Entry_Index (Entry_Call.E)), + Entry_Call); + end if; + end Dequeue_Call; + + ------------------ + -- Dequeue_Head -- + ------------------ + + -- Remove and return the head of entry_queue E + + procedure Dequeue_Head + (E : in out Entry_Queue; + Call : out Entry_Call_Link) + is + Temp : Entry_Call_Link; + + begin + pragma Assert (Check_Queue (E)); + -- If empty queue, return null pointer + + if E.Head = null then + Call := null; + return; + end if; + + Temp := E.Head; + + -- Case of one element + + if E.Head = E.Tail then + E.Head := null; + E.Tail := null; + + -- More than one element + + else + pragma Assert (Temp /= null); + pragma Assert (Temp.Next /= null); + pragma Assert (Temp.Prev /= null); + + E.Head := Temp.Next; + Temp.Prev.Next := Temp.Next; + Temp.Next.Prev := Temp.Prev; + end if; + + -- Successfully dequeued + + Temp.Prev := null; + Temp.Next := null; + Call := Temp; + pragma Assert (Check_Queue (E)); + end Dequeue_Head; + + ------------- + -- Enqueue -- + ------------- + + -- Enqueue call at the end of entry_queue E, for FIFO queuing policy. + -- Enqueue call priority ordered, FIFO at same priority level, for + -- Priority queuing policy. + + procedure Enqueue (E : in out Entry_Queue; Call : Entry_Call_Link) is + Temp : Entry_Call_Link := E.Head; + + begin + pragma Assert (Check_Queue (E)); + pragma Assert (Call /= null); + + -- Priority Queuing + + if Priority_Queuing then + if Temp = null then + Call.Prev := Call; + Call.Next := Call; + E.Head := Call; + E.Tail := Call; + + else + loop + -- Find the entry that the new guy should precede + + exit when Call.Prio > Temp.Prio; + Temp := Temp.Next; + + if Temp = E.Head then + Temp := null; + exit; + end if; + end loop; + + if Temp = null then + -- Insert at tail + + Call.Prev := E.Tail; + Call.Next := E.Head; + E.Tail := Call; + + else + Call.Prev := Temp.Prev; + Call.Next := Temp; + + -- Insert at head + + if Temp = E.Head then + E.Head := Call; + end if; + end if; + + pragma Assert (Call.Prev /= null); + pragma Assert (Call.Next /= null); + + Call.Prev.Next := Call; + Call.Next.Prev := Call; + end if; + + pragma Assert (Check_Queue (E)); + return; + end if; + + -- FIFO Queuing + + if E.Head = null then + E.Head := Call; + else + E.Tail.Next := Call; + Call.Prev := E.Tail; + end if; + + E.Head.Prev := Call; + E.Tail := Call; + Call.Next := E.Head; + pragma Assert (Check_Queue (E)); + end Enqueue; + + ------------------ + -- Enqueue_Call -- + ------------------ + + procedure Enqueue_Call (Entry_Call : Entry_Call_Link) is + Called_PO : Protection_Entries_Access; + + begin + pragma Assert (Entry_Call /= null); + + if Entry_Call.Called_Task /= null then + Enqueue + (Entry_Call.Called_Task.Entry_Queues + (Task_Entry_Index (Entry_Call.E)), + Entry_Call); + + else + Called_PO := To_Protection (Entry_Call.Called_PO); + Enqueue (Called_PO.Entry_Queues + (Protected_Entry_Index (Entry_Call.E)), + Entry_Call); + end if; + end Enqueue_Call; + + ---------- + -- Head -- + ---------- + + -- Return the head of entry_queue E + + function Head (E : Entry_Queue) return Entry_Call_Link is + begin + pragma Assert (Check_Queue (E)); + return E.Head; + end Head; + + ------------- + -- Onqueue -- + ------------- + + -- Return True if Call is on any entry_queue at all + + function Onqueue (Call : Entry_Call_Link) return Boolean is + begin + pragma Assert (Call /= null); + + -- Utilize the fact that every queue is circular, so if Call + -- is on any queue at all, Call.Next must NOT be null. + + return Call.Next /= null; + end Onqueue; + + -------------------------------- + -- Requeue_Call_With_New_Prio -- + -------------------------------- + + procedure Requeue_Call_With_New_Prio + (Entry_Call : Entry_Call_Link; Prio : System.Any_Priority) is + begin + pragma Assert (Entry_Call /= null); + + -- Perform a queue reordering only when the policy being used is the + -- Priority Queuing. + + if Priority_Queuing then + if Onqueue (Entry_Call) then + Dequeue_Call (Entry_Call); + Entry_Call.Prio := Prio; + Enqueue_Call (Entry_Call); + end if; + end if; + end Requeue_Call_With_New_Prio; + + --------------------------------- + -- Select_Protected_Entry_Call -- + --------------------------------- + + -- Select an entry of a protected object. Selection depends on the + -- queuing policy being used. + + procedure Select_Protected_Entry_Call + (Self_ID : Task_Id; + Object : Protection_Entries_Access; + Call : out Entry_Call_Link) + is + Entry_Call : Entry_Call_Link; + Temp_Call : Entry_Call_Link; + Entry_Index : Protected_Entry_Index := Null_Entry; -- stop warning + + begin + Entry_Call := null; + + begin + -- Priority queuing case + + if Priority_Queuing then + for J in Object.Entry_Queues'Range loop + Temp_Call := Head (Object.Entry_Queues (J)); + + if Temp_Call /= null + and then + Object.Entry_Bodies + (Object.Find_Body_Index + (Object.Compiler_Info, J)). + Barrier (Object.Compiler_Info, J) + then + if Entry_Call = null + or else Entry_Call.Prio < Temp_Call.Prio + then + Entry_Call := Temp_Call; + Entry_Index := J; + end if; + end if; + end loop; + + -- FIFO queueing case + + else + for J in Object.Entry_Queues'Range loop + Temp_Call := Head (Object.Entry_Queues (J)); + + if Temp_Call /= null + and then + Object.Entry_Bodies + (Object.Find_Body_Index + (Object.Compiler_Info, J)). + Barrier (Object.Compiler_Info, J) + then + Entry_Call := Temp_Call; + Entry_Index := J; + exit; + end if; + end loop; + end if; + + exception + when others => + Broadcast_Program_Error (Self_ID, Object, null); + end; + + -- If a call was selected, dequeue it and return it for service + + if Entry_Call /= null then + Temp_Call := Entry_Call; + Dequeue_Head (Object.Entry_Queues (Entry_Index), Entry_Call); + pragma Assert (Temp_Call = Entry_Call); + end if; + + Call := Entry_Call; + end Select_Protected_Entry_Call; + + ---------------------------- + -- Select_Task_Entry_Call -- + ---------------------------- + + -- Select an entry for rendezvous. Selection depends on the queuing policy + -- being used. + + procedure Select_Task_Entry_Call + (Acceptor : Task_Id; + Open_Accepts : Accept_List_Access; + Call : out Entry_Call_Link; + Selection : out Select_Index; + Open_Alternative : out Boolean) + is + Entry_Call : Entry_Call_Link; + Temp_Call : Entry_Call_Link; + Entry_Index : Task_Entry_Index := Task_Entry_Index'First; + Temp_Entry : Task_Entry_Index; + + begin + Open_Alternative := False; + Entry_Call := null; + Selection := No_Rendezvous; + + if Priority_Queuing then + -- Priority queueing case + + for J in Open_Accepts'Range loop + Temp_Entry := Open_Accepts (J).S; + + if Temp_Entry /= Null_Task_Entry then + Open_Alternative := True; + Temp_Call := Head (Acceptor.Entry_Queues (Temp_Entry)); + + if Temp_Call /= null + and then (Entry_Call = null + or else Entry_Call.Prio < Temp_Call.Prio) + then + Entry_Call := Head (Acceptor.Entry_Queues (Temp_Entry)); + Entry_Index := Temp_Entry; + Selection := J; + end if; + end if; + end loop; + + else + -- FIFO Queuing case + + for J in Open_Accepts'Range loop + Temp_Entry := Open_Accepts (J).S; + + if Temp_Entry /= Null_Task_Entry then + Open_Alternative := True; + Temp_Call := Head (Acceptor.Entry_Queues (Temp_Entry)); + + if Temp_Call /= null then + Entry_Call := Head (Acceptor.Entry_Queues (Temp_Entry)); + Entry_Index := Temp_Entry; + Selection := J; + exit; + end if; + end if; + end loop; + end if; + + if Entry_Call /= null then + Dequeue_Head (Acceptor.Entry_Queues (Entry_Index), Entry_Call); + + -- Guard is open + end if; + + Call := Entry_Call; + end Select_Task_Entry_Call; + + ------------------------ + -- Send_Program_Error -- + ------------------------ + + procedure Send_Program_Error + (Self_ID : Task_Id; + Entry_Call : Entry_Call_Link) + is + Caller : Task_Id; + begin + Caller := Entry_Call.Self; + Entry_Call.Exception_To_Raise := Program_Error'Identity; + Write_Lock (Caller); + Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done); + Unlock (Caller); + end Send_Program_Error; + +end System.Tasking.Queuing; |