| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNU ADA 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 -- |
| -- -- |
| -- $Revision: 1.5 $ |
| -- -- |
| -- Copyright (C) 1998-2001 Ada Core Technologies, 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 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). -- |
| -- -- |
| ------------------------------------------------------------------------------ |
| |
| 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.Exceptions; |
| -- Used for Raise_Exception |
| |
| with System.Task_Primitives.Operations; |
| -- Used for Write_Lock, |
| -- Unlock, |
| -- Self, |
| -- Monotonic_Clock, |
| -- Self, |
| -- Timed_Sleep, |
| -- Wakeup, |
| -- Yield |
| |
| with System.Tasking.Utilities; |
| -- Used for Make_Independent |
| |
| with System.Tasking.Initialization; |
| -- Used for Defer_Abort |
| -- Undefer_Abort |
| |
| with System.Tasking.Debug; |
| -- Used for Trace |
| |
| with System.OS_Primitives; |
| -- used for Max_Sensible_Delay |
| |
| with Ada.Task_Identification; |
| -- used for Task_ID type |
| |
| with Unchecked_Conversion; |
| |
| 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; |
| |
| function To_System is new 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); |
| 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); |
| STI.Undefer_Abort_Nestable (D.Self_Id); |
| end Cancel_Async_Delay; |
| |
| --------------------------- |
| -- Enqueue_Time_Duration -- |
| --------------------------- |
| |
| function Enqueue_Duration |
| (T : in Duration; |
| D : Delay_Block_Access) |
| return Boolean |
| is |
| begin |
| if T <= 0.0 then |
| D.Timed_Out := True; |
| STPO.Yield; |
| return False; |
| |
| else |
| 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 |
| Ada.Exceptions.Raise_Exception (Storage_Error'Identity, |
| "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; |
| |
| STI.Defer_Abort (Self_Id); |
| 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); |
| STI.Undefer_Abort (Self_Id); |
| 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 |
| Next_Wakeup_Time : Duration := Duration'Last; |
| Timedout : Boolean; |
| Yielded : Boolean; |
| Now : Duration; |
| Dequeued, |
| Tpred, |
| Tsucc : Delay_Block_Access; |
| Dequeued_Task : Task_ID; |
| |
| -- Initialize_Timer_Queue returns null, but has critical side-effects |
| -- of initializing the timer queue. |
| |
| begin |
| Timer_Server_ID := STPO.Self; |
| STU.Make_Independent; |
| |
| -- 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); |
| 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 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. |
| |
| 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); |
| STI.Undefer_Abort (Timer_Server_ID); |
| end loop; |
| end Timer_Server; |
| |
| ------------------------------ |
| -- Package Body Elaboration -- |
| ------------------------------ |
| |
| begin |
| Timer_Queue.Succ := Timer_Queue'Unchecked_Access; |
| Timer_Queue.Pred := Timer_Queue'Unchecked_Access; |
| Timer_Queue.Resume_Time := Duration'Last; |
| Timer_Server_ID := To_System (Timer_Server'Identity); |
| end System.Tasking.Async_Delays; |
