File : s-tposen-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 -- S I N G L E _ E N T R Y --
7 -- --
8 -- B o d y --
9 -- --
10 -- Copyright (C) 1998-2013, AdaCore --
11 -- --
12 -- GNARL 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. GNARL 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 -- --
20 -- --
21 -- --
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 Style_Checks (All_Checks);
34 -- Turn off subprogram ordering check, since restricted GNARLI
35 -- subprograms are gathered together at end.
36
37 -- This package provides an optimized version of Protected_Objects.Operations
38 -- and Protected_Objects.Entries making the following assumptions:
39 --
40 -- PO have only one entry
41 -- There is only one caller at a time (No_Entry_Queue)
42 -- There is no dynamic priority support (No_Dynamic_Priorities)
43 -- No Abort Statements
44 -- (No_Abort_Statements, Max_Asynchronous_Select_Nesting => 0)
45 -- PO are at library level
46 -- No Requeue
47 -- None of the tasks will terminate (no need for finalization)
48 --
49 -- This interface is intended to be used in the ravenscar and restricted
50 -- profiles, the compiler is responsible for ensuring that the conditions
51 -- mentioned above are respected, except for the No_Entry_Queue restriction
52 -- that is checked dynamically in this package, since the check cannot be
53 -- performed at compile time (see Protected_Single_Entry_Call, Service_Entry).
54
55 pragma Polling (Off);
56 -- Turn off polling, we do not want polling to take place during tasking
57 -- operations. It can cause infinite loops and other problems.
58
59 pragma Suppress (All_Checks);
60
61 with System.Multiprocessors;
62
63 with System.Task_Primitives.Operations;
64 -- used for Self
65 -- Get_Priority
66 -- Set_Priority
67
68 with System.Tasking.Protected_Objects.Multiprocessors;
69
70 package body System.Tasking.Protected_Objects.Single_Entry is
71
72 use System.Multiprocessors;
73
74 package STPO renames System.Task_Primitives.Operations;
75 package STPOM renames System.Tasking.Protected_Objects.Multiprocessors;
76
77 Multiprocessor : constant Boolean := CPU'Range_Length /= 1;
78
79 ---------------------------------
80 -- Initialize_Protection_Entry --
81 ---------------------------------
82
83 procedure Initialize_Protection_Entry
84 (Object : Protection_Entry_Access;
85 Ceiling_Priority : Integer;
86 Compiler_Info : System.Address;
87 Entry_Body : Entry_Body_Access)
88 is
89 begin
90 Initialize_Protection (Object.Common'Access, Ceiling_Priority);
91
92 Object.Compiler_Info := Compiler_Info;
93 Object.Call_In_Progress := null;
94 Object.Entry_Body := Entry_Body;
95 Object.Entry_Queue := null;
96 end Initialize_Protection_Entry;
97
98 ----------------
99 -- Lock_Entry --
100 ----------------
101
102 procedure Lock_Entry (Object : Protection_Entry_Access) is
103 begin
104 Lock (Object.Common'Access);
105 end Lock_Entry;
106
107 ----------------------------
108 -- Protected_Single_Count --
109 ----------------------------
110
111 function Protected_Count_Entry (Object : Protection_Entry) return Natural is
112 begin
113 return Boolean'Pos (Object.Entry_Queue /= null);
114 end Protected_Count_Entry;
115
116 ---------------------------------
117 -- Protected_Single_Entry_Call --
118 ---------------------------------
119
120 procedure Protected_Single_Entry_Call
121 (Object : Protection_Entry_Access;
122 Uninterpreted_Data : System.Address)
123 is
124 Self_Id : constant Task_Id := STPO.Self;
125
126 begin
127 -- For this run time, pragma Detect_Blocking is always active, so we
128 -- must raise Program_Error if this potentially blocking operation is
129 -- called from a protected action.
130
131 if Self_Id.Common.Protected_Action_Nesting > 0 then
132 raise Program_Error;
133 end if;
134
135 Lock_Entry (Object);
136 Self_Id.Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
137
138 if Object.Entry_Body.Barrier (Object.Compiler_Info, 1) then
139
140 -- No other task can be executing an entry within this protected
141 -- object. On a single processor implementation (such as this one),
142 -- the ceiling priority protocol and the strictly preemptive priority
143 -- scheduling policy guarantee that protected objects are always
144 -- available when any task tries to use them (otherwise, either the
145 -- currently executing task would not have had a high enough priority
146 -- to be executing, or a blocking operation would have been called
147 -- from within the entry body).
148
149 pragma Assert (Object.Call_In_Progress = null);
150
151 Object.Call_In_Progress := Self_Id.Entry_Call'Access;
152 Object.Entry_Body.Action
153 (Object.Compiler_Info, Self_Id.Entry_Call.Uninterpreted_Data, 1);
154 Object.Call_In_Progress := null;
155
156 -- Entry call is over
157
158 Unlock_Entry (Object);
159
160 else
161 if Object.Entry_Queue /= null then
162
163 -- This violates the No_Entry_Queue restriction, raise
164 -- Program_Error.
165
166 Unlock_Entry (Object);
167 raise Program_Error;
168 end if;
169
170 -- There is a potential race condition between the Unlock_Entry and
171 -- the Sleep below (the Wakeup may be called before the Sleep). This
172 -- case is explicitly handled in the Sleep and Wakeup procedures:
173 -- Sleep won't block if Wakeup has been called before.
174
175 Object.Entry_Queue := Self_Id.Entry_Call'Access;
176 Unlock_Entry (Object);
177
178 -- Suspend until entry call has been completed.
179 -- On exit, the call will not be queued.
180
181 Self_Id.Common.State := Entry_Caller_Sleep;
182 STPO.Sleep (Self_Id, Entry_Caller_Sleep);
183 Self_Id.Common.State := Runnable;
184 end if;
185 end Protected_Single_Entry_Call;
186
187 -----------------------------------
188 -- Protected_Single_Entry_Caller --
189 -----------------------------------
190
191 function Protected_Single_Entry_Caller
192 (Object : Protection_Entry) return Task_Id
193 is
194 begin
195 return Object.Call_In_Progress.Self;
196 end Protected_Single_Entry_Caller;
197
198 -------------------
199 -- Service_Entry --
200 -------------------
201
202 procedure Service_Entry (Object : Protection_Entry_Access) is
203 Entry_Call : constant Entry_Call_Link := Object.Entry_Queue;
204 Caller : Task_Id;
205
206 begin
207 if Entry_Call /= null
208 and then Object.Entry_Body.Barrier (Object.Compiler_Info, 1)
209 then
210 Object.Entry_Queue := null;
211
212 -- No other task can be executing an entry within this protected
213 -- object. On a single processor implementation (such as this one),
214 -- the ceiling priority protocol and the strictly preemptive
215 -- priority scheduling policy guarantee that protected objects are
216 -- always available when any task tries to use them (otherwise,
217 -- either the currently executing task would not have had a high
218 -- enough priority to be executing, or a blocking operation would
219 -- have been called from within the entry body).
220
221 pragma Assert (Object.Call_In_Progress = null);
222
223 Object.Call_In_Progress := Entry_Call;
224 Object.Entry_Body.Action
225 (Object.Compiler_Info, Entry_Call.Uninterpreted_Data, 1);
226 Object.Call_In_Progress := null;
227 Caller := Entry_Call.Self;
228 Unlock_Entry (Object);
229
230 -- Signal the entry caller that the entry is completed
231
232 if not Multiprocessor
233 or else Caller.Common.Base_CPU = STPO.Self.Common.Base_CPU
234 then
235 -- Entry caller and servicing tasks are on the same CPU.
236 -- We are allowed to directly wake up the task.
237
238 STPO.Wakeup (Caller, Entry_Caller_Sleep);
239 else
240 -- The entry caller is on a different CPU.
241
242 STPOM.Served (Entry_Call);
243 end if;
244
245 else
246 -- Just unlock the entry
247
248 Unlock_Entry (Object);
249 end if;
250 end Service_Entry;
251
252 ------------------
253 -- Unlock_Entry --
254 ------------------
255
256 procedure Unlock_Entry (Object : Protection_Entry_Access) is
257 begin
258 Unlock (Object.Common'Access);
259 end Unlock_Entry;
260
261 end System.Tasking.Protected_Objects.Single_Entry;