aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.9/gcc/ada/s-tpoben.adb
blob: 3249122b386aa308a45d82ea49b61035dcd315b0 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
------------------------------------------------------------------------------
--                                                                          --
--                GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS                  --
--                                                                          --
--                SYSTEM.TASKING.PROTECTED_OBJECTS.ENTRIES                  --
--                                                                          --
--                               B o d y                                    --
--                                                                          --
--          Copyright (C) 1998-2012, Free Software Foundation, Inc.         --
--                                                                          --
-- GNARL is free software; you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
--                                                                          --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception,   --
-- version 3.1, as published by the Free Software Foundation.               --
--                                                                          --
-- You should have received a copy of the GNU General Public License and    --
-- a copy of the GCC Runtime Library Exception along with this program;     --
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
-- <http://www.gnu.org/licenses/>.                                          --
--                                                                          --
-- GNARL was developed by the GNARL team at Florida State University.       --
-- Extensive contributions were provided by Ada Core Technologies, Inc.     --
--                                                                          --
------------------------------------------------------------------------------

--  This package contains all the simple primitives related to protected
--  objects with entries (i.e init, lock, unlock).

--  The handling of protected objects with no entries is done in
--  System.Tasking.Protected_Objects, the complex routines for protected
--  objects with entries in System.Tasking.Protected_Objects.Operations.

--  The split between Entries and Operations is needed to break circular
--  dependencies inside the run time.

--  Note: the compiler generates direct calls to this interface, via Rtsfind

with System.Task_Primitives.Operations;
with System.Restrictions;
with System.Parameters;

with System.Tasking.Initialization;
pragma Elaborate_All (System.Tasking.Initialization);
--  To insure that tasking is initialized if any protected objects are created

package body System.Tasking.Protected_Objects.Entries is

   package STPO renames System.Task_Primitives.Operations;

   use Parameters;
   use Task_Primitives.Operations;

   ----------------
   -- Local Data --
   ----------------

   Locking_Policy : Character;
   pragma Import (C, Locking_Policy, "__gl_locking_policy");

   --------------
   -- Finalize --
   --------------

   overriding procedure Finalize (Object : in out Protection_Entries) is
      Entry_Call        : Entry_Call_Link;
      Caller            : Task_Id;
      Ceiling_Violation : Boolean;
      Self_ID           : constant Task_Id := STPO.Self;
      Old_Base_Priority : System.Any_Priority;

   begin
      if Object.Finalized then
         return;
      end if;

      STPO.Write_Lock (Object.L'Unrestricted_Access, Ceiling_Violation);

      if Single_Lock then
         Lock_RTS;
      end if;

      if Ceiling_Violation then

         --  Dip our own priority down to ceiling of lock. See similar code in
         --  Tasking.Entry_Calls.Lock_Server.

         STPO.Write_Lock (Self_ID);
         Old_Base_Priority := Self_ID.Common.Base_Priority;
         Self_ID.New_Base_Priority := Object.Ceiling;
         Initialization.Change_Base_Priority (Self_ID);
         STPO.Unlock (Self_ID);

         if Single_Lock then
            Unlock_RTS;
         end if;

         STPO.Write_Lock (Object.L'Unrestricted_Access, Ceiling_Violation);

         if Ceiling_Violation then
            raise Program_Error with "Ceiling Violation";
         end if;

         if Single_Lock then
            Lock_RTS;
         end if;

         Object.Old_Base_Priority := Old_Base_Priority;
         Object.Pending_Action := True;
      end if;

      --  Send program_error to all tasks still queued on this object

      for E in Object.Entry_Queues'Range loop
         Entry_Call := Object.Entry_Queues (E).Head;

         while Entry_Call /= null loop
            Caller := Entry_Call.Self;
            Entry_Call.Exception_To_Raise := Program_Error'Identity;

            STPO.Write_Lock (Caller);
            Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
            STPO.Unlock (Caller);

            exit when Entry_Call = Object.Entry_Queues (E).Tail;
            Entry_Call := Entry_Call.Next;
         end loop;
      end loop;

      Object.Finalized := True;

      if Single_Lock then
         Unlock_RTS;
      end if;

      STPO.Unlock (Object.L'Unrestricted_Access);

      STPO.Finalize_Lock (Object.L'Unrestricted_Access);
   end Finalize;

   -----------------
   -- Get_Ceiling --
   -----------------

   function Get_Ceiling
     (Object : Protection_Entries_Access) return System.Any_Priority is
   begin
      return Object.New_Ceiling;
   end Get_Ceiling;

   -------------------------------------
   -- Has_Interrupt_Or_Attach_Handler --
   -------------------------------------

   function Has_Interrupt_Or_Attach_Handler
     (Object : Protection_Entries_Access)
      return   Boolean
   is
      pragma Warnings (Off, Object);
   begin
      return False;
   end Has_Interrupt_Or_Attach_Handler;

   -----------------------------------
   -- Initialize_Protection_Entries --
   -----------------------------------

   procedure Initialize_Protection_Entries
     (Object           : Protection_Entries_Access;
      Ceiling_Priority : Integer;
      Compiler_Info    : System.Address;
      Entry_Bodies     : Protected_Entry_Body_Access;
      Find_Body_Index  : Find_Body_Index_Access)
   is
      Init_Priority : Integer := Ceiling_Priority;
      Self_ID       : constant Task_Id := STPO.Self;

   begin
      if Init_Priority = Unspecified_Priority then
         Init_Priority := System.Priority'Last;
      end if;

      if Locking_Policy = 'C'
        and then Has_Interrupt_Or_Attach_Handler (Object)
        and then Init_Priority not in System.Interrupt_Priority
      then
         --  Required by C.3.1(11)

         raise Program_Error;
      end if;

      --  If a PO is created from a controlled operation, abort is already
      --  deferred at this point, so we need to use Defer_Abort_Nestable. In
      --  some cases, the following assertion can help to spot inconsistencies,
      --  outside the above scenario involving controlled types.

      --  pragma Assert (Self_Id.Deferral_Level = 0);

      Initialization.Defer_Abort_Nestable (Self_ID);
      Initialize_Lock (Init_Priority, Object.L'Access);
      Initialization.Undefer_Abort_Nestable (Self_ID);

      Object.Ceiling          := System.Any_Priority (Init_Priority);
      Object.New_Ceiling      := System.Any_Priority (Init_Priority);
      Object.Owner            := Null_Task;
      Object.Compiler_Info    := Compiler_Info;
      Object.Pending_Action   := False;
      Object.Call_In_Progress := null;
      Object.Entry_Bodies     := Entry_Bodies;
      Object.Find_Body_Index  := Find_Body_Index;

      for E in Object.Entry_Queues'Range loop
         Object.Entry_Queues (E).Head := null;
         Object.Entry_Queues (E).Tail := null;
      end loop;
   end Initialize_Protection_Entries;

   ------------------
   -- Lock_Entries --
   ------------------

   procedure Lock_Entries (Object : Protection_Entries_Access) is
      Ceiling_Violation : Boolean;

   begin
      Lock_Entries_With_Status (Object, Ceiling_Violation);

      if Ceiling_Violation then
         raise Program_Error with "Ceiling Violation";
      end if;
   end Lock_Entries;

   ------------------------------
   -- Lock_Entries_With_Status --
   ------------------------------

   procedure Lock_Entries_With_Status
     (Object            : Protection_Entries_Access;
      Ceiling_Violation : out Boolean)
   is
   begin
      if Object.Finalized then
         raise Program_Error with "Protected Object is finalized";
      end if;

      --  If pragma Detect_Blocking is active then, as described in the ARM
      --  9.5.1, par. 15, we must check whether this is an external call on a
      --  protected subprogram with the same target object as that of the
      --  protected action that is currently in progress (i.e., if the caller
      --  is already the protected object's owner). If this is the case hence
      --  Program_Error must be raised.

      if Detect_Blocking and then Object.Owner = Self then
         raise Program_Error;
      end if;

      --  The lock is made without deferring abort

      --  Therefore the abort has to be deferred before calling this routine.
      --  This means that the compiler has to generate a Defer_Abort call
      --  before the call to Lock.

      --  The caller is responsible for undeferring abort, and compiler
      --  generated calls must be protected with cleanup handlers to ensure
      --  that abort is undeferred in all cases.

      pragma Assert
        (STPO.Self.Deferral_Level > 0
          or else not Restrictions.Abort_Allowed);

      Write_Lock (Object.L'Access, Ceiling_Violation);

      --  We are entering in a protected action, so that we increase the
      --  protected object nesting level (if pragma Detect_Blocking is
      --  active), and update the protected object's owner.

      if Detect_Blocking then
         declare
            Self_Id : constant Task_Id := Self;

         begin
            --  Update the protected object's owner

            Object.Owner := Self_Id;

            --  Increase protected object nesting level

            Self_Id.Common.Protected_Action_Nesting :=
              Self_Id.Common.Protected_Action_Nesting + 1;
         end;
      end if;
   end Lock_Entries_With_Status;

   ----------------------------
   -- Lock_Read_Only_Entries --
   ----------------------------

   procedure Lock_Read_Only_Entries (Object : Protection_Entries_Access) is
      Ceiling_Violation : Boolean;

   begin
      if Object.Finalized then
         raise Program_Error with "Protected Object is finalized";
      end if;

      --  If pragma Detect_Blocking is active then, as described in the ARM
      --  9.5.1, par. 15, we must check whether this is an external call on a
      --  protected subprogram with the same target object as that of the
      --  protected action that is currently in progress (i.e., if the caller
      --  is already the protected object's owner). If this is the case hence
      --  Program_Error must be raised.

      --  Note that in this case (getting read access), several tasks may
      --  have read ownership of the protected object, so that this method of
      --  storing the (single) protected object's owner does not work
      --  reliably for read locks. However, this is the approach taken for two
      --  major reasons: first, this function is not currently being used (it
      --  is provided for possible future use), and second, it largely
      --  simplifies the implementation.

      if Detect_Blocking and then Object.Owner = Self then
         raise Program_Error;
      end if;

      Read_Lock (Object.L'Access, Ceiling_Violation);

      if Ceiling_Violation then
         raise Program_Error with "Ceiling Violation";
      end if;

      --  We are entering in a protected action, so that we increase the
      --  protected object nesting level (if pragma Detect_Blocking is
      --  active), and update the protected object's owner.

      if Detect_Blocking then
         declare
            Self_Id : constant Task_Id := Self;

         begin
            --  Update the protected object's owner

            Object.Owner := Self_Id;

            --  Increase protected object nesting level

            Self_Id.Common.Protected_Action_Nesting :=
              Self_Id.Common.Protected_Action_Nesting + 1;
         end;
      end if;
   end Lock_Read_Only_Entries;

   -----------------------
   -- Number_Of_Entries --
   -----------------------

   function Number_Of_Entries
     (Object : Protection_Entries_Access) return Entry_Index
   is
   begin
      return Entry_Index (Object.Num_Entries);
   end Number_Of_Entries;

   -----------------
   -- Set_Ceiling --
   -----------------

   procedure Set_Ceiling
     (Object : Protection_Entries_Access;
      Prio   : System.Any_Priority) is
   begin
      Object.New_Ceiling := Prio;
   end Set_Ceiling;

   ---------------------
   -- Set_Entry_Names --
   ---------------------

   procedure Set_Entry_Names
     (Object : Protection_Entries_Access;
      Names  : Protected_Entry_Names_Access)
   is
   begin
      Object.Entry_Names := Names;
   end Set_Entry_Names;

   --------------------
   -- Unlock_Entries --
   --------------------

   procedure Unlock_Entries (Object : Protection_Entries_Access) is
   begin
      --  We are exiting from a protected action, so that we decrease the
      --  protected object nesting level (if pragma Detect_Blocking is
      --  active), and remove ownership of the protected object.

      if Detect_Blocking then
         declare
            Self_Id : constant Task_Id := Self;

         begin
            --  Calls to this procedure can only take place when being within
            --  a protected action and when the caller is the protected
            --  object's owner.

            pragma Assert (Self_Id.Common.Protected_Action_Nesting > 0
                             and then Object.Owner = Self_Id);

            --  Remove ownership of the protected object

            Object.Owner := Null_Task;

            Self_Id.Common.Protected_Action_Nesting :=
              Self_Id.Common.Protected_Action_Nesting - 1;
         end;
      end if;

      --  Before releasing the mutex we must actually update its ceiling
      --  priority if it has been changed.

      if Object.New_Ceiling /= Object.Ceiling then
         if Locking_Policy = 'C' then
            System.Task_Primitives.Operations.Set_Ceiling
              (Object.L'Access, Object.New_Ceiling);
         end if;

         Object.Ceiling := Object.New_Ceiling;
      end if;

      Unlock (Object.L'Access);
   end Unlock_Entries;

end System.Tasking.Protected_Objects.Entries;