1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
5 -- SYSTEM.TASKING.PROTECTED_OBJECTS.ENTRIES --
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 -- This package contains all the simple primitives related to protected
33 -- objects with entries (i.e init, lock, unlock).
35 -- The handling of protected objects with no entries is done in
36 -- System.Tasking.Protected_Objects, the complex routines for protected
37 -- objects with entries in System.Tasking.Protected_Objects.Operations.
39 -- The split between Entries and Operations is needed to break circular
40 -- dependencies inside the run time.
42 -- Note: the compiler generates direct calls to this interface, via Rtsfind
44 with System
.Task_Primitives
.Operations
;
45 with System
.Restrictions
;
47 with System
.Tasking
.Initialization
;
48 pragma Elaborate_All
(System
.Tasking
.Initialization
);
49 -- To insure that tasking is initialized if any protected objects are created
51 package body System
.Tasking
.Protected_Objects
.Entries
is
53 package STPO
renames System
.Task_Primitives
.Operations
;
55 use Task_Primitives
.Operations
;
61 Locking_Policy
: constant Character;
62 pragma Import
(C
, Locking_Policy
, "__gl_locking_policy");
68 overriding
procedure Finalize
(Object
: in out Protection_Entries
) is
69 Entry_Call
: Entry_Call_Link
;
71 Ceiling_Violation
: Boolean;
72 Self_ID
: constant Task_Id
:= STPO
.Self
;
73 Old_Base_Priority
: System
.Any_Priority
;
76 if Object
.Finalized
then
80 STPO
.Write_Lock
(Object
.L
'Unrestricted_Access, Ceiling_Violation
);
82 if Ceiling_Violation
then
84 -- Dip our own priority down to ceiling of lock. See similar code in
85 -- Tasking.Entry_Calls.Lock_Server.
87 STPO
.Write_Lock
(Self_ID
);
88 Old_Base_Priority
:= Self_ID
.Common
.Base_Priority
;
89 Self_ID
.New_Base_Priority
:= Object
.Ceiling
;
90 Initialization
.Change_Base_Priority
(Self_ID
);
91 STPO
.Unlock
(Self_ID
);
92 STPO
.Write_Lock
(Object
.L
'Unrestricted_Access, Ceiling_Violation
);
94 if Ceiling_Violation
then
95 raise Program_Error
with "ceiling violation";
98 Object
.Old_Base_Priority
:= Old_Base_Priority
;
99 Object
.Pending_Action
:= True;
102 -- Send program_error to all tasks still queued on this object
104 for E
in Object
.Entry_Queues
'Range loop
105 Entry_Call
:= Object
.Entry_Queues
(E
).Head
;
107 while Entry_Call
/= null loop
108 Caller
:= Entry_Call
.Self
;
109 Entry_Call
.Exception_To_Raise
:= Program_Error
'Identity;
111 STPO
.Write_Lock
(Caller
);
112 Initialization
.Wakeup_Entry_Caller
(Self_ID
, Entry_Call
, Done
);
113 STPO
.Unlock
(Caller
);
115 exit when Entry_Call
= Object
.Entry_Queues
(E
).Tail
;
116 Entry_Call
:= Entry_Call
.Next
;
120 Object
.Finalized
:= True;
121 STPO
.Unlock
(Object
.L
'Unrestricted_Access);
122 STPO
.Finalize_Lock
(Object
.L
'Unrestricted_Access);
130 (Object
: Protection_Entries_Access
) return System
.Any_Priority
is
132 return Object
.New_Ceiling
;
135 -------------------------------------
136 -- Has_Interrupt_Or_Attach_Handler --
137 -------------------------------------
139 function Has_Interrupt_Or_Attach_Handler
140 (Object
: Protection_Entries_Access
)
143 pragma Warnings
(Off
, Object
);
146 end Has_Interrupt_Or_Attach_Handler
;
148 -----------------------------------
149 -- Initialize_Protection_Entries --
150 -----------------------------------
152 procedure Initialize_Protection_Entries
153 (Object
: Protection_Entries_Access
;
154 Ceiling_Priority
: Integer;
155 Compiler_Info
: System
.Address
;
156 Entry_Queue_Maxes
: Protected_Entry_Queue_Max_Access
;
157 Entry_Bodies
: Protected_Entry_Body_Access
;
158 Find_Body_Index
: Find_Body_Index_Access
)
160 Init_Priority
: Integer := Ceiling_Priority
;
161 Self_ID
: constant Task_Id
:= STPO
.Self
;
164 if Init_Priority
= Unspecified_Priority
then
165 Init_Priority
:= System
.Priority
'Last;
168 if Locking_Policy
= 'C'
169 and then Has_Interrupt_Or_Attach_Handler
(Object
)
170 and then Init_Priority
not in System
.Interrupt_Priority
172 -- Required by C.3.1(11)
177 -- If a PO is created from a controlled operation, abort is already
178 -- deferred at this point, so we need to use Defer_Abort_Nestable. In
179 -- some cases, the following assertion can help to spot inconsistencies,
180 -- outside the above scenario involving controlled types.
182 -- pragma Assert (Self_Id.Deferral_Level = 0);
184 Initialization
.Defer_Abort_Nestable
(Self_ID
);
185 Initialize_Lock
(Init_Priority
, Object
.L
'Access);
186 Initialization
.Undefer_Abort_Nestable
(Self_ID
);
188 Object
.Ceiling
:= System
.Any_Priority
(Init_Priority
);
189 Object
.New_Ceiling
:= System
.Any_Priority
(Init_Priority
);
190 Object
.Owner
:= Null_Task
;
191 Object
.Compiler_Info
:= Compiler_Info
;
192 Object
.Pending_Action
:= False;
193 Object
.Call_In_Progress
:= null;
194 Object
.Entry_Queue_Maxes
:= Entry_Queue_Maxes
;
195 Object
.Entry_Bodies
:= Entry_Bodies
;
196 Object
.Find_Body_Index
:= Find_Body_Index
;
198 for E
in Object
.Entry_Queues
'Range loop
199 Object
.Entry_Queues
(E
).Head
:= null;
200 Object
.Entry_Queues
(E
).Tail
:= null;
202 end Initialize_Protection_Entries
;
208 procedure Lock_Entries
(Object
: Protection_Entries_Access
) is
209 Ceiling_Violation
: Boolean;
212 Lock_Entries_With_Status
(Object
, Ceiling_Violation
);
214 if Ceiling_Violation
then
215 raise Program_Error
with "ceiling violation";
219 ------------------------------
220 -- Lock_Entries_With_Status --
221 ------------------------------
223 procedure Lock_Entries_With_Status
224 (Object
: Protection_Entries_Access
;
225 Ceiling_Violation
: out Boolean)
228 if Object
.Finalized
then
229 raise Program_Error
with "protected object is finalized";
232 -- If pragma Detect_Blocking is active then, as described in the ARM
233 -- 9.5.1, par. 15, we must check whether this is an external call on a
234 -- protected subprogram with the same target object as that of the
235 -- protected action that is currently in progress (i.e., if the caller
236 -- is already the protected object's owner). If this is the case hence
237 -- Program_Error must be raised.
239 if Detect_Blocking
and then Object
.Owner
= Self
then
243 -- The lock is made without deferring abort
245 -- Therefore the abort has to be deferred before calling this routine.
246 -- This means that the compiler has to generate a Defer_Abort call
247 -- before the call to Lock.
249 -- The caller is responsible for undeferring abort, and compiler
250 -- generated calls must be protected with cleanup handlers to ensure
251 -- that abort is undeferred in all cases.
254 (STPO
.Self
.Deferral_Level
> 0
255 or else not Restrictions
.Abort_Allowed
);
257 Write_Lock
(Object
.L
'Access, Ceiling_Violation
);
259 -- We are entering in a protected action, so that we increase the
260 -- protected object nesting level (if pragma Detect_Blocking is
261 -- active), and update the protected object's owner.
263 if Detect_Blocking
then
265 Self_Id
: constant Task_Id
:= Self
;
268 -- Update the protected object's owner
270 Object
.Owner
:= Self_Id
;
272 -- Increase protected object nesting level
274 Self_Id
.Common
.Protected_Action_Nesting
:=
275 Self_Id
.Common
.Protected_Action_Nesting
+ 1;
278 end Lock_Entries_With_Status
;
280 ----------------------------
281 -- Lock_Read_Only_Entries --
282 ----------------------------
284 procedure Lock_Read_Only_Entries
(Object
: Protection_Entries_Access
) is
285 Ceiling_Violation
: Boolean;
288 if Object
.Finalized
then
289 raise Program_Error
with "protected object is finalized";
292 -- If pragma Detect_Blocking is active then, as described in the ARM
293 -- 9.5.1, par. 15, we must check whether this is an external call on a
294 -- protected subprogram with the same target object as that of the
295 -- protected action that is currently in progress (i.e., if the caller
296 -- is already the protected object's owner). If this is the case hence
297 -- Program_Error must be raised.
299 -- Note that in this case (getting read access), several tasks may
300 -- have read ownership of the protected object, so that this method of
301 -- storing the (single) protected object's owner does not work
302 -- reliably for read locks. However, this is the approach taken for two
303 -- major reasons: first, this function is not currently being used (it
304 -- is provided for possible future use), and second, it largely
305 -- simplifies the implementation.
307 if Detect_Blocking
and then Object
.Owner
= Self
then
311 Read_Lock
(Object
.L
'Access, Ceiling_Violation
);
313 if Ceiling_Violation
then
314 raise Program_Error
with "ceiling violation";
317 -- We are entering in a protected action, so that we increase the
318 -- protected object nesting level (if pragma Detect_Blocking is
319 -- active), and update the protected object's owner.
321 if Detect_Blocking
then
323 Self_Id
: constant Task_Id
:= Self
;
326 -- Update the protected object's owner
328 Object
.Owner
:= Self_Id
;
330 -- Increase protected object nesting level
332 Self_Id
.Common
.Protected_Action_Nesting
:=
333 Self_Id
.Common
.Protected_Action_Nesting
+ 1;
336 end Lock_Read_Only_Entries
;
338 -----------------------
339 -- Number_Of_Entries --
340 -----------------------
342 function Number_Of_Entries
343 (Object
: Protection_Entries_Access
) return Entry_Index
346 return Entry_Index
(Object
.Num_Entries
);
347 end Number_Of_Entries
;
353 procedure Set_Ceiling
354 (Object
: Protection_Entries_Access
;
355 Prio
: System
.Any_Priority
) is
357 Object
.New_Ceiling
:= Prio
;
364 procedure Unlock_Entries
(Object
: Protection_Entries_Access
) is
366 -- We are exiting from a protected action, so that we decrease the
367 -- protected object nesting level (if pragma Detect_Blocking is
368 -- active), and remove ownership of the protected object.
370 if Detect_Blocking
then
372 Self_Id
: constant Task_Id
:= Self
;
375 -- Calls to this procedure can only take place when being within
376 -- a protected action and when the caller is the protected
379 pragma Assert
(Self_Id
.Common
.Protected_Action_Nesting
> 0
380 and then Object
.Owner
= Self_Id
);
382 -- Remove ownership of the protected object
384 Object
.Owner
:= Null_Task
;
386 Self_Id
.Common
.Protected_Action_Nesting
:=
387 Self_Id
.Common
.Protected_Action_Nesting
- 1;
391 -- Before releasing the mutex we must actually update its ceiling
392 -- priority if it has been changed.
394 if Object
.New_Ceiling
/= Object
.Ceiling
then
395 if Locking_Policy
= 'C' then
396 System
.Task_Primitives
.Operations
.Set_Ceiling
397 (Object
.L
'Access, Object
.New_Ceiling
);
400 Object
.Ceiling
:= Object
.New_Ceiling
;
403 Unlock
(Object
.L
'Access);
406 end System
.Tasking
.Protected_Objects
.Entries
;