|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- S Y S T E M . T A S K I N G . P R O T E C T E D _ O B J E C T S --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
|
9 -- Copyright (C) 1991-2017, Florida State University --
|
|
145
|
10 -- Copyright (C) 1995-2019, AdaCore --
|
|
111
|
11 -- --
|
|
|
12 -- GNAT is free software; you can redistribute it and/or modify it under --
|
|
|
13 -- terms of the GNU General Public License as published by the Free Soft- --
|
|
|
14 -- ware Foundation; either version 3, or (at your option) any later ver- --
|
|
|
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
|
|
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
|
|
17 -- or FITNESS FOR A PARTICULAR PURPOSE. --
|
|
|
18 -- --
|
|
|
19 -- As a special exception under Section 7 of GPL version 3, you are granted --
|
|
|
20 -- additional permissions described in the GCC Runtime Library Exception, --
|
|
|
21 -- version 3.1, as published by the Free Software Foundation. --
|
|
|
22 -- --
|
|
|
23 -- You should have received a copy of the GNU General Public License and --
|
|
|
24 -- a copy of the GCC Runtime Library Exception along with this program; --
|
|
|
25 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
|
|
|
26 -- <http://www.gnu.org/licenses/>. --
|
|
|
27 -- --
|
|
|
28 -- GNARL was developed by the GNARL team at Florida State University. --
|
|
|
29 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
|
|
|
30 -- --
|
|
|
31 ------------------------------------------------------------------------------
|
|
|
32
|
|
|
33 pragma Polling (Off);
|
|
|
34 -- Turn off polling, we do not want ATC polling to take place during tasking
|
|
|
35 -- operations. It causes infinite loops and other problems.
|
|
|
36
|
|
|
37 with System.Task_Primitives.Operations;
|
|
|
38 with System.Soft_Links.Tasking;
|
|
|
39
|
|
|
40 with System.Secondary_Stack;
|
|
|
41 pragma Elaborate_All (System.Secondary_Stack);
|
|
|
42 pragma Unreferenced (System.Secondary_Stack);
|
|
|
43 -- Make sure the body of Secondary_Stack is elaborated before calling
|
|
|
44 -- Init_Tasking_Soft_Links. See comments for this routine for explanation.
|
|
|
45
|
|
|
46 package body System.Tasking.Protected_Objects is
|
|
|
47
|
|
|
48 use System.Task_Primitives.Operations;
|
|
|
49
|
|
|
50 ----------------
|
|
|
51 -- Local Data --
|
|
|
52 ----------------
|
|
|
53
|
|
|
54 Locking_Policy : Character;
|
|
|
55 pragma Import (C, Locking_Policy, "__gl_locking_policy");
|
|
|
56
|
|
|
57 -------------------------
|
|
|
58 -- Finalize_Protection --
|
|
|
59 -------------------------
|
|
|
60
|
|
|
61 procedure Finalize_Protection (Object : in out Protection) is
|
|
|
62 begin
|
|
|
63 Finalize_Lock (Object.L'Unrestricted_Access);
|
|
|
64 end Finalize_Protection;
|
|
|
65
|
|
|
66 ---------------------------
|
|
|
67 -- Initialize_Protection --
|
|
|
68 ---------------------------
|
|
|
69
|
|
|
70 procedure Initialize_Protection
|
|
|
71 (Object : Protection_Access;
|
|
|
72 Ceiling_Priority : Integer)
|
|
|
73 is
|
|
|
74 Init_Priority : Integer := Ceiling_Priority;
|
|
|
75
|
|
|
76 begin
|
|
|
77 if Init_Priority = Unspecified_Priority then
|
|
|
78 Init_Priority := System.Priority'Last;
|
|
|
79 end if;
|
|
|
80
|
|
|
81 Initialize_Lock (Init_Priority, Object.L'Access);
|
|
|
82 Object.Ceiling := System.Any_Priority (Init_Priority);
|
|
|
83 Object.New_Ceiling := System.Any_Priority (Init_Priority);
|
|
|
84 Object.Owner := Null_Task;
|
|
|
85 end Initialize_Protection;
|
|
|
86
|
|
|
87 -----------------
|
|
|
88 -- Get_Ceiling --
|
|
|
89 -----------------
|
|
|
90
|
|
|
91 function Get_Ceiling
|
|
|
92 (Object : Protection_Access) return System.Any_Priority is
|
|
|
93 begin
|
|
|
94 return Object.New_Ceiling;
|
|
|
95 end Get_Ceiling;
|
|
|
96
|
|
|
97 ----------
|
|
|
98 -- Lock --
|
|
|
99 ----------
|
|
|
100
|
|
|
101 procedure Lock (Object : Protection_Access) is
|
|
|
102 Ceiling_Violation : Boolean;
|
|
|
103
|
|
|
104 begin
|
|
|
105 -- The lock is made without deferring abort
|
|
|
106
|
|
|
107 -- Therefore the abort has to be deferred before calling this routine.
|
|
|
108 -- This means that the compiler has to generate a Defer_Abort call
|
|
|
109 -- before the call to Lock.
|
|
|
110
|
|
|
111 -- The caller is responsible for undeferring abort, and compiler
|
|
|
112 -- generated calls must be protected with cleanup handlers to ensure
|
|
|
113 -- that abort is undeferred in all cases.
|
|
|
114
|
|
|
115 -- If pragma Detect_Blocking is active then, as described in the ARM
|
|
|
116 -- 9.5.1, par. 15, we must check whether this is an external call on a
|
|
|
117 -- protected subprogram with the same target object as that of the
|
|
|
118 -- protected action that is currently in progress (i.e., if the caller
|
|
|
119 -- is already the protected object's owner). If this is the case hence
|
|
|
120 -- Program_Error must be raised.
|
|
|
121
|
|
|
122 if Detect_Blocking and then Object.Owner = Self then
|
|
|
123 raise Program_Error;
|
|
|
124 end if;
|
|
|
125
|
|
|
126 Write_Lock (Object.L'Access, Ceiling_Violation);
|
|
|
127
|
|
|
128 if Ceiling_Violation then
|
|
|
129 raise Program_Error;
|
|
|
130 end if;
|
|
|
131
|
|
|
132 -- We are entering in a protected action, so that we increase the
|
|
|
133 -- protected object nesting level (if pragma Detect_Blocking is
|
|
|
134 -- active), and update the protected object's owner.
|
|
|
135
|
|
|
136 if Detect_Blocking then
|
|
|
137 declare
|
|
|
138 Self_Id : constant Task_Id := Self;
|
|
|
139 begin
|
|
|
140 -- Update the protected object's owner
|
|
|
141
|
|
|
142 Object.Owner := Self_Id;
|
|
|
143
|
|
|
144 -- Increase protected object nesting level
|
|
|
145
|
|
|
146 Self_Id.Common.Protected_Action_Nesting :=
|
|
|
147 Self_Id.Common.Protected_Action_Nesting + 1;
|
|
|
148 end;
|
|
|
149 end if;
|
|
|
150 end Lock;
|
|
|
151
|
|
|
152 --------------------
|
|
|
153 -- Lock_Read_Only --
|
|
|
154 --------------------
|
|
|
155
|
|
|
156 procedure Lock_Read_Only (Object : Protection_Access) is
|
|
|
157 Ceiling_Violation : Boolean;
|
|
|
158
|
|
|
159 begin
|
|
|
160 -- If pragma Detect_Blocking is active then, as described in the ARM
|
|
|
161 -- 9.5.1, par. 15, we must check whether this is an external call on
|
|
|
162 -- protected subprogram with the same target object as that of the
|
|
|
163 -- protected action that is currently in progress (i.e., if the caller
|
|
|
164 -- is already the protected object's owner). If this is the case hence
|
|
|
165 -- Program_Error must be raised.
|
|
|
166 --
|
|
|
167 -- Note that in this case (getting read access), several tasks may have
|
|
|
168 -- read ownership of the protected object, so that this method of
|
|
|
169 -- storing the (single) protected object's owner does not work reliably
|
|
|
170 -- for read locks. However, this is the approach taken for two major
|
|
|
171 -- reasons: first, this function is not currently being used (it is
|
|
|
172 -- provided for possible future use), and second, it largely simplifies
|
|
|
173 -- the implementation.
|
|
|
174
|
|
|
175 if Detect_Blocking and then Object.Owner = Self then
|
|
|
176 raise Program_Error;
|
|
|
177 end if;
|
|
|
178
|
|
|
179 Read_Lock (Object.L'Access, Ceiling_Violation);
|
|
|
180
|
|
|
181 if Ceiling_Violation then
|
|
|
182 raise Program_Error;
|
|
|
183 end if;
|
|
|
184
|
|
|
185 -- We are entering in a protected action, so we increase the protected
|
|
|
186 -- object nesting level (if pragma Detect_Blocking is active).
|
|
|
187
|
|
|
188 if Detect_Blocking then
|
|
|
189 declare
|
|
|
190 Self_Id : constant Task_Id := Self;
|
|
|
191 begin
|
|
|
192 -- Update the protected object's owner
|
|
|
193
|
|
|
194 Object.Owner := Self_Id;
|
|
|
195
|
|
|
196 -- Increase protected object nesting level
|
|
|
197
|
|
|
198 Self_Id.Common.Protected_Action_Nesting :=
|
|
|
199 Self_Id.Common.Protected_Action_Nesting + 1;
|
|
|
200 end;
|
|
|
201 end if;
|
|
|
202 end Lock_Read_Only;
|
|
|
203
|
|
|
204 -----------------
|
|
|
205 -- Set_Ceiling --
|
|
|
206 -----------------
|
|
|
207
|
|
|
208 procedure Set_Ceiling
|
|
|
209 (Object : Protection_Access;
|
|
|
210 Prio : System.Any_Priority) is
|
|
|
211 begin
|
|
|
212 Object.New_Ceiling := Prio;
|
|
|
213 end Set_Ceiling;
|
|
|
214
|
|
|
215 ------------
|
|
|
216 -- Unlock --
|
|
|
217 ------------
|
|
|
218
|
|
|
219 procedure Unlock (Object : Protection_Access) is
|
|
|
220 begin
|
|
|
221 -- We are exiting from a protected action, so that we decrease the
|
|
|
222 -- protected object nesting level (if pragma Detect_Blocking is
|
|
|
223 -- active), and remove ownership of the protected object.
|
|
|
224
|
|
|
225 if Detect_Blocking then
|
|
|
226 declare
|
|
|
227 Self_Id : constant Task_Id := Self;
|
|
|
228
|
|
|
229 begin
|
|
|
230 -- Calls to this procedure can only take place when being within
|
|
|
231 -- a protected action and when the caller is the protected
|
|
|
232 -- object's owner.
|
|
|
233
|
|
|
234 pragma Assert (Self_Id.Common.Protected_Action_Nesting > 0
|
|
|
235 and then Object.Owner = Self_Id);
|
|
|
236
|
|
|
237 -- Remove ownership of the protected object
|
|
|
238
|
|
|
239 Object.Owner := Null_Task;
|
|
|
240
|
|
|
241 -- We are exiting from a protected action, so we decrease the
|
|
|
242 -- protected object nesting level.
|
|
|
243
|
|
|
244 Self_Id.Common.Protected_Action_Nesting :=
|
|
|
245 Self_Id.Common.Protected_Action_Nesting - 1;
|
|
|
246 end;
|
|
|
247 end if;
|
|
|
248
|
|
|
249 -- Before releasing the mutex we must actually update its ceiling
|
|
|
250 -- priority if it has been changed.
|
|
|
251
|
|
|
252 if Object.New_Ceiling /= Object.Ceiling then
|
|
|
253 if Locking_Policy = 'C' then
|
|
|
254 System.Task_Primitives.Operations.Set_Ceiling
|
|
|
255 (Object.L'Access, Object.New_Ceiling);
|
|
|
256 end if;
|
|
|
257
|
|
|
258 Object.Ceiling := Object.New_Ceiling;
|
|
|
259 end if;
|
|
|
260
|
|
|
261 Unlock (Object.L'Access);
|
|
|
262
|
|
|
263 end Unlock;
|
|
|
264
|
|
|
265 begin
|
|
|
266 -- Ensure that tasking is initialized, as well as tasking soft links
|
|
|
267 -- when using protected objects.
|
|
|
268
|
|
|
269 Tasking.Initialize;
|
|
|
270 System.Soft_Links.Tasking.Init_Tasking_Soft_Links;
|
|
|
271 end System.Tasking.Protected_Objects;
|
