aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.4.0/gcc/ada/s-taasde.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.4.0/gcc/ada/s-taasde.adb')
-rw-r--r--gcc-4.4.0/gcc/ada/s-taasde.adb412
1 files changed, 0 insertions, 412 deletions
diff --git a/gcc-4.4.0/gcc/ada/s-taasde.adb b/gcc-4.4.0/gcc/ada/s-taasde.adb
deleted file mode 100644
index 315d9ba13..000000000
--- a/gcc-4.4.0/gcc/ada/s-taasde.adb
+++ /dev/null
@@ -1,412 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . T A S K I N G . A S Y N C _ D E L A Y S --
--- --
--- B o d y --
--- --
--- Copyright (C) 1998-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. --
--- --
-------------------------------------------------------------------------------
-
-pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during
--- tasking operations. It causes infinite loops and other problems.
-
-with Ada.Unchecked_Conversion;
-with Ada.Task_Identification;
-
-with System.Task_Primitives.Operations;
-with System.Tasking.Utilities;
-with System.Tasking.Initialization;
-with System.Tasking.Debug;
-with System.OS_Primitives;
-with System.Interrupt_Management.Operations;
-with System.Parameters;
-with System.Traces.Tasking;
-
-package body System.Tasking.Async_Delays is
-
- package STPO renames System.Task_Primitives.Operations;
- package ST renames System.Tasking;
- package STU renames System.Tasking.Utilities;
- package STI renames System.Tasking.Initialization;
- package OSP renames System.OS_Primitives;
-
- use Parameters;
- use System.Traces;
- use System.Traces.Tasking;
-
- function To_System is new Ada.Unchecked_Conversion
- (Ada.Task_Identification.Task_Id, Task_Id);
-
- Timer_Server_ID : ST.Task_Id;
-
- Timer_Attention : Boolean := False;
- pragma Atomic (Timer_Attention);
-
- task Timer_Server is
- pragma Interrupt_Priority (System.Any_Priority'Last);
- end Timer_Server;
-
- -- The timer queue is a circular doubly linked list, ordered by absolute
- -- wakeup time. The first item in the queue is Timer_Queue.Succ.
- -- It is given a Resume_Time that is larger than any legitimate wakeup
- -- time, so that the ordered insertion will always stop searching when it
- -- gets back to the queue header block.
-
- Timer_Queue : aliased Delay_Block;
-
- ------------------------
- -- Cancel_Async_Delay --
- ------------------------
-
- -- This should (only) be called from the compiler-generated cleanup routine
- -- for an async. select statement with delay statement as trigger. The
- -- effect should be to remove the delay from the timer queue, and exit one
- -- ATC nesting level.
- -- The usage and logic are similar to Cancel_Protected_Entry_Call, but
- -- simplified because this is not a true entry call.
-
- procedure Cancel_Async_Delay (D : Delay_Block_Access) is
- Dpred : Delay_Block_Access;
- Dsucc : Delay_Block_Access;
-
- begin
- -- Note that we mark the delay as being cancelled
- -- using a level value that is reserved.
-
- -- make this operation idempotent
-
- if D.Level = ATC_Level_Infinity then
- return;
- end if;
-
- D.Level := ATC_Level_Infinity;
-
- -- remove self from timer queue
-
- STI.Defer_Abort_Nestable (D.Self_Id);
-
- if Single_Lock then
- STPO.Lock_RTS;
- end if;
-
- STPO.Write_Lock (Timer_Server_ID);
- Dpred := D.Pred;
- Dsucc := D.Succ;
- Dpred.Succ := Dsucc;
- Dsucc.Pred := Dpred;
- D.Succ := D;
- D.Pred := D;
- STPO.Unlock (Timer_Server_ID);
-
- -- Note that the above deletion code is required to be
- -- idempotent, since the block may have been dequeued
- -- previously by the Timer_Server.
-
- -- leave the asynchronous select
-
- STPO.Write_Lock (D.Self_Id);
- STU.Exit_One_ATC_Level (D.Self_Id);
- STPO.Unlock (D.Self_Id);
-
- if Single_Lock then
- STPO.Unlock_RTS;
- end if;
-
- STI.Undefer_Abort_Nestable (D.Self_Id);
- end Cancel_Async_Delay;
-
- ---------------------------
- -- Enqueue_Time_Duration --
- ---------------------------
-
- function Enqueue_Duration
- (T : Duration;
- D : Delay_Block_Access) return Boolean
- is
- begin
- if T <= 0.0 then
- D.Timed_Out := True;
- STPO.Yield;
- return False;
-
- else
- -- The corresponding call to Undefer_Abort is performed by the
- -- expanded code (see exp_ch9).
-
- STI.Defer_Abort (STPO.Self);
- Time_Enqueue
- (STPO.Monotonic_Clock
- + Duration'Min (T, OSP.Max_Sensible_Delay), D);
- return True;
- end if;
- end Enqueue_Duration;
-
- ------------------
- -- Time_Enqueue --
- ------------------
-
- -- Allocate a queue element for the wakeup time T and put it in the
- -- queue in wakeup time order. Assume we are on an asynchronous
- -- select statement with delay trigger. Put the calling task to
- -- sleep until either the delay expires or is cancelled.
-
- -- We use one entry call record for this delay, since we have
- -- to increment the ATC nesting level, but since it is not a
- -- real entry call we do not need to use any of the fields of
- -- the call record. The following code implements a subset of
- -- the actions for the asynchronous case of Protected_Entry_Call,
- -- much simplified since we know this never blocks, and does not
- -- have the full semantics of a protected entry call.
-
- procedure Time_Enqueue
- (T : Duration;
- D : Delay_Block_Access)
- is
- Self_Id : constant Task_Id := STPO.Self;
- Q : Delay_Block_Access;
-
- use type ST.Task_Id;
- -- for visibility of operator "="
-
- begin
- pragma Debug (Debug.Trace (Self_Id, "Async_Delay", 'P'));
- pragma Assert (Self_Id.Deferral_Level = 1,
- "async delay from within abort-deferred region");
-
- if Self_Id.ATC_Nesting_Level = ATC_Level'Last then
- raise Storage_Error with "not enough ATC nesting levels";
- end if;
-
- Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
-
- pragma Debug
- (Debug.Trace (Self_Id, "ASD: entered ATC level: " &
- ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
-
- D.Level := Self_Id.ATC_Nesting_Level;
- D.Self_Id := Self_Id;
- D.Resume_Time := T;
-
- if Single_Lock then
- STPO.Lock_RTS;
- end if;
-
- STPO.Write_Lock (Timer_Server_ID);
-
- -- Previously, there was code here to dynamically create
- -- the Timer_Server task, if one did not already exist.
- -- That code had a timing window that could allow multiple
- -- timer servers to be created. Luckily, the need for
- -- postponing creation of the timer server should now be
- -- gone, since this package will only be linked in if
- -- there are calls to enqueue calls on the timer server.
-
- -- Insert D in the timer queue, at the position determined
- -- by the wakeup time T.
-
- Q := Timer_Queue.Succ;
-
- while Q.Resume_Time < T loop
- Q := Q.Succ;
- end loop;
-
- -- Q is the block that has Resume_Time equal to or greater than
- -- T. After the insertion we want Q to be the successor of D.
-
- D.Succ := Q;
- D.Pred := Q.Pred;
- D.Pred.Succ := D;
- Q.Pred := D;
-
- -- If the new element became the head of the queue,
- -- signal the Timer_Server to wake up.
-
- if Timer_Queue.Succ = D then
- Timer_Attention := True;
- STPO.Wakeup (Timer_Server_ID, ST.Timer_Server_Sleep);
- end if;
-
- STPO.Unlock (Timer_Server_ID);
-
- if Single_Lock then
- STPO.Unlock_RTS;
- end if;
- end Time_Enqueue;
-
- ---------------
- -- Timed_Out --
- ---------------
-
- function Timed_Out (D : Delay_Block_Access) return Boolean is
- begin
- return D.Timed_Out;
- end Timed_Out;
-
- ------------------
- -- Timer_Server --
- ------------------
-
- task body Timer_Server is
- function Get_Next_Wakeup_Time return Duration;
- -- Used to initialize Next_Wakeup_Time, but also to ensure that
- -- Make_Independent is called during the elaboration of this task.
-
- --------------------------
- -- Get_Next_Wakeup_Time --
- --------------------------
-
- function Get_Next_Wakeup_Time return Duration is
- begin
- STU.Make_Independent;
- return Duration'Last;
- end Get_Next_Wakeup_Time;
-
- -- Local Declarations
-
- Next_Wakeup_Time : Duration := Get_Next_Wakeup_Time;
- Timedout : Boolean;
- Yielded : Boolean;
- Now : Duration;
- Dequeued : Delay_Block_Access;
- Dequeued_Task : Task_Id;
-
- pragma Unreferenced (Timedout, Yielded);
-
- begin
- Timer_Server_ID := STPO.Self;
-
- -- Since this package may be elaborated before System.Interrupt,
- -- we need to call Setup_Interrupt_Mask explicitly to ensure that
- -- this task has the proper signal mask.
-
- Interrupt_Management.Operations.Setup_Interrupt_Mask;
-
- -- Initialize the timer queue to empty, and make the wakeup time of the
- -- header node be larger than any real wakeup time we will ever use.
-
- loop
- STI.Defer_Abort (Timer_Server_ID);
-
- if Single_Lock then
- STPO.Lock_RTS;
- end if;
-
- STPO.Write_Lock (Timer_Server_ID);
-
- -- The timer server needs to catch pending aborts after finalization
- -- of library packages. If it doesn't poll for it, the server will
- -- sometimes hang.
-
- if not Timer_Attention then
- Timer_Server_ID.Common.State := ST.Timer_Server_Sleep;
-
- if Next_Wakeup_Time = Duration'Last then
- Timer_Server_ID.User_State := 1;
- Next_Wakeup_Time :=
- STPO.Monotonic_Clock + OSP.Max_Sensible_Delay;
-
- else
- Timer_Server_ID.User_State := 2;
- end if;
-
- STPO.Timed_Sleep
- (Timer_Server_ID, Next_Wakeup_Time,
- OSP.Absolute_RT, ST.Timer_Server_Sleep,
- Timedout, Yielded);
- Timer_Server_ID.Common.State := ST.Runnable;
- end if;
-
- -- Service all of the wakeup requests on the queue whose times have
- -- been reached, and update Next_Wakeup_Time to next wakeup time
- -- after that (the wakeup time of the head of the queue if any, else
- -- a time far in the future).
-
- Timer_Server_ID.User_State := 3;
- Timer_Attention := False;
-
- Now := STPO.Monotonic_Clock;
- while Timer_Queue.Succ.Resume_Time <= Now loop
-
- -- Dequeue the waiting task from the front of the queue
-
- pragma Debug (System.Tasking.Debug.Trace
- (Timer_Server_ID, "Timer service: waking up waiting task", 'E'));
-
- Dequeued := Timer_Queue.Succ;
- Timer_Queue.Succ := Dequeued.Succ;
- Dequeued.Succ.Pred := Dequeued.Pred;
- Dequeued.Succ := Dequeued;
- Dequeued.Pred := Dequeued;
-
- -- We want to abort the queued task to the level of the async.
- -- select statement with the delay. To do that, we need to lock
- -- the ATCB of that task, but to avoid deadlock we need to release
- -- the lock of the Timer_Server. This leaves a window in which
- -- another task might perform an enqueue or dequeue operation on
- -- the timer queue, but that is OK because we always restart the
- -- next iteration at the head of the queue.
-
- if Parameters.Runtime_Traces then
- Send_Trace_Info (E_Kill, Dequeued.Self_Id);
- end if;
-
- STPO.Unlock (Timer_Server_ID);
- STPO.Write_Lock (Dequeued.Self_Id);
- Dequeued_Task := Dequeued.Self_Id;
- Dequeued.Timed_Out := True;
- STI.Locked_Abort_To_Level
- (Timer_Server_ID, Dequeued_Task, Dequeued.Level - 1);
- STPO.Unlock (Dequeued_Task);
- STPO.Write_Lock (Timer_Server_ID);
- end loop;
-
- Next_Wakeup_Time := Timer_Queue.Succ.Resume_Time;
-
- -- Service returns the Next_Wakeup_Time.
- -- The Next_Wakeup_Time is either an infinity (no delay request)
- -- or the wakeup time of the queue head. This value is used for
- -- an actual delay in this server.
-
- STPO.Unlock (Timer_Server_ID);
-
- if Single_Lock then
- STPO.Unlock_RTS;
- end if;
-
- STI.Undefer_Abort (Timer_Server_ID);
- end loop;
- end Timer_Server;
-
- ------------------------------
- -- Package Body Elaboration --
- ------------------------------
-
-begin
- Timer_Queue.Succ := Timer_Queue'Access;
- Timer_Queue.Pred := Timer_Queue'Access;
- Timer_Queue.Resume_Time := Duration'Last;
- Timer_Server_ID := To_System (Timer_Server'Identity);
-end System.Tasking.Async_Delays;