]>
Commit | Line | Data |
---|---|---|
84481f76 RK |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
b497b460 | 3 | -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- |
84481f76 RK |
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 | -- -- | |
4b490c1e | 9 | -- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- |
84481f76 RK |
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- -- | |
748086b7 JJ |
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- -- | |
84481f76 | 15 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- |
748086b7 JJ |
16 | -- or FITNESS FOR A PARTICULAR PURPOSE. -- |
17 | -- -- | |
18 | -- As a special exception under Section 7 of GPL version 3, you are granted -- | |
19 | -- additional permissions described in the GCC Runtime Library Exception, -- | |
20 | -- version 3.1, as published by the Free Software Foundation. -- | |
21 | -- -- | |
a20f4389 AC |
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/>. -- | |
84481f76 | 26 | -- -- |
91ed4b19 NN |
27 | -- GNARL was developed by the GNARL team at Florida State University. -- |
28 | -- Extensive contributions were provided by Ada Core Technologies, Inc. -- | |
84481f76 RK |
29 | -- -- |
30 | ------------------------------------------------------------------------------ | |
31 | ||
32 | -- This is the VxWorks version of this package | |
33 | ||
dc97c7a8 AC |
34 | -- This package contains all the GNULL primitives that interface directly with |
35 | -- the underlying OS. | |
84481f76 RK |
36 | |
37 | pragma Polling (Off); | |
dc97c7a8 AC |
38 | -- Turn off polling, we do not want ATC polling to take place during tasking |
39 | -- operations. It causes infinite loops and other problems. | |
84481f76 | 40 | |
dc97c7a8 | 41 | with Ada.Unchecked_Conversion; |
84481f76 | 42 | |
07fc65c4 | 43 | with Interfaces.C; |
84481f76 | 44 | |
8918fe18 | 45 | with System.Multiprocessors; |
dc97c7a8 AC |
46 | with System.Tasking.Debug; |
47 | with System.Interrupt_Management; | |
7ab4d95a | 48 | with System.Float_Control; |
ef992452 | 49 | with System.OS_Constants; |
72774950 | 50 | |
dc97c7a8 | 51 | with System.Soft_Links; |
72774950 | 52 | -- We use System.Soft_Links instead of System.Tasking.Initialization |
dc97c7a8 AC |
53 | -- because the later is a higher level package that we shouldn't depend |
54 | -- on. For example when using the restricted run time, it is replaced by | |
72774950 JR |
55 | -- System.Tasking.Restricted.Stages. |
56 | ||
95cd3246 | 57 | with System.Task_Info; |
c4394c15 AC |
58 | with System.VxWorks.Ext; |
59 | ||
84481f76 RK |
60 | package body System.Task_Primitives.Operations is |
61 | ||
ef992452 | 62 | package OSC renames System.OS_Constants; |
72774950 JR |
63 | package SSL renames System.Soft_Links; |
64 | ||
84481f76 RK |
65 | use System.Tasking.Debug; |
66 | use System.Tasking; | |
84481f76 RK |
67 | use System.OS_Interface; |
68 | use System.Parameters; | |
c4394c15 | 69 | use type System.VxWorks.Ext.t_id; |
07fc65c4 | 70 | use type Interfaces.C.int; |
c37cbdc3 | 71 | use type System.OS_Interface.unsigned; |
84481f76 | 72 | |
07fc65c4 | 73 | subtype int is System.OS_Interface.int; |
c37cbdc3 | 74 | subtype unsigned is System.OS_Interface.unsigned; |
07fc65c4 GB |
75 | |
76 | Relative : constant := 0; | |
77 | ||
78 | ---------------- | |
79 | -- Local Data -- | |
80 | ---------------- | |
84481f76 | 81 | |
1a49cf99 AC |
82 | -- The followings are logically constants, but need to be initialized at |
83 | -- run time. | |
84481f76 | 84 | |
b5e792e2 | 85 | Environment_Task_Id : Task_Id; |
1a49cf99 | 86 | -- A variable to hold Task_Id for the environment task |
84481f76 | 87 | |
1a49cf99 | 88 | -- The followings are internal configuration constants needed |
84481f76 | 89 | |
806f6d37 AC |
90 | Dispatching_Policy : Character; |
91 | pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); | |
92 | ||
93 | Foreign_Task_Elaborated : aliased Boolean := True; | |
94 | -- Used to identified fake tasks (i.e., non-Ada Threads) | |
84481f76 RK |
95 | |
96 | Locking_Policy : Character; | |
97 | pragma Import (C, Locking_Policy, "__gl_locking_policy"); | |
98 | ||
07fc65c4 | 99 | Mutex_Protocol : Priority_Type; |
84481f76 | 100 | |
806f6d37 AC |
101 | Single_RTS_Lock : aliased RTS_Lock; |
102 | -- This is a lock to allow only one thread of control in the RTS at a | |
103 | -- time; it is used to execute in mutual exclusion from all other tasks. | |
104 | -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List | |
0312b364 | 105 | |
806f6d37 AC |
106 | Time_Slice_Val : Integer; |
107 | pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); | |
0312b364 | 108 | |
d2b4b3da AC |
109 | Null_Thread_Id : constant Thread_Id := 0; |
110 | -- Constant to indicate that the thread identifier has not yet been | |
111 | -- initialized. | |
112 | ||
fbf5a39b AC |
113 | -------------------- |
114 | -- Local Packages -- | |
115 | -------------------- | |
116 | ||
117 | package Specific is | |
118 | ||
b9260c3d AC |
119 | procedure Initialize; |
120 | pragma Inline (Initialize); | |
121 | -- Initialize task specific data | |
122 | ||
fbf5a39b AC |
123 | function Is_Valid_Task return Boolean; |
124 | pragma Inline (Is_Valid_Task); | |
125 | -- Does executing thread have a TCB? | |
126 | ||
b5e792e2 | 127 | procedure Set (Self_Id : Task_Id); |
fbf5a39b | 128 | pragma Inline (Set); |
ba759acd AC |
129 | -- Set the self id for the current task, unless Self_Id is null, in |
130 | -- which case the task specific data is deleted. | |
b9260c3d | 131 | |
b5e792e2 | 132 | function Self return Task_Id; |
fbf5a39b | 133 | pragma Inline (Self); |
1a49cf99 | 134 | -- Return a pointer to the Ada Task Control Block of the calling task |
fbf5a39b AC |
135 | |
136 | end Specific; | |
137 | ||
138 | package body Specific is separate; | |
1a49cf99 | 139 | -- The body of this package is target specific |
fbf5a39b | 140 | |
f4f92d9d AC |
141 | ---------------------------------- |
142 | -- ATCB allocation/deallocation -- | |
143 | ---------------------------------- | |
144 | ||
145 | package body ATCB_Allocation is separate; | |
146 | -- The body of this package is shared across several targets | |
147 | ||
fbf5a39b AC |
148 | --------------------------------- |
149 | -- Support for foreign threads -- | |
150 | --------------------------------- | |
151 | ||
bad0a3df PMR |
152 | function Register_Foreign_Thread |
153 | (Thread : Thread_Id; | |
154 | Sec_Stack_Size : Size_Type := Unspecified_Size) return Task_Id; | |
155 | -- Allocate and initialize a new ATCB for the current Thread. The size of | |
156 | -- the secondary stack can be optionally specified. | |
fbf5a39b AC |
157 | |
158 | function Register_Foreign_Thread | |
bad0a3df PMR |
159 | (Thread : Thread_Id; |
160 | Sec_Stack_Size : Size_Type := Unspecified_Size) | |
161 | return Task_Id is separate; | |
fbf5a39b | 162 | |
84481f76 RK |
163 | ----------------------- |
164 | -- Local Subprograms -- | |
165 | ----------------------- | |
166 | ||
167 | procedure Abort_Handler (signo : Signal); | |
1a49cf99 | 168 | -- Handler for the abort (SIGABRT) signal to handle asynchronous abort |
fbf5a39b AC |
169 | |
170 | procedure Install_Signal_Handlers; | |
171 | -- Install the default signal handlers for the current task | |
84481f76 | 172 | |
9db0b232 | 173 | function Is_Task_Context return Boolean; |
0e290c54 AC |
174 | -- This function returns True if the current execution is in the context of |
175 | -- a task, and False if it is an interrupt context. | |
9db0b232 | 176 | |
806f6d37 AC |
177 | type Set_Stack_Limit_Proc_Acc is access procedure; |
178 | pragma Convention (C, Set_Stack_Limit_Proc_Acc); | |
179 | ||
180 | Set_Stack_Limit_Hook : Set_Stack_Limit_Proc_Acc; | |
181 | pragma Import (C, Set_Stack_Limit_Hook, "__gnat_set_stack_limit_hook"); | |
0e290c54 AC |
182 | -- Procedure to be called when a task is created to set stack limit. Used |
183 | -- only for VxWorks 5 and VxWorks MILS guest OS. | |
806f6d37 | 184 | |
dae22b53 AC |
185 | function To_Address is |
186 | new Ada.Unchecked_Conversion (Task_Id, System.Address); | |
84481f76 RK |
187 | |
188 | ------------------- | |
189 | -- Abort_Handler -- | |
190 | ------------------- | |
191 | ||
192 | procedure Abort_Handler (signo : Signal) is | |
fbf5a39b AC |
193 | pragma Unreferenced (signo); |
194 | ||
96a8b705 JL |
195 | -- Do not call Self at this point as we're in a signal handler |
196 | -- and it may not be available, in particular on targets where we | |
197 | -- support ZCX and where we don't do anything here anyway. | |
198 | Self_ID : Task_Id; | |
90878b12 AC |
199 | Old_Set : aliased sigset_t; |
200 | Unblocked_Mask : aliased sigset_t; | |
201 | Result : int; | |
67ce0d7e RD |
202 | pragma Warnings (Off, Result); |
203 | ||
90878b12 AC |
204 | use System.Interrupt_Management; |
205 | ||
84481f76 | 206 | begin |
fbf5a39b AC |
207 | -- It is not safe to raise an exception when using ZCX and the GCC |
208 | -- exception handling mechanism. | |
209 | ||
164e06c6 | 210 | if ZCX_By_Default then |
fbf5a39b AC |
211 | return; |
212 | end if; | |
213 | ||
96a8b705 JL |
214 | Self_ID := Self; |
215 | ||
84481f76 | 216 | if Self_ID.Deferral_Level = 0 |
07fc65c4 GB |
217 | and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level |
218 | and then not Self_ID.Aborting | |
84481f76 RK |
219 | then |
220 | Self_ID.Aborting := True; | |
221 | ||
806f6d37 | 222 | -- Make sure signals used for RTS internal purposes are unmasked |
84481f76 | 223 | |
90878b12 AC |
224 | Result := sigemptyset (Unblocked_Mask'Access); |
225 | pragma Assert (Result = 0); | |
226 | Result := | |
227 | sigaddset | |
228 | (Unblocked_Mask'Access, | |
229 | Signal (Abort_Task_Interrupt)); | |
230 | pragma Assert (Result = 0); | |
231 | Result := sigaddset (Unblocked_Mask'Access, SIGBUS); | |
232 | pragma Assert (Result = 0); | |
233 | Result := sigaddset (Unblocked_Mask'Access, SIGFPE); | |
234 | pragma Assert (Result = 0); | |
235 | Result := sigaddset (Unblocked_Mask'Access, SIGILL); | |
236 | pragma Assert (Result = 0); | |
237 | Result := sigaddset (Unblocked_Mask'Access, SIGSEGV); | |
238 | pragma Assert (Result = 0); | |
239 | ||
dae22b53 AC |
240 | Result := |
241 | pthread_sigmask | |
242 | (SIG_UNBLOCK, | |
90878b12 | 243 | Unblocked_Mask'Access, |
bb1f5840 | 244 | Old_Set'Access); |
84481f76 RK |
245 | pragma Assert (Result = 0); |
246 | ||
247 | raise Standard'Abort_Signal; | |
248 | end if; | |
249 | end Abort_Handler; | |
250 | ||
251 | ----------------- | |
252 | -- Stack_Guard -- | |
253 | ----------------- | |
254 | ||
b5e792e2 | 255 | procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is |
fbf5a39b AC |
256 | pragma Unreferenced (T); |
257 | pragma Unreferenced (On); | |
258 | ||
84481f76 | 259 | begin |
fbf5a39b AC |
260 | -- Nothing needed (why not???) |
261 | ||
07fc65c4 | 262 | null; |
84481f76 RK |
263 | end Stack_Guard; |
264 | ||
265 | ------------------- | |
266 | -- Get_Thread_Id -- | |
267 | ------------------- | |
268 | ||
b5e792e2 | 269 | function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is |
84481f76 RK |
270 | begin |
271 | return T.Common.LL.Thread; | |
272 | end Get_Thread_Id; | |
273 | ||
274 | ---------- | |
275 | -- Self -- | |
276 | ---------- | |
277 | ||
b5e792e2 | 278 | function Self return Task_Id renames Specific.Self; |
84481f76 RK |
279 | |
280 | ----------------------------- | |
281 | -- Install_Signal_Handlers -- | |
282 | ----------------------------- | |
283 | ||
84481f76 | 284 | procedure Install_Signal_Handlers is |
fbf5a39b AC |
285 | act : aliased struct_sigaction; |
286 | old_act : aliased struct_sigaction; | |
287 | Tmp_Set : aliased sigset_t; | |
288 | Result : int; | |
84481f76 RK |
289 | |
290 | begin | |
291 | act.sa_flags := 0; | |
292 | act.sa_handler := Abort_Handler'Address; | |
293 | ||
294 | Result := sigemptyset (Tmp_Set'Access); | |
295 | pragma Assert (Result = 0); | |
296 | act.sa_mask := Tmp_Set; | |
297 | ||
298 | Result := | |
299 | sigaction | |
dae22b53 | 300 | (Signal (Interrupt_Management.Abort_Task_Interrupt), |
84481f76 RK |
301 | act'Unchecked_Access, |
302 | old_act'Unchecked_Access); | |
303 | pragma Assert (Result = 0); | |
304 | ||
305 | Interrupt_Management.Initialize_Interrupts; | |
306 | end Install_Signal_Handlers; | |
307 | ||
308 | --------------------- | |
309 | -- Initialize_Lock -- | |
310 | --------------------- | |
311 | ||
2c851ddd | 312 | procedure Initialize_Lock |
dae22b53 AC |
313 | (Prio : System.Any_Priority; |
314 | L : not null access Lock) | |
315 | is | |
84481f76 | 316 | begin |
07fc65c4 GB |
317 | L.Mutex := semMCreate (SEM_Q_PRIORITY + SEM_INVERSION_SAFE); |
318 | L.Prio_Ceiling := int (Prio); | |
319 | L.Protocol := Mutex_Protocol; | |
320 | pragma Assert (L.Mutex /= 0); | |
84481f76 RK |
321 | end Initialize_Lock; |
322 | ||
2c851ddd | 323 | procedure Initialize_Lock |
dae22b53 AC |
324 | (L : not null access RTS_Lock; |
325 | Level : Lock_Level) | |
2c851ddd | 326 | is |
fbf5a39b | 327 | pragma Unreferenced (Level); |
84481f76 | 328 | begin |
07fc65c4 GB |
329 | L.Mutex := semMCreate (SEM_Q_PRIORITY + SEM_INVERSION_SAFE); |
330 | L.Prio_Ceiling := int (System.Any_Priority'Last); | |
331 | L.Protocol := Mutex_Protocol; | |
332 | pragma Assert (L.Mutex /= 0); | |
84481f76 RK |
333 | end Initialize_Lock; |
334 | ||
335 | ------------------- | |
336 | -- Finalize_Lock -- | |
337 | ------------------- | |
338 | ||
2c851ddd | 339 | procedure Finalize_Lock (L : not null access Lock) is |
07fc65c4 | 340 | Result : int; |
84481f76 | 341 | begin |
07fc65c4 | 342 | Result := semDelete (L.Mutex); |
84481f76 RK |
343 | pragma Assert (Result = 0); |
344 | end Finalize_Lock; | |
345 | ||
2c851ddd | 346 | procedure Finalize_Lock (L : not null access RTS_Lock) is |
07fc65c4 | 347 | Result : int; |
84481f76 | 348 | begin |
07fc65c4 | 349 | Result := semDelete (L.Mutex); |
84481f76 RK |
350 | pragma Assert (Result = 0); |
351 | end Finalize_Lock; | |
352 | ||
353 | ---------------- | |
354 | -- Write_Lock -- | |
355 | ---------------- | |
356 | ||
2c851ddd | 357 | procedure Write_Lock |
dae22b53 AC |
358 | (L : not null access Lock; |
359 | Ceiling_Violation : out Boolean) | |
2c851ddd | 360 | is |
07fc65c4 | 361 | Result : int; |
dae22b53 | 362 | |
84481f76 | 363 | begin |
07fc65c4 GB |
364 | if L.Protocol = Prio_Protect |
365 | and then int (Self.Common.Current_Priority) > L.Prio_Ceiling | |
366 | then | |
367 | Ceiling_Violation := True; | |
368 | return; | |
369 | else | |
370 | Ceiling_Violation := False; | |
371 | end if; | |
84481f76 | 372 | |
07fc65c4 GB |
373 | Result := semTake (L.Mutex, WAIT_FOREVER); |
374 | pragma Assert (Result = 0); | |
84481f76 RK |
375 | end Write_Lock; |
376 | ||
07fc65c4 | 377 | procedure Write_Lock |
2c851ddd | 378 | (L : not null access RTS_Lock; |
fbf5a39b | 379 | Global_Lock : Boolean := False) |
07fc65c4 GB |
380 | is |
381 | Result : int; | |
84481f76 | 382 | begin |
07fc65c4 GB |
383 | if not Single_Lock or else Global_Lock then |
384 | Result := semTake (L.Mutex, WAIT_FOREVER); | |
385 | pragma Assert (Result = 0); | |
386 | end if; | |
84481f76 RK |
387 | end Write_Lock; |
388 | ||
b5e792e2 | 389 | procedure Write_Lock (T : Task_Id) is |
07fc65c4 | 390 | Result : int; |
84481f76 | 391 | begin |
07fc65c4 GB |
392 | if not Single_Lock then |
393 | Result := semTake (T.Common.LL.L.Mutex, WAIT_FOREVER); | |
394 | pragma Assert (Result = 0); | |
395 | end if; | |
84481f76 RK |
396 | end Write_Lock; |
397 | ||
398 | --------------- | |
399 | -- Read_Lock -- | |
400 | --------------- | |
401 | ||
2c851ddd | 402 | procedure Read_Lock |
64a63cd5 | 403 | (L : not null access Lock; |
dae22b53 AC |
404 | Ceiling_Violation : out Boolean) |
405 | is | |
84481f76 RK |
406 | begin |
407 | Write_Lock (L, Ceiling_Violation); | |
408 | end Read_Lock; | |
409 | ||
410 | ------------ | |
411 | -- Unlock -- | |
412 | ------------ | |
413 | ||
2c851ddd | 414 | procedure Unlock (L : not null access Lock) is |
b9260c3d | 415 | Result : int; |
84481f76 | 416 | begin |
07fc65c4 | 417 | Result := semGive (L.Mutex); |
84481f76 RK |
418 | pragma Assert (Result = 0); |
419 | end Unlock; | |
420 | ||
2c851ddd | 421 | procedure Unlock |
dae22b53 AC |
422 | (L : not null access RTS_Lock; |
423 | Global_Lock : Boolean := False) | |
2c851ddd | 424 | is |
07fc65c4 | 425 | Result : int; |
84481f76 | 426 | begin |
07fc65c4 GB |
427 | if not Single_Lock or else Global_Lock then |
428 | Result := semGive (L.Mutex); | |
429 | pragma Assert (Result = 0); | |
430 | end if; | |
84481f76 RK |
431 | end Unlock; |
432 | ||
b5e792e2 | 433 | procedure Unlock (T : Task_Id) is |
07fc65c4 | 434 | Result : int; |
84481f76 | 435 | begin |
07fc65c4 GB |
436 | if not Single_Lock then |
437 | Result := semGive (T.Common.LL.L.Mutex); | |
438 | pragma Assert (Result = 0); | |
439 | end if; | |
84481f76 RK |
440 | end Unlock; |
441 | ||
dae22b53 AC |
442 | ----------------- |
443 | -- Set_Ceiling -- | |
444 | ----------------- | |
445 | ||
446 | -- Dynamic priority ceilings are not supported by the underlying system | |
447 | ||
448 | procedure Set_Ceiling | |
449 | (L : not null access Lock; | |
450 | Prio : System.Any_Priority) | |
451 | is | |
452 | pragma Unreferenced (L, Prio); | |
453 | begin | |
454 | null; | |
455 | end Set_Ceiling; | |
456 | ||
07fc65c4 GB |
457 | ----------- |
458 | -- Sleep -- | |
459 | ----------- | |
84481f76 | 460 | |
b5e792e2 | 461 | procedure Sleep (Self_ID : Task_Id; Reason : System.Tasking.Task_States) is |
fbf5a39b AC |
462 | pragma Unreferenced (Reason); |
463 | ||
07fc65c4 | 464 | Result : int; |
fbf5a39b | 465 | |
84481f76 RK |
466 | begin |
467 | pragma Assert (Self_ID = Self); | |
84481f76 | 468 | |
1a49cf99 AC |
469 | -- Release the mutex before sleeping |
470 | ||
196b1993 AC |
471 | Result := |
472 | semGive (if Single_Lock | |
473 | then Single_RTS_Lock.Mutex | |
474 | else Self_ID.Common.LL.L.Mutex); | |
07fc65c4 GB |
475 | pragma Assert (Result = 0); |
476 | ||
1a49cf99 AC |
477 | -- Perform a blocking operation to take the CV semaphore. Note that a |
478 | -- blocking operation in VxWorks will reenable task scheduling. When we | |
479 | -- are no longer blocked and control is returned, task scheduling will | |
480 | -- again be disabled. | |
07fc65c4 | 481 | |
fbf5a39b AC |
482 | Result := semTake (Self_ID.Common.LL.CV, WAIT_FOREVER); |
483 | pragma Assert (Result = 0); | |
07fc65c4 | 484 | |
1a49cf99 AC |
485 | -- Take the mutex back |
486 | ||
196b1993 AC |
487 | Result := |
488 | semTake ((if Single_Lock | |
489 | then Single_RTS_Lock.Mutex | |
490 | else Self_ID.Common.LL.L.Mutex), WAIT_FOREVER); | |
07fc65c4 | 491 | pragma Assert (Result = 0); |
84481f76 RK |
492 | end Sleep; |
493 | ||
494 | ----------------- | |
495 | -- Timed_Sleep -- | |
496 | ----------------- | |
497 | ||
1a49cf99 AC |
498 | -- This is for use within the run-time system, so abort is assumed to be |
499 | -- already deferred, and the caller should be holding its own ATCB lock. | |
84481f76 RK |
500 | |
501 | procedure Timed_Sleep | |
b5e792e2 | 502 | (Self_ID : Task_Id; |
84481f76 RK |
503 | Time : Duration; |
504 | Mode : ST.Delay_Modes; | |
505 | Reason : System.Tasking.Task_States; | |
506 | Timedout : out Boolean; | |
507 | Yielded : out Boolean) | |
508 | is | |
fbf5a39b AC |
509 | pragma Unreferenced (Reason); |
510 | ||
511 | Orig : constant Duration := Monotonic_Clock; | |
512 | Absolute : Duration; | |
513 | Ticks : int; | |
514 | Result : int; | |
515 | Wakeup : Boolean := False; | |
84481f76 RK |
516 | |
517 | begin | |
fbf5a39b AC |
518 | Timedout := False; |
519 | Yielded := True; | |
84481f76 RK |
520 | |
521 | if Mode = Relative then | |
fbf5a39b AC |
522 | Absolute := Orig + Time; |
523 | ||
1a49cf99 AC |
524 | -- Systematically add one since the first tick will delay *at most* |
525 | -- 1 / Rate_Duration seconds, so we need to add one to be on the | |
526 | -- safe side. | |
07fc65c4 | 527 | |
fbf5a39b AC |
528 | Ticks := To_Clock_Ticks (Time); |
529 | ||
530 | if Ticks > 0 and then Ticks < int'Last then | |
531 | Ticks := Ticks + 1; | |
532 | end if; | |
533 | ||
84481f76 | 534 | else |
fbf5a39b AC |
535 | Absolute := Time; |
536 | Ticks := To_Clock_Ticks (Time - Monotonic_Clock); | |
84481f76 RK |
537 | end if; |
538 | ||
07fc65c4 | 539 | if Ticks > 0 then |
fbf5a39b | 540 | loop |
1a49cf99 AC |
541 | -- Release the mutex before sleeping |
542 | ||
196b1993 AC |
543 | Result := |
544 | semGive (if Single_Lock | |
545 | then Single_RTS_Lock.Mutex | |
546 | else Self_ID.Common.LL.L.Mutex); | |
fbf5a39b | 547 | pragma Assert (Result = 0); |
84481f76 | 548 | |
1a49cf99 AC |
549 | -- Perform a blocking operation to take the CV semaphore. Note |
550 | -- that a blocking operation in VxWorks will reenable task | |
551 | -- scheduling. When we are no longer blocked and control is | |
552 | -- returned, task scheduling will again be disabled. | |
84481f76 | 553 | |
fbf5a39b | 554 | Result := semTake (Self_ID.Common.LL.CV, Ticks); |
84481f76 | 555 | |
fbf5a39b | 556 | if Result = 0 then |
1a49cf99 | 557 | |
fbf5a39b | 558 | -- Somebody may have called Wakeup for us |
84481f76 | 559 | |
fbf5a39b | 560 | Wakeup := True; |
07fc65c4 | 561 | |
fbf5a39b AC |
562 | else |
563 | if errno /= S_objLib_OBJ_TIMEOUT then | |
564 | Wakeup := True; | |
1a49cf99 | 565 | |
fbf5a39b | 566 | else |
1a49cf99 AC |
567 | -- If Ticks = int'last, it was most probably truncated so |
568 | -- let's make another round after recomputing Ticks from | |
12a13f01 | 569 | -- the absolute time. |
fbf5a39b AC |
570 | |
571 | if Ticks /= int'Last then | |
572 | Timedout := True; | |
dae22b53 | 573 | |
fbf5a39b AC |
574 | else |
575 | Ticks := To_Clock_Ticks (Absolute - Monotonic_Clock); | |
576 | ||
577 | if Ticks < 0 then | |
578 | Timedout := True; | |
579 | end if; | |
580 | end if; | |
581 | end if; | |
582 | end if; | |
07fc65c4 | 583 | |
1a49cf99 AC |
584 | -- Take the mutex back |
585 | ||
196b1993 AC |
586 | Result := |
587 | semTake ((if Single_Lock | |
588 | then Single_RTS_Lock.Mutex | |
589 | else Self_ID.Common.LL.L.Mutex), WAIT_FOREVER); | |
fbf5a39b | 590 | pragma Assert (Result = 0); |
07fc65c4 | 591 | |
fbf5a39b AC |
592 | exit when Timedout or Wakeup; |
593 | end loop; | |
84481f76 | 594 | |
fbf5a39b AC |
595 | else |
596 | Timedout := True; | |
07fc65c4 | 597 | |
1a49cf99 AC |
598 | -- Should never hold a lock while yielding |
599 | ||
07fc65c4 | 600 | if Single_Lock then |
fbf5a39b | 601 | Result := semGive (Single_RTS_Lock.Mutex); |
81501d2b | 602 | Result := taskDelay (0); |
07fc65c4 | 603 | Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER); |
fbf5a39b | 604 | |
07fc65c4 | 605 | else |
fbf5a39b | 606 | Result := semGive (Self_ID.Common.LL.L.Mutex); |
81501d2b | 607 | Result := taskDelay (0); |
07fc65c4 GB |
608 | Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER); |
609 | end if; | |
84481f76 RK |
610 | end if; |
611 | end Timed_Sleep; | |
612 | ||
613 | ----------------- | |
614 | -- Timed_Delay -- | |
615 | ----------------- | |
616 | ||
1a49cf99 AC |
617 | -- This is for use in implementing delay statements, so we assume the |
618 | -- caller is holding no locks. | |
84481f76 RK |
619 | |
620 | procedure Timed_Delay | |
b9260c3d AC |
621 | (Self_ID : Task_Id; |
622 | Time : Duration; | |
623 | Mode : ST.Delay_Modes) | |
84481f76 | 624 | is |
07fc65c4 GB |
625 | Orig : constant Duration := Monotonic_Clock; |
626 | Absolute : Duration; | |
627 | Ticks : int; | |
628 | Timedout : Boolean; | |
fbf5a39b | 629 | Aborted : Boolean := False; |
07fc65c4 | 630 | |
ec946d18 AC |
631 | Result : int; |
632 | pragma Warnings (Off, Result); | |
633 | ||
84481f76 | 634 | begin |
84481f76 | 635 | if Mode = Relative then |
07fc65c4 | 636 | Absolute := Orig + Time; |
fbf5a39b | 637 | Ticks := To_Clock_Ticks (Time); |
07fc65c4 | 638 | |
fbf5a39b | 639 | if Ticks > 0 and then Ticks < int'Last then |
07fc65c4 | 640 | |
1a49cf99 AC |
641 | -- First tick will delay anytime between 0 and 1 / sysClkRateGet |
642 | -- seconds, so we need to add one to be on the safe side. | |
07fc65c4 GB |
643 | |
644 | Ticks := Ticks + 1; | |
645 | end if; | |
fbf5a39b | 646 | |
84481f76 | 647 | else |
07fc65c4 GB |
648 | Absolute := Time; |
649 | Ticks := To_Clock_Ticks (Time - Orig); | |
84481f76 RK |
650 | end if; |
651 | ||
07fc65c4 | 652 | if Ticks > 0 then |
1a49cf99 | 653 | |
dae22b53 | 654 | -- Modifying State, locking the TCB |
1a49cf99 | 655 | |
196b1993 AC |
656 | Result := |
657 | semTake ((if Single_Lock | |
658 | then Single_RTS_Lock.Mutex | |
659 | else Self_ID.Common.LL.L.Mutex), WAIT_FOREVER); | |
fbf5a39b AC |
660 | |
661 | pragma Assert (Result = 0); | |
662 | ||
84481f76 | 663 | Self_ID.Common.State := Delay_Sleep; |
fbf5a39b | 664 | Timedout := False; |
84481f76 RK |
665 | |
666 | loop | |
fbf5a39b | 667 | Aborted := Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; |
84481f76 | 668 | |
fbf5a39b | 669 | -- Release the TCB before sleeping |
07fc65c4 | 670 | |
196b1993 AC |
671 | Result := |
672 | semGive (if Single_Lock | |
673 | then Single_RTS_Lock.Mutex | |
674 | else Self_ID.Common.LL.L.Mutex); | |
07fc65c4 GB |
675 | pragma Assert (Result = 0); |
676 | ||
fbf5a39b | 677 | exit when Aborted; |
07fc65c4 | 678 | |
fbf5a39b | 679 | Result := semTake (Self_ID.Common.LL.CV, Ticks); |
07fc65c4 GB |
680 | |
681 | if Result /= 0 then | |
1a49cf99 | 682 | |
0e290c54 AC |
683 | -- If Ticks = int'last, it was most probably truncated, so make |
684 | -- another round after recomputing Ticks from absolute time. | |
07fc65c4 | 685 | |
fbf5a39b | 686 | if errno = S_objLib_OBJ_TIMEOUT and then Ticks /= int'Last then |
07fc65c4 GB |
687 | Timedout := True; |
688 | else | |
689 | Ticks := To_Clock_Ticks (Absolute - Monotonic_Clock); | |
fbf5a39b AC |
690 | |
691 | if Ticks < 0 then | |
692 | Timedout := True; | |
693 | end if; | |
07fc65c4 GB |
694 | end if; |
695 | end if; | |
696 | ||
fbf5a39b | 697 | -- Take back the lock after having slept, to protect further |
b9260c3d | 698 | -- access to Self_ID. |
fbf5a39b | 699 | |
196b1993 AC |
700 | Result := |
701 | semTake | |
702 | ((if Single_Lock | |
703 | then Single_RTS_Lock.Mutex | |
704 | else Self_ID.Common.LL.L.Mutex), WAIT_FOREVER); | |
07fc65c4 GB |
705 | |
706 | pragma Assert (Result = 0); | |
84481f76 | 707 | |
07fc65c4 | 708 | exit when Timedout; |
84481f76 RK |
709 | end loop; |
710 | ||
711 | Self_ID.Common.State := Runnable; | |
84481f76 | 712 | |
196b1993 AC |
713 | Result := |
714 | semGive | |
715 | (if Single_Lock | |
716 | then Single_RTS_Lock.Mutex | |
717 | else Self_ID.Common.LL.L.Mutex); | |
fbf5a39b | 718 | |
07fc65c4 | 719 | else |
81501d2b | 720 | Result := taskDelay (0); |
84481f76 | 721 | end if; |
84481f76 RK |
722 | end Timed_Delay; |
723 | ||
724 | --------------------- | |
725 | -- Monotonic_Clock -- | |
726 | --------------------- | |
727 | ||
728 | function Monotonic_Clock return Duration is | |
729 | TS : aliased timespec; | |
07fc65c4 | 730 | Result : int; |
84481f76 | 731 | begin |
c269a1f5 | 732 | Result := clock_gettime (OSC.CLOCK_RT_Ada, TS'Unchecked_Access); |
84481f76 RK |
733 | pragma Assert (Result = 0); |
734 | return To_Duration (TS); | |
735 | end Monotonic_Clock; | |
736 | ||
737 | ------------------- | |
738 | -- RT_Resolution -- | |
739 | ------------------- | |
740 | ||
741 | function RT_Resolution return Duration is | |
742 | begin | |
fbf5a39b | 743 | return 1.0 / Duration (sysClkRateGet); |
84481f76 RK |
744 | end RT_Resolution; |
745 | ||
746 | ------------ | |
747 | -- Wakeup -- | |
748 | ------------ | |
749 | ||
b5e792e2 | 750 | procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is |
fbf5a39b | 751 | pragma Unreferenced (Reason); |
fbf5a39b | 752 | Result : int; |
fbf5a39b AC |
753 | begin |
754 | Result := semGive (T.Common.LL.CV); | |
755 | pragma Assert (Result = 0); | |
84481f76 RK |
756 | end Wakeup; |
757 | ||
758 | ----------- | |
759 | -- Yield -- | |
760 | ----------- | |
761 | ||
762 | procedure Yield (Do_Yield : Boolean := True) is | |
fbf5a39b | 763 | pragma Unreferenced (Do_Yield); |
07fc65c4 | 764 | Result : int; |
91b1417d | 765 | pragma Unreferenced (Result); |
84481f76 | 766 | begin |
07fc65c4 | 767 | Result := taskDelay (0); |
84481f76 RK |
768 | end Yield; |
769 | ||
770 | ------------------ | |
771 | -- Set_Priority -- | |
772 | ------------------ | |
773 | ||
84481f76 | 774 | procedure Set_Priority |
b5e792e2 | 775 | (T : Task_Id; |
fbf5a39b | 776 | Prio : System.Any_Priority; |
84481f76 RK |
777 | Loss_Of_Inheritance : Boolean := False) |
778 | is | |
55c1c66d AC |
779 | pragma Unreferenced (Loss_Of_Inheritance); |
780 | ||
07fc65c4 | 781 | Result : int; |
84481f76 RK |
782 | |
783 | begin | |
fbf5a39b AC |
784 | Result := |
785 | taskPrioritySet | |
786 | (T.Common.LL.Thread, To_VxWorks_Priority (int (Prio))); | |
84481f76 RK |
787 | pragma Assert (Result = 0); |
788 | ||
fa5aa835 AC |
789 | -- Note: in VxWorks 6.6 (or earlier), the task is placed at the end of |
790 | -- the priority queue instead of the head. This is not the behavior | |
791 | -- required by Annex D (RM D.2.3(5/2)), but we consider it an acceptable | |
792 | -- variation (RM 1.1.3(6)), given this is the built-in behavior of the | |
793 | -- operating system. VxWorks versions starting from 6.7 implement the | |
794 | -- required Annex D semantics. | |
f6da8aff RD |
795 | |
796 | -- In older versions we attempted to better approximate the Annex D | |
797 | -- required behavior, but this simulation was not entirely accurate, | |
798 | -- and it seems better to live with the standard VxWorks semantics. | |
799 | ||
84481f76 RK |
800 | T.Common.Current_Priority := Prio; |
801 | end Set_Priority; | |
802 | ||
803 | ------------------ | |
804 | -- Get_Priority -- | |
805 | ------------------ | |
806 | ||
b5e792e2 | 807 | function Get_Priority (T : Task_Id) return System.Any_Priority is |
84481f76 RK |
808 | begin |
809 | return T.Common.Current_Priority; | |
810 | end Get_Priority; | |
811 | ||
812 | ---------------- | |
813 | -- Enter_Task -- | |
814 | ---------------- | |
815 | ||
b5e792e2 | 816 | procedure Enter_Task (Self_ID : Task_Id) is |
84481f76 | 817 | begin |
ec946d18 AC |
818 | -- Store the user-level task id in the Thread field (to be used |
819 | -- internally by the run-time system) and the kernel-level task id in | |
820 | -- the LWP field (to be used by the debugger). | |
821 | ||
07fc65c4 | 822 | Self_ID.Common.LL.Thread := taskIdSelf; |
ec946d18 AC |
823 | Self_ID.Common.LL.LWP := getpid; |
824 | ||
fbf5a39b AC |
825 | Specific.Set (Self_ID); |
826 | ||
7ab4d95a AC |
827 | -- Properly initializes the FPU for PPC/MIPS systems |
828 | ||
829 | System.Float_Control.Reset; | |
84481f76 | 830 | |
1a49cf99 AC |
831 | -- Install the signal handlers |
832 | ||
84481f76 RK |
833 | -- This is called for each task since there is no signal inheritance |
834 | -- between VxWorks tasks. | |
835 | ||
836 | Install_Signal_Handlers; | |
837 | ||
dc97c7a8 AC |
838 | -- If stack checking is enabled, set the stack limit for this task |
839 | ||
0312b364 EB |
840 | if Set_Stack_Limit_Hook /= null then |
841 | Set_Stack_Limit_Hook.all; | |
842 | end if; | |
84481f76 RK |
843 | end Enter_Task; |
844 | ||
fbf5a39b AC |
845 | ------------------- |
846 | -- Is_Valid_Task -- | |
847 | ------------------- | |
848 | ||
849 | function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task; | |
850 | ||
851 | ----------------------------- | |
852 | -- Register_Foreign_Thread -- | |
853 | ----------------------------- | |
854 | ||
b5e792e2 | 855 | function Register_Foreign_Thread return Task_Id is |
fbf5a39b AC |
856 | begin |
857 | if Is_Valid_Task then | |
858 | return Self; | |
859 | else | |
860 | return Register_Foreign_Thread (taskIdSelf); | |
861 | end if; | |
862 | end Register_Foreign_Thread; | |
863 | ||
07fc65c4 GB |
864 | -------------------- |
865 | -- Initialize_TCB -- | |
866 | -------------------- | |
84481f76 | 867 | |
b5e792e2 | 868 | procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is |
84481f76 | 869 | begin |
fbf5a39b | 870 | Self_ID.Common.LL.CV := semBCreate (SEM_Q_PRIORITY, SEM_EMPTY); |
d2b4b3da | 871 | Self_ID.Common.LL.Thread := Null_Thread_Id; |
84481f76 | 872 | |
fbf5a39b | 873 | if Self_ID.Common.LL.CV = 0 then |
84481f76 | 874 | Succeeded := False; |
dae22b53 | 875 | |
84481f76 | 876 | else |
07fc65c4 | 877 | Succeeded := True; |
84481f76 | 878 | |
07fc65c4 GB |
879 | if not Single_Lock then |
880 | Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level); | |
881 | end if; | |
882 | end if; | |
84481f76 RK |
883 | end Initialize_TCB; |
884 | ||
885 | ----------------- | |
886 | -- Create_Task -- | |
887 | ----------------- | |
888 | ||
889 | procedure Create_Task | |
b5e792e2 | 890 | (T : Task_Id; |
84481f76 RK |
891 | Wrapper : System.Address; |
892 | Stack_Size : System.Parameters.Size_Type; | |
893 | Priority : System.Any_Priority; | |
894 | Succeeded : out Boolean) | |
895 | is | |
07fc65c4 | 896 | Adjusted_Stack_Size : size_t; |
95cd3246 | 897 | |
702d2020 AC |
898 | use type System.Multiprocessors.CPU_Range; |
899 | ||
84481f76 | 900 | begin |
0e290c54 AC |
901 | -- Check whether both Dispatching_Domain and CPU are specified for |
902 | -- the task, and the CPU value is not contained within the range of | |
67645bde AC |
903 | -- processors for the domain. |
904 | ||
579fda56 AC |
905 | if T.Common.Domain /= null |
906 | and then T.Common.Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU | |
907 | and then | |
908 | (T.Common.Base_CPU not in T.Common.Domain'Range | |
909 | or else not T.Common.Domain (T.Common.Base_CPU)) | |
67645bde AC |
910 | then |
911 | Succeeded := False; | |
912 | return; | |
913 | end if; | |
914 | ||
1a49cf99 AC |
915 | -- Ask for four extra bytes of stack space so that the ATCB pointer can |
916 | -- be stored below the stack limit, plus extra space for the frame of | |
917 | -- Task_Wrapper. This is so the user gets the amount of stack requested | |
b9260c3d AC |
918 | -- exclusive of the needs. |
919 | ||
1a49cf99 AC |
920 | -- We also have to allocate n more bytes for the task name storage and |
921 | -- enough space for the Wind Task Control Block which is around 0x778 | |
922 | -- bytes. VxWorks also seems to carve out additional space, so use 2048 | |
923 | -- as a nice round number. We might want to increment to the nearest | |
924 | -- page size in case we ever support VxVMI. | |
b9260c3d AC |
925 | |
926 | -- ??? - we should come back and visit this so we can set the task name | |
1a49cf99 | 927 | -- to something appropriate. |
fbf5a39b | 928 | |
57d8e34e | 929 | Adjusted_Stack_Size := size_t (Stack_Size) + 2048; |
84481f76 | 930 | |
07fc65c4 | 931 | -- Since the initial signal mask of a thread is inherited from the |
1a49cf99 AC |
932 | -- creator, and the Environment task has all its signals masked, we do |
933 | -- not need to manipulate caller's signal mask at this point. All tasks | |
934 | -- in RTS will have All_Tasks_Mask initially. | |
07fc65c4 | 935 | |
ec946d18 AC |
936 | -- We now compute the VxWorks task name and options, then spawn ... |
937 | ||
938 | declare | |
939 | Name : aliased String (1 .. T.Common.Task_Image_Len + 1); | |
940 | Name_Address : System.Address; | |
941 | -- Task name we are going to hand down to VxWorks | |
1a49cf99 | 942 | |
2c851ddd PO |
943 | function Get_Task_Options return int; |
944 | pragma Import (C, Get_Task_Options, "__gnat_get_task_options"); | |
945 | -- Function that returns the options to be set for the task that we | |
946 | -- are creating. We fetch the options assigned to the current task, | |
947 | -- so offering some user level control over the options for a task | |
948 | -- hierarchy, and force VX_FP_TASK because it is almost always | |
949 | -- required. | |
ec946d18 AC |
950 | |
951 | begin | |
952 | -- If there is no Ada task name handy, let VxWorks choose one. | |
953 | -- Otherwise, tell VxWorks what the Ada task name is. | |
954 | ||
955 | if T.Common.Task_Image_Len = 0 then | |
956 | Name_Address := System.Null_Address; | |
957 | else | |
fbf5a39b AC |
958 | Name (1 .. Name'Last - 1) := |
959 | T.Common.Task_Image (1 .. T.Common.Task_Image_Len); | |
07fc65c4 | 960 | Name (Name'Last) := ASCII.NUL; |
ec946d18 AC |
961 | Name_Address := Name'Address; |
962 | end if; | |
07fc65c4 | 963 | |
ec946d18 AC |
964 | -- Now spawn the VxWorks task for real |
965 | ||
dae22b53 AC |
966 | T.Common.LL.Thread := |
967 | taskSpawn | |
968 | (Name_Address, | |
969 | To_VxWorks_Priority (int (Priority)), | |
970 | Get_Task_Options, | |
971 | Adjusted_Stack_Size, | |
972 | Wrapper, | |
973 | To_Address (T)); | |
ec946d18 | 974 | end; |
84481f76 | 975 | |
95cd3246 AC |
976 | -- Set processor affinity |
977 | ||
c37cbdc3 | 978 | Set_Task_Affinity (T); |
8918fe18 | 979 | |
0e290c54 AC |
980 | -- Only case of failure is if taskSpawn returned 0 (aka Null_Thread_Id) |
981 | ||
982 | if T.Common.LL.Thread = Null_Thread_Id then | |
07fc65c4 GB |
983 | Succeeded := False; |
984 | else | |
985 | Succeeded := True; | |
dc97c7a8 AC |
986 | Task_Creation_Hook (T.Common.LL.Thread); |
987 | Set_Priority (T, Priority); | |
07fc65c4 | 988 | end if; |
84481f76 RK |
989 | end Create_Task; |
990 | ||
991 | ------------------ | |
992 | -- Finalize_TCB -- | |
993 | ------------------ | |
994 | ||
b5e792e2 | 995 | procedure Finalize_TCB (T : Task_Id) is |
f4f92d9d | 996 | Result : int; |
84481f76 RK |
997 | |
998 | begin | |
fbf5a39b | 999 | if not Single_Lock then |
07fc65c4 GB |
1000 | Result := semDelete (T.Common.LL.L.Mutex); |
1001 | pragma Assert (Result = 0); | |
1002 | end if; | |
0bf08bfe | 1003 | |
d2b4b3da | 1004 | T.Common.LL.Thread := Null_Thread_Id; |
84481f76 | 1005 | |
fbf5a39b | 1006 | Result := semDelete (T.Common.LL.CV); |
84481f76 RK |
1007 | pragma Assert (Result = 0); |
1008 | ||
1009 | if T.Known_Tasks_Index /= -1 then | |
1010 | Known_Tasks (T.Known_Tasks_Index) := null; | |
1011 | end if; | |
1012 | ||
f4f92d9d | 1013 | ATCB_Allocation.Free_ATCB (T); |
84481f76 RK |
1014 | end Finalize_TCB; |
1015 | ||
1016 | --------------- | |
1017 | -- Exit_Task -- | |
1018 | --------------- | |
1019 | ||
1020 | procedure Exit_Task is | |
1021 | begin | |
fbf5a39b | 1022 | Specific.Set (null); |
84481f76 RK |
1023 | end Exit_Task; |
1024 | ||
1025 | ---------------- | |
1026 | -- Abort_Task -- | |
1027 | ---------------- | |
1028 | ||
b5e792e2 | 1029 | procedure Abort_Task (T : Task_Id) is |
07fc65c4 | 1030 | Result : int; |
84481f76 | 1031 | begin |
dae22b53 AC |
1032 | Result := |
1033 | kill | |
1034 | (T.Common.LL.Thread, | |
1035 | Signal (Interrupt_Management.Abort_Task_Interrupt)); | |
84481f76 RK |
1036 | pragma Assert (Result = 0); |
1037 | end Abort_Task; | |
1038 | ||
b497b460 JR |
1039 | ---------------- |
1040 | -- Initialize -- | |
1041 | ---------------- | |
1042 | ||
1043 | procedure Initialize (S : in out Suspension_Object) is | |
1044 | begin | |
dae22b53 | 1045 | -- Initialize internal state (always to False (RM D.10(6))) |
b497b460 JR |
1046 | |
1047 | S.State := False; | |
1048 | S.Waiting := False; | |
1049 | ||
1050 | -- Initialize internal mutex | |
1051 | ||
0e290c54 AC |
1052 | -- Use simpler binary semaphore instead of VxWorks mutual exclusion |
1053 | -- semaphore, because we don't need the fancier semantics and their | |
1054 | -- overhead. | |
b497b460 JR |
1055 | |
1056 | S.L := semBCreate (SEM_Q_FIFO, SEM_FULL); | |
1057 | ||
1058 | -- Initialize internal condition variable | |
1059 | ||
1060 | S.CV := semBCreate (SEM_Q_FIFO, SEM_EMPTY); | |
1061 | end Initialize; | |
1062 | ||
1063 | -------------- | |
1064 | -- Finalize -- | |
1065 | -------------- | |
1066 | ||
1067 | procedure Finalize (S : in out Suspension_Object) is | |
dc97c7a8 AC |
1068 | pragma Unmodified (S); |
1069 | -- S may be modified on other targets, but not on VxWorks | |
1070 | ||
b497b460 | 1071 | Result : STATUS; |
dae22b53 | 1072 | |
b497b460 JR |
1073 | begin |
1074 | -- Destroy internal mutex | |
1075 | ||
1076 | Result := semDelete (S.L); | |
1077 | pragma Assert (Result = OK); | |
1078 | ||
1079 | -- Destroy internal condition variable | |
1080 | ||
1081 | Result := semDelete (S.CV); | |
1082 | pragma Assert (Result = OK); | |
1083 | end Finalize; | |
1084 | ||
1085 | ------------------- | |
1086 | -- Current_State -- | |
1087 | ------------------- | |
1088 | ||
1089 | function Current_State (S : Suspension_Object) return Boolean is | |
1090 | begin | |
1091 | -- We do not want to use lock on this read operation. State is marked | |
1092 | -- as Atomic so that we ensure that the value retrieved is correct. | |
1093 | ||
1094 | return S.State; | |
1095 | end Current_State; | |
1096 | ||
1097 | --------------- | |
1098 | -- Set_False -- | |
1099 | --------------- | |
1100 | ||
1101 | procedure Set_False (S : in out Suspension_Object) is | |
dae22b53 AC |
1102 | Result : STATUS; |
1103 | ||
b497b460 | 1104 | begin |
72774950 JR |
1105 | SSL.Abort_Defer.all; |
1106 | ||
b497b460 JR |
1107 | Result := semTake (S.L, WAIT_FOREVER); |
1108 | pragma Assert (Result = OK); | |
1109 | ||
1110 | S.State := False; | |
1111 | ||
1112 | Result := semGive (S.L); | |
1113 | pragma Assert (Result = OK); | |
72774950 JR |
1114 | |
1115 | SSL.Abort_Undefer.all; | |
b497b460 JR |
1116 | end Set_False; |
1117 | ||
1118 | -------------- | |
1119 | -- Set_True -- | |
1120 | -------------- | |
1121 | ||
1122 | procedure Set_True (S : in out Suspension_Object) is | |
1123 | Result : STATUS; | |
dae22b53 | 1124 | |
b497b460 | 1125 | begin |
9db0b232 AC |
1126 | -- Set_True can be called from an interrupt context, in which case |
1127 | -- Abort_Defer is undefined. | |
f5d96d00 | 1128 | |
9db0b232 AC |
1129 | if Is_Task_Context then |
1130 | SSL.Abort_Defer.all; | |
1131 | end if; | |
72774950 | 1132 | |
b497b460 JR |
1133 | Result := semTake (S.L, WAIT_FOREVER); |
1134 | pragma Assert (Result = OK); | |
1135 | ||
0e290c54 AC |
1136 | -- If there is already a task waiting on this suspension object then we |
1137 | -- resume it, leaving the state of the suspension object to False, as it | |
1138 | -- is specified in (RM D.10 (9)). Otherwise, it just leaves the state to | |
1139 | -- True. | |
b497b460 JR |
1140 | |
1141 | if S.Waiting then | |
1142 | S.Waiting := False; | |
1143 | S.State := False; | |
1144 | ||
1145 | Result := semGive (S.CV); | |
1146 | pragma Assert (Result = OK); | |
1147 | else | |
1148 | S.State := True; | |
1149 | end if; | |
1150 | ||
1151 | Result := semGive (S.L); | |
1152 | pragma Assert (Result = OK); | |
72774950 | 1153 | |
9db0b232 AC |
1154 | -- Set_True can be called from an interrupt context, in which case |
1155 | -- Abort_Undefer is undefined. | |
f5d96d00 | 1156 | |
9db0b232 AC |
1157 | if Is_Task_Context then |
1158 | SSL.Abort_Undefer.all; | |
1159 | end if; | |
1160 | ||
b497b460 JR |
1161 | end Set_True; |
1162 | ||
1163 | ------------------------ | |
1164 | -- Suspend_Until_True -- | |
1165 | ------------------------ | |
1166 | ||
1167 | procedure Suspend_Until_True (S : in out Suspension_Object) is | |
1168 | Result : STATUS; | |
dae22b53 | 1169 | |
b497b460 | 1170 | begin |
72774950 JR |
1171 | SSL.Abort_Defer.all; |
1172 | ||
b497b460 JR |
1173 | Result := semTake (S.L, WAIT_FOREVER); |
1174 | ||
1175 | if S.Waiting then | |
dae22b53 | 1176 | |
b497b460 JR |
1177 | -- Program_Error must be raised upon calling Suspend_Until_True |
1178 | -- if another task is already waiting on that suspension object | |
0e290c54 | 1179 | -- (RM D.10(10)). |
b497b460 JR |
1180 | |
1181 | Result := semGive (S.L); | |
1182 | pragma Assert (Result = OK); | |
1183 | ||
72774950 JR |
1184 | SSL.Abort_Undefer.all; |
1185 | ||
b497b460 | 1186 | raise Program_Error; |
dae22b53 | 1187 | |
b497b460 JR |
1188 | else |
1189 | -- Suspend the task if the state is False. Otherwise, the task | |
1190 | -- continues its execution, and the state of the suspension object | |
0e290c54 | 1191 | -- is set to False (RM D.10 (9)). |
b497b460 JR |
1192 | |
1193 | if S.State then | |
1194 | S.State := False; | |
1195 | ||
1196 | Result := semGive (S.L); | |
1197 | pragma Assert (Result = 0); | |
72774950 JR |
1198 | |
1199 | SSL.Abort_Undefer.all; | |
dae22b53 | 1200 | |
b497b460 JR |
1201 | else |
1202 | S.Waiting := True; | |
1203 | ||
1204 | -- Release the mutex before sleeping | |
1205 | ||
1206 | Result := semGive (S.L); | |
1207 | pragma Assert (Result = OK); | |
1208 | ||
72774950 JR |
1209 | SSL.Abort_Undefer.all; |
1210 | ||
b497b460 JR |
1211 | Result := semTake (S.CV, WAIT_FOREVER); |
1212 | pragma Assert (Result = 0); | |
1213 | end if; | |
1214 | end if; | |
1215 | end Suspend_Until_True; | |
1216 | ||
84481f76 RK |
1217 | ---------------- |
1218 | -- Check_Exit -- | |
1219 | ---------------- | |
1220 | ||
fbf5a39b | 1221 | -- Dummy version |
84481f76 | 1222 | |
b5e792e2 | 1223 | function Check_Exit (Self_ID : ST.Task_Id) return Boolean is |
fbf5a39b | 1224 | pragma Unreferenced (Self_ID); |
84481f76 RK |
1225 | begin |
1226 | return True; | |
1227 | end Check_Exit; | |
1228 | ||
1229 | -------------------- | |
1230 | -- Check_No_Locks -- | |
1231 | -------------------- | |
1232 | ||
b5e792e2 | 1233 | function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is |
fbf5a39b | 1234 | pragma Unreferenced (Self_ID); |
84481f76 RK |
1235 | begin |
1236 | return True; | |
1237 | end Check_No_Locks; | |
1238 | ||
1239 | ---------------------- | |
1240 | -- Environment_Task -- | |
1241 | ---------------------- | |
1242 | ||
b5e792e2 | 1243 | function Environment_Task return Task_Id is |
84481f76 | 1244 | begin |
b5e792e2 | 1245 | return Environment_Task_Id; |
84481f76 RK |
1246 | end Environment_Task; |
1247 | ||
07fc65c4 GB |
1248 | -------------- |
1249 | -- Lock_RTS -- | |
1250 | -------------- | |
84481f76 | 1251 | |
07fc65c4 | 1252 | procedure Lock_RTS is |
84481f76 | 1253 | begin |
07fc65c4 GB |
1254 | Write_Lock (Single_RTS_Lock'Access, Global_Lock => True); |
1255 | end Lock_RTS; | |
84481f76 | 1256 | |
07fc65c4 GB |
1257 | ---------------- |
1258 | -- Unlock_RTS -- | |
1259 | ---------------- | |
84481f76 | 1260 | |
07fc65c4 | 1261 | procedure Unlock_RTS is |
84481f76 | 1262 | begin |
07fc65c4 GB |
1263 | Unlock (Single_RTS_Lock'Access, Global_Lock => True); |
1264 | end Unlock_RTS; | |
84481f76 RK |
1265 | |
1266 | ------------------ | |
1267 | -- Suspend_Task -- | |
1268 | ------------------ | |
1269 | ||
1270 | function Suspend_Task | |
b5e792e2 | 1271 | (T : ST.Task_Id; |
0ab80019 | 1272 | Thread_Self : Thread_Id) return Boolean |
fbf5a39b | 1273 | is |
84481f76 | 1274 | begin |
d2b4b3da | 1275 | if T.Common.LL.Thread /= Null_Thread_Id |
0bf08bfe JB |
1276 | and then T.Common.LL.Thread /= Thread_Self |
1277 | then | |
84481f76 RK |
1278 | return taskSuspend (T.Common.LL.Thread) = 0; |
1279 | else | |
1280 | return True; | |
1281 | end if; | |
1282 | end Suspend_Task; | |
1283 | ||
1284 | ----------------- | |
1285 | -- Resume_Task -- | |
1286 | ----------------- | |
1287 | ||
1288 | function Resume_Task | |
b5e792e2 | 1289 | (T : ST.Task_Id; |
0ab80019 | 1290 | Thread_Self : Thread_Id) return Boolean |
fbf5a39b | 1291 | is |
84481f76 | 1292 | begin |
d2b4b3da | 1293 | if T.Common.LL.Thread /= Null_Thread_Id |
0bf08bfe JB |
1294 | and then T.Common.LL.Thread /= Thread_Self |
1295 | then | |
84481f76 RK |
1296 | return taskResume (T.Common.LL.Thread) = 0; |
1297 | else | |
1298 | return True; | |
1299 | end if; | |
1300 | end Resume_Task; | |
1301 | ||
c9b9ec14 JG |
1302 | -------------------- |
1303 | -- Stop_All_Tasks -- | |
1304 | -------------------- | |
1305 | ||
1306 | procedure Stop_All_Tasks | |
1307 | is | |
1308 | Thread_Self : constant Thread_Id := taskIdSelf; | |
1309 | C : Task_Id; | |
1310 | ||
1311 | Dummy : int; | |
b6e5a1ec | 1312 | Old : int; |
c9b9ec14 JG |
1313 | |
1314 | begin | |
b6e5a1ec | 1315 | Old := Int_Lock; |
c9b9ec14 JG |
1316 | |
1317 | C := All_Tasks_List; | |
1318 | while C /= null loop | |
d2b4b3da | 1319 | if C.Common.LL.Thread /= Null_Thread_Id |
c9b9ec14 JG |
1320 | and then C.Common.LL.Thread /= Thread_Self |
1321 | then | |
1322 | Dummy := Task_Stop (C.Common.LL.Thread); | |
1323 | end if; | |
1324 | ||
1325 | C := C.Common.All_Tasks_Link; | |
1326 | end loop; | |
1327 | ||
b6e5a1ec | 1328 | Dummy := Int_Unlock (Old); |
c9b9ec14 JG |
1329 | end Stop_All_Tasks; |
1330 | ||
ed18d858 JG |
1331 | --------------- |
1332 | -- Stop_Task -- | |
1333 | --------------- | |
1334 | ||
1335 | function Stop_Task (T : ST.Task_Id) return Boolean is | |
1336 | begin | |
d2b4b3da | 1337 | if T.Common.LL.Thread /= Null_Thread_Id then |
ed18d858 JG |
1338 | return Task_Stop (T.Common.LL.Thread) = 0; |
1339 | else | |
1340 | return True; | |
1341 | end if; | |
1342 | end Stop_Task; | |
1343 | ||
c9b9ec14 JG |
1344 | ------------------- |
1345 | -- Continue_Task -- | |
1346 | ------------------- | |
1347 | ||
1348 | function Continue_Task (T : ST.Task_Id) return Boolean | |
1349 | is | |
1350 | begin | |
d2b4b3da | 1351 | if T.Common.LL.Thread /= Null_Thread_Id then |
c9b9ec14 JG |
1352 | return Task_Cont (T.Common.LL.Thread) = 0; |
1353 | else | |
1354 | return True; | |
1355 | end if; | |
1356 | end Continue_Task; | |
1357 | ||
9db0b232 AC |
1358 | --------------------- |
1359 | -- Is_Task_Context -- | |
1360 | --------------------- | |
1361 | ||
1362 | function Is_Task_Context return Boolean is | |
9db0b232 | 1363 | begin |
92817e89 | 1364 | return System.OS_Interface.Interrupt_Context /= 1; |
9db0b232 AC |
1365 | end Is_Task_Context; |
1366 | ||
84481f76 RK |
1367 | ---------------- |
1368 | -- Initialize -- | |
1369 | ---------------- | |
1370 | ||
b5e792e2 | 1371 | procedure Initialize (Environment_Task : Task_Id) is |
07fc65c4 | 1372 | Result : int; |
c37cbdc3 | 1373 | pragma Unreferenced (Result); |
8918fe18 | 1374 | |
84481f76 | 1375 | begin |
b9260c3d AC |
1376 | Environment_Task_Id := Environment_Task; |
1377 | ||
1378 | Interrupt_Management.Initialize; | |
1379 | Specific.Initialize; | |
1380 | ||
84481f76 | 1381 | if Locking_Policy = 'C' then |
07fc65c4 GB |
1382 | Mutex_Protocol := Prio_Protect; |
1383 | elsif Locking_Policy = 'I' then | |
1384 | Mutex_Protocol := Prio_Inherit; | |
84481f76 | 1385 | else |
07fc65c4 | 1386 | Mutex_Protocol := Prio_None; |
84481f76 RK |
1387 | end if; |
1388 | ||
1389 | if Time_Slice_Val > 0 then | |
dae22b53 AC |
1390 | Result := |
1391 | Set_Time_Slice | |
1392 | (To_Clock_Ticks | |
1393 | (Duration (Time_Slice_Val) / Duration (1_000_000.0))); | |
ec946d18 AC |
1394 | |
1395 | elsif Dispatching_Policy = 'R' then | |
1396 | Result := Set_Time_Slice (To_Clock_Ticks (0.01)); | |
1397 | ||
84481f76 RK |
1398 | end if; |
1399 | ||
1a49cf99 | 1400 | -- Initialize the lock used to synchronize chain of all ATCBs |
fbf5a39b AC |
1401 | |
1402 | Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); | |
1403 | ||
3204b9cd AC |
1404 | -- Make environment task known here because it doesn't go through |
1405 | -- Activate_Tasks, which does it for all other tasks. | |
1406 | ||
1407 | Known_Tasks (Known_Tasks'First) := Environment_Task; | |
1408 | Environment_Task.Known_Tasks_Index := Known_Tasks'First; | |
1409 | ||
fbf5a39b | 1410 | Enter_Task (Environment_Task); |
8918fe18 AC |
1411 | |
1412 | -- Set processor affinity | |
1413 | ||
c37cbdc3 AC |
1414 | Set_Task_Affinity (Environment_Task); |
1415 | end Initialize; | |
1416 | ||
1417 | ----------------------- | |
1418 | -- Set_Task_Affinity -- | |
1419 | ----------------------- | |
1420 | ||
1421 | procedure Set_Task_Affinity (T : ST.Task_Id) is | |
1422 | Result : int := 0; | |
1423 | pragma Unreferenced (Result); | |
1424 | ||
1425 | use System.Task_Info; | |
1426 | use type System.Multiprocessors.CPU_Range; | |
1427 | ||
1428 | begin | |
d2b4b3da AC |
1429 | -- Do nothing if the underlying thread has not yet been created. If the |
1430 | -- thread has not yet been created then the proper affinity will be set | |
1431 | -- during its creation. | |
1432 | ||
1433 | if T.Common.LL.Thread = Null_Thread_Id then | |
1434 | null; | |
1435 | ||
c37cbdc3 AC |
1436 | -- pragma CPU |
1437 | ||
d2b4b3da | 1438 | elsif T.Common.Base_CPU /= Multiprocessors.Not_A_Specific_CPU then |
7cda9727 RD |
1439 | |
1440 | -- Ada 2012 pragma CPU uses CPU numbers starting from 1, while on | |
1441 | -- VxWorks the first CPU is identified by a 0, so we need to adjust. | |
c0e538ad | 1442 | |
8918fe18 AC |
1443 | Result := |
1444 | taskCpuAffinitySet | |
c37cbdc3 AC |
1445 | (T.Common.LL.Thread, int (T.Common.Base_CPU) - 1); |
1446 | ||
1447 | -- Task_Info | |
1448 | ||
1449 | elsif T.Common.Task_Info /= Unspecified_Task_Info then | |
7cda9727 | 1450 | Result := taskCpuAffinitySet (T.Common.LL.Thread, T.Common.Task_Info); |
c37cbdc3 AC |
1451 | |
1452 | -- Handle dispatching domains | |
1453 | ||
7cda9727 RD |
1454 | elsif T.Common.Domain /= null |
1455 | and then (T.Common.Domain /= ST.System_Domain | |
1456 | or else T.Common.Domain.all /= | |
1457 | (Multiprocessors.CPU'First .. | |
1458 | Multiprocessors.Number_Of_CPUs => True)) | |
c37cbdc3 AC |
1459 | then |
1460 | declare | |
1461 | CPU_Set : unsigned := 0; | |
7cda9727 | 1462 | |
c37cbdc3 AC |
1463 | begin |
1464 | -- Set the affinity to all the processors belonging to the | |
1465 | -- dispatching domain. | |
1466 | ||
1467 | for Proc in T.Common.Domain'Range loop | |
1468 | if T.Common.Domain (Proc) then | |
7cda9727 | 1469 | |
c37cbdc3 AC |
1470 | -- The thread affinity mask is a bit vector in which each |
1471 | -- bit represents a logical processor. | |
1472 | ||
1473 | CPU_Set := CPU_Set + 2 ** (Integer (Proc) - 1); | |
1474 | end if; | |
1475 | end loop; | |
1476 | ||
7cda9727 | 1477 | Result := taskMaskAffinitySet (T.Common.LL.Thread, CPU_Set); |
c37cbdc3 | 1478 | end; |
8918fe18 | 1479 | end if; |
c37cbdc3 | 1480 | end Set_Task_Affinity; |
fbf5a39b | 1481 | |
84481f76 | 1482 | end System.Task_Primitives.Operations; |