File : s-tposen-xi-full.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
4 -- --
5 -- SYSTEM.TASKING.PROTECTED_OBJECTS.SINGLE_ENTRY --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1998-2013, AdaCore --
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. GNARL 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 -- --
19 -- --
20 -- --
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 pragma Style_Checks (All_Checks);
33 -- Turn off subprogram ordering check, since restricted GNARLI subprograms are
34 -- gathered together at end.
35
36 -- This package provides an optimized version of Protected_Objects.Operations
37 -- and Protected_Objects.Entries making the following assumptions:
38
39 -- PO's have only one entry
40 -- There is only one caller at a time (No_Entry_Queue)
41 -- There is no dynamic priority support (No_Dynamic_Priorities)
42 -- No Abort Statements
43 -- (No_Abort_Statements, Max_Asynchronous_Select_Nesting => 0)
44 -- PO are at library level
45 -- No Requeue
46 -- None of the tasks will terminate (no need for finalization)
47 --
48 -- This interface is intended to be used in the ravenscar and restricted
49 -- profiles, the compiler is responsible for ensuring that the conditions
50 -- mentioned above are respected, except for the No_Entry_Queue restriction
51 -- that is checked dynamically in this package, since the check cannot be
52 -- performed at compile time (see Protected_Single_Entry_Call, Service_Entry).
53 --
54 -- Note that the difference with respect to the high integrity version of
55 -- this package is that exception handlers are allowed, so that support for
56 -- exceptional completion of entry bodies needs to be provided.
57
58 pragma Polling (Off);
59 -- Turn off polling, we do not want polling to take place during tasking
60 -- operations. It can cause infinite loops and other problems.
61
62 pragma Suppress (All_Checks);
63 -- Why is this needed???
64
65 with System.Multiprocessors;
66
67 with System.Task_Primitives.Operations;
68
69 with System.Tasking.Protected_Objects.Multiprocessors;
70
71 package body System.Tasking.Protected_Objects.Single_Entry is
72
73 use System.Multiprocessors;
74
75 package STPO renames System.Task_Primitives.Operations;
76 package STPOM renames System.Tasking.Protected_Objects.Multiprocessors;
77
78 Multiprocessor : constant Boolean := CPU'Range_Length /= 1;
79
80 --------------------------------------------
81 -- Exceptional_Complete_Single_Entry_Body --
82 --------------------------------------------
83
84 procedure Exceptional_Complete_Single_Entry_Body
85 (Object : Protection_Entry_Access;
86 Ex : Ada.Exceptions.Exception_Id)
87 is
88 begin
89 Object.Call_In_Progress.Exception_To_Raise := Ex;
90 end Exceptional_Complete_Single_Entry_Body;
91
92 ---------------------------------
93 -- Initialize_Protection_Entry --
94 ---------------------------------
95
96 procedure Initialize_Protection_Entry
97 (Object : Protection_Entry_Access;
98 Ceiling_Priority : Integer;
99 Compiler_Info : System.Address;
100 Entry_Body : Entry_Body_Access)
101 is
102 begin
103 Initialize_Protection (Object.Common'Access, Ceiling_Priority);
104
105 Object.Compiler_Info := Compiler_Info;
106 Object.Call_In_Progress := null;
107 Object.Entry_Body := Entry_Body;
108 Object.Entry_Queue := null;
109 end Initialize_Protection_Entry;
110
111 ----------------
112 -- Lock_Entry --
113 ----------------
114
115 procedure Lock_Entry (Object : Protection_Entry_Access) is
116 begin
117 Lock (Object.Common'Access);
118 end Lock_Entry;
119
120 ----------------------------
121 -- Protected_Single_Count --
122 ----------------------------
123
124 function Protected_Count_Entry (Object : Protection_Entry) return Natural is
125 begin
126 return Boolean'Pos (Object.Entry_Queue /= null);
127 end Protected_Count_Entry;
128
129 ---------------------------------
130 -- Protected_Single_Entry_Call --
131 ---------------------------------
132
133 procedure Protected_Single_Entry_Call
134 (Object : Protection_Entry_Access;
135 Uninterpreted_Data : System.Address)
136 is
137 Self_Id : constant Task_Id := STPO.Self;
138
139 use type Ada.Exceptions.Exception_Id;
140
141 begin
142 -- For this run time, pragma Detect_Blocking is always active, so we
143 -- must raise Program_Error if this potentially blocking operation is
144 -- called from a protected action.
145
146 if Self_Id.Common.Protected_Action_Nesting > 0 then
147 raise Program_Error;
148 end if;
149
150 Lock_Entry (Object);
151 Self_Id.Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
152 Self_Id.Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
153
154 if Object.Entry_Body.Barrier (Object.Compiler_Info, 1) then
155
156 -- No other task can be executing an entry within this protected
157 -- object. On a single processor implementation (such as this one),
158 -- the ceiling priority protocol and the strictly preemptive priority
159 -- scheduling policy guarantee that protected objects are always
160 -- available when any task tries to use them (otherwise, either the
161 -- currently executing task would not have had a high enough priority
162 -- to be executing, or a blocking operation would have been called
163 -- from within the entry body).
164
165 pragma Assert (Object.Call_In_Progress = null);
166
167 Object.Call_In_Progress := Self_Id.Entry_Call'Access;
168 Object.Entry_Body.Action
169 (Object.Compiler_Info, Self_Id.Entry_Call.Uninterpreted_Data, 1);
170 Object.Call_In_Progress := null;
171
172 -- Entry call is over
173
174 Unlock_Entry (Object);
175
176 else
177 if Object.Entry_Queue /= null then
178
179 -- This violates restriction No_Entry_Queue, raise Program_Error
180
181 Unlock_Entry (Object);
182 raise Program_Error with "No_Entry_Queue restriction violated";
183 end if;
184
185 -- There is a potential race condition between the Unlock_Entry and
186 -- the Sleep below (the Wakeup may be called before the Sleep). This
187 -- case is explicitly handled in the Sleep and Wakeup procedures:
188 -- Sleep won't block if Wakeup has been called before.
189
190 Object.Entry_Queue := Self_Id.Entry_Call'Access;
191 Unlock_Entry (Object);
192
193 -- Suspend until entry call has been completed. On exit, the call
194 -- will not be queued.
195
196 Self_Id.Common.State := Entry_Caller_Sleep;
197 STPO.Sleep (Self_Id, Entry_Caller_Sleep);
198 Self_Id.Common.State := Runnable;
199 end if;
200
201 -- Check whether there is any exception to raise
202
203 if Self_Id.Entry_Call.Exception_To_Raise /= Ada.Exceptions.Null_Id then
204 Ada.Exceptions.Raise_Exception
205 (Self_Id.Entry_Call.Exception_To_Raise);
206 end if;
207 end Protected_Single_Entry_Call;
208
209 -----------------------------------
210 -- Protected_Single_Entry_Caller --
211 -----------------------------------
212
213 function Protected_Single_Entry_Caller
214 (Object : Protection_Entry) return Task_Id
215 is
216 begin
217 return Object.Call_In_Progress.Self;
218 end Protected_Single_Entry_Caller;
219
220 -------------------
221 -- Service_Entry --
222 -------------------
223
224 procedure Service_Entry (Object : Protection_Entry_Access) is
225 Entry_Call : constant Entry_Call_Link := Object.Entry_Queue;
226 Caller : Task_Id;
227
228 begin
229 if Entry_Call /= null
230 and then Object.Entry_Body.Barrier (Object.Compiler_Info, 1)
231 then
232 Object.Entry_Queue := null;
233
234 -- No other task can be executing an entry within this protected
235 -- object. On a single processor implementation (such as this one),
236 -- the ceiling priority protocol and the strictly preemptive priority
237 -- scheduling policy guarantee that protected objects are always
238 -- available when any task tries to use them (otherwise, either the
239 -- currently executing task would not have had a high enough priority
240 -- to be executing, or a blocking operation would have been called
241 -- from within the entry body).
242
243 pragma Assert (Object.Call_In_Progress = null);
244
245 Object.Call_In_Progress := Entry_Call;
246 Object.Entry_Body.Action
247 (Object.Compiler_Info, Entry_Call.Uninterpreted_Data, 1);
248 Object.Call_In_Progress := null;
249 Caller := Entry_Call.Self;
250 Unlock_Entry (Object);
251
252 -- Signal the entry caller that the entry is completed
253
254 if not Multiprocessor
255 or else Caller.Common.Base_CPU = STPO.Self.Common.Base_CPU
256 then
257 -- Entry caller and servicing tasks are on the same CPU.
258 -- We are allowed to directly wake up the task.
259
260 STPO.Wakeup (Caller, Entry_Caller_Sleep);
261 else
262 -- The entry caller is on a different CPU.
263
264 STPOM.Served (Entry_Call);
265 end if;
266
267 else
268 -- Just unlock the entry
269
270 Unlock_Entry (Object);
271 end if;
272 end Service_Entry;
273
274 ------------------
275 -- Unlock_Entry --
276 ------------------
277
278 procedure Unlock_Entry (Object : Protection_Entry_Access) is
279 begin
280 Unlock (Object.Common'Access);
281 end Unlock_Entry;
282
283 end System.Tasking.Protected_Objects.Single_Entry;