|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- S Y S T E M . T A S K I N G . A S Y N C _ D E L A Y S --
|
|
|
6 -- --
|
|
|
7 -- S p e c --
|
|
|
8 -- --
|
|
131
|
9 -- Copyright (C) 1998-2018, Free Software Foundation, Inc. --
|
|
111
|
10 -- --
|
|
|
11 -- GNARL is free software; you can redistribute it and/or modify it under --
|
|
|
12 -- terms of the GNU General Public License as published by the Free Soft- --
|
|
|
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
|
|
|
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
|
|
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
|
|
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
|
|
|
17 -- --
|
|
|
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
|
|
|
19 -- additional permissions described in the GCC Runtime Library Exception, --
|
|
|
20 -- version 3.1, as published by the Free Software Foundation. --
|
|
|
21 -- --
|
|
|
22 -- You should have received a copy of the GNU General Public License and --
|
|
|
23 -- a copy of the GCC Runtime Library Exception along with this program; --
|
|
|
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
|
|
|
25 -- <http://www.gnu.org/licenses/>. --
|
|
|
26 -- --
|
|
|
27 -- GNARL was developed by the GNARL team at Florida State University. --
|
|
|
28 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
|
|
|
29 -- --
|
|
|
30 ------------------------------------------------------------------------------
|
|
|
31
|
|
|
32 -- This package contains the procedures to implements timeouts (delays) for
|
|
|
33 -- asynchronous select statements.
|
|
|
34
|
|
|
35 -- Note: the compiler generates direct calls to this interface, via Rtsfind.
|
|
|
36 -- Any changes to this interface may require corresponding compiler changes.
|
|
|
37
|
|
|
38 package System.Tasking.Async_Delays is
|
|
|
39
|
|
|
40 -- Suppose the following source code is given:
|
|
|
41
|
|
|
42 -- select delay When;
|
|
|
43 -- ...continuation for timeout case...
|
|
|
44 -- then abort
|
|
|
45 -- ...abortable part...
|
|
|
46 -- end select;
|
|
|
47
|
|
|
48 -- The compiler should expand this to the following:
|
|
|
49
|
|
|
50 -- declare
|
|
|
51 -- DB : aliased Delay_Block;
|
|
|
52 -- begin
|
|
|
53 -- if System.Tasking.Async_Delays.Enqueue_Duration
|
|
|
54 -- (When, DB'Unchecked_Access)
|
|
|
55 -- then
|
|
|
56 -- begin
|
|
|
57 -- A101b : declare
|
|
|
58 -- procedure _clean is
|
|
|
59 -- begin
|
|
|
60 -- System.Tasking.Async_Delays.Cancel_Async_Delay
|
|
|
61 -- (DB'Unchecked_Access);
|
|
|
62 -- return;
|
|
|
63 -- end _clean;
|
|
|
64 -- begin
|
|
|
65 -- abort_undefer.all;
|
|
|
66 -- ...abortable part...
|
|
|
67 -- exception
|
|
|
68 -- when all others =>
|
|
|
69 -- declare
|
|
|
70 -- E105b : exception_occurrence;
|
|
|
71 -- begin
|
|
|
72 -- save_occurrence (E105b, get_current_excep.all.all);
|
|
|
73 -- _clean;
|
|
|
74 -- reraise_occurrence_no_defer (E105b);
|
|
|
75 -- end;
|
|
|
76 -- at end
|
|
|
77 -- _clean;
|
|
|
78 -- end A101b;
|
|
|
79 -- exception
|
|
|
80 -- when _abort_signal =>
|
|
|
81 -- abort_undefer.all;
|
|
|
82 -- end;
|
|
|
83 -- end if;
|
|
|
84
|
|
|
85 -- if Timed_Out (DB'Unchecked_Access) then
|
|
|
86 -- ...continuation for timeout case...
|
|
|
87 -- end if;
|
|
|
88 -- end;
|
|
|
89
|
|
|
90 -----------------
|
|
|
91 -- Delay_Block --
|
|
|
92 -----------------
|
|
|
93
|
|
|
94 type Delay_Block is limited private;
|
|
|
95 type Delay_Block_Access is access all Delay_Block;
|
|
|
96
|
|
|
97 function Enqueue_Duration
|
|
|
98 (T : Duration;
|
|
|
99 D : Delay_Block_Access) return Boolean;
|
|
|
100 -- Enqueue the specified relative delay. Returns True if the delay has
|
|
|
101 -- been enqueued, False if it has already expired. If the delay has been
|
|
|
102 -- enqueued, abort is deferred.
|
|
|
103
|
|
|
104 procedure Cancel_Async_Delay (D : Delay_Block_Access);
|
|
|
105 -- Cancel the specified asynchronous delay
|
|
|
106
|
|
|
107 function Timed_Out (D : Delay_Block_Access) return Boolean;
|
|
|
108 pragma Inline (Timed_Out);
|
|
|
109 -- Return True if the delay specified in D has timed out
|
|
|
110
|
|
|
111 -- There are child units for delays on Ada.Calendar.Time/Ada.Real_Time.Time
|
|
|
112 -- so that an application need not link in features that it is not using.
|
|
|
113
|
|
|
114 private
|
|
|
115
|
|
|
116 type Delay_Block is limited record
|
|
|
117 Self_Id : Task_Id;
|
|
|
118 -- ID of the calling task
|
|
|
119
|
|
|
120 Level : ATC_Level_Base;
|
|
|
121 -- Normally Level is the ATC nesting level of the asynchronous select
|
|
|
122 -- statement to which this delay belongs, but after a call has been
|
|
|
123 -- dequeued we set it to ATC_Level_Infinity so that the Cancel operation
|
|
|
124 -- can detect repeated calls, and act idempotently.
|
|
|
125
|
|
|
126 Resume_Time : Duration;
|
|
|
127 -- The absolute wake up time, represented as Duration
|
|
|
128
|
|
|
129 Timed_Out : Boolean := False;
|
|
|
130 -- Set to true if the delay has timed out
|
|
|
131
|
|
|
132 Succ, Pred : Delay_Block_Access;
|
|
|
133 -- A double linked list
|
|
|
134 end record;
|
|
|
135
|
|
|
136 -- The above "overlaying" of Self_Id and Level to hold other data that has
|
|
|
137 -- a non-overlapping lifetime is an unabashed hack to save memory.
|
|
|
138
|
|
|
139 procedure Time_Enqueue
|
|
|
140 (T : Duration;
|
|
|
141 D : Delay_Block_Access);
|
|
|
142 pragma Inline (Time_Enqueue);
|
|
|
143 -- Used by the child units to enqueue delays on the timer queue implemented
|
|
|
144 -- in the body of this package. T denotes a point in time as the duration
|
|
|
145 -- elapsed since the epoch of the Ada real-time clock.
|
|
|
146
|
|
|
147 end System.Tasking.Async_Delays;
|
