From 554fd8c5195424bdbcabf5de30fdc183aba391bd Mon Sep 17 00:00:00 2001 From: upstream source tree Date: Sun, 15 Mar 2015 20:14:05 -0400 Subject: obtained gcc-4.6.4.tar.bz2 from upstream website; verified gcc-4.6.4.tar.bz2.sig; imported gcc-4.6.4 source tree from verified upstream tarball. downloading a git-generated archive based on the 'upstream' tag should provide you with a source tree that is binary identical to the one extracted from the above tarball. if you have obtained the source via the command 'git clone', however, do note that line-endings of files in your working directory might differ from line-endings of the respective files in the upstream repository. --- gcc/ada/s-taasde.adb | 412 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 412 insertions(+) create mode 100644 gcc/ada/s-taasde.adb (limited to 'gcc/ada/s-taasde.adb') diff --git a/gcc/ada/s-taasde.adb b/gcc/ada/s-taasde.adb new file mode 100644 index 000000000..315d9ba13 --- /dev/null +++ b/gcc/ada/s-taasde.adb @@ -0,0 +1,412 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; -- cgit v1.2.3