annotate gcc/ada/libgnarl/s-tpobop.adb @ 131:84e7813d76e9

gcc-8.2
author mir3636
date Thu, 25 Oct 2018 07:37:49 +0900
parents 04ced10e8804
children 1830386684a0
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
111
kono
parents:
diff changeset
1 ------------------------------------------------------------------------------
kono
parents:
diff changeset
2 -- --
kono
parents:
diff changeset
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
kono
parents:
diff changeset
4 -- --
kono
parents:
diff changeset
5 -- SYSTEM.TASKING.PROTECTED_OBJECTS.OPERATIONS --
kono
parents:
diff changeset
6 -- --
kono
parents:
diff changeset
7 -- B o d y --
kono
parents:
diff changeset
8 -- --
131
84e7813d76e9 gcc-8.2
mir3636
parents: 111
diff changeset
9 -- Copyright (C) 1998-2018, Free Software Foundation, Inc. --
111
kono
parents:
diff changeset
10 -- --
kono
parents:
diff changeset
11 -- GNARL is free software; you can redistribute it and/or modify it under --
kono
parents:
diff changeset
12 -- terms of the GNU General Public License as published by the Free Soft- --
kono
parents:
diff changeset
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
kono
parents:
diff changeset
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
kono
parents:
diff changeset
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
kono
parents:
diff changeset
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
kono
parents:
diff changeset
17 -- --
kono
parents:
diff changeset
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
kono
parents:
diff changeset
19 -- additional permissions described in the GCC Runtime Library Exception, --
kono
parents:
diff changeset
20 -- version 3.1, as published by the Free Software Foundation. --
kono
parents:
diff changeset
21 -- --
kono
parents:
diff changeset
22 -- You should have received a copy of the GNU General Public License and --
kono
parents:
diff changeset
23 -- a copy of the GCC Runtime Library Exception along with this program; --
kono
parents:
diff changeset
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
kono
parents:
diff changeset
25 -- <http://www.gnu.org/licenses/>. --
kono
parents:
diff changeset
26 -- --
kono
parents:
diff changeset
27 -- GNARL was developed by the GNARL team at Florida State University. --
kono
parents:
diff changeset
28 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
kono
parents:
diff changeset
29 -- --
kono
parents:
diff changeset
30 ------------------------------------------------------------------------------
kono
parents:
diff changeset
31
kono
parents:
diff changeset
32 -- This package contains all extended primitives related to Protected_Objects
kono
parents:
diff changeset
33 -- with entries.
kono
parents:
diff changeset
34
kono
parents:
diff changeset
35 -- The handling of protected objects with no entries is done in
kono
parents:
diff changeset
36 -- System.Tasking.Protected_Objects, the simple routines for protected
kono
parents:
diff changeset
37 -- objects with entries in System.Tasking.Protected_Objects.Entries.
kono
parents:
diff changeset
38
kono
parents:
diff changeset
39 -- The split between Entries and Operations is needed to break circular
kono
parents:
diff changeset
40 -- dependencies inside the run time.
kono
parents:
diff changeset
41
kono
parents:
diff changeset
42 -- This package contains all primitives related to Protected_Objects.
kono
parents:
diff changeset
43 -- Note: the compiler generates direct calls to this interface, via Rtsfind.
kono
parents:
diff changeset
44
kono
parents:
diff changeset
45 with System.Task_Primitives.Operations;
kono
parents:
diff changeset
46 with System.Tasking.Entry_Calls;
kono
parents:
diff changeset
47 with System.Tasking.Queuing;
kono
parents:
diff changeset
48 with System.Tasking.Rendezvous;
kono
parents:
diff changeset
49 with System.Tasking.Utilities;
kono
parents:
diff changeset
50 with System.Tasking.Debug;
kono
parents:
diff changeset
51 with System.Parameters;
kono
parents:
diff changeset
52 with System.Restrictions;
kono
parents:
diff changeset
53
kono
parents:
diff changeset
54 with System.Tasking.Initialization;
kono
parents:
diff changeset
55 pragma Elaborate_All (System.Tasking.Initialization);
kono
parents:
diff changeset
56 -- Insures that tasking is initialized if any protected objects are created
kono
parents:
diff changeset
57
kono
parents:
diff changeset
58 package body System.Tasking.Protected_Objects.Operations is
kono
parents:
diff changeset
59
kono
parents:
diff changeset
60 package STPO renames System.Task_Primitives.Operations;
kono
parents:
diff changeset
61
kono
parents:
diff changeset
62 use Parameters;
kono
parents:
diff changeset
63 use Ada.Exceptions;
kono
parents:
diff changeset
64 use Entries;
kono
parents:
diff changeset
65
kono
parents:
diff changeset
66 use System.Restrictions;
kono
parents:
diff changeset
67 use System.Restrictions.Rident;
kono
parents:
diff changeset
68
kono
parents:
diff changeset
69 -----------------------
kono
parents:
diff changeset
70 -- Local Subprograms --
kono
parents:
diff changeset
71 -----------------------
kono
parents:
diff changeset
72
kono
parents:
diff changeset
73 procedure Update_For_Queue_To_PO
kono
parents:
diff changeset
74 (Entry_Call : Entry_Call_Link;
kono
parents:
diff changeset
75 With_Abort : Boolean);
kono
parents:
diff changeset
76 pragma Inline (Update_For_Queue_To_PO);
kono
parents:
diff changeset
77 -- Update the state of an existing entry call to reflect the fact that it
kono
parents:
diff changeset
78 -- is being enqueued, based on whether the current queuing action is with
kono
parents:
diff changeset
79 -- or without abort. Call this only while holding the PO's lock. It returns
kono
parents:
diff changeset
80 -- with the PO's lock still held.
kono
parents:
diff changeset
81
kono
parents:
diff changeset
82 procedure Requeue_Call
kono
parents:
diff changeset
83 (Self_Id : Task_Id;
kono
parents:
diff changeset
84 Object : Protection_Entries_Access;
kono
parents:
diff changeset
85 Entry_Call : Entry_Call_Link);
kono
parents:
diff changeset
86 -- Handle requeue of Entry_Call.
kono
parents:
diff changeset
87 -- In particular, queue the call if needed, or service it immediately
kono
parents:
diff changeset
88 -- if possible.
kono
parents:
diff changeset
89
kono
parents:
diff changeset
90 ---------------------------------
kono
parents:
diff changeset
91 -- Cancel_Protected_Entry_Call --
kono
parents:
diff changeset
92 ---------------------------------
kono
parents:
diff changeset
93
kono
parents:
diff changeset
94 -- Compiler interface only (do not call from within the RTS)
kono
parents:
diff changeset
95
kono
parents:
diff changeset
96 -- This should have analogous effect to Cancel_Task_Entry_Call, setting
kono
parents:
diff changeset
97 -- the value of Block.Cancelled instead of returning the parameter value
kono
parents:
diff changeset
98 -- Cancelled.
kono
parents:
diff changeset
99
kono
parents:
diff changeset
100 -- The effect should be idempotent, since the call may already have been
kono
parents:
diff changeset
101 -- dequeued.
kono
parents:
diff changeset
102
kono
parents:
diff changeset
103 -- Source code:
kono
parents:
diff changeset
104
kono
parents:
diff changeset
105 -- select r.e;
kono
parents:
diff changeset
106 -- ...A...
kono
parents:
diff changeset
107 -- then abort
kono
parents:
diff changeset
108 -- ...B...
kono
parents:
diff changeset
109 -- end select;
kono
parents:
diff changeset
110
kono
parents:
diff changeset
111 -- Expanded code:
kono
parents:
diff changeset
112
kono
parents:
diff changeset
113 -- declare
kono
parents:
diff changeset
114 -- X : protected_entry_index := 1;
kono
parents:
diff changeset
115 -- B80b : communication_block;
kono
parents:
diff changeset
116 -- communication_blockIP (B80b);
kono
parents:
diff changeset
117
kono
parents:
diff changeset
118 -- begin
kono
parents:
diff changeset
119 -- begin
kono
parents:
diff changeset
120 -- A79b : label
kono
parents:
diff changeset
121 -- A79b : declare
kono
parents:
diff changeset
122 -- procedure _clean is
kono
parents:
diff changeset
123 -- begin
kono
parents:
diff changeset
124 -- if enqueued (B80b) then
kono
parents:
diff changeset
125 -- cancel_protected_entry_call (B80b);
kono
parents:
diff changeset
126 -- end if;
kono
parents:
diff changeset
127 -- return;
kono
parents:
diff changeset
128 -- end _clean;
kono
parents:
diff changeset
129
kono
parents:
diff changeset
130 -- begin
kono
parents:
diff changeset
131 -- protected_entry_call (rTV!(r)._object'unchecked_access, X,
kono
parents:
diff changeset
132 -- null_address, asynchronous_call, B80b, objectF => 0);
kono
parents:
diff changeset
133 -- if enqueued (B80b) then
kono
parents:
diff changeset
134 -- ...B...
kono
parents:
diff changeset
135 -- end if;
kono
parents:
diff changeset
136 -- at end
kono
parents:
diff changeset
137 -- _clean;
kono
parents:
diff changeset
138 -- end A79b;
kono
parents:
diff changeset
139
kono
parents:
diff changeset
140 -- exception
kono
parents:
diff changeset
141 -- when _abort_signal =>
kono
parents:
diff changeset
142 -- abort_undefer.all;
kono
parents:
diff changeset
143 -- null;
kono
parents:
diff changeset
144 -- end;
kono
parents:
diff changeset
145
kono
parents:
diff changeset
146 -- if not cancelled (B80b) then
kono
parents:
diff changeset
147 -- x := ...A...
kono
parents:
diff changeset
148 -- end if;
kono
parents:
diff changeset
149 -- end;
kono
parents:
diff changeset
150
kono
parents:
diff changeset
151 -- If the entry call completes after we get into the abortable part,
kono
parents:
diff changeset
152 -- Abort_Signal should be raised and ATC will take us to the at-end
kono
parents:
diff changeset
153 -- handler, which will call _clean.
kono
parents:
diff changeset
154
kono
parents:
diff changeset
155 -- If the entry call returns with the call already completed, we can skip
kono
parents:
diff changeset
156 -- this, and use the "if enqueued()" to go past the at-end handler, but we
kono
parents:
diff changeset
157 -- will still call _clean.
kono
parents:
diff changeset
158
kono
parents:
diff changeset
159 -- If the abortable part completes before the entry call is Done, it will
kono
parents:
diff changeset
160 -- call _clean.
kono
parents:
diff changeset
161
kono
parents:
diff changeset
162 -- If the entry call or the abortable part raises an exception,
kono
parents:
diff changeset
163 -- we will still call _clean, but the value of Cancelled should not matter.
kono
parents:
diff changeset
164
kono
parents:
diff changeset
165 -- Whoever calls _clean first gets to decide whether the call
kono
parents:
diff changeset
166 -- has been "cancelled".
kono
parents:
diff changeset
167
kono
parents:
diff changeset
168 -- Enqueued should be true if there is any chance that the call is still on
kono
parents:
diff changeset
169 -- a queue. It seems to be safe to make it True if the call was Onqueue at
kono
parents:
diff changeset
170 -- some point before return from Protected_Entry_Call.
kono
parents:
diff changeset
171
kono
parents:
diff changeset
172 -- Cancelled should be true iff the abortable part completed
kono
parents:
diff changeset
173 -- and succeeded in cancelling the entry call before it completed.
kono
parents:
diff changeset
174
kono
parents:
diff changeset
175 -- ?????
kono
parents:
diff changeset
176 -- The need for Enqueued is less obvious. The "if enqueued ()" tests are
kono
parents:
diff changeset
177 -- not necessary, since Cancel_Protected_Entry_Call/Protected_Entry_Call
kono
parents:
diff changeset
178 -- must do the same test internally, with locking. The one that makes
kono
parents:
diff changeset
179 -- cancellation conditional may be a useful heuristic since at least 1/2
kono
parents:
diff changeset
180 -- the time the call should be off-queue by that point. The other one seems
kono
parents:
diff changeset
181 -- totally useless, since Protected_Entry_Call must do the same check and
kono
parents:
diff changeset
182 -- then possibly wait for the call to be abortable, internally.
kono
parents:
diff changeset
183
kono
parents:
diff changeset
184 -- We can check Call.State here without locking the caller's mutex,
kono
parents:
diff changeset
185 -- since the call must be over after returning from Wait_For_Completion.
kono
parents:
diff changeset
186 -- No other task can access the call record at this point.
kono
parents:
diff changeset
187
kono
parents:
diff changeset
188 procedure Cancel_Protected_Entry_Call
kono
parents:
diff changeset
189 (Block : in out Communication_Block) is
kono
parents:
diff changeset
190 begin
kono
parents:
diff changeset
191 Entry_Calls.Try_To_Cancel_Entry_Call (Block.Cancelled);
kono
parents:
diff changeset
192 end Cancel_Protected_Entry_Call;
kono
parents:
diff changeset
193
kono
parents:
diff changeset
194 ---------------
kono
parents:
diff changeset
195 -- Cancelled --
kono
parents:
diff changeset
196 ---------------
kono
parents:
diff changeset
197
kono
parents:
diff changeset
198 function Cancelled (Block : Communication_Block) return Boolean is
kono
parents:
diff changeset
199 begin
kono
parents:
diff changeset
200 return Block.Cancelled;
kono
parents:
diff changeset
201 end Cancelled;
kono
parents:
diff changeset
202
kono
parents:
diff changeset
203 -------------------------
kono
parents:
diff changeset
204 -- Complete_Entry_Body --
kono
parents:
diff changeset
205 -------------------------
kono
parents:
diff changeset
206
kono
parents:
diff changeset
207 procedure Complete_Entry_Body (Object : Protection_Entries_Access) is
kono
parents:
diff changeset
208 begin
kono
parents:
diff changeset
209 Exceptional_Complete_Entry_Body (Object, Ada.Exceptions.Null_Id);
kono
parents:
diff changeset
210 end Complete_Entry_Body;
kono
parents:
diff changeset
211
kono
parents:
diff changeset
212 --------------
kono
parents:
diff changeset
213 -- Enqueued --
kono
parents:
diff changeset
214 --------------
kono
parents:
diff changeset
215
kono
parents:
diff changeset
216 function Enqueued (Block : Communication_Block) return Boolean is
kono
parents:
diff changeset
217 begin
kono
parents:
diff changeset
218 return Block.Enqueued;
kono
parents:
diff changeset
219 end Enqueued;
kono
parents:
diff changeset
220
kono
parents:
diff changeset
221 -------------------------------------
kono
parents:
diff changeset
222 -- Exceptional_Complete_Entry_Body --
kono
parents:
diff changeset
223 -------------------------------------
kono
parents:
diff changeset
224
kono
parents:
diff changeset
225 procedure Exceptional_Complete_Entry_Body
kono
parents:
diff changeset
226 (Object : Protection_Entries_Access;
kono
parents:
diff changeset
227 Ex : Ada.Exceptions.Exception_Id)
kono
parents:
diff changeset
228 is
kono
parents:
diff changeset
229 procedure Transfer_Occurrence
kono
parents:
diff changeset
230 (Target : Ada.Exceptions.Exception_Occurrence_Access;
kono
parents:
diff changeset
231 Source : Ada.Exceptions.Exception_Occurrence);
kono
parents:
diff changeset
232 pragma Import (C, Transfer_Occurrence, "__gnat_transfer_occurrence");
kono
parents:
diff changeset
233
kono
parents:
diff changeset
234 Entry_Call : constant Entry_Call_Link := Object.Call_In_Progress;
kono
parents:
diff changeset
235 Self_Id : Task_Id;
kono
parents:
diff changeset
236
kono
parents:
diff changeset
237 begin
kono
parents:
diff changeset
238 pragma Debug
kono
parents:
diff changeset
239 (Debug.Trace (STPO.Self, "Exceptional_Complete_Entry_Body", 'P'));
kono
parents:
diff changeset
240
kono
parents:
diff changeset
241 -- We must have abort deferred, since we are inside a protected
kono
parents:
diff changeset
242 -- operation.
kono
parents:
diff changeset
243
kono
parents:
diff changeset
244 if Entry_Call /= null then
kono
parents:
diff changeset
245
kono
parents:
diff changeset
246 -- The call was not requeued
kono
parents:
diff changeset
247
kono
parents:
diff changeset
248 Entry_Call.Exception_To_Raise := Ex;
kono
parents:
diff changeset
249
kono
parents:
diff changeset
250 if Ex /= Ada.Exceptions.Null_Id then
kono
parents:
diff changeset
251
kono
parents:
diff changeset
252 -- An exception was raised and abort was deferred, so adjust
kono
parents:
diff changeset
253 -- before propagating, otherwise the task will stay with deferral
kono
parents:
diff changeset
254 -- enabled for its remaining life.
kono
parents:
diff changeset
255
kono
parents:
diff changeset
256 Self_Id := STPO.Self;
kono
parents:
diff changeset
257
kono
parents:
diff changeset
258 if not ZCX_By_Default then
kono
parents:
diff changeset
259 Initialization.Undefer_Abort_Nestable (Self_Id);
kono
parents:
diff changeset
260 end if;
kono
parents:
diff changeset
261
kono
parents:
diff changeset
262 Transfer_Occurrence
kono
parents:
diff changeset
263 (Entry_Call.Self.Common.Compiler_Data.Current_Excep'Access,
kono
parents:
diff changeset
264 Self_Id.Common.Compiler_Data.Current_Excep);
kono
parents:
diff changeset
265 end if;
kono
parents:
diff changeset
266
kono
parents:
diff changeset
267 -- Wakeup_Entry_Caller will be called from PO_Do_Or_Queue or
kono
parents:
diff changeset
268 -- PO_Service_Entries on return.
kono
parents:
diff changeset
269
kono
parents:
diff changeset
270 end if;
kono
parents:
diff changeset
271 end Exceptional_Complete_Entry_Body;
kono
parents:
diff changeset
272
kono
parents:
diff changeset
273 --------------------
kono
parents:
diff changeset
274 -- PO_Do_Or_Queue --
kono
parents:
diff changeset
275 --------------------
kono
parents:
diff changeset
276
kono
parents:
diff changeset
277 procedure PO_Do_Or_Queue
kono
parents:
diff changeset
278 (Self_ID : Task_Id;
kono
parents:
diff changeset
279 Object : Protection_Entries_Access;
kono
parents:
diff changeset
280 Entry_Call : Entry_Call_Link)
kono
parents:
diff changeset
281 is
kono
parents:
diff changeset
282 E : constant Protected_Entry_Index :=
kono
parents:
diff changeset
283 Protected_Entry_Index (Entry_Call.E);
kono
parents:
diff changeset
284 Index : constant Protected_Entry_Index :=
kono
parents:
diff changeset
285 Object.Find_Body_Index (Object.Compiler_Info, E);
kono
parents:
diff changeset
286 Barrier_Value : Boolean;
kono
parents:
diff changeset
287 Queue_Length : Natural;
kono
parents:
diff changeset
288 begin
kono
parents:
diff changeset
289 -- When the Action procedure for an entry body returns, it is either
kono
parents:
diff changeset
290 -- completed (having called [Exceptional_]Complete_Entry_Body) or it
kono
parents:
diff changeset
291 -- is queued, having executed a requeue statement.
kono
parents:
diff changeset
292
kono
parents:
diff changeset
293 Barrier_Value :=
kono
parents:
diff changeset
294 Object.Entry_Bodies (Index).Barrier (Object.Compiler_Info, E);
kono
parents:
diff changeset
295
kono
parents:
diff changeset
296 if Barrier_Value then
kono
parents:
diff changeset
297
kono
parents:
diff changeset
298 -- Not abortable while service is in progress
kono
parents:
diff changeset
299
kono
parents:
diff changeset
300 if Entry_Call.State = Now_Abortable then
kono
parents:
diff changeset
301 Entry_Call.State := Was_Abortable;
kono
parents:
diff changeset
302 end if;
kono
parents:
diff changeset
303
kono
parents:
diff changeset
304 Object.Call_In_Progress := Entry_Call;
kono
parents:
diff changeset
305
kono
parents:
diff changeset
306 pragma Debug
kono
parents:
diff changeset
307 (Debug.Trace (Self_ID, "PODOQ: start entry body", 'P'));
kono
parents:
diff changeset
308 Object.Entry_Bodies (Index).Action (
kono
parents:
diff changeset
309 Object.Compiler_Info, Entry_Call.Uninterpreted_Data, E);
kono
parents:
diff changeset
310
kono
parents:
diff changeset
311 if Object.Call_In_Progress /= null then
kono
parents:
diff changeset
312
kono
parents:
diff changeset
313 -- Body of current entry served call to completion
kono
parents:
diff changeset
314
kono
parents:
diff changeset
315 Object.Call_In_Progress := null;
kono
parents:
diff changeset
316
kono
parents:
diff changeset
317 if Single_Lock then
kono
parents:
diff changeset
318 STPO.Lock_RTS;
kono
parents:
diff changeset
319 end if;
kono
parents:
diff changeset
320
kono
parents:
diff changeset
321 STPO.Write_Lock (Entry_Call.Self);
kono
parents:
diff changeset
322 Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
kono
parents:
diff changeset
323 STPO.Unlock (Entry_Call.Self);
kono
parents:
diff changeset
324
kono
parents:
diff changeset
325 if Single_Lock then
kono
parents:
diff changeset
326 STPO.Unlock_RTS;
kono
parents:
diff changeset
327 end if;
kono
parents:
diff changeset
328
kono
parents:
diff changeset
329 else
kono
parents:
diff changeset
330 Requeue_Call (Self_ID, Object, Entry_Call);
kono
parents:
diff changeset
331 end if;
kono
parents:
diff changeset
332
kono
parents:
diff changeset
333 elsif Entry_Call.Mode /= Conditional_Call
kono
parents:
diff changeset
334 or else not Entry_Call.With_Abort
kono
parents:
diff changeset
335 then
kono
parents:
diff changeset
336 if Run_Time_Restrictions.Set (Max_Entry_Queue_Length)
kono
parents:
diff changeset
337 or else Object.Entry_Queue_Maxes /= null
kono
parents:
diff changeset
338 then
kono
parents:
diff changeset
339 -- Need to check the queue length. Computing the length is an
kono
parents:
diff changeset
340 -- unusual case and is slow (need to walk the queue).
kono
parents:
diff changeset
341
kono
parents:
diff changeset
342 Queue_Length := Queuing.Count_Waiting (Object.Entry_Queues (E));
kono
parents:
diff changeset
343
kono
parents:
diff changeset
344 if (Run_Time_Restrictions.Set (Max_Entry_Queue_Length)
kono
parents:
diff changeset
345 and then Queue_Length >=
kono
parents:
diff changeset
346 Run_Time_Restrictions.Value (Max_Entry_Queue_Length))
kono
parents:
diff changeset
347 or else
kono
parents:
diff changeset
348 (Object.Entry_Queue_Maxes /= null
kono
parents:
diff changeset
349 and then Object.Entry_Queue_Maxes (Index) /= 0
kono
parents:
diff changeset
350 and then Queue_Length >= Object.Entry_Queue_Maxes (Index))
kono
parents:
diff changeset
351 then
kono
parents:
diff changeset
352 -- This violates the Max_Entry_Queue_Length restriction or the
kono
parents:
diff changeset
353 -- Max_Queue_Length bound, raise Program_Error.
kono
parents:
diff changeset
354
kono
parents:
diff changeset
355 Entry_Call.Exception_To_Raise := Program_Error'Identity;
kono
parents:
diff changeset
356
kono
parents:
diff changeset
357 if Single_Lock then
kono
parents:
diff changeset
358 STPO.Lock_RTS;
kono
parents:
diff changeset
359 end if;
kono
parents:
diff changeset
360
kono
parents:
diff changeset
361 STPO.Write_Lock (Entry_Call.Self);
kono
parents:
diff changeset
362 Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
kono
parents:
diff changeset
363 STPO.Unlock (Entry_Call.Self);
kono
parents:
diff changeset
364
kono
parents:
diff changeset
365 if Single_Lock then
kono
parents:
diff changeset
366 STPO.Unlock_RTS;
kono
parents:
diff changeset
367 end if;
kono
parents:
diff changeset
368
kono
parents:
diff changeset
369 return;
kono
parents:
diff changeset
370 end if;
kono
parents:
diff changeset
371 end if;
kono
parents:
diff changeset
372
kono
parents:
diff changeset
373 -- Do the work: queue the call
kono
parents:
diff changeset
374
kono
parents:
diff changeset
375 Queuing.Enqueue (Object.Entry_Queues (E), Entry_Call);
kono
parents:
diff changeset
376 Update_For_Queue_To_PO (Entry_Call, Entry_Call.With_Abort);
kono
parents:
diff changeset
377
kono
parents:
diff changeset
378 return;
kono
parents:
diff changeset
379 else
kono
parents:
diff changeset
380 -- Conditional_Call and With_Abort
kono
parents:
diff changeset
381
kono
parents:
diff changeset
382 if Single_Lock then
kono
parents:
diff changeset
383 STPO.Lock_RTS;
kono
parents:
diff changeset
384 end if;
kono
parents:
diff changeset
385
kono
parents:
diff changeset
386 STPO.Write_Lock (Entry_Call.Self);
kono
parents:
diff changeset
387 pragma Assert (Entry_Call.State /= Not_Yet_Abortable);
kono
parents:
diff changeset
388 Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Cancelled);
kono
parents:
diff changeset
389 STPO.Unlock (Entry_Call.Self);
kono
parents:
diff changeset
390
kono
parents:
diff changeset
391 if Single_Lock then
kono
parents:
diff changeset
392 STPO.Unlock_RTS;
kono
parents:
diff changeset
393 end if;
kono
parents:
diff changeset
394 end if;
kono
parents:
diff changeset
395
kono
parents:
diff changeset
396 exception
kono
parents:
diff changeset
397 when others =>
kono
parents:
diff changeset
398 Queuing.Broadcast_Program_Error (Self_ID, Object, Entry_Call);
kono
parents:
diff changeset
399 end PO_Do_Or_Queue;
kono
parents:
diff changeset
400
kono
parents:
diff changeset
401 ------------------------
kono
parents:
diff changeset
402 -- PO_Service_Entries --
kono
parents:
diff changeset
403 ------------------------
kono
parents:
diff changeset
404
kono
parents:
diff changeset
405 procedure PO_Service_Entries
kono
parents:
diff changeset
406 (Self_ID : Task_Id;
kono
parents:
diff changeset
407 Object : Entries.Protection_Entries_Access;
kono
parents:
diff changeset
408 Unlock_Object : Boolean := True)
kono
parents:
diff changeset
409 is
kono
parents:
diff changeset
410 E : Protected_Entry_Index;
kono
parents:
diff changeset
411 Caller : Task_Id;
kono
parents:
diff changeset
412 Entry_Call : Entry_Call_Link;
kono
parents:
diff changeset
413
kono
parents:
diff changeset
414 begin
kono
parents:
diff changeset
415 loop
kono
parents:
diff changeset
416 Queuing.Select_Protected_Entry_Call (Self_ID, Object, Entry_Call);
kono
parents:
diff changeset
417
kono
parents:
diff changeset
418 exit when Entry_Call = null;
kono
parents:
diff changeset
419
kono
parents:
diff changeset
420 E := Protected_Entry_Index (Entry_Call.E);
kono
parents:
diff changeset
421
kono
parents:
diff changeset
422 -- Not abortable while service is in progress
kono
parents:
diff changeset
423
kono
parents:
diff changeset
424 if Entry_Call.State = Now_Abortable then
kono
parents:
diff changeset
425 Entry_Call.State := Was_Abortable;
kono
parents:
diff changeset
426 end if;
kono
parents:
diff changeset
427
kono
parents:
diff changeset
428 Object.Call_In_Progress := Entry_Call;
kono
parents:
diff changeset
429
kono
parents:
diff changeset
430 begin
kono
parents:
diff changeset
431 pragma Debug
kono
parents:
diff changeset
432 (Debug.Trace (Self_ID, "POSE: start entry body", 'P'));
kono
parents:
diff changeset
433
kono
parents:
diff changeset
434 Object.Entry_Bodies
kono
parents:
diff changeset
435 (Object.Find_Body_Index (Object.Compiler_Info, E)).Action
kono
parents:
diff changeset
436 (Object.Compiler_Info, Entry_Call.Uninterpreted_Data, E);
kono
parents:
diff changeset
437
kono
parents:
diff changeset
438 exception
kono
parents:
diff changeset
439 when others =>
kono
parents:
diff changeset
440 Queuing.Broadcast_Program_Error
kono
parents:
diff changeset
441 (Self_ID, Object, Entry_Call);
kono
parents:
diff changeset
442 end;
kono
parents:
diff changeset
443
kono
parents:
diff changeset
444 if Object.Call_In_Progress = null then
kono
parents:
diff changeset
445 Requeue_Call (Self_ID, Object, Entry_Call);
kono
parents:
diff changeset
446 exit when Entry_Call.State = Cancelled;
kono
parents:
diff changeset
447
kono
parents:
diff changeset
448 else
kono
parents:
diff changeset
449 Object.Call_In_Progress := null;
kono
parents:
diff changeset
450 Caller := Entry_Call.Self;
kono
parents:
diff changeset
451
kono
parents:
diff changeset
452 if Single_Lock then
kono
parents:
diff changeset
453 STPO.Lock_RTS;
kono
parents:
diff changeset
454 end if;
kono
parents:
diff changeset
455
kono
parents:
diff changeset
456 STPO.Write_Lock (Caller);
kono
parents:
diff changeset
457 Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
kono
parents:
diff changeset
458 STPO.Unlock (Caller);
kono
parents:
diff changeset
459
kono
parents:
diff changeset
460 if Single_Lock then
kono
parents:
diff changeset
461 STPO.Unlock_RTS;
kono
parents:
diff changeset
462 end if;
kono
parents:
diff changeset
463 end if;
kono
parents:
diff changeset
464 end loop;
kono
parents:
diff changeset
465
kono
parents:
diff changeset
466 if Unlock_Object then
kono
parents:
diff changeset
467 Unlock_Entries (Object);
kono
parents:
diff changeset
468 end if;
kono
parents:
diff changeset
469 end PO_Service_Entries;
kono
parents:
diff changeset
470
kono
parents:
diff changeset
471 ---------------------
kono
parents:
diff changeset
472 -- Protected_Count --
kono
parents:
diff changeset
473 ---------------------
kono
parents:
diff changeset
474
kono
parents:
diff changeset
475 function Protected_Count
kono
parents:
diff changeset
476 (Object : Protection_Entries'Class;
kono
parents:
diff changeset
477 E : Protected_Entry_Index) return Natural
kono
parents:
diff changeset
478 is
kono
parents:
diff changeset
479 begin
kono
parents:
diff changeset
480 return Queuing.Count_Waiting (Object.Entry_Queues (E));
kono
parents:
diff changeset
481 end Protected_Count;
kono
parents:
diff changeset
482
kono
parents:
diff changeset
483 --------------------------
kono
parents:
diff changeset
484 -- Protected_Entry_Call --
kono
parents:
diff changeset
485 --------------------------
kono
parents:
diff changeset
486
kono
parents:
diff changeset
487 -- Compiler interface only (do not call from within the RTS)
kono
parents:
diff changeset
488
kono
parents:
diff changeset
489 -- select r.e;
kono
parents:
diff changeset
490 -- ...A...
kono
parents:
diff changeset
491 -- else
kono
parents:
diff changeset
492 -- ...B...
kono
parents:
diff changeset
493 -- end select;
kono
parents:
diff changeset
494
kono
parents:
diff changeset
495 -- declare
kono
parents:
diff changeset
496 -- X : protected_entry_index := 1;
kono
parents:
diff changeset
497 -- B85b : communication_block;
kono
parents:
diff changeset
498 -- communication_blockIP (B85b);
kono
parents:
diff changeset
499
kono
parents:
diff changeset
500 -- begin
kono
parents:
diff changeset
501 -- protected_entry_call (rTV!(r)._object'unchecked_access, X,
kono
parents:
diff changeset
502 -- null_address, conditional_call, B85b, objectF => 0);
kono
parents:
diff changeset
503
kono
parents:
diff changeset
504 -- if cancelled (B85b) then
kono
parents:
diff changeset
505 -- ...B...
kono
parents:
diff changeset
506 -- else
kono
parents:
diff changeset
507 -- ...A...
kono
parents:
diff changeset
508 -- end if;
kono
parents:
diff changeset
509 -- end;
kono
parents:
diff changeset
510
kono
parents:
diff changeset
511 -- See also Cancel_Protected_Entry_Call for code expansion of asynchronous
kono
parents:
diff changeset
512 -- entry call.
kono
parents:
diff changeset
513
kono
parents:
diff changeset
514 -- The initial part of this procedure does not need to lock the calling
kono
parents:
diff changeset
515 -- task's ATCB, up to the point where the call record first may be queued
kono
parents:
diff changeset
516 -- (PO_Do_Or_Queue), since before that no other task will have access to
kono
parents:
diff changeset
517 -- the record.
kono
parents:
diff changeset
518
kono
parents:
diff changeset
519 -- If this is a call made inside of an abort deferred region, the call
kono
parents:
diff changeset
520 -- should be never abortable.
kono
parents:
diff changeset
521
kono
parents:
diff changeset
522 -- If the call was not queued abortably, we need to wait until it is before
kono
parents:
diff changeset
523 -- proceeding with the abortable part.
kono
parents:
diff changeset
524
kono
parents:
diff changeset
525 -- There are some heuristics here, just to save time for frequently
kono
parents:
diff changeset
526 -- occurring cases. For example, we check Initially_Abortable to try to
kono
parents:
diff changeset
527 -- avoid calling the procedure Wait_Until_Abortable, since the normal case
kono
parents:
diff changeset
528 -- for async. entry calls is to be queued abortably.
kono
parents:
diff changeset
529
kono
parents:
diff changeset
530 -- Another heuristic uses the Block.Enqueued to try to avoid calling
kono
parents:
diff changeset
531 -- Cancel_Protected_Entry_Call if the call can be served immediately.
kono
parents:
diff changeset
532
kono
parents:
diff changeset
533 procedure Protected_Entry_Call
kono
parents:
diff changeset
534 (Object : Protection_Entries_Access;
kono
parents:
diff changeset
535 E : Protected_Entry_Index;
kono
parents:
diff changeset
536 Uninterpreted_Data : System.Address;
kono
parents:
diff changeset
537 Mode : Call_Modes;
kono
parents:
diff changeset
538 Block : out Communication_Block)
kono
parents:
diff changeset
539 is
kono
parents:
diff changeset
540 Self_ID : constant Task_Id := STPO.Self;
kono
parents:
diff changeset
541 Entry_Call : Entry_Call_Link;
kono
parents:
diff changeset
542 Initially_Abortable : Boolean;
kono
parents:
diff changeset
543 Ceiling_Violation : Boolean;
kono
parents:
diff changeset
544
kono
parents:
diff changeset
545 begin
kono
parents:
diff changeset
546 pragma Debug
kono
parents:
diff changeset
547 (Debug.Trace (Self_ID, "Protected_Entry_Call", 'P'));
kono
parents:
diff changeset
548
kono
parents:
diff changeset
549 if Self_ID.ATC_Nesting_Level = ATC_Level'Last then
kono
parents:
diff changeset
550 raise Storage_Error with "not enough ATC nesting levels";
kono
parents:
diff changeset
551 end if;
kono
parents:
diff changeset
552
kono
parents:
diff changeset
553 -- If pragma Detect_Blocking is active then Program_Error must be
kono
parents:
diff changeset
554 -- raised if this potentially blocking operation is called from a
kono
parents:
diff changeset
555 -- protected action.
kono
parents:
diff changeset
556
kono
parents:
diff changeset
557 if Detect_Blocking
kono
parents:
diff changeset
558 and then Self_ID.Common.Protected_Action_Nesting > 0
kono
parents:
diff changeset
559 then
kono
parents:
diff changeset
560 raise Program_Error with "potentially blocking operation";
kono
parents:
diff changeset
561 end if;
kono
parents:
diff changeset
562
kono
parents:
diff changeset
563 -- Self_ID.Deferral_Level should be 0, except when called from Finalize,
kono
parents:
diff changeset
564 -- where abort is already deferred.
kono
parents:
diff changeset
565
kono
parents:
diff changeset
566 Initialization.Defer_Abort_Nestable (Self_ID);
kono
parents:
diff changeset
567 Lock_Entries_With_Status (Object, Ceiling_Violation);
kono
parents:
diff changeset
568
kono
parents:
diff changeset
569 if Ceiling_Violation then
kono
parents:
diff changeset
570
kono
parents:
diff changeset
571 -- Failed ceiling check
kono
parents:
diff changeset
572
kono
parents:
diff changeset
573 Initialization.Undefer_Abort_Nestable (Self_ID);
kono
parents:
diff changeset
574 raise Program_Error;
kono
parents:
diff changeset
575 end if;
kono
parents:
diff changeset
576
kono
parents:
diff changeset
577 Block.Self := Self_ID;
kono
parents:
diff changeset
578 Self_ID.ATC_Nesting_Level := Self_ID.ATC_Nesting_Level + 1;
kono
parents:
diff changeset
579 pragma Debug
kono
parents:
diff changeset
580 (Debug.Trace (Self_ID, "PEC: entered ATC level: " &
kono
parents:
diff changeset
581 ATC_Level'Image (Self_ID.ATC_Nesting_Level), 'A'));
kono
parents:
diff changeset
582 Entry_Call :=
kono
parents:
diff changeset
583 Self_ID.Entry_Calls (Self_ID.ATC_Nesting_Level)'Access;
kono
parents:
diff changeset
584 Entry_Call.Next := null;
kono
parents:
diff changeset
585 Entry_Call.Mode := Mode;
kono
parents:
diff changeset
586 Entry_Call.Cancellation_Attempted := False;
kono
parents:
diff changeset
587
kono
parents:
diff changeset
588 Entry_Call.State :=
kono
parents:
diff changeset
589 (if Self_ID.Deferral_Level > 1
kono
parents:
diff changeset
590 then Never_Abortable else Now_Abortable);
kono
parents:
diff changeset
591
kono
parents:
diff changeset
592 Entry_Call.E := Entry_Index (E);
kono
parents:
diff changeset
593 Entry_Call.Prio := STPO.Get_Priority (Self_ID);
kono
parents:
diff changeset
594 Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
kono
parents:
diff changeset
595 Entry_Call.Called_PO := To_Address (Object);
kono
parents:
diff changeset
596 Entry_Call.Called_Task := null;
kono
parents:
diff changeset
597 Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
kono
parents:
diff changeset
598 Entry_Call.With_Abort := True;
kono
parents:
diff changeset
599
kono
parents:
diff changeset
600 PO_Do_Or_Queue (Self_ID, Object, Entry_Call);
kono
parents:
diff changeset
601 Initially_Abortable := Entry_Call.State = Now_Abortable;
kono
parents:
diff changeset
602 PO_Service_Entries (Self_ID, Object);
kono
parents:
diff changeset
603
kono
parents:
diff changeset
604 -- Try to prevent waiting later (in Try_To_Cancel_Protected_Entry_Call)
kono
parents:
diff changeset
605 -- for completed or cancelled calls. (This is a heuristic, only.)
kono
parents:
diff changeset
606
kono
parents:
diff changeset
607 if Entry_Call.State >= Done then
kono
parents:
diff changeset
608
kono
parents:
diff changeset
609 -- Once State >= Done it will not change any more
kono
parents:
diff changeset
610
kono
parents:
diff changeset
611 if Single_Lock then
kono
parents:
diff changeset
612 STPO.Lock_RTS;
kono
parents:
diff changeset
613 end if;
kono
parents:
diff changeset
614
kono
parents:
diff changeset
615 STPO.Write_Lock (Self_ID);
kono
parents:
diff changeset
616 Utilities.Exit_One_ATC_Level (Self_ID);
kono
parents:
diff changeset
617 STPO.Unlock (Self_ID);
kono
parents:
diff changeset
618
kono
parents:
diff changeset
619 if Single_Lock then
kono
parents:
diff changeset
620 STPO.Unlock_RTS;
kono
parents:
diff changeset
621 end if;
kono
parents:
diff changeset
622
kono
parents:
diff changeset
623 Block.Enqueued := False;
kono
parents:
diff changeset
624 Block.Cancelled := Entry_Call.State = Cancelled;
kono
parents:
diff changeset
625 Initialization.Undefer_Abort_Nestable (Self_ID);
kono
parents:
diff changeset
626 Entry_Calls.Check_Exception (Self_ID, Entry_Call);
kono
parents:
diff changeset
627 return;
kono
parents:
diff changeset
628
kono
parents:
diff changeset
629 else
kono
parents:
diff changeset
630 -- In this case we cannot conclude anything, since State can change
kono
parents:
diff changeset
631 -- concurrently.
kono
parents:
diff changeset
632
kono
parents:
diff changeset
633 null;
kono
parents:
diff changeset
634 end if;
kono
parents:
diff changeset
635
kono
parents:
diff changeset
636 -- Now for the general case
kono
parents:
diff changeset
637
kono
parents:
diff changeset
638 if Mode = Asynchronous_Call then
kono
parents:
diff changeset
639
kono
parents:
diff changeset
640 -- Try to avoid an expensive call
kono
parents:
diff changeset
641
kono
parents:
diff changeset
642 if not Initially_Abortable then
kono
parents:
diff changeset
643 if Single_Lock then
kono
parents:
diff changeset
644 STPO.Lock_RTS;
kono
parents:
diff changeset
645 Entry_Calls.Wait_Until_Abortable (Self_ID, Entry_Call);
kono
parents:
diff changeset
646 STPO.Unlock_RTS;
kono
parents:
diff changeset
647 else
kono
parents:
diff changeset
648 Entry_Calls.Wait_Until_Abortable (Self_ID, Entry_Call);
kono
parents:
diff changeset
649 end if;
kono
parents:
diff changeset
650 end if;
kono
parents:
diff changeset
651
kono
parents:
diff changeset
652 else
kono
parents:
diff changeset
653 case Mode is
kono
parents:
diff changeset
654 when Conditional_Call
kono
parents:
diff changeset
655 | Simple_Call
kono
parents:
diff changeset
656 =>
kono
parents:
diff changeset
657 if Single_Lock then
kono
parents:
diff changeset
658 STPO.Lock_RTS;
kono
parents:
diff changeset
659 Entry_Calls.Wait_For_Completion (Entry_Call);
kono
parents:
diff changeset
660 STPO.Unlock_RTS;
kono
parents:
diff changeset
661
kono
parents:
diff changeset
662 else
kono
parents:
diff changeset
663 STPO.Write_Lock (Self_ID);
kono
parents:
diff changeset
664 Entry_Calls.Wait_For_Completion (Entry_Call);
kono
parents:
diff changeset
665 STPO.Unlock (Self_ID);
kono
parents:
diff changeset
666 end if;
kono
parents:
diff changeset
667
kono
parents:
diff changeset
668 Block.Cancelled := Entry_Call.State = Cancelled;
kono
parents:
diff changeset
669
kono
parents:
diff changeset
670 when Asynchronous_Call
kono
parents:
diff changeset
671 | Timed_Call
kono
parents:
diff changeset
672 =>
kono
parents:
diff changeset
673 pragma Assert (False);
kono
parents:
diff changeset
674 null;
kono
parents:
diff changeset
675 end case;
kono
parents:
diff changeset
676 end if;
kono
parents:
diff changeset
677
kono
parents:
diff changeset
678 Initialization.Undefer_Abort_Nestable (Self_ID);
kono
parents:
diff changeset
679 Entry_Calls.Check_Exception (Self_ID, Entry_Call);
kono
parents:
diff changeset
680 end Protected_Entry_Call;
kono
parents:
diff changeset
681
kono
parents:
diff changeset
682 ------------------
kono
parents:
diff changeset
683 -- Requeue_Call --
kono
parents:
diff changeset
684 ------------------
kono
parents:
diff changeset
685
kono
parents:
diff changeset
686 procedure Requeue_Call
kono
parents:
diff changeset
687 (Self_Id : Task_Id;
kono
parents:
diff changeset
688 Object : Protection_Entries_Access;
kono
parents:
diff changeset
689 Entry_Call : Entry_Call_Link)
kono
parents:
diff changeset
690 is
kono
parents:
diff changeset
691 New_Object : Protection_Entries_Access;
kono
parents:
diff changeset
692 Ceiling_Violation : Boolean;
kono
parents:
diff changeset
693 Result : Boolean;
kono
parents:
diff changeset
694 E : Protected_Entry_Index;
kono
parents:
diff changeset
695
kono
parents:
diff changeset
696 begin
kono
parents:
diff changeset
697 New_Object := To_Protection (Entry_Call.Called_PO);
kono
parents:
diff changeset
698
kono
parents:
diff changeset
699 if New_Object = null then
kono
parents:
diff changeset
700
kono
parents:
diff changeset
701 -- Call is to be requeued to a task entry
kono
parents:
diff changeset
702
kono
parents:
diff changeset
703 if Single_Lock then
kono
parents:
diff changeset
704 STPO.Lock_RTS;
kono
parents:
diff changeset
705 end if;
kono
parents:
diff changeset
706
kono
parents:
diff changeset
707 Result := Rendezvous.Task_Do_Or_Queue (Self_Id, Entry_Call);
kono
parents:
diff changeset
708
kono
parents:
diff changeset
709 if not Result then
kono
parents:
diff changeset
710 Queuing.Broadcast_Program_Error
kono
parents:
diff changeset
711 (Self_Id, Object, Entry_Call, RTS_Locked => True);
kono
parents:
diff changeset
712 end if;
kono
parents:
diff changeset
713
kono
parents:
diff changeset
714 if Single_Lock then
kono
parents:
diff changeset
715 STPO.Unlock_RTS;
kono
parents:
diff changeset
716 end if;
kono
parents:
diff changeset
717
kono
parents:
diff changeset
718 else
kono
parents:
diff changeset
719 -- Call should be requeued to a PO
kono
parents:
diff changeset
720
kono
parents:
diff changeset
721 if Object /= New_Object then
kono
parents:
diff changeset
722
kono
parents:
diff changeset
723 -- Requeue is to different PO
kono
parents:
diff changeset
724
kono
parents:
diff changeset
725 Lock_Entries_With_Status (New_Object, Ceiling_Violation);
kono
parents:
diff changeset
726
kono
parents:
diff changeset
727 if Ceiling_Violation then
kono
parents:
diff changeset
728 Object.Call_In_Progress := null;
kono
parents:
diff changeset
729 Queuing.Broadcast_Program_Error (Self_Id, Object, Entry_Call);
kono
parents:
diff changeset
730
kono
parents:
diff changeset
731 else
kono
parents:
diff changeset
732 PO_Do_Or_Queue (Self_Id, New_Object, Entry_Call);
kono
parents:
diff changeset
733 PO_Service_Entries (Self_Id, New_Object);
kono
parents:
diff changeset
734 end if;
kono
parents:
diff changeset
735
kono
parents:
diff changeset
736 else
kono
parents:
diff changeset
737 -- Requeue is to same protected object
kono
parents:
diff changeset
738
kono
parents:
diff changeset
739 -- ??? Try to compensate apparent failure of the scheduler on some
kono
parents:
diff changeset
740 -- OS (e.g VxWorks) to give higher priority tasks a chance to run
kono
parents:
diff changeset
741 -- (see CXD6002).
kono
parents:
diff changeset
742
kono
parents:
diff changeset
743 STPO.Yield (Do_Yield => False);
kono
parents:
diff changeset
744
kono
parents:
diff changeset
745 if Entry_Call.With_Abort
kono
parents:
diff changeset
746 and then Entry_Call.Cancellation_Attempted
kono
parents:
diff changeset
747 then
kono
parents:
diff changeset
748 -- If this is a requeue with abort and someone tried to cancel
kono
parents:
diff changeset
749 -- this call, cancel it at this point.
kono
parents:
diff changeset
750
kono
parents:
diff changeset
751 Entry_Call.State := Cancelled;
kono
parents:
diff changeset
752 return;
kono
parents:
diff changeset
753 end if;
kono
parents:
diff changeset
754
kono
parents:
diff changeset
755 if not Entry_Call.With_Abort
kono
parents:
diff changeset
756 or else Entry_Call.Mode /= Conditional_Call
kono
parents:
diff changeset
757 then
kono
parents:
diff changeset
758 E := Protected_Entry_Index (Entry_Call.E);
kono
parents:
diff changeset
759
kono
parents:
diff changeset
760 if Run_Time_Restrictions.Set (Max_Entry_Queue_Length)
kono
parents:
diff changeset
761 and then
kono
parents:
diff changeset
762 Run_Time_Restrictions.Value (Max_Entry_Queue_Length) <=
kono
parents:
diff changeset
763 Queuing.Count_Waiting (Object.Entry_Queues (E))
kono
parents:
diff changeset
764 then
kono
parents:
diff changeset
765 -- This violates the Max_Entry_Queue_Length restriction,
kono
parents:
diff changeset
766 -- raise Program_Error.
kono
parents:
diff changeset
767
kono
parents:
diff changeset
768 Entry_Call.Exception_To_Raise := Program_Error'Identity;
kono
parents:
diff changeset
769
kono
parents:
diff changeset
770 if Single_Lock then
kono
parents:
diff changeset
771 STPO.Lock_RTS;
kono
parents:
diff changeset
772 end if;
kono
parents:
diff changeset
773
kono
parents:
diff changeset
774 STPO.Write_Lock (Entry_Call.Self);
kono
parents:
diff changeset
775 Initialization.Wakeup_Entry_Caller
kono
parents:
diff changeset
776 (Self_Id, Entry_Call, Done);
kono
parents:
diff changeset
777 STPO.Unlock (Entry_Call.Self);
kono
parents:
diff changeset
778
kono
parents:
diff changeset
779 if Single_Lock then
kono
parents:
diff changeset
780 STPO.Unlock_RTS;
kono
parents:
diff changeset
781 end if;
kono
parents:
diff changeset
782
kono
parents:
diff changeset
783 else
kono
parents:
diff changeset
784 Queuing.Enqueue
kono
parents:
diff changeset
785 (New_Object.Entry_Queues (E), Entry_Call);
kono
parents:
diff changeset
786 Update_For_Queue_To_PO (Entry_Call, Entry_Call.With_Abort);
kono
parents:
diff changeset
787 end if;
kono
parents:
diff changeset
788
kono
parents:
diff changeset
789 else
kono
parents:
diff changeset
790 PO_Do_Or_Queue (Self_Id, New_Object, Entry_Call);
kono
parents:
diff changeset
791 end if;
kono
parents:
diff changeset
792 end if;
kono
parents:
diff changeset
793 end if;
kono
parents:
diff changeset
794 end Requeue_Call;
kono
parents:
diff changeset
795
kono
parents:
diff changeset
796 ----------------------------
kono
parents:
diff changeset
797 -- Protected_Entry_Caller --
kono
parents:
diff changeset
798 ----------------------------
kono
parents:
diff changeset
799
kono
parents:
diff changeset
800 function Protected_Entry_Caller
kono
parents:
diff changeset
801 (Object : Protection_Entries'Class) return Task_Id is
kono
parents:
diff changeset
802 begin
kono
parents:
diff changeset
803 return Object.Call_In_Progress.Self;
kono
parents:
diff changeset
804 end Protected_Entry_Caller;
kono
parents:
diff changeset
805
kono
parents:
diff changeset
806 -----------------------------
kono
parents:
diff changeset
807 -- Requeue_Protected_Entry --
kono
parents:
diff changeset
808 -----------------------------
kono
parents:
diff changeset
809
kono
parents:
diff changeset
810 -- Compiler interface only (do not call from within the RTS)
kono
parents:
diff changeset
811
kono
parents:
diff changeset
812 -- entry e when b is
kono
parents:
diff changeset
813 -- begin
kono
parents:
diff changeset
814 -- b := false;
kono
parents:
diff changeset
815 -- ...A...
kono
parents:
diff changeset
816 -- requeue e2;
kono
parents:
diff changeset
817 -- end e;
kono
parents:
diff changeset
818
kono
parents:
diff changeset
819 -- procedure rPT__E10b (O : address; P : address; E :
kono
parents:
diff changeset
820 -- protected_entry_index) is
kono
parents:
diff changeset
821 -- type rTVP is access rTV;
kono
parents:
diff changeset
822 -- freeze rTVP []
kono
parents:
diff changeset
823 -- _object : rTVP := rTVP!(O);
kono
parents:
diff changeset
824 -- begin
kono
parents:
diff changeset
825 -- declare
kono
parents:
diff changeset
826 -- rR : protection renames _object._object;
kono
parents:
diff changeset
827 -- vP : integer renames _object.v;
kono
parents:
diff changeset
828 -- bP : boolean renames _object.b;
kono
parents:
diff changeset
829 -- begin
kono
parents:
diff changeset
830 -- b := false;
kono
parents:
diff changeset
831 -- ...A...
kono
parents:
diff changeset
832 -- requeue_protected_entry (rR'unchecked_access, rR'
kono
parents:
diff changeset
833 -- unchecked_access, 2, false, objectF => 0, new_objectF =>
kono
parents:
diff changeset
834 -- 0);
kono
parents:
diff changeset
835 -- return;
kono
parents:
diff changeset
836 -- end;
kono
parents:
diff changeset
837 -- complete_entry_body (_object._object'unchecked_access, objectF =>
kono
parents:
diff changeset
838 -- 0);
kono
parents:
diff changeset
839 -- return;
kono
parents:
diff changeset
840 -- exception
kono
parents:
diff changeset
841 -- when others =>
kono
parents:
diff changeset
842 -- abort_undefer.all;
kono
parents:
diff changeset
843 -- exceptional_complete_entry_body (_object._object'
kono
parents:
diff changeset
844 -- unchecked_access, current_exception, objectF => 0);
kono
parents:
diff changeset
845 -- return;
kono
parents:
diff changeset
846 -- end rPT__E10b;
kono
parents:
diff changeset
847
kono
parents:
diff changeset
848 procedure Requeue_Protected_Entry
kono
parents:
diff changeset
849 (Object : Protection_Entries_Access;
kono
parents:
diff changeset
850 New_Object : Protection_Entries_Access;
kono
parents:
diff changeset
851 E : Protected_Entry_Index;
kono
parents:
diff changeset
852 With_Abort : Boolean)
kono
parents:
diff changeset
853 is
kono
parents:
diff changeset
854 Entry_Call : constant Entry_Call_Link := Object.Call_In_Progress;
kono
parents:
diff changeset
855
kono
parents:
diff changeset
856 begin
kono
parents:
diff changeset
857 pragma Debug
kono
parents:
diff changeset
858 (Debug.Trace (STPO.Self, "Requeue_Protected_Entry", 'P'));
kono
parents:
diff changeset
859 pragma Assert (STPO.Self.Deferral_Level > 0);
kono
parents:
diff changeset
860
kono
parents:
diff changeset
861 Entry_Call.E := Entry_Index (E);
kono
parents:
diff changeset
862 Entry_Call.Called_PO := To_Address (New_Object);
kono
parents:
diff changeset
863 Entry_Call.Called_Task := null;
kono
parents:
diff changeset
864 Entry_Call.With_Abort := With_Abort;
kono
parents:
diff changeset
865 Object.Call_In_Progress := null;
kono
parents:
diff changeset
866 end Requeue_Protected_Entry;
kono
parents:
diff changeset
867
kono
parents:
diff changeset
868 -------------------------------------
kono
parents:
diff changeset
869 -- Requeue_Task_To_Protected_Entry --
kono
parents:
diff changeset
870 -------------------------------------
kono
parents:
diff changeset
871
kono
parents:
diff changeset
872 -- Compiler interface only (do not call from within the RTS)
kono
parents:
diff changeset
873
kono
parents:
diff changeset
874 -- accept e1 do
kono
parents:
diff changeset
875 -- ...A...
kono
parents:
diff changeset
876 -- requeue r.e2;
kono
parents:
diff changeset
877 -- end e1;
kono
parents:
diff changeset
878
kono
parents:
diff changeset
879 -- A79b : address;
kono
parents:
diff changeset
880 -- L78b : label
kono
parents:
diff changeset
881
kono
parents:
diff changeset
882 -- begin
kono
parents:
diff changeset
883 -- accept_call (1, A79b);
kono
parents:
diff changeset
884 -- ...A...
kono
parents:
diff changeset
885 -- requeue_task_to_protected_entry (rTV!(r)._object'
kono
parents:
diff changeset
886 -- unchecked_access, 2, false, new_objectF => 0);
kono
parents:
diff changeset
887 -- goto L78b;
kono
parents:
diff changeset
888 -- <<L78b>>
kono
parents:
diff changeset
889 -- complete_rendezvous;
kono
parents:
diff changeset
890
kono
parents:
diff changeset
891 -- exception
kono
parents:
diff changeset
892 -- when all others =>
kono
parents:
diff changeset
893 -- exceptional_complete_rendezvous (get_gnat_exception);
kono
parents:
diff changeset
894 -- end;
kono
parents:
diff changeset
895
kono
parents:
diff changeset
896 procedure Requeue_Task_To_Protected_Entry
kono
parents:
diff changeset
897 (New_Object : Protection_Entries_Access;
kono
parents:
diff changeset
898 E : Protected_Entry_Index;
kono
parents:
diff changeset
899 With_Abort : Boolean)
kono
parents:
diff changeset
900 is
kono
parents:
diff changeset
901 Self_ID : constant Task_Id := STPO.Self;
kono
parents:
diff changeset
902 Entry_Call : constant Entry_Call_Link := Self_ID.Common.Call;
kono
parents:
diff changeset
903
kono
parents:
diff changeset
904 begin
kono
parents:
diff changeset
905 Initialization.Defer_Abort (Self_ID);
kono
parents:
diff changeset
906
kono
parents:
diff changeset
907 -- We do not need to lock Self_ID here since the call is not abortable
kono
parents:
diff changeset
908 -- at this point, and therefore, the caller cannot cancel the call.
kono
parents:
diff changeset
909
kono
parents:
diff changeset
910 Entry_Call.Needs_Requeue := True;
kono
parents:
diff changeset
911 Entry_Call.With_Abort := With_Abort;
kono
parents:
diff changeset
912 Entry_Call.Called_PO := To_Address (New_Object);
kono
parents:
diff changeset
913 Entry_Call.Called_Task := null;
kono
parents:
diff changeset
914 Entry_Call.E := Entry_Index (E);
kono
parents:
diff changeset
915 Initialization.Undefer_Abort (Self_ID);
kono
parents:
diff changeset
916 end Requeue_Task_To_Protected_Entry;
kono
parents:
diff changeset
917
kono
parents:
diff changeset
918 ---------------------
kono
parents:
diff changeset
919 -- Service_Entries --
kono
parents:
diff changeset
920 ---------------------
kono
parents:
diff changeset
921
kono
parents:
diff changeset
922 procedure Service_Entries (Object : Protection_Entries_Access) is
kono
parents:
diff changeset
923 Self_ID : constant Task_Id := STPO.Self;
kono
parents:
diff changeset
924 begin
kono
parents:
diff changeset
925 PO_Service_Entries (Self_ID, Object);
kono
parents:
diff changeset
926 end Service_Entries;
kono
parents:
diff changeset
927
kono
parents:
diff changeset
928 --------------------------------
kono
parents:
diff changeset
929 -- Timed_Protected_Entry_Call --
kono
parents:
diff changeset
930 --------------------------------
kono
parents:
diff changeset
931
kono
parents:
diff changeset
932 -- Compiler interface only (do not call from within the RTS)
kono
parents:
diff changeset
933
kono
parents:
diff changeset
934 procedure Timed_Protected_Entry_Call
kono
parents:
diff changeset
935 (Object : Protection_Entries_Access;
kono
parents:
diff changeset
936 E : Protected_Entry_Index;
kono
parents:
diff changeset
937 Uninterpreted_Data : System.Address;
kono
parents:
diff changeset
938 Timeout : Duration;
kono
parents:
diff changeset
939 Mode : Delay_Modes;
kono
parents:
diff changeset
940 Entry_Call_Successful : out Boolean)
kono
parents:
diff changeset
941 is
kono
parents:
diff changeset
942 Self_Id : constant Task_Id := STPO.Self;
kono
parents:
diff changeset
943 Entry_Call : Entry_Call_Link;
kono
parents:
diff changeset
944 Ceiling_Violation : Boolean;
kono
parents:
diff changeset
945
kono
parents:
diff changeset
946 Yielded : Boolean;
kono
parents:
diff changeset
947 pragma Unreferenced (Yielded);
kono
parents:
diff changeset
948
kono
parents:
diff changeset
949 begin
kono
parents:
diff changeset
950 if Self_Id.ATC_Nesting_Level = ATC_Level'Last then
kono
parents:
diff changeset
951 raise Storage_Error with "not enough ATC nesting levels";
kono
parents:
diff changeset
952 end if;
kono
parents:
diff changeset
953
kono
parents:
diff changeset
954 -- If pragma Detect_Blocking is active then Program_Error must be
kono
parents:
diff changeset
955 -- raised if this potentially blocking operation is called from a
kono
parents:
diff changeset
956 -- protected action.
kono
parents:
diff changeset
957
kono
parents:
diff changeset
958 if Detect_Blocking
kono
parents:
diff changeset
959 and then Self_Id.Common.Protected_Action_Nesting > 0
kono
parents:
diff changeset
960 then
kono
parents:
diff changeset
961 raise Program_Error with "potentially blocking operation";
kono
parents:
diff changeset
962 end if;
kono
parents:
diff changeset
963
kono
parents:
diff changeset
964 Initialization.Defer_Abort_Nestable (Self_Id);
kono
parents:
diff changeset
965 Lock_Entries_With_Status (Object, Ceiling_Violation);
kono
parents:
diff changeset
966
kono
parents:
diff changeset
967 if Ceiling_Violation then
kono
parents:
diff changeset
968 Initialization.Undefer_Abort (Self_Id);
kono
parents:
diff changeset
969 raise Program_Error;
kono
parents:
diff changeset
970 end if;
kono
parents:
diff changeset
971
kono
parents:
diff changeset
972 Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
kono
parents:
diff changeset
973 pragma Debug
kono
parents:
diff changeset
974 (Debug.Trace (Self_Id, "TPEC: exited to ATC level: " &
kono
parents:
diff changeset
975 ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
kono
parents:
diff changeset
976 Entry_Call := Self_Id.Entry_Calls (Self_Id.ATC_Nesting_Level)'Access;
kono
parents:
diff changeset
977 Entry_Call.Next := null;
kono
parents:
diff changeset
978 Entry_Call.Mode := Timed_Call;
kono
parents:
diff changeset
979 Entry_Call.Cancellation_Attempted := False;
kono
parents:
diff changeset
980
kono
parents:
diff changeset
981 Entry_Call.State :=
kono
parents:
diff changeset
982 (if Self_Id.Deferral_Level > 1
kono
parents:
diff changeset
983 then Never_Abortable
kono
parents:
diff changeset
984 else Now_Abortable);
kono
parents:
diff changeset
985
kono
parents:
diff changeset
986 Entry_Call.E := Entry_Index (E);
kono
parents:
diff changeset
987 Entry_Call.Prio := STPO.Get_Priority (Self_Id);
kono
parents:
diff changeset
988 Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
kono
parents:
diff changeset
989 Entry_Call.Called_PO := To_Address (Object);
kono
parents:
diff changeset
990 Entry_Call.Called_Task := null;
kono
parents:
diff changeset
991 Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
kono
parents:
diff changeset
992 Entry_Call.With_Abort := True;
kono
parents:
diff changeset
993
kono
parents:
diff changeset
994 PO_Do_Or_Queue (Self_Id, Object, Entry_Call);
kono
parents:
diff changeset
995 PO_Service_Entries (Self_Id, Object);
kono
parents:
diff changeset
996
kono
parents:
diff changeset
997 if Single_Lock then
kono
parents:
diff changeset
998 STPO.Lock_RTS;
kono
parents:
diff changeset
999 else
kono
parents:
diff changeset
1000 STPO.Write_Lock (Self_Id);
kono
parents:
diff changeset
1001 end if;
kono
parents:
diff changeset
1002
kono
parents:
diff changeset
1003 -- Try to avoid waiting for completed or cancelled calls
kono
parents:
diff changeset
1004
kono
parents:
diff changeset
1005 if Entry_Call.State >= Done then
kono
parents:
diff changeset
1006 Utilities.Exit_One_ATC_Level (Self_Id);
kono
parents:
diff changeset
1007
kono
parents:
diff changeset
1008 if Single_Lock then
kono
parents:
diff changeset
1009 STPO.Unlock_RTS;
kono
parents:
diff changeset
1010 else
kono
parents:
diff changeset
1011 STPO.Unlock (Self_Id);
kono
parents:
diff changeset
1012 end if;
kono
parents:
diff changeset
1013
kono
parents:
diff changeset
1014 Entry_Call_Successful := Entry_Call.State = Done;
kono
parents:
diff changeset
1015 Initialization.Undefer_Abort_Nestable (Self_Id);
kono
parents:
diff changeset
1016 Entry_Calls.Check_Exception (Self_Id, Entry_Call);
kono
parents:
diff changeset
1017 return;
kono
parents:
diff changeset
1018 end if;
kono
parents:
diff changeset
1019
kono
parents:
diff changeset
1020 Entry_Calls.Wait_For_Completion_With_Timeout
kono
parents:
diff changeset
1021 (Entry_Call, Timeout, Mode, Yielded);
kono
parents:
diff changeset
1022
kono
parents:
diff changeset
1023 if Single_Lock then
kono
parents:
diff changeset
1024 STPO.Unlock_RTS;
kono
parents:
diff changeset
1025 else
kono
parents:
diff changeset
1026 STPO.Unlock (Self_Id);
kono
parents:
diff changeset
1027 end if;
kono
parents:
diff changeset
1028
kono
parents:
diff changeset
1029 -- ??? Do we need to yield in case Yielded is False
kono
parents:
diff changeset
1030
kono
parents:
diff changeset
1031 Initialization.Undefer_Abort_Nestable (Self_Id);
kono
parents:
diff changeset
1032 Entry_Call_Successful := Entry_Call.State = Done;
kono
parents:
diff changeset
1033 Entry_Calls.Check_Exception (Self_Id, Entry_Call);
kono
parents:
diff changeset
1034 end Timed_Protected_Entry_Call;
kono
parents:
diff changeset
1035
kono
parents:
diff changeset
1036 ----------------------------
kono
parents:
diff changeset
1037 -- Update_For_Queue_To_PO --
kono
parents:
diff changeset
1038 ----------------------------
kono
parents:
diff changeset
1039
kono
parents:
diff changeset
1040 -- Update the state of an existing entry call, based on
kono
parents:
diff changeset
1041 -- whether the current queuing action is with or without abort.
kono
parents:
diff changeset
1042 -- Call this only while holding the server's lock.
kono
parents:
diff changeset
1043 -- It returns with the server's lock released.
kono
parents:
diff changeset
1044
kono
parents:
diff changeset
1045 New_State : constant array (Boolean, Entry_Call_State)
kono
parents:
diff changeset
1046 of Entry_Call_State :=
kono
parents:
diff changeset
1047 (True =>
kono
parents:
diff changeset
1048 (Never_Abortable => Never_Abortable,
kono
parents:
diff changeset
1049 Not_Yet_Abortable => Now_Abortable,
kono
parents:
diff changeset
1050 Was_Abortable => Now_Abortable,
kono
parents:
diff changeset
1051 Now_Abortable => Now_Abortable,
kono
parents:
diff changeset
1052 Done => Done,
kono
parents:
diff changeset
1053 Cancelled => Cancelled),
kono
parents:
diff changeset
1054 False =>
kono
parents:
diff changeset
1055 (Never_Abortable => Never_Abortable,
kono
parents:
diff changeset
1056 Not_Yet_Abortable => Not_Yet_Abortable,
kono
parents:
diff changeset
1057 Was_Abortable => Was_Abortable,
kono
parents:
diff changeset
1058 Now_Abortable => Now_Abortable,
kono
parents:
diff changeset
1059 Done => Done,
kono
parents:
diff changeset
1060 Cancelled => Cancelled)
kono
parents:
diff changeset
1061 );
kono
parents:
diff changeset
1062
kono
parents:
diff changeset
1063 procedure Update_For_Queue_To_PO
kono
parents:
diff changeset
1064 (Entry_Call : Entry_Call_Link;
kono
parents:
diff changeset
1065 With_Abort : Boolean)
kono
parents:
diff changeset
1066 is
kono
parents:
diff changeset
1067 Old : constant Entry_Call_State := Entry_Call.State;
kono
parents:
diff changeset
1068
kono
parents:
diff changeset
1069 begin
kono
parents:
diff changeset
1070 pragma Assert (Old < Done);
kono
parents:
diff changeset
1071
kono
parents:
diff changeset
1072 Entry_Call.State := New_State (With_Abort, Entry_Call.State);
kono
parents:
diff changeset
1073
kono
parents:
diff changeset
1074 if Entry_Call.Mode = Asynchronous_Call then
kono
parents:
diff changeset
1075 if Old < Was_Abortable and then
kono
parents:
diff changeset
1076 Entry_Call.State = Now_Abortable
kono
parents:
diff changeset
1077 then
kono
parents:
diff changeset
1078 if Single_Lock then
kono
parents:
diff changeset
1079 STPO.Lock_RTS;
kono
parents:
diff changeset
1080 end if;
kono
parents:
diff changeset
1081
kono
parents:
diff changeset
1082 STPO.Write_Lock (Entry_Call.Self);
kono
parents:
diff changeset
1083
kono
parents:
diff changeset
1084 if Entry_Call.Self.Common.State = Async_Select_Sleep then
kono
parents:
diff changeset
1085 STPO.Wakeup (Entry_Call.Self, Async_Select_Sleep);
kono
parents:
diff changeset
1086 end if;
kono
parents:
diff changeset
1087
kono
parents:
diff changeset
1088 STPO.Unlock (Entry_Call.Self);
kono
parents:
diff changeset
1089
kono
parents:
diff changeset
1090 if Single_Lock then
kono
parents:
diff changeset
1091 STPO.Unlock_RTS;
kono
parents:
diff changeset
1092 end if;
kono
parents:
diff changeset
1093
kono
parents:
diff changeset
1094 end if;
kono
parents:
diff changeset
1095
kono
parents:
diff changeset
1096 elsif Entry_Call.Mode = Conditional_Call then
kono
parents:
diff changeset
1097 pragma Assert (Entry_Call.State < Was_Abortable);
kono
parents:
diff changeset
1098 null;
kono
parents:
diff changeset
1099 end if;
kono
parents:
diff changeset
1100 end Update_For_Queue_To_PO;
kono
parents:
diff changeset
1101
kono
parents:
diff changeset
1102 end System.Tasking.Protected_Objects.Operations;