1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
5 -- SYSTEM.TASKING.PROTECTED_OBJECTS.SINGLE_ENTRY --
9 -- Copyright (C) 1998-2023, Free Software Foundation, Inc. --
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. --
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. --
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/>. --
27 -- GNARL was developed by the GNARL team at Florida State University. --
28 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
30 ------------------------------------------------------------------------------
32 pragma Style_Checks
(All_Checks
);
33 -- Turn off subprogram ordering check, since restricted GNARLI subprograms are
34 -- gathered together at end.
36 -- This package provides an optimized version of Protected_Objects.Operations
37 -- and Protected_Objects.Entries making the following assumptions:
39 -- PO has 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
46 -- None of the tasks will terminate (no need for finalization)
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, and is relatively cheap (see PO_Do_Or_Queue,
55 pragma Suppress
(All_Checks
);
56 -- Why is this required ???
60 with System
.Task_Primitives
.Operations
;
62 package body System
.Tasking
.Protected_Objects
.Single_Entry
is
64 package STPO
renames System
.Task_Primitives
.Operations
;
66 -----------------------
67 -- Local Subprograms --
68 -----------------------
70 procedure Send_Program_Error
(Entry_Call
: Entry_Call_Link
);
71 pragma Inline
(Send_Program_Error
);
72 -- Raise Program_Error in the caller of the specified entry call
74 --------------------------
75 -- Entry Calls Handling --
76 --------------------------
78 procedure Wakeup_Entry_Caller
(Entry_Call
: Entry_Call_Link
);
79 pragma Inline
(Wakeup_Entry_Caller
);
80 -- This is called at the end of service of an entry call, to abort the
81 -- caller if he is in an abortable part, and to wake up the caller if he
82 -- is on Entry_Caller_Sleep. Call it holding the lock of Entry_Call.Self.
84 procedure Wait_For_Completion
(Entry_Call
: Entry_Call_Link
);
85 pragma Inline
(Wait_For_Completion
);
86 -- This procedure suspends the calling task until the specified entry call
87 -- has either been completed or cancelled. On exit, the call will not be
88 -- queued. This waits for calls on protected entries.
89 -- Call this only when holding Self_ID locked.
91 procedure Check_Exception
93 Entry_Call
: Entry_Call_Link
);
94 pragma Inline
(Check_Exception
);
95 -- Raise any pending exception from the Entry_Call. This should be called
96 -- at the end of every compiler interface procedure that implements an
97 -- entry call. The caller should not be holding any locks, or there will
100 procedure PO_Do_Or_Queue
101 (Object
: Protection_Entry_Access
;
102 Entry_Call
: Entry_Call_Link
);
103 -- This procedure executes or queues an entry call, depending on the status
104 -- of the corresponding barrier. The specified object is assumed locked.
106 ---------------------
107 -- Check_Exception --
108 ---------------------
110 procedure Check_Exception
112 Entry_Call
: Entry_Call_Link
)
114 pragma Warnings
(Off
, Self_ID
);
116 procedure Internal_Raise
(X
: Ada
.Exceptions
.Exception_Id
);
117 pragma Import
(C
, Internal_Raise
, "__gnat_raise_with_msg");
119 use type Ada
.Exceptions
.Exception_Id
;
121 E
: constant Ada
.Exceptions
.Exception_Id
:=
122 Entry_Call
.Exception_To_Raise
;
125 if E
/= Ada
.Exceptions
.Null_Id
then
130 ------------------------
131 -- Send_Program_Error --
132 ------------------------
134 procedure Send_Program_Error
(Entry_Call
: Entry_Call_Link
) is
135 Caller
: constant Task_Id
:= Entry_Call
.Self
;
138 Entry_Call
.Exception_To_Raise
:= Program_Error
'Identity;
139 STPO
.Write_Lock
(Caller
);
140 Wakeup_Entry_Caller
(Entry_Call
);
141 STPO
.Unlock
(Caller
);
142 end Send_Program_Error
;
144 -------------------------
145 -- Wait_For_Completion --
146 -------------------------
148 procedure Wait_For_Completion
(Entry_Call
: Entry_Call_Link
) is
149 Self_Id
: constant Task_Id
:= Entry_Call
.Self
;
151 Self_Id
.Common
.State
:= Entry_Caller_Sleep
;
152 STPO
.Sleep
(Self_Id
, Entry_Caller_Sleep
);
153 Self_Id
.Common
.State
:= Runnable
;
154 end Wait_For_Completion
;
156 -------------------------
157 -- Wakeup_Entry_Caller --
158 -------------------------
160 -- This is called at the end of service of an entry call, to abort the
161 -- caller if he is in an abortable part, and to wake up the caller if it
162 -- is on Entry_Caller_Sleep. It assumes that the call is already off-queue.
164 -- (This enforces the rule that a task must be off-queue if its state is
165 -- Done or Cancelled.) Call it holding the lock of Entry_Call.Self.
167 -- The caller is waiting on Entry_Caller_Sleep, in Wait_For_Completion.
169 procedure Wakeup_Entry_Caller
170 (Entry_Call
: Entry_Call_Link
)
172 Caller
: constant Task_Id
:= Entry_Call
.Self
;
175 (Caller
.Common
.State
/= Terminated
and then
176 Caller
.Common
.State
/= Unactivated
);
177 Entry_Call
.State
:= Done
;
178 STPO
.Wakeup
(Caller
, Entry_Caller_Sleep
);
179 end Wakeup_Entry_Caller
;
181 -----------------------
182 -- Restricted GNARLI --
183 -----------------------
185 --------------------------------------------
186 -- Exceptional_Complete_Single_Entry_Body --
187 --------------------------------------------
189 procedure Exceptional_Complete_Single_Entry_Body
190 (Object
: Protection_Entry_Access
;
191 Ex
: Ada
.Exceptions
.Exception_Id
)
194 Object
.Call_In_Progress
.Exception_To_Raise
:= Ex
;
195 end Exceptional_Complete_Single_Entry_Body
;
197 ---------------------------------
198 -- Initialize_Protection_Entry --
199 ---------------------------------
201 procedure Initialize_Protection_Entry
202 (Object
: Protection_Entry_Access
;
203 Ceiling_Priority
: Integer;
204 Compiler_Info
: System
.Address
;
205 Entry_Body
: Entry_Body_Access
)
208 Initialize_Protection
(Object
.Common
'Access, Ceiling_Priority
);
210 Object
.Compiler_Info
:= Compiler_Info
;
211 Object
.Call_In_Progress
:= null;
212 Object
.Entry_Body
:= Entry_Body
;
213 Object
.Entry_Queue
:= null;
214 end Initialize_Protection_Entry
;
220 -- Compiler interface only
222 -- Do not call this procedure from within the run-time system.
224 procedure Lock_Entry
(Object
: Protection_Entry_Access
) is
226 Lock
(Object
.Common
'Access);
229 --------------------------
230 -- Lock_Read_Only_Entry --
231 --------------------------
233 -- Compiler interface only
235 -- Do not call this procedure from within the runtime system
237 procedure Lock_Read_Only_Entry
(Object
: Protection_Entry_Access
) is
239 Lock_Read_Only
(Object
.Common
'Access);
240 end Lock_Read_Only_Entry
;
246 procedure PO_Do_Or_Queue
247 (Object
: Protection_Entry_Access
;
248 Entry_Call
: Entry_Call_Link
)
250 Barrier_Value
: Boolean;
253 -- When the Action procedure for an entry body returns, it must be
254 -- completed (having called [Exceptional_]Complete_Entry_Body).
256 Barrier_Value
:= Object
.Entry_Body
.Barrier
(Object
.Compiler_Info
, 1);
258 if Barrier_Value
then
259 if Object
.Call_In_Progress
/= null then
261 -- This violates the No_Entry_Queue restriction, send
262 -- Program_Error to the caller.
264 Send_Program_Error
(Entry_Call
);
268 Object
.Call_In_Progress
:= Entry_Call
;
269 Object
.Entry_Body
.Action
270 (Object
.Compiler_Info
, Entry_Call
.Uninterpreted_Data
, 1);
271 Object
.Call_In_Progress
:= null;
273 STPO
.Write_Lock
(Entry_Call
.Self
);
274 Wakeup_Entry_Caller
(Entry_Call
);
275 STPO
.Unlock
(Entry_Call
.Self
);
278 pragma Assert
(Entry_Call
.Mode
= Simple_Call
);
280 if Object
.Entry_Queue
/= null then
282 -- This violates the No_Entry_Queue restriction, send
283 -- Program_Error to the caller.
285 Send_Program_Error
(Entry_Call
);
288 Object
.Entry_Queue
:= Entry_Call
;
295 Send_Program_Error
(Entry_Call
);
298 ---------------------------
299 -- Protected_Count_Entry --
300 ---------------------------
302 function Protected_Count_Entry
(Object
: Protection_Entry
) return Natural is
304 if Object
.Entry_Queue
/= null then
309 end Protected_Count_Entry
;
311 ---------------------------------
312 -- Protected_Single_Entry_Call --
313 ---------------------------------
315 procedure Protected_Single_Entry_Call
316 (Object
: Protection_Entry_Access
;
317 Uninterpreted_Data
: System
.Address
)
319 Self_Id
: constant Task_Id
:= STPO
.Self
;
320 Entry_Call
: Entry_Call_Record
renames
321 Self_Id
.Entry_Calls
(Self_Id
.Entry_Calls
'First);
323 -- If pragma Detect_Blocking is active then Program_Error must be
324 -- raised if this potentially blocking operation is called from a
328 and then Self_Id
.Common
.Protected_Action_Nesting
> 0
330 raise Program_Error
with "potentially blocking operation";
335 Entry_Call
.Mode
:= Simple_Call
;
336 Entry_Call
.State
:= Now_Abortable
;
337 Entry_Call
.Uninterpreted_Data
:= Uninterpreted_Data
;
338 Entry_Call
.Exception_To_Raise
:= Ada
.Exceptions
.Null_Id
;
340 PO_Do_Or_Queue
(Object
, Entry_Call
'Access);
341 Unlock_Entry
(Object
);
343 -- The call is either `Done' or not. It cannot be cancelled since there
344 -- is no ATC construct.
346 pragma Assert
(Entry_Call
.State
/= Cancelled
);
348 if Entry_Call
.State
/= Done
then
349 STPO
.Write_Lock
(Self_Id
);
350 Wait_For_Completion
(Entry_Call
'Access);
351 STPO
.Unlock
(Self_Id
);
354 Check_Exception
(Self_Id
, Entry_Call
'Access);
355 end Protected_Single_Entry_Call
;
357 -----------------------------------
358 -- Protected_Single_Entry_Caller --
359 -----------------------------------
361 function Protected_Single_Entry_Caller
362 (Object
: Protection_Entry
) return Task_Id
365 return Object
.Call_In_Progress
.Self
;
366 end Protected_Single_Entry_Caller
;
372 procedure Service_Entry
(Object
: Protection_Entry_Access
) is
373 Entry_Call
: constant Entry_Call_Link
:= Object
.Entry_Queue
;
377 if Entry_Call
/= null
378 and then Object
.Entry_Body
.Barrier
(Object
.Compiler_Info
, 1)
380 Object
.Entry_Queue
:= null;
382 if Object
.Call_In_Progress
/= null then
384 -- Violation of No_Entry_Queue restriction, raise exception
386 Send_Program_Error
(Entry_Call
);
387 Unlock_Entry
(Object
);
391 Object
.Call_In_Progress
:= Entry_Call
;
392 Object
.Entry_Body
.Action
393 (Object
.Compiler_Info
, Entry_Call
.Uninterpreted_Data
, 1);
394 Object
.Call_In_Progress
:= null;
395 Caller
:= Entry_Call
.Self
;
396 Unlock_Entry
(Object
);
398 STPO
.Write_Lock
(Caller
);
399 Wakeup_Entry_Caller
(Entry_Call
);
400 STPO
.Unlock
(Caller
);
403 -- Just unlock the entry
405 Unlock_Entry
(Object
);
410 Send_Program_Error
(Entry_Call
);
411 Unlock_Entry
(Object
);
418 procedure Unlock_Entry
(Object
: Protection_Entry_Access
) is
420 Unlock
(Object
.Common
'Access);
423 end System
.Tasking
.Protected_Objects
.Single_Entry
;