diff options
Diffstat (limited to 'gcc-4.4.3/gcc/ada/s-tasque.adb')
| -rw-r--r-- | gcc-4.4.3/gcc/ada/s-tasque.adb | 625 |
1 files changed, 0 insertions, 625 deletions
diff --git a/gcc-4.4.3/gcc/ada/s-tasque.adb b/gcc-4.4.3/gcc/ada/s-tasque.adb deleted file mode 100644 index 5116c88c0..000000000 --- a/gcc-4.4.3/gcc/ada/s-tasque.adb +++ /dev/null @@ -1,625 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; |