File : s-tarest-raven-cert.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 . R E S T R I C T E D . S T A G E S --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1999-2014, AdaCore --
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. 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. --
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 a simplified version of the System.Tasking.Stages package, for use
33 -- with the VxWorks Ravenscar / cert profile.
34
35 -- This package represents the high level tasking interface used by the
36 -- compiler to expand Ada 95 tasking constructs into simpler run time calls.
37
38 pragma Style_Checks (All_Checks);
39 -- Turn off subprogram alpha order check, since we group soft link bodies and
40 -- also separate off subprograms for restricted GNARLI.
41
42 pragma Polling (Off);
43 -- Turn off polling, we do not want ATC polling to take place during
44 -- tasking operations. It causes infinite loops and other problems.
45
46 with System.Task_Primitives.Operations;
47 -- used for Enter_Task
48 -- Wakeup
49 -- Get_Priority
50 -- Set_Priority
51 -- Sleep
52
53 with System.Secondary_Stack;
54 -- used for SS_Init
55 -- Default_Secondary_Stack_Size
56
57 with System.Storage_Elements;
58 -- used for Storage_Array
59
60 with System.Multiprocessors;
61 -- used for CPU type
62
63 package body System.Tasking.Restricted.Stages is
64
65 use System.Secondary_Stack;
66 use System.Task_Primitives.Operations;
67 use System.Task_Info;
68
69 Tasks_Activation_Chain : Task_Id;
70 -- Chain of all the tasks to activate
71
72 -----------------------
73 -- Local Subprograms --
74 -----------------------
75
76 procedure Activate_Tasks (Chain : Task_Id);
77 -- Activate the list of tasks started by Chain
78
79 procedure Create_Restricted_Task
80 (Priority : Integer;
81 Stack_Address : System.Address;
82 Size : System.Parameters.Size_Type;
83 Task_Info : System.Task_Info.Task_Info_Type;
84 CPU : Integer;
85 State : Task_Procedure_Access;
86 Discriminants : System.Address;
87 Created_Task : Task_Id);
88 -- Code shared between Create_Restricted_Task (the concurrent version) and
89 -- Create_Restricted_Task_Sequential. See comment of the former in the
90 -- specification of this package.
91
92 procedure Task_Wrapper (Self_ID : Task_Id);
93 -- This is the procedure that is called by the GNULL from the new context
94 -- when a task is created. It waits for activation and then calls the task
95 -- body procedure. When the task body procedure completes, it terminates
96 -- the task.
97
98 function Get_Sec_Stack return Address;
99 -- Return the address of the task specific secondary stack, as expected by
100 -- System.Secondary_Stack
101 pragma Export (C, Get_Sec_Stack, "__gnat_get_secondary_stack");
102
103 -------------------
104 -- Get_Sec_Stack --
105 -------------------
106
107 function Get_Sec_Stack return Address is
108 begin
109 return Self.Common.Compiler_Data.Sec_Stack_Addr;
110 end Get_Sec_Stack;
111
112 ------------------
113 -- Task_Wrapper --
114 ------------------
115
116 -- The task wrapper is a procedure that is called first for each task
117 -- task body, and which in turn calls the compiler-generated task body
118 -- procedure. The wrapper's main job is to do initialization for the task.
119
120 -- The variable ID in the task wrapper is used to implement the Self
121 -- function on targets where there is a fast way to find the stack
122 -- base of the current thread, since it should be at a fixed offset
123 -- from the stack base.
124
125 procedure Task_Wrapper (Self_ID : Task_Id) is
126 use type System.Storage_Elements.Storage_Offset;
127
128 Sec_Stack_Size : constant Storage_Elements.Storage_Offset :=
129 Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size / 4;
130 -- Secondary stack is ~1/4 size of requested stack
131
132 Secondary_Stack : aliased Storage_Elements.Storage_Array
133 (1 .. Sec_Stack_Size);
134 for Secondary_Stack'Alignment use Standard'Maximum_Alignment;
135 -- This is the secondary stack data. Note that it is critical that this
136 -- have maximum alignment, since any kind of data can be allocated here.
137
138 begin
139 Self_ID.Common.Compiler_Data.Sec_Stack_Addr := Secondary_Stack'Address;
140 SS_Init (Secondary_Stack'Address, Integer (Sec_Stack_Size));
141
142 -- Initialize low-level TCB components, that cannot be initialized by
143 -- the creator.
144
145 Enter_Task (Self_ID);
146
147 -- Call the task body procedure
148
149 Self_ID.Common.Task_Entry_Point (Self_ID.Common.Task_Arg);
150
151 -- Normal termination. An unhandled exception will have been passed on
152 -- to the last chance handler. We're following the same protocol as with
153 -- APEX processes.
154
155 Sleep (Self_ID, Terminated);
156 end Task_Wrapper;
157
158 -----------------------
159 -- Restricted GNARLI --
160 -----------------------
161
162 -----------------------------------
163 -- Activate_All_Tasks_Sequential --
164 -----------------------------------
165
166 procedure Activate_All_Tasks_Sequential is
167 begin
168 pragma Assert (Partition_Elaboration_Policy = 'S');
169 Activate_Tasks (Tasks_Activation_Chain);
170 Tasks_Activation_Chain := Null_Task;
171 end Activate_All_Tasks_Sequential;
172
173 -------------------------------
174 -- Activate_Restricted_Tasks --
175 -------------------------------
176
177 procedure Activate_Restricted_Tasks
178 (Chain_Access : Activation_Chain_Access)
179 is
180 begin
181 if Partition_Elaboration_Policy = 'S' then
182
183 -- In sequential elaboration policy, the chain must be empty. This
184 -- procedure can be called if the unit has been compiled without
185 -- partition elaboration policy, but the partition has a sequential
186 -- elaboration policy.
187
188 pragma Assert (Chain_Access.T_ID = Null_Task);
189 null;
190
191 else
192 Activate_Tasks (Chain_Access.T_ID);
193 Chain_Access.T_ID := Null_Task;
194 end if;
195 end Activate_Restricted_Tasks;
196
197 --------------------
198 -- Activate_Tasks --
199 --------------------
200
201 procedure Activate_Tasks (Chain : Task_Id) is
202 Self_ID : constant Task_Id := Task_Primitives.Operations.Self;
203 C : Task_Id;
204 Next_C : Task_Id;
205 Success : Boolean;
206
207 begin
208 -- Raise the priority to prevent activated tasks from racing ahead
209 -- before we finish activating the chain.
210
211 Set_Priority (Self_ID, System.Any_Priority'Last);
212
213 -- Activate all the tasks in the chain
214
215 -- Creation of the thread of control was deferred until activation.
216 -- So create it now.
217
218 -- Note that since all created tasks will be blocked trying to get our
219 -- (environment task) lock, there is no need to lock C here.
220
221 C := Chain;
222 while C /= null loop
223 Next_C := C.Common.Activation_Link;
224
225 C.Common.Activation_Link := null;
226
227 -- Note: pragma Cpu is not supported in VxWorks Ravenscar/cert
228 -- profile. All tasks are statically assigned to the first CPU.
229
230 Task_Primitives.Operations.Create_Task
231 (T => C,
232 Wrapper => Task_Wrapper'Address,
233 Stack_Size => Parameters.Size_Type
234 (C.Common.Compiler_Data.Pri_Stack_Info.Size),
235 Priority => C.Common.Base_Priority,
236 Base_CPU => System.Multiprocessors.CPU'First,
237 Succeeded => Success);
238
239 if Success then
240 C.Common.State := Runnable;
241 else
242 raise Program_Error;
243 end if;
244
245 C := Next_C;
246 end loop;
247
248 Self_ID.Common.State := Runnable;
249
250 -- Restore the original priority
251
252 Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
253 end Activate_Tasks;
254
255 ------------------------------------
256 -- Complete_Restricted_Activation --
257 ------------------------------------
258
259 procedure Complete_Restricted_Activation is
260 begin
261 -- Nothing to be done
262
263 null;
264 end Complete_Restricted_Activation;
265
266 ------------------------------
267 -- Complete_Restricted_Task --
268 ------------------------------
269
270 procedure Complete_Restricted_Task is
271 begin
272 -- Mark the task as terminated. Do not suspend the task now
273 -- because we need to allow for the task termination procedure
274 -- to execute (if needed) in the Task_Wrapper.
275
276 Task_Primitives.Operations.Self.Common.State := Terminated;
277 end Complete_Restricted_Task;
278
279 ----------------------------
280 -- Create_Restricted_Task --
281 ----------------------------
282
283 procedure Create_Restricted_Task
284 (Priority : Integer;
285 Stack_Address : System.Address;
286 Size : System.Parameters.Size_Type;
287 Task_Info : System.Task_Info.Task_Info_Type;
288 CPU : Integer;
289 State : Task_Procedure_Access;
290 Discriminants : System.Address;
291 Created_Task : Task_Id)
292 is
293 Base_Priority : System.Any_Priority;
294 Base_CPU : System.Multiprocessors.CPU_Range;
295 Success : Boolean;
296
297 begin
298 Base_Priority :=
299 (if Priority = Unspecified_Priority
300 then System.Default_Priority
301 else System.Any_Priority (Priority));
302
303 -- Legal values of CPU are the special Unspecified_CPU value which is
304 -- inserted by the compiler for tasks without CPU aspect, and those in
305 -- the range of CPU_Range but no greater than Number_Of_CPUs. Otherwise
306 -- the task is defined to have failed, and it becomes a completed task
307 -- (RM D.16(14/3)).
308
309 if CPU /= Unspecified_CPU
310 and then (CPU < Integer (System.Multiprocessors.CPU_Range'First)
311 or else
312 CPU > Integer (System.Multiprocessors.Number_Of_CPUs))
313 then
314 raise Tasking_Error with "CPU not in range";
315
316 -- Normal CPU affinity
317
318 else
319 -- When the application code says nothing about the task affinity
320 -- (task without CPU aspect) then the compiler inserts the
321 -- Unspecified_CPU value which indicates to the run-time library that
322 -- the task will activate and execute on the same processor as its
323 -- activating task if the activating task is assigned a processor
324 -- (RM D.16(14/3)).
325
326 Base_CPU :=
327 (if CPU = Unspecified_CPU
328 then Self.Common.Base_CPU
329 else System.Multiprocessors.CPU_Range (CPU));
330 end if;
331
332 -- No need to lock Self_ID here, since only environment task is running
333
334 Initialize_ATCB
335 (State, Discriminants, Base_Priority, Base_CPU,
336 Task_Info, Stack_Address, Size, Created_Task, Success);
337
338 if not Success then
339 raise Program_Error;
340 end if;
341
342 Created_Task.Entry_Call.Self := Created_Task;
343 end Create_Restricted_Task;
344
345 procedure Create_Restricted_Task
346 (Priority : Integer;
347 Stack_Address : System.Address;
348 Size : System.Parameters.Size_Type;
349 Task_Info : System.Task_Info.Task_Info_Type;
350 CPU : Integer;
351 State : Task_Procedure_Access;
352 Discriminants : System.Address;
353 Elaborated : Access_Boolean;
354 Chain : in out Activation_Chain;
355 Task_Image : String;
356 Created_Task : Task_Id)
357 is
358 begin
359 if Partition_Elaboration_Policy = 'S' then
360
361 -- A unit may have been compiled without partition elaboration
362 -- policy, and in this case the compiler will emit calls for the
363 -- default policy (concurrent). But if the partition policy is
364 -- sequential, activation must be deferred.
365
366 Create_Restricted_Task_Sequential
367 (Priority, Stack_Address, Size, Task_Info, CPU, State,
368 Discriminants, Elaborated, Task_Image, Created_Task);
369
370 else
371 Create_Restricted_Task
372 (Priority, Stack_Address, Size, Task_Info, CPU, State,
373 Discriminants, Created_Task);
374
375 -- Append this task to the activation chain
376
377 Created_Task.Common.Activation_Link := Chain.T_ID;
378 Chain.T_ID := Created_Task;
379 end if;
380 end Create_Restricted_Task;
381
382 ---------------------------------------
383 -- Create_Restricted_Task_Sequential --
384 ---------------------------------------
385
386 procedure Create_Restricted_Task_Sequential
387 (Priority : Integer;
388 Stack_Address : System.Address;
389 Size : System.Parameters.Size_Type;
390 Task_Info : System.Task_Info.Task_Info_Type;
391 CPU : Integer;
392 State : Task_Procedure_Access;
393 Discriminants : System.Address;
394 Elaborated : Access_Boolean;
395 Task_Image : String;
396 Created_Task : Task_Id)
397 is
398 pragma Unreferenced (Task_Image, Elaborated);
399
400 begin
401 Create_Restricted_Task
402 (Priority, Stack_Address, Size, Task_Info,
403 CPU, State, Discriminants, Created_Task);
404
405 -- Append this task to the activation chain
406
407 Created_Task.Common.Activation_Link := Tasks_Activation_Chain;
408 Tasks_Activation_Chain := Created_Task;
409 end Create_Restricted_Task_Sequential;
410
411 ---------------------------
412 -- Finalize_Global_Tasks --
413 ---------------------------
414
415 -- Dummy version since this procedure is not used in true ravenscar mode
416
417 procedure Finalize_Global_Tasks is
418 begin
419 raise Program_Error;
420 end Finalize_Global_Tasks;
421
422 ---------------------------
423 -- Restricted_Terminated --
424 ---------------------------
425
426 function Restricted_Terminated (T : Task_Id) return Boolean is
427 begin
428 return T.Common.State = Terminated;
429 end Restricted_Terminated;
430
431 begin
432 Tasking.Initialize;
433 end System.Tasking.Restricted.Stages;