File : s-taprob-raven.adb
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) 1992-2015, Free Software Foundation, Inc. --
10 -- --
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. GNARL 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. --
17 -- --
18 -- --
19 -- --
20 -- --
21 -- --
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/>. --
26 -- --
27 -- GNARL was developed by the GNARL team at Florida State University. --
28 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
29 -- --
30 ------------------------------------------------------------------------------
31
32 -- This is the Ravenscar version of this package
33
34 with System.Task_Primitives.Operations;
35 -- Used for Set_Priority
36 -- Get_Priority
37 -- Self
38
39 package body System.Tasking.Protected_Objects is
40
41 use System.Task_Primitives.Operations;
42 use System.Multiprocessors;
43
44 Multiprocessor : constant Boolean := CPU'Range_Length /= 1;
45 -- Set true if on multiprocessor (more than one CPU)
46
47 ---------------------------
48 -- Initialize_Protection --
49 ---------------------------
50
51 procedure Initialize_Protection
52 (Object : Protection_Access;
53 Ceiling_Priority : Integer)
54 is
55 Init_Priority : Integer := Ceiling_Priority;
56
57 begin
58 if Init_Priority = Unspecified_Priority then
59 Init_Priority := System.Priority'Last;
60 end if;
61
62 Object.Ceiling := System.Any_Priority (Init_Priority);
63 Object.Caller_Priority := System.Any_Priority'First;
64 Object.Owner := Null_Task;
65
66 -- Only for multiprocessor
67
68 if Multiprocessor then
69 Multiprocessors.Fair_Locks.Initialize (Object.Lock);
70 end if;
71 end Initialize_Protection;
72
73 ----------
74 -- Lock --
75 ----------
76
77 procedure Lock (Object : Protection_Access) is
78 Self_Id : constant Task_Id := Self;
79 Caller_Priority : constant Any_Priority := Get_Priority (Self_Id);
80
81 begin
82 -- For this run time, pragma Detect_Blocking is always active. As
83 -- described in ARM 9.5.1, par. 15, an external call on a protected
84 -- subprogram with the same target object as that of the protected
85 -- action that is currently in progress (i.e., if the caller is
86 -- already the protected object's owner) is a potentially blocking
87 -- operation, and hence Program_Error must be raised.
88
89 if Object.Owner = Self_Id then
90 raise Program_Error;
91 end if;
92
93 -- Check ceiling locking violation. It is perfectly correct to stay at
94 -- the same priority because a running task will never be preempted by
95 -- another task at the same priority (no potentially blocking operation,
96 -- no time slicing).
97
98 if Caller_Priority > Object.Ceiling then
99 raise Program_Error;
100 end if;
101
102 Set_Priority (Self_Id, Object.Ceiling);
103
104 -- Locking for multiprocessor systems
105
106 -- This lock ensure mutual exclusion of tasks from different processors,
107 -- not for tasks on the same processors. But, because of the ceiling
108 -- priority, this case never occurs.
109
110 if Multiprocessor then
111
112 -- Only for multiprocessor
113
114 Multiprocessors.Fair_Locks.Lock (Object.Lock);
115 end if;
116
117 -- Update the protected object's owner
118
119 Object.Owner := Self_Id;
120
121 -- Store caller's active priority so that it can be later
122 -- restored when finishing the protected action.
123
124 Object.Caller_Priority := Caller_Priority;
125
126 -- We are entering in a protected action, so that we increase the
127 -- protected object nesting level.
128
129 Self_Id.Common.Protected_Action_Nesting :=
130 Self_Id.Common.Protected_Action_Nesting + 1;
131 end Lock;
132
133 ------------
134 -- Unlock --
135 ------------
136
137 procedure Unlock (Object : Protection_Access) is
138 Self_Id : constant Task_Id := Self;
139 Caller_Priority : constant Any_Priority := Object.Caller_Priority;
140
141 begin
142 -- Calls to this procedure can only take place when being within a
143 -- protected action and when the caller is the protected object's
144 -- owner.
145
146 pragma Assert (Self_Id.Common.Protected_Action_Nesting > 0
147 and then Object.Owner = Self_Id);
148
149 -- Remove ownership of the protected object
150
151 Object.Owner := Null_Task;
152
153 -- We are exiting from a protected action, so that we decrease the
154 -- protected object nesting level.
155
156 Self_Id.Common.Protected_Action_Nesting :=
157 Self_Id.Common.Protected_Action_Nesting - 1;
158
159 -- Locking for multiprocessor systems
160
161 if Multiprocessor then
162
163 -- Only for multiprocessor
164
165 Multiprocessors.Fair_Locks.Unlock (Object.Lock);
166 end if;
167
168 Set_Priority (Self_Id, Caller_Priority);
169 end Unlock;
170
171 begin
172 -- Ensure that tasking is initialized when using protected objects
173
174 Tasking.Initialize;
175 end System.Tasking.Protected_Objects;