X-Git-Url: https://oss.titaniummirror.com/gitweb?a=blobdiff_plain;f=gcc%2Fada%2Fs-tasque.adb;fp=gcc%2Fada%2Fs-tasque.adb;h=0000000000000000000000000000000000000000;hb=6fed43773c9b0ce596dca5686f37ac3fc0fa11c0;hp=787493e3d20a22d954e6713555c87ee61be468f7;hpb=27b11d56b743098deb193d510b337ba22dc52e5c;p=msp430-gcc.git diff --git a/gcc/ada/s-tasque.adb b/gcc/ada/s-tasque.adb deleted file mode 100644 index 787493e3..00000000 --- a/gcc/ada/s-tasque.adb +++ /dev/null @@ -1,632 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNU ADA 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 -- --- -- --- $Revision: 1.1 $ --- -- --- Copyright (C) 1991-2001, Florida State University -- --- -- --- 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 2, or (at your option) any later ver- -- --- sion. GNARL 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. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNARL; see file COPYING. If not, write -- --- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- --- MA 02111-1307, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU General Public License. This exception does not -- --- however invalidate any other reasons why the executable file might be -- --- covered by the GNU Public License. -- --- -- --- GNARL was developed by the GNARL team at Florida State University. It is -- --- now maintained by Ada Core Technologies Inc. in cooperation with Florida -- --- State University (http://www.gnat.com). -- --- -- ------------------------------------------------------------------------------- - --- 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; --- used for Write_Lock --- Unlock - -with System.Tasking.Initialization; --- used for Wakeup_Entry_Caller - -package body System.Tasking.Queuing is - - use System.Task_Primitives.Operations; - use System.Tasking.Protected_Objects; - use System.Tasking.Protected_Objects.Entries; - - procedure Wakeup_Entry_Caller - (Self_ID : Task_ID; - Entry_Call : Entry_Call_Link; - New_State : Entry_Call_State) - renames Initialization.Wakeup_Entry_Caller; - - -- 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) - is - Entry_Call : Entry_Call_Link; - - begin - 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; - 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 : in 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 : in 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; - - begin - Entry_Call := null; - - begin - if Priority_Queuing then - - -- Priority queuing - - 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; - - else - -- FIFO queuing - - 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; - Temp_Entry : Task_Entry_Index; - - begin - Open_Alternative := False; - Entry_Call := null; - - if Priority_Queuing then - - -- Priority Queuing - - 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 - - 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 - Selection := No_Rendezvous; - - else - 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); - Wakeup_Entry_Caller (Self_ID, Entry_Call, Done); - Unlock (Caller); - end Send_Program_Error; - -end System.Tasking.Queuing;