+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
projects / msp430-gcc.git / blobdiff