|
111
|
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 -- --
|
|
145
|
9 -- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
|
|
111
|
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 -- 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 -- --
|
|
|
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 VxWorks version of this package
|
|
|
33
|
|
|
34 -- This package contains all the GNULL primitives that interface directly with
|
|
|
35 -- the underlying OS.
|
|
|
36
|
|
|
37 pragma Polling (Off);
|
|
|
38 -- Turn off polling, we do not want ATC polling to take place during tasking
|
|
|
39 -- operations. It causes infinite loops and other problems.
|
|
|
40
|
|
|
41 with Ada.Unchecked_Conversion;
|
|
|
42
|
|
|
43 with Interfaces.C;
|
|
|
44
|
|
|
45 with System.Multiprocessors;
|
|
|
46 with System.Tasking.Debug;
|
|
|
47 with System.Interrupt_Management;
|
|
|
48 with System.Float_Control;
|
|
|
49 with System.OS_Constants;
|
|
|
50
|
|
|
51 with System.Soft_Links;
|
|
|
52 -- We use System.Soft_Links instead of System.Tasking.Initialization
|
|
|
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
|
|
|
55 -- System.Tasking.Restricted.Stages.
|
|
|
56
|
|
|
57 with System.Task_Info;
|
|
|
58 with System.VxWorks.Ext;
|
|
|
59
|
|
|
60 package body System.Task_Primitives.Operations is
|
|
|
61
|
|
|
62 package OSC renames System.OS_Constants;
|
|
|
63 package SSL renames System.Soft_Links;
|
|
|
64
|
|
|
65 use System.Tasking.Debug;
|
|
|
66 use System.Tasking;
|
|
|
67 use System.OS_Interface;
|
|
|
68 use System.Parameters;
|
|
|
69 use type System.VxWorks.Ext.t_id;
|
|
|
70 use type Interfaces.C.int;
|
|
|
71 use type System.OS_Interface.unsigned;
|
|
|
72
|
|
|
73 subtype int is System.OS_Interface.int;
|
|
|
74 subtype unsigned is System.OS_Interface.unsigned;
|
|
|
75
|
|
|
76 Relative : constant := 0;
|
|
|
77
|
|
|
78 ----------------
|
|
|
79 -- Local Data --
|
|
|
80 ----------------
|
|
|
81
|
|
|
82 -- The followings are logically constants, but need to be initialized at
|
|
|
83 -- run time.
|
|
|
84
|
|
|
85 Environment_Task_Id : Task_Id;
|
|
|
86 -- A variable to hold Task_Id for the environment task
|
|
|
87
|
|
|
88 -- The followings are internal configuration constants needed
|
|
|
89
|
|
|
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)
|
|
|
95
|
|
|
96 Locking_Policy : Character;
|
|
|
97 pragma Import (C, Locking_Policy, "__gl_locking_policy");
|
|
|
98
|
|
|
99 Mutex_Protocol : Priority_Type;
|
|
|
100
|
|
|
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
|
|
|
105
|
|
|
106 Time_Slice_Val : Integer;
|
|
|
107 pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
|
|
|
108
|
|
|
109 Null_Thread_Id : constant Thread_Id := 0;
|
|
|
110 -- Constant to indicate that the thread identifier has not yet been
|
|
|
111 -- initialized.
|
|
|
112
|
|
|
113 --------------------
|
|
|
114 -- Local Packages --
|
|
|
115 --------------------
|
|
|
116
|
|
|
117 package Specific is
|
|
|
118
|
|
|
119 procedure Initialize;
|
|
|
120 pragma Inline (Initialize);
|
|
|
121 -- Initialize task specific data
|
|
|
122
|
|
|
123 function Is_Valid_Task return Boolean;
|
|
|
124 pragma Inline (Is_Valid_Task);
|
|
|
125 -- Does executing thread have a TCB?
|
|
|
126
|
|
|
127 procedure Set (Self_Id : Task_Id);
|
|
|
128 pragma Inline (Set);
|
|
|
129 -- Set the self id for the current task, unless Self_Id is null, in
|
|
|
130 -- which case the task specific data is deleted.
|
|
|
131
|
|
|
132 function Self return Task_Id;
|
|
|
133 pragma Inline (Self);
|
|
|
134 -- Return a pointer to the Ada Task Control Block of the calling task
|
|
|
135
|
|
|
136 end Specific;
|
|
|
137
|
|
|
138 package body Specific is separate;
|
|
|
139 -- The body of this package is target specific
|
|
|
140
|
|
|
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
|
|
|
148 ---------------------------------
|
|
|
149 -- Support for foreign threads --
|
|
|
150 ---------------------------------
|
|
|
151
|
|
|
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.
|
|
|
157
|
|
|
158 function Register_Foreign_Thread
|
|
|
159 (Thread : Thread_Id;
|
|
|
160 Sec_Stack_Size : Size_Type := Unspecified_Size)
|
|
|
161 return Task_Id is separate;
|
|
|
162
|
|
|
163 -----------------------
|
|
|
164 -- Local Subprograms --
|
|
|
165 -----------------------
|
|
|
166
|
|
|
167 procedure Abort_Handler (signo : Signal);
|
|
|
168 -- Handler for the abort (SIGABRT) signal to handle asynchronous abort
|
|
|
169
|
|
|
170 procedure Install_Signal_Handlers;
|
|
|
171 -- Install the default signal handlers for the current task
|
|
|
172
|
|
|
173 function Is_Task_Context return Boolean;
|
|
|
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.
|
|
|
176
|
|
|
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");
|
|
|
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.
|
|
|
184
|
|
|
185 function To_Address is
|
|
|
186 new Ada.Unchecked_Conversion (Task_Id, System.Address);
|
|
|
187
|
|
|
188 -------------------
|
|
|
189 -- Abort_Handler --
|
|
|
190 -------------------
|
|
|
191
|
|
|
192 procedure Abort_Handler (signo : Signal) is
|
|
|
193 pragma Unreferenced (signo);
|
|
|
194
|
|
145
|
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;
|
|
111
|
199 Old_Set : aliased sigset_t;
|
|
|
200 Unblocked_Mask : aliased sigset_t;
|
|
|
201 Result : int;
|
|
|
202 pragma Warnings (Off, Result);
|
|
|
203
|
|
|
204 use System.Interrupt_Management;
|
|
|
205
|
|
|
206 begin
|
|
|
207 -- It is not safe to raise an exception when using ZCX and the GCC
|
|
|
208 -- exception handling mechanism.
|
|
|
209
|
|
|
210 if ZCX_By_Default then
|
|
|
211 return;
|
|
|
212 end if;
|
|
|
213
|
|
145
|
214 Self_ID := Self;
|
|
|
215
|
|
111
|
216 if Self_ID.Deferral_Level = 0
|
|
|
217 and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
|
|
|
218 and then not Self_ID.Aborting
|
|
|
219 then
|
|
|
220 Self_ID.Aborting := True;
|
|
|
221
|
|
|
222 -- Make sure signals used for RTS internal purposes are unmasked
|
|
|
223
|
|
|
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
|
|
|
240 Result :=
|
|
|
241 pthread_sigmask
|
|
|
242 (SIG_UNBLOCK,
|
|
|
243 Unblocked_Mask'Access,
|
|
|
244 Old_Set'Access);
|
|
|
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
|
|
|
255 procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
|
|
|
256 pragma Unreferenced (T);
|
|
|
257 pragma Unreferenced (On);
|
|
|
258
|
|
|
259 begin
|
|
|
260 -- Nothing needed (why not???)
|
|
|
261
|
|
|
262 null;
|
|
|
263 end Stack_Guard;
|
|
|
264
|
|
|
265 -------------------
|
|
|
266 -- Get_Thread_Id --
|
|
|
267 -------------------
|
|
|
268
|
|
|
269 function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
|
|
|
270 begin
|
|
|
271 return T.Common.LL.Thread;
|
|
|
272 end Get_Thread_Id;
|
|
|
273
|
|
|
274 ----------
|
|
|
275 -- Self --
|
|
|
276 ----------
|
|
|
277
|
|
|
278 function Self return Task_Id renames Specific.Self;
|
|
|
279
|
|
|
280 -----------------------------
|
|
|
281 -- Install_Signal_Handlers --
|
|
|
282 -----------------------------
|
|
|
283
|
|
|
284 procedure Install_Signal_Handlers is
|
|
|
285 act : aliased struct_sigaction;
|
|
|
286 old_act : aliased struct_sigaction;
|
|
|
287 Tmp_Set : aliased sigset_t;
|
|
|
288 Result : int;
|
|
|
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
|
|
|
300 (Signal (Interrupt_Management.Abort_Task_Interrupt),
|
|
|
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
|
|
|
312 procedure Initialize_Lock
|
|
|
313 (Prio : System.Any_Priority;
|
|
|
314 L : not null access Lock)
|
|
|
315 is
|
|
|
316 begin
|
|
|
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);
|
|
|
321 end Initialize_Lock;
|
|
|
322
|
|
|
323 procedure Initialize_Lock
|
|
|
324 (L : not null access RTS_Lock;
|
|
|
325 Level : Lock_Level)
|
|
|
326 is
|
|
|
327 pragma Unreferenced (Level);
|
|
|
328 begin
|
|
|
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);
|
|
|
333 end Initialize_Lock;
|
|
|
334
|
|
|
335 -------------------
|
|
|
336 -- Finalize_Lock --
|
|
|
337 -------------------
|
|
|
338
|
|
|
339 procedure Finalize_Lock (L : not null access Lock) is
|
|
|
340 Result : int;
|
|
|
341 begin
|
|
|
342 Result := semDelete (L.Mutex);
|
|
|
343 pragma Assert (Result = 0);
|
|
|
344 end Finalize_Lock;
|
|
|
345
|
|
|
346 procedure Finalize_Lock (L : not null access RTS_Lock) is
|
|
|
347 Result : int;
|
|
|
348 begin
|
|
|
349 Result := semDelete (L.Mutex);
|
|
|
350 pragma Assert (Result = 0);
|
|
|
351 end Finalize_Lock;
|
|
|
352
|
|
|
353 ----------------
|
|
|
354 -- Write_Lock --
|
|
|
355 ----------------
|
|
|
356
|
|
|
357 procedure Write_Lock
|
|
|
358 (L : not null access Lock;
|
|
|
359 Ceiling_Violation : out Boolean)
|
|
|
360 is
|
|
|
361 Result : int;
|
|
|
362
|
|
|
363 begin
|
|
|
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;
|
|
|
372
|
|
|
373 Result := semTake (L.Mutex, WAIT_FOREVER);
|
|
|
374 pragma Assert (Result = 0);
|
|
|
375 end Write_Lock;
|
|
|
376
|
|
|
377 procedure Write_Lock
|
|
|
378 (L : not null access RTS_Lock;
|
|
|
379 Global_Lock : Boolean := False)
|
|
|
380 is
|
|
|
381 Result : int;
|
|
|
382 begin
|
|
|
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;
|
|
|
387 end Write_Lock;
|
|
|
388
|
|
|
389 procedure Write_Lock (T : Task_Id) is
|
|
|
390 Result : int;
|
|
|
391 begin
|
|
|
392 if not Single_Lock then
|
|
|
393 Result := semTake (T.Common.LL.L.Mutex, WAIT_FOREVER);
|
|
|
394 pragma Assert (Result = 0);
|
|
|
395 end if;
|
|
|
396 end Write_Lock;
|
|
|
397
|
|
|
398 ---------------
|
|
|
399 -- Read_Lock --
|
|
|
400 ---------------
|
|
|
401
|
|
|
402 procedure Read_Lock
|
|
|
403 (L : not null access Lock;
|
|
|
404 Ceiling_Violation : out Boolean)
|
|
|
405 is
|
|
|
406 begin
|
|
|
407 Write_Lock (L, Ceiling_Violation);
|
|
|
408 end Read_Lock;
|
|
|
409
|
|
|
410 ------------
|
|
|
411 -- Unlock --
|
|
|
412 ------------
|
|
|
413
|
|
|
414 procedure Unlock (L : not null access Lock) is
|
|
|
415 Result : int;
|
|
|
416 begin
|
|
|
417 Result := semGive (L.Mutex);
|
|
|
418 pragma Assert (Result = 0);
|
|
|
419 end Unlock;
|
|
|
420
|
|
|
421 procedure Unlock
|
|
|
422 (L : not null access RTS_Lock;
|
|
|
423 Global_Lock : Boolean := False)
|
|
|
424 is
|
|
|
425 Result : int;
|
|
|
426 begin
|
|
|
427 if not Single_Lock or else Global_Lock then
|
|
|
428 Result := semGive (L.Mutex);
|
|
|
429 pragma Assert (Result = 0);
|
|
|
430 end if;
|
|
|
431 end Unlock;
|
|
|
432
|
|
|
433 procedure Unlock (T : Task_Id) is
|
|
|
434 Result : int;
|
|
|
435 begin
|
|
|
436 if not Single_Lock then
|
|
|
437 Result := semGive (T.Common.LL.L.Mutex);
|
|
|
438 pragma Assert (Result = 0);
|
|
|
439 end if;
|
|
|
440 end Unlock;
|
|
|
441
|
|
|
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
|
|
|
457 -----------
|
|
|
458 -- Sleep --
|
|
|
459 -----------
|
|
|
460
|
|
|
461 procedure Sleep (Self_ID : Task_Id; Reason : System.Tasking.Task_States) is
|
|
|
462 pragma Unreferenced (Reason);
|
|
|
463
|
|
|
464 Result : int;
|
|
|
465
|
|
|
466 begin
|
|
|
467 pragma Assert (Self_ID = Self);
|
|
|
468
|
|
|
469 -- Release the mutex before sleeping
|
|
|
470
|
|
|
471 Result :=
|
|
|
472 semGive (if Single_Lock
|
|
|
473 then Single_RTS_Lock.Mutex
|
|
|
474 else Self_ID.Common.LL.L.Mutex);
|
|
|
475 pragma Assert (Result = 0);
|
|
|
476
|
|
|
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.
|
|
|
481
|
|
|
482 Result := semTake (Self_ID.Common.LL.CV, WAIT_FOREVER);
|
|
|
483 pragma Assert (Result = 0);
|
|
|
484
|
|
|
485 -- Take the mutex back
|
|
|
486
|
|
|
487 Result :=
|
|
|
488 semTake ((if Single_Lock
|
|
|
489 then Single_RTS_Lock.Mutex
|
|
|
490 else Self_ID.Common.LL.L.Mutex), WAIT_FOREVER);
|
|
|
491 pragma Assert (Result = 0);
|
|
|
492 end Sleep;
|
|
|
493
|
|
|
494 -----------------
|
|
|
495 -- Timed_Sleep --
|
|
|
496 -----------------
|
|
|
497
|
|
|
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.
|
|
|
500
|
|
|
501 procedure Timed_Sleep
|
|
|
502 (Self_ID : Task_Id;
|
|
|
503 Time : Duration;
|
|
|
504 Mode : ST.Delay_Modes;
|
|
|
505 Reason : System.Tasking.Task_States;
|
|
|
506 Timedout : out Boolean;
|
|
|
507 Yielded : out Boolean)
|
|
|
508 is
|
|
|
509 pragma Unreferenced (Reason);
|
|
|
510
|
|
|
511 Orig : constant Duration := Monotonic_Clock;
|
|
|
512 Absolute : Duration;
|
|
|
513 Ticks : int;
|
|
|
514 Result : int;
|
|
|
515 Wakeup : Boolean := False;
|
|
|
516
|
|
|
517 begin
|
|
|
518 Timedout := False;
|
|
|
519 Yielded := True;
|
|
|
520
|
|
|
521 if Mode = Relative then
|
|
|
522 Absolute := Orig + Time;
|
|
|
523
|
|
|
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.
|
|
|
527
|
|
|
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
|
|
|
534 else
|
|
|
535 Absolute := Time;
|
|
|
536 Ticks := To_Clock_Ticks (Time - Monotonic_Clock);
|
|
|
537 end if;
|
|
|
538
|
|
|
539 if Ticks > 0 then
|
|
|
540 loop
|
|
|
541 -- Release the mutex before sleeping
|
|
|
542
|
|
|
543 Result :=
|
|
|
544 semGive (if Single_Lock
|
|
|
545 then Single_RTS_Lock.Mutex
|
|
|
546 else Self_ID.Common.LL.L.Mutex);
|
|
|
547 pragma Assert (Result = 0);
|
|
|
548
|
|
|
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.
|
|
|
553
|
|
|
554 Result := semTake (Self_ID.Common.LL.CV, Ticks);
|
|
|
555
|
|
|
556 if Result = 0 then
|
|
|
557
|
|
|
558 -- Somebody may have called Wakeup for us
|
|
|
559
|
|
|
560 Wakeup := True;
|
|
|
561
|
|
|
562 else
|
|
|
563 if errno /= S_objLib_OBJ_TIMEOUT then
|
|
|
564 Wakeup := True;
|
|
|
565
|
|
|
566 else
|
|
|
567 -- If Ticks = int'last, it was most probably truncated so
|
|
|
568 -- let's make another round after recomputing Ticks from
|
|
|
569 -- the absolute time.
|
|
|
570
|
|
|
571 if Ticks /= int'Last then
|
|
|
572 Timedout := True;
|
|
|
573
|
|
|
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;
|
|
|
583
|
|
|
584 -- Take the mutex back
|
|
|
585
|
|
|
586 Result :=
|
|
|
587 semTake ((if Single_Lock
|
|
|
588 then Single_RTS_Lock.Mutex
|
|
|
589 else Self_ID.Common.LL.L.Mutex), WAIT_FOREVER);
|
|
|
590 pragma Assert (Result = 0);
|
|
|
591
|
|
|
592 exit when Timedout or Wakeup;
|
|
|
593 end loop;
|
|
|
594
|
|
|
595 else
|
|
|
596 Timedout := True;
|
|
|
597
|
|
|
598 -- Should never hold a lock while yielding
|
|
|
599
|
|
|
600 if Single_Lock then
|
|
|
601 Result := semGive (Single_RTS_Lock.Mutex);
|
|
|
602 Result := taskDelay (0);
|
|
|
603 Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER);
|
|
|
604
|
|
|
605 else
|
|
|
606 Result := semGive (Self_ID.Common.LL.L.Mutex);
|
|
|
607 Result := taskDelay (0);
|
|
|
608 Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER);
|
|
|
609 end if;
|
|
|
610 end if;
|
|
|
611 end Timed_Sleep;
|
|
|
612
|
|
|
613 -----------------
|
|
|
614 -- Timed_Delay --
|
|
|
615 -----------------
|
|
|
616
|
|
|
617 -- This is for use in implementing delay statements, so we assume the
|
|
|
618 -- caller is holding no locks.
|
|
|
619
|
|
|
620 procedure Timed_Delay
|
|
|
621 (Self_ID : Task_Id;
|
|
|
622 Time : Duration;
|
|
|
623 Mode : ST.Delay_Modes)
|
|
|
624 is
|
|
|
625 Orig : constant Duration := Monotonic_Clock;
|
|
|
626 Absolute : Duration;
|
|
|
627 Ticks : int;
|
|
|
628 Timedout : Boolean;
|
|
|
629 Aborted : Boolean := False;
|
|
|
630
|
|
|
631 Result : int;
|
|
|
632 pragma Warnings (Off, Result);
|
|
|
633
|
|
|
634 begin
|
|
|
635 if Mode = Relative then
|
|
|
636 Absolute := Orig + Time;
|
|
|
637 Ticks := To_Clock_Ticks (Time);
|
|
|
638
|
|
|
639 if Ticks > 0 and then Ticks < int'Last then
|
|
|
640
|
|
|
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.
|
|
|
643
|
|
|
644 Ticks := Ticks + 1;
|
|
|
645 end if;
|
|
|
646
|
|
|
647 else
|
|
|
648 Absolute := Time;
|
|
|
649 Ticks := To_Clock_Ticks (Time - Orig);
|
|
|
650 end if;
|
|
|
651
|
|
|
652 if Ticks > 0 then
|
|
|
653
|
|
|
654 -- Modifying State, locking the TCB
|
|
|
655
|
|
|
656 Result :=
|
|
|
657 semTake ((if Single_Lock
|
|
|
658 then Single_RTS_Lock.Mutex
|
|
|
659 else Self_ID.Common.LL.L.Mutex), WAIT_FOREVER);
|
|
|
660
|
|
|
661 pragma Assert (Result = 0);
|
|
|
662
|
|
|
663 Self_ID.Common.State := Delay_Sleep;
|
|
|
664 Timedout := False;
|
|
|
665
|
|
|
666 loop
|
|
|
667 Aborted := Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
|
|
|
668
|
|
|
669 -- Release the TCB before sleeping
|
|
|
670
|
|
|
671 Result :=
|
|
|
672 semGive (if Single_Lock
|
|
|
673 then Single_RTS_Lock.Mutex
|
|
|
674 else Self_ID.Common.LL.L.Mutex);
|
|
|
675 pragma Assert (Result = 0);
|
|
|
676
|
|
|
677 exit when Aborted;
|
|
|
678
|
|
|
679 Result := semTake (Self_ID.Common.LL.CV, Ticks);
|
|
|
680
|
|
|
681 if Result /= 0 then
|
|
|
682
|
|
|
683 -- If Ticks = int'last, it was most probably truncated, so make
|
|
|
684 -- another round after recomputing Ticks from absolute time.
|
|
|
685
|
|
|
686 if errno = S_objLib_OBJ_TIMEOUT and then Ticks /= int'Last then
|
|
|
687 Timedout := True;
|
|
|
688 else
|
|
|
689 Ticks := To_Clock_Ticks (Absolute - Monotonic_Clock);
|
|
|
690
|
|
|
691 if Ticks < 0 then
|
|
|
692 Timedout := True;
|
|
|
693 end if;
|
|
|
694 end if;
|
|
|
695 end if;
|
|
|
696
|
|
|
697 -- Take back the lock after having slept, to protect further
|
|
|
698 -- access to Self_ID.
|
|
|
699
|
|
|
700 Result :=
|
|
|
701 semTake
|
|
|
702 ((if Single_Lock
|
|
|
703 then Single_RTS_Lock.Mutex
|
|
|
704 else Self_ID.Common.LL.L.Mutex), WAIT_FOREVER);
|
|
|
705
|
|
|
706 pragma Assert (Result = 0);
|
|
|
707
|
|
|
708 exit when Timedout;
|
|
|
709 end loop;
|
|
|
710
|
|
|
711 Self_ID.Common.State := Runnable;
|
|
|
712
|
|
|
713 Result :=
|
|
|
714 semGive
|
|
|
715 (if Single_Lock
|
|
|
716 then Single_RTS_Lock.Mutex
|
|
|
717 else Self_ID.Common.LL.L.Mutex);
|
|
|
718
|
|
|
719 else
|
|
|
720 Result := taskDelay (0);
|
|
|
721 end if;
|
|
|
722 end Timed_Delay;
|
|
|
723
|
|
|
724 ---------------------
|
|
|
725 -- Monotonic_Clock --
|
|
|
726 ---------------------
|
|
|
727
|
|
|
728 function Monotonic_Clock return Duration is
|
|
|
729 TS : aliased timespec;
|
|
|
730 Result : int;
|
|
|
731 begin
|
|
|
732 Result := clock_gettime (OSC.CLOCK_RT_Ada, TS'Unchecked_Access);
|
|
|
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
|
|
|
743 return 1.0 / Duration (sysClkRateGet);
|
|
|
744 end RT_Resolution;
|
|
|
745
|
|
|
746 ------------
|
|
|
747 -- Wakeup --
|
|
|
748 ------------
|
|
|
749
|
|
|
750 procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
|
|
|
751 pragma Unreferenced (Reason);
|
|
|
752 Result : int;
|
|
|
753 begin
|
|
|
754 Result := semGive (T.Common.LL.CV);
|
|
|
755 pragma Assert (Result = 0);
|
|
|
756 end Wakeup;
|
|
|
757
|
|
|
758 -----------
|
|
|
759 -- Yield --
|
|
|
760 -----------
|
|
|
761
|
|
|
762 procedure Yield (Do_Yield : Boolean := True) is
|
|
|
763 pragma Unreferenced (Do_Yield);
|
|
|
764 Result : int;
|
|
|
765 pragma Unreferenced (Result);
|
|
|
766 begin
|
|
|
767 Result := taskDelay (0);
|
|
|
768 end Yield;
|
|
|
769
|
|
|
770 ------------------
|
|
|
771 -- Set_Priority --
|
|
|
772 ------------------
|
|
|
773
|
|
|
774 procedure Set_Priority
|
|
|
775 (T : Task_Id;
|
|
|
776 Prio : System.Any_Priority;
|
|
|
777 Loss_Of_Inheritance : Boolean := False)
|
|
|
778 is
|
|
|
779 pragma Unreferenced (Loss_Of_Inheritance);
|
|
|
780
|
|
|
781 Result : int;
|
|
|
782
|
|
|
783 begin
|
|
|
784 Result :=
|
|
|
785 taskPrioritySet
|
|
|
786 (T.Common.LL.Thread, To_VxWorks_Priority (int (Prio)));
|
|
|
787 pragma Assert (Result = 0);
|
|
|
788
|
|
|
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.
|
|
|
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
|
|
|
800 T.Common.Current_Priority := Prio;
|
|
|
801 end Set_Priority;
|
|
|
802
|
|
|
803 ------------------
|
|
|
804 -- Get_Priority --
|
|
|
805 ------------------
|
|
|
806
|
|
|
807 function Get_Priority (T : Task_Id) return System.Any_Priority is
|
|
|
808 begin
|
|
|
809 return T.Common.Current_Priority;
|
|
|
810 end Get_Priority;
|
|
|
811
|
|
|
812 ----------------
|
|
|
813 -- Enter_Task --
|
|
|
814 ----------------
|
|
|
815
|
|
|
816 procedure Enter_Task (Self_ID : Task_Id) is
|
|
|
817 begin
|
|
|
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
|
|
|
822 Self_ID.Common.LL.Thread := taskIdSelf;
|
|
|
823 Self_ID.Common.LL.LWP := getpid;
|
|
|
824
|
|
|
825 Specific.Set (Self_ID);
|
|
|
826
|
|
|
827 -- Properly initializes the FPU for PPC/MIPS systems
|
|
|
828
|
|
|
829 System.Float_Control.Reset;
|
|
|
830
|
|
|
831 -- Install the signal handlers
|
|
|
832
|
|
|
833 -- This is called for each task since there is no signal inheritance
|
|
|
834 -- between VxWorks tasks.
|
|
|
835
|
|
|
836 Install_Signal_Handlers;
|
|
|
837
|
|
|
838 -- If stack checking is enabled, set the stack limit for this task
|
|
|
839
|
|
|
840 if Set_Stack_Limit_Hook /= null then
|
|
|
841 Set_Stack_Limit_Hook.all;
|
|
|
842 end if;
|
|
|
843 end Enter_Task;
|
|
|
844
|
|
|
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
|
|
|
855 function Register_Foreign_Thread return Task_Id is
|
|
|
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
|
|
|
864 --------------------
|
|
|
865 -- Initialize_TCB --
|
|
|
866 --------------------
|
|
|
867
|
|
|
868 procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
|
|
|
869 begin
|
|
|
870 Self_ID.Common.LL.CV := semBCreate (SEM_Q_PRIORITY, SEM_EMPTY);
|
|
|
871 Self_ID.Common.LL.Thread := Null_Thread_Id;
|
|
|
872
|
|
|
873 if Self_ID.Common.LL.CV = 0 then
|
|
|
874 Succeeded := False;
|
|
|
875
|
|
|
876 else
|
|
|
877 Succeeded := True;
|
|
|
878
|
|
|
879 if not Single_Lock then
|
|
|
880 Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level);
|
|
|
881 end if;
|
|
|
882 end if;
|
|
|
883 end Initialize_TCB;
|
|
|
884
|
|
|
885 -----------------
|
|
|
886 -- Create_Task --
|
|
|
887 -----------------
|
|
|
888
|
|
|
889 procedure Create_Task
|
|
|
890 (T : Task_Id;
|
|
|
891 Wrapper : System.Address;
|
|
|
892 Stack_Size : System.Parameters.Size_Type;
|
|
|
893 Priority : System.Any_Priority;
|
|
|
894 Succeeded : out Boolean)
|
|
|
895 is
|
|
|
896 Adjusted_Stack_Size : size_t;
|
|
|
897
|
|
|
898 use type System.Multiprocessors.CPU_Range;
|
|
|
899
|
|
|
900 begin
|
|
|
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
|
|
|
903 -- processors for the domain.
|
|
|
904
|
|
|
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))
|
|
|
910 then
|
|
|
911 Succeeded := False;
|
|
|
912 return;
|
|
|
913 end if;
|
|
|
914
|
|
|
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
|
|
|
918 -- exclusive of the needs.
|
|
|
919
|
|
|
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.
|
|
|
925
|
|
|
926 -- ??? - we should come back and visit this so we can set the task name
|
|
|
927 -- to something appropriate.
|
|
|
928
|
|
|
929 Adjusted_Stack_Size := size_t (Stack_Size) + 2048;
|
|
|
930
|
|
|
931 -- Since the initial signal mask of a thread is inherited from the
|
|
|
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.
|
|
|
935
|
|
|
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
|
|
|
942
|
|
|
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.
|
|
|
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
|
|
|
958 Name (1 .. Name'Last - 1) :=
|
|
|
959 T.Common.Task_Image (1 .. T.Common.Task_Image_Len);
|
|
|
960 Name (Name'Last) := ASCII.NUL;
|
|
|
961 Name_Address := Name'Address;
|
|
|
962 end if;
|
|
|
963
|
|
|
964 -- Now spawn the VxWorks task for real
|
|
|
965
|
|
|
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));
|
|
|
974 end;
|
|
|
975
|
|
|
976 -- Set processor affinity
|
|
|
977
|
|
|
978 Set_Task_Affinity (T);
|
|
|
979
|
|
|
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
|
|
|
983 Succeeded := False;
|
|
|
984 else
|
|
|
985 Succeeded := True;
|
|
|
986 Task_Creation_Hook (T.Common.LL.Thread);
|
|
|
987 Set_Priority (T, Priority);
|
|
|
988 end if;
|
|
|
989 end Create_Task;
|
|
|
990
|
|
|
991 ------------------
|
|
|
992 -- Finalize_TCB --
|
|
|
993 ------------------
|
|
|
994
|
|
|
995 procedure Finalize_TCB (T : Task_Id) is
|
|
|
996 Result : int;
|
|
|
997
|
|
|
998 begin
|
|
|
999 if not Single_Lock then
|
|
|
1000 Result := semDelete (T.Common.LL.L.Mutex);
|
|
|
1001 pragma Assert (Result = 0);
|
|
|
1002 end if;
|
|
|
1003
|
|
|
1004 T.Common.LL.Thread := Null_Thread_Id;
|
|
|
1005
|
|
|
1006 Result := semDelete (T.Common.LL.CV);
|
|
|
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
|
|
|
1013 ATCB_Allocation.Free_ATCB (T);
|
|
|
1014 end Finalize_TCB;
|
|
|
1015
|
|
|
1016 ---------------
|
|
|
1017 -- Exit_Task --
|
|
|
1018 ---------------
|
|
|
1019
|
|
|
1020 procedure Exit_Task is
|
|
|
1021 begin
|
|
|
1022 Specific.Set (null);
|
|
|
1023 end Exit_Task;
|
|
|
1024
|
|
|
1025 ----------------
|
|
|
1026 -- Abort_Task --
|
|
|
1027 ----------------
|
|
|
1028
|
|
|
1029 procedure Abort_Task (T : Task_Id) is
|
|
|
1030 Result : int;
|
|
|
1031 begin
|
|
|
1032 Result :=
|
|
|
1033 kill
|
|
|
1034 (T.Common.LL.Thread,
|
|
|
1035 Signal (Interrupt_Management.Abort_Task_Interrupt));
|
|
|
1036 pragma Assert (Result = 0);
|
|
|
1037 end Abort_Task;
|
|
|
1038
|
|
|
1039 ----------------
|
|
|
1040 -- Initialize --
|
|
|
1041 ----------------
|
|
|
1042
|
|
|
1043 procedure Initialize (S : in out Suspension_Object) is
|
|
|
1044 begin
|
|
|
1045 -- Initialize internal state (always to False (RM D.10(6)))
|
|
|
1046
|
|
|
1047 S.State := False;
|
|
|
1048 S.Waiting := False;
|
|
|
1049
|
|
|
1050 -- Initialize internal mutex
|
|
|
1051
|
|
|
1052 -- Use simpler binary semaphore instead of VxWorks mutual exclusion
|
|
|
1053 -- semaphore, because we don't need the fancier semantics and their
|
|
|
1054 -- overhead.
|
|
|
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
|
|
|
1068 pragma Unmodified (S);
|
|
|
1069 -- S may be modified on other targets, but not on VxWorks
|
|
|
1070
|
|
|
1071 Result : STATUS;
|
|
|
1072
|
|
|
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
|
|
|
1102 Result : STATUS;
|
|
|
1103
|
|
|
1104 begin
|
|
|
1105 SSL.Abort_Defer.all;
|
|
|
1106
|
|
|
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);
|
|
|
1114
|
|
|
1115 SSL.Abort_Undefer.all;
|
|
|
1116 end Set_False;
|
|
|
1117
|
|
|
1118 --------------
|
|
|
1119 -- Set_True --
|
|
|
1120 --------------
|
|
|
1121
|
|
|
1122 procedure Set_True (S : in out Suspension_Object) is
|
|
|
1123 Result : STATUS;
|
|
|
1124
|
|
|
1125 begin
|
|
|
1126 -- Set_True can be called from an interrupt context, in which case
|
|
|
1127 -- Abort_Defer is undefined.
|
|
|
1128
|
|
|
1129 if Is_Task_Context then
|
|
|
1130 SSL.Abort_Defer.all;
|
|
|
1131 end if;
|
|
|
1132
|
|
|
1133 Result := semTake (S.L, WAIT_FOREVER);
|
|
|
1134 pragma Assert (Result = OK);
|
|
|
1135
|
|
|
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.
|
|
|
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);
|
|
|
1153
|
|
|
1154 -- Set_True can be called from an interrupt context, in which case
|
|
|
1155 -- Abort_Undefer is undefined.
|
|
|
1156
|
|
|
1157 if Is_Task_Context then
|
|
|
1158 SSL.Abort_Undefer.all;
|
|
|
1159 end if;
|
|
|
1160
|
|
|
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;
|
|
|
1169
|
|
|
1170 begin
|
|
|
1171 SSL.Abort_Defer.all;
|
|
|
1172
|
|
|
1173 Result := semTake (S.L, WAIT_FOREVER);
|
|
|
1174
|
|
|
1175 if S.Waiting then
|
|
|
1176
|
|
|
1177 -- Program_Error must be raised upon calling Suspend_Until_True
|
|
|
1178 -- if another task is already waiting on that suspension object
|
|
|
1179 -- (RM D.10(10)).
|
|
|
1180
|
|
|
1181 Result := semGive (S.L);
|
|
|
1182 pragma Assert (Result = OK);
|
|
|
1183
|
|
|
1184 SSL.Abort_Undefer.all;
|
|
|
1185
|
|
|
1186 raise Program_Error;
|
|
|
1187
|
|
|
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
|
|
|
1191 -- is set to False (RM D.10 (9)).
|
|
|
1192
|
|
|
1193 if S.State then
|
|
|
1194 S.State := False;
|
|
|
1195
|
|
|
1196 Result := semGive (S.L);
|
|
|
1197 pragma Assert (Result = 0);
|
|
|
1198
|
|
|
1199 SSL.Abort_Undefer.all;
|
|
|
1200
|
|
|
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
|
|
|
1209 SSL.Abort_Undefer.all;
|
|
|
1210
|
|
|
1211 Result := semTake (S.CV, WAIT_FOREVER);
|
|
|
1212 pragma Assert (Result = 0);
|
|
|
1213 end if;
|
|
|
1214 end if;
|
|
|
1215 end Suspend_Until_True;
|
|
|
1216
|
|
|
1217 ----------------
|
|
|
1218 -- Check_Exit --
|
|
|
1219 ----------------
|
|
|
1220
|
|
|
1221 -- Dummy version
|
|
|
1222
|
|
|
1223 function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
|
|
|
1224 pragma Unreferenced (Self_ID);
|
|
|
1225 begin
|
|
|
1226 return True;
|
|
|
1227 end Check_Exit;
|
|
|
1228
|
|
|
1229 --------------------
|
|
|
1230 -- Check_No_Locks --
|
|
|
1231 --------------------
|
|
|
1232
|
|
|
1233 function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
|
|
|
1234 pragma Unreferenced (Self_ID);
|
|
|
1235 begin
|
|
|
1236 return True;
|
|
|
1237 end Check_No_Locks;
|
|
|
1238
|
|
|
1239 ----------------------
|
|
|
1240 -- Environment_Task --
|
|
|
1241 ----------------------
|
|
|
1242
|
|
|
1243 function Environment_Task return Task_Id is
|
|
|
1244 begin
|
|
|
1245 return Environment_Task_Id;
|
|
|
1246 end Environment_Task;
|
|
|
1247
|
|
|
1248 --------------
|
|
|
1249 -- Lock_RTS --
|
|
|
1250 --------------
|
|
|
1251
|
|
|
1252 procedure Lock_RTS is
|
|
|
1253 begin
|
|
|
1254 Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
|
|
|
1255 end Lock_RTS;
|
|
|
1256
|
|
|
1257 ----------------
|
|
|
1258 -- Unlock_RTS --
|
|
|
1259 ----------------
|
|
|
1260
|
|
|
1261 procedure Unlock_RTS is
|
|
|
1262 begin
|
|
|
1263 Unlock (Single_RTS_Lock'Access, Global_Lock => True);
|
|
|
1264 end Unlock_RTS;
|
|
|
1265
|
|
|
1266 ------------------
|
|
|
1267 -- Suspend_Task --
|
|
|
1268 ------------------
|
|
|
1269
|
|
|
1270 function Suspend_Task
|
|
|
1271 (T : ST.Task_Id;
|
|
|
1272 Thread_Self : Thread_Id) return Boolean
|
|
|
1273 is
|
|
|
1274 begin
|
|
|
1275 if T.Common.LL.Thread /= Null_Thread_Id
|
|
|
1276 and then T.Common.LL.Thread /= Thread_Self
|
|
|
1277 then
|
|
|
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
|
|
|
1289 (T : ST.Task_Id;
|
|
|
1290 Thread_Self : Thread_Id) return Boolean
|
|
|
1291 is
|
|
|
1292 begin
|
|
|
1293 if T.Common.LL.Thread /= Null_Thread_Id
|
|
|
1294 and then T.Common.LL.Thread /= Thread_Self
|
|
|
1295 then
|
|
|
1296 return taskResume (T.Common.LL.Thread) = 0;
|
|
|
1297 else
|
|
|
1298 return True;
|
|
|
1299 end if;
|
|
|
1300 end Resume_Task;
|
|
|
1301
|
|
|
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;
|
|
|
1312 Old : int;
|
|
|
1313
|
|
|
1314 begin
|
|
|
1315 Old := Int_Lock;
|
|
|
1316
|
|
|
1317 C := All_Tasks_List;
|
|
|
1318 while C /= null loop
|
|
|
1319 if C.Common.LL.Thread /= Null_Thread_Id
|
|
|
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
|
|
|
1328 Dummy := Int_Unlock (Old);
|
|
|
1329 end Stop_All_Tasks;
|
|
|
1330
|
|
|
1331 ---------------
|
|
|
1332 -- Stop_Task --
|
|
|
1333 ---------------
|
|
|
1334
|
|
|
1335 function Stop_Task (T : ST.Task_Id) return Boolean is
|
|
|
1336 begin
|
|
|
1337 if T.Common.LL.Thread /= Null_Thread_Id then
|
|
|
1338 return Task_Stop (T.Common.LL.Thread) = 0;
|
|
|
1339 else
|
|
|
1340 return True;
|
|
|
1341 end if;
|
|
|
1342 end Stop_Task;
|
|
|
1343
|
|
|
1344 -------------------
|
|
|
1345 -- Continue_Task --
|
|
|
1346 -------------------
|
|
|
1347
|
|
|
1348 function Continue_Task (T : ST.Task_Id) return Boolean
|
|
|
1349 is
|
|
|
1350 begin
|
|
|
1351 if T.Common.LL.Thread /= Null_Thread_Id then
|
|
|
1352 return Task_Cont (T.Common.LL.Thread) = 0;
|
|
|
1353 else
|
|
|
1354 return True;
|
|
|
1355 end if;
|
|
|
1356 end Continue_Task;
|
|
|
1357
|
|
|
1358 ---------------------
|
|
|
1359 -- Is_Task_Context --
|
|
|
1360 ---------------------
|
|
|
1361
|
|
|
1362 function Is_Task_Context return Boolean is
|
|
|
1363 begin
|
|
|
1364 return System.OS_Interface.Interrupt_Context /= 1;
|
|
|
1365 end Is_Task_Context;
|
|
|
1366
|
|
|
1367 ----------------
|
|
|
1368 -- Initialize --
|
|
|
1369 ----------------
|
|
|
1370
|
|
|
1371 procedure Initialize (Environment_Task : Task_Id) is
|
|
|
1372 Result : int;
|
|
|
1373 pragma Unreferenced (Result);
|
|
|
1374
|
|
|
1375 begin
|
|
|
1376 Environment_Task_Id := Environment_Task;
|
|
|
1377
|
|
|
1378 Interrupt_Management.Initialize;
|
|
|
1379 Specific.Initialize;
|
|
|
1380
|
|
|
1381 if Locking_Policy = 'C' then
|
|
|
1382 Mutex_Protocol := Prio_Protect;
|
|
|
1383 elsif Locking_Policy = 'I' then
|
|
|
1384 Mutex_Protocol := Prio_Inherit;
|
|
|
1385 else
|
|
|
1386 Mutex_Protocol := Prio_None;
|
|
|
1387 end if;
|
|
|
1388
|
|
|
1389 if Time_Slice_Val > 0 then
|
|
|
1390 Result :=
|
|
|
1391 Set_Time_Slice
|
|
|
1392 (To_Clock_Ticks
|
|
|
1393 (Duration (Time_Slice_Val) / Duration (1_000_000.0)));
|
|
|
1394
|
|
|
1395 elsif Dispatching_Policy = 'R' then
|
|
|
1396 Result := Set_Time_Slice (To_Clock_Ticks (0.01));
|
|
|
1397
|
|
|
1398 end if;
|
|
|
1399
|
|
|
1400 -- Initialize the lock used to synchronize chain of all ATCBs
|
|
|
1401
|
|
|
1402 Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
|
|
|
1403
|
|
|
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
|
|
|
1410 Enter_Task (Environment_Task);
|
|
|
1411
|
|
|
1412 -- Set processor affinity
|
|
|
1413
|
|
|
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
|
|
|
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
|
|
|
1436 -- pragma CPU
|
|
|
1437
|
|
|
1438 elsif T.Common.Base_CPU /= Multiprocessors.Not_A_Specific_CPU then
|
|
|
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.
|
|
|
1442
|
|
|
1443 Result :=
|
|
|
1444 taskCpuAffinitySet
|
|
|
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
|
|
|
1450 Result := taskCpuAffinitySet (T.Common.LL.Thread, T.Common.Task_Info);
|
|
|
1451
|
|
|
1452 -- Handle dispatching domains
|
|
|
1453
|
|
|
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))
|
|
|
1459 then
|
|
|
1460 declare
|
|
|
1461 CPU_Set : unsigned := 0;
|
|
|
1462
|
|
|
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
|
|
|
1469
|
|
|
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
|
|
|
1477 Result := taskMaskAffinitySet (T.Common.LL.Thread, CPU_Set);
|
|
|
1478 end;
|
|
|
1479 end if;
|
|
|
1480 end Set_Task_Affinity;
|
|
|
1481
|
|
|
1482 end System.Task_Primitives.Operations;
|
