File : s-taprop-raven-cert-vxworks.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
4 -- --
5 -- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2001-2016, 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. 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 ------------------------------------------------------------------------------
28
29 -- This is the VxWorks Ravenscar Cert version of this package
30
31 -- This package contains all the GNULL primitives that interface directly
32 -- with the underlying OS.
33
34 with System.Init;
35 with System.OS_Interface;
36 with System.OS_Versions;
37 with System.Tasking.Debug;
38 with System.VxWorks.Ext;
39 with System.Float_Control;
40
41 with Interfaces.C;
42
43 package body System.Task_Primitives.Operations is
44
45 use System.Tasking;
46 use System.OS_Interface;
47 use System.OS_Versions;
48 use System.Parameters;
49 use type System.VxWorks.Ext.t_id;
50 use type Interfaces.Unsigned_16;
51 use type Interfaces.C.int;
52
53 ----------------
54 -- Local Data --
55 ----------------
56
57 CLOCK_REALTIME : constant := 0;
58 -- This would usually be obtained from System.OS_Constants, but it is
59 -- not used on CERT platforms
60
61 Low_Priority : constant := 255;
62 -- VxWorks native (default) lowest scheduling priority
63
64 type Set_Stack_Limit_Proc_Acc is access procedure;
65 pragma Convention (C, Set_Stack_Limit_Proc_Acc);
66
67 Set_Stack_Limit_Hook : Set_Stack_Limit_Proc_Acc;
68 pragma Import (C, Set_Stack_Limit_Hook, "__gnat_set_stack_limit_hook");
69 -- Procedure to be called when a task is created to set stack limit if
70 -- limit checking is used.
71
72 Task_Count : Interfaces.Unsigned_16 := 0;
73 -- Count of tasks created so far. Used to create unique part of task name
74 -- required by taskOpen for VxWorks Cert 6.x
75
76 Task_Number_Image_Length : constant := 4;
77 subtype Task_Number_Image is String (1 .. Task_Number_Image_Length);
78 -- Unique part of task name required when using taskOpen instead of
79 -- taskSpawn, as necessitated by VxWorks Cert 6.x
80
81 --------------------
82 -- Local Packages --
83 --------------------
84
85 package Specific is
86
87 procedure Set (New_Task_Id : Task_Id);
88 pragma Inline (Set);
89 -- Allocate ATCB and Stack_Limit if needed and set the task ID
90
91 function Self return Task_Id;
92 pragma Inline (Self);
93 -- Return a pointer to the Ada Task Control Block of the calling task
94
95 end Specific;
96
97 package body Specific is separate;
98 -- The body of this package is target specific
99
100 function Created_Task_Count return Task_Number_Image;
101 -- Get unique part of task name for use with taskOpen. This is obtained
102 -- by incrementing the count of tasks created so far, and then returning
103 -- the hexadecimal image of this count.
104
105 function To_VxWorks_Priority
106 (Priority : System.OS_Interface.int) return System.OS_Interface.int;
107 pragma Inline (To_VxWorks_Priority);
108 -- Convert between VxWorks and Ada priority
109
110 function To_Ada_Priority
111 (Priority : System.OS_Interface.int) return System.Any_Priority;
112 pragma Inline (To_Ada_Priority);
113 -- Convert between Ada priority and VxWorks priority
114
115 ------------------------
116 -- Created_Task_Count --
117 ------------------------
118
119 function Created_Task_Count return Task_Number_Image is
120 H : constant array (0 .. 15) of Character := "0123456789ABCDEF";
121 -- Table of hex digits
122
123 S : Task_Number_Image;
124 N : Integer;
125
126 begin
127 Task_Count := Task_Count + 1;
128
129 N := Integer (Task_Count);
130 for P in reverse 1 .. S'Last loop
131 S (P) := H (N mod 16);
132 N := N / 16;
133 end loop;
134
135 return S;
136 end Created_Task_Count;
137
138 -------------------------
139 -- To_VxWorks_Priority --
140 -------------------------
141
142 function To_VxWorks_Priority
143 (Priority : System.OS_Interface.int) return System.OS_Interface.int
144 is
145 begin
146 return Low_Priority - Priority;
147 end To_VxWorks_Priority;
148
149 ---------------------
150 -- To_Ada_Priority --
151 ---------------------
152
153 function To_Ada_Priority
154 (Priority : System.OS_Interface.int) return System.Any_Priority
155 is
156 begin
157 return System.Any_Priority (Low_Priority - Priority);
158 end To_Ada_Priority;
159
160 -----------
161 -- Sleep --
162 -----------
163
164 procedure Sleep (Self_ID : Task_Id; Reason : System.Tasking.Task_States) is
165 pragma Warnings (Off, Reason);
166
167 Result : System.OS_Interface.int;
168
169 begin
170 -- Perform a blocking operation to take the CV semaphore
171
172 Result := semTake (Self_ID.Common.LL.CV, WAIT_FOREVER);
173 pragma Assert (Result = 0);
174 end Sleep;
175
176 -----------------
177 -- Delay_Until --
178 -----------------
179
180 procedure Delay_Until (Abs_Time : Time) is
181 Current_Time : constant Time := Monotonic_Clock;
182
183 Result : System.OS_Interface.int;
184 pragma Unreferenced (Result);
185
186 begin
187 if Current_Time < Abs_Time then
188 Result := taskDelay (To_Clock_Ticks (Abs_Time - Current_Time));
189 else
190 Result := taskDelay (0);
191 end if;
192 end Delay_Until;
193
194 ---------------------
195 -- Monotonic_Clock --
196 ---------------------
197
198 function Monotonic_Clock return Time is
199 TS : aliased timespec;
200 Result : int;
201 begin
202 Result := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access);
203 pragma Assert (Result = 0);
204 return Time (To_Duration (TS));
205 end Monotonic_Clock;
206
207 -------------------
208 -- RT_Resolution --
209 -------------------
210
211 function RT_Resolution return Time is
212 use Interfaces;
213
214 Ticks_Per_Second : constant Unsigned_64 := Unsigned_64 (sysClkRateGet);
215 begin
216 return Time (1.0 / (Duration (Ticks_Per_Second)));
217 end RT_Resolution;
218
219 ------------
220 -- Wakeup --
221 ------------
222
223 procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
224 pragma Warnings (Off, Reason);
225 Result : System.OS_Interface.int;
226 begin
227 Result := semGive (T.Common.LL.CV);
228 pragma Assert (Result = 0);
229 end Wakeup;
230
231 ------------------
232 -- Set_Priority --
233 ------------------
234
235 procedure Set_Priority
236 (T : Task_Id;
237 Prio : System.Any_Priority)
238 is
239 Result : System.OS_Interface.int;
240 begin
241 Result := taskPrioritySet
242 (T.Common.LL.Thread,
243 To_VxWorks_Priority (System.OS_Interface.int (Prio)));
244 pragma Assert (Result = 0);
245 end Set_Priority;
246
247 ------------------
248 -- Get_Priority --
249 ------------------
250
251 function Get_Priority (T : Task_Id) return System.Any_Priority is
252 Result : System.OS_Interface.int;
253 VxWorks_Priority : aliased System.OS_Interface.int;
254 begin
255 Result := taskPriorityGet (T.Common.LL.Thread, VxWorks_Priority'Access);
256 pragma Assert (Result = 0);
257 return To_Ada_Priority (VxWorks_Priority);
258 end Get_Priority;
259
260 ----------------
261 -- Enter_Task --
262 ----------------
263
264 procedure Enter_Task (Self_ID : Task_Id) is
265 Result : System.OS_Interface.int;
266 pragma Unreferenced (Result);
267 begin
268
269 -- RTP use TLS for the ATCB (aka Self_Id)
270
271 Specific.Set (Self_ID);
272
273 -- Properly initializes the FPU for PPC systems
274
275 System.Float_Control.Reset;
276
277 System.Init.Install_Handler;
278
279 -- Register the task to System.Tasking.Debug
280
281 System.Tasking.Debug.Add_Task_Id (Self_ID);
282
283 -- If stack checking is enabled and limit checking is used, set the
284 -- stack limit for this task.
285
286 if Set_Stack_Limit_Hook /= null then
287 Set_Stack_Limit_Hook.all;
288 end if;
289 end Enter_Task;
290
291 --------------------
292 -- Initialize_TCB --
293 --------------------
294
295 procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
296 begin
297 Self_ID.Common.LL.CV := semBCreate (SEM_Q_PRIORITY, SEM_EMPTY);
298 Succeeded := (if Self_ID.Common.LL.CV = 0 then False else True);
299 end Initialize_TCB;
300
301 -----------------
302 -- Create_Task --
303 -----------------
304
305 procedure Create_Task
306 (T : Task_Id;
307 Wrapper : System.Address;
308 Stack_Size : System.Parameters.Size_Type;
309 Priority : System.Any_Priority;
310 Base_CPU : System.Multiprocessors.CPU_Range;
311 Succeeded : out Boolean)
312 is
313 pragma Unreferenced (Base_CPU);
314 Adjusted_Stack_Size : System.OS_Interface.size_t;
315
316 function Get_Task_Options return int;
317 pragma Import (C, Get_Task_Options, "__gnat_get_task_options");
318 -- Function that returns the options to be set for the task that we
319 -- are creating. We fetch the options assigned to the current task,
320 -- thus offering some user level control over the options for a task
321 -- hierarchy, and force VX_FP_TASK because it is almost always required.
322
323 begin
324 -- Add ~1/4 to requested stack size for secondary stack
325
326 if Stack_Size = Unspecified_Size then
327 Adjusted_Stack_Size :=
328 System.OS_Interface.size_t ((Default_Stack_Size * 5) / 4);
329 elsif Stack_Size < Minimum_Stack_Size then
330 Adjusted_Stack_Size :=
331 System.OS_Interface.size_t ((Minimum_Stack_Size * 5) / 4);
332 else
333 Adjusted_Stack_Size :=
334 System.OS_Interface.size_t ((Stack_Size * 5) / 4);
335 end if;
336
337 pragma Warnings (Off, OS);
338
339 -- Conditional compilation
340
341 if OS = VxWorks_Cert_RTP then
342
343 -- taskSpawn() is not available on VxWorks Cert 6.x for RTPs, so we
344 -- have to use taskOpen. Note that taskOpen() is not available in
345 -- the Cert kernel unless RTP support is configured in, so we can't
346 -- use just one of these APIs for VxWorks 6 Cert.
347
348 declare
349 Task_Name_Length : constant := 10;
350 Name : aliased String (1 .. Task_Name_Length);
351
352 Name_Address : System.Address;
353 -- Task name we are going to hand down to VxWorks - required for
354 -- taskOpen.
355
356 function Get_Object_Options return int;
357 pragma Import (C, Get_Object_Options, "__gnat_get_object_options");
358 -- These options are needed by taskOpen. They cause the task to be
359 -- created unconditionally.
360
361 function taskOpen
362 (name : System.Address;
363 priority : int;
364 options : int;
365 mode : int;
366 pStackBase : System.Address;
367 stackSize : int;
368 context : System.Address;
369 entryPt : System.Address;
370 arg1 : System.Address) return System.VxWorks.Ext.t_id;
371 pragma Import (C, taskOpen, "taskOpen");
372 -- VxWorks Cert (6.x) does not support taskSpawn for RTPs
373
374 begin
375 -- No Ada task names are available for this run-time library, but
376 -- taskOpen requires a unique task name, so we construct one.
377
378 Name (1 .. Task_Name_Length) :=
379 "tAda_" & Created_Task_Count & ASCII.NUL;
380
381 Name_Address := Name'Address;
382
383 T.Common.LL.Thread := taskOpen
384 (Name_Address,
385 To_VxWorks_Priority (System.OS_Interface.int (Priority)),
386 Get_Task_Options,
387 Get_Object_Options,
388 System.Null_Address,
389 int (Adjusted_Stack_Size),
390 System.Null_Address,
391 Wrapper,
392 To_Address (T));
393 end;
394
395 Succeeded := T.Common.LL.Thread /= -1;
396
397 else
398 -- VxWorks 653 and VxWorks MILS vThreads or Vx6 Cert kernel task
399
400 T.Common.LL.Thread := taskSpawn
401 (System.Null_Address,
402 To_VxWorks_Priority (System.OS_Interface.int (Priority)),
403 Get_Task_Options,
404 Adjusted_Stack_Size,
405 Wrapper,
406 To_Address (T));
407
408 Succeeded := T.Common.LL.Thread /= -1;
409
410 if Succeeded then
411 Specific.Set (T);
412 end if;
413 end if;
414
415 pragma Warnings (On, OS);
416 end Create_Task;
417
418 ----------------
419 -- Initialize --
420 ----------------
421
422 procedure Initialize (Environment_Task : System.Tasking.Task_Id) is
423 begin
424
425 -- Store the identifier for the environment task
426
427 Operations.Environment_Task := Environment_Task;
428 Specific.Set (Environment_Task);
429 Enter_Task (Environment_Task);
430 end Initialize;
431
432 ---------------------
433 -- Is_Task_Context --
434 ---------------------
435
436 function Is_Task_Context return Boolean is
437 begin
438 return System.OS_Interface.Interrupt_Context /= 1;
439 end Is_Task_Context;
440
441 ----------
442 -- Self --
443 ----------
444
445 function Self return Task_Id renames Specific.Self;
446
447 end System.Task_Primitives.Operations;