rs6000: load high and low part of 128bit vector independently [PR110040]
[official-gcc.git] / gcc / ada / libgnarl / s-taprop__vxworks.adb
blobfeafab4257bd4c02b8fb0b907376492fcb09b936
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
4 -- --
5 -- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2024, Free Software Foundation, Inc. --
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 ------------------------------------------------------------------------------
32 -- This is the VxWorks version of this package
34 -- This package contains all the GNULL primitives that interface directly with
35 -- the underlying OS.
37 with Ada.Unchecked_Conversion;
39 with Interfaces.C;
41 with System.Float_Control;
42 with System.Interrupt_Management;
43 with System.Multiprocessors;
44 with System.OS_Constants;
45 with System.Tasking.Debug;
47 with System.Soft_Links;
48 -- We use System.Soft_Links instead of System.Tasking.Initialization
49 -- because the later is a higher level package that we shouldn't depend
50 -- on. For example when using the restricted run time, it is replaced by
51 -- System.Tasking.Restricted.Stages.
53 with System.Task_Info;
54 with System.VxWorks.Ext;
56 package body System.Task_Primitives.Operations is
58 package OSC renames System.OS_Constants;
59 package SSL renames System.Soft_Links;
61 use System.OS_Interface;
62 use System.OS_Locks;
63 use System.Parameters;
64 use System.Tasking;
65 use System.Tasking.Debug;
67 use type Interfaces.C.int;
68 use type System.OS_Interface.unsigned;
69 use type System.VxWorks.Ext.t_id;
70 use type System.VxWorks.Ext.STATUS;
71 use type System.VxWorks.Ext.BOOL;
73 subtype int is System.OS_Interface.int;
74 subtype unsigned is System.OS_Interface.unsigned;
75 subtype STATUS is System.VxWorks.Ext.STATUS;
77 OK : constant STATUS := System.VxWorks.Ext.OK;
79 Relative : constant := 0;
81 ----------------
82 -- Local Data --
83 ----------------
85 -- The followings are logically constants, but need to be initialized at
86 -- run time.
88 Environment_Task_Id : Task_Id;
89 -- A variable to hold Task_Id for the environment task
91 -- The followings are internal configuration constants needed
93 Dispatching_Policy : constant Character;
94 pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
96 Foreign_Task_Elaborated : aliased Boolean := True;
97 -- Used to identified fake tasks (i.e., non-Ada Threads)
99 Locking_Policy : constant Character;
100 pragma Import (C, Locking_Policy, "__gl_locking_policy");
102 Mutex_Protocol : Priority_Type;
104 Single_RTS_Lock : aliased RTS_Lock;
105 -- This is a lock to allow only one thread of control in the RTS at a
106 -- time; it is used to execute in mutual exclusion from all other tasks.
107 -- Used to protect All_Tasks_List
109 Time_Slice_Val : constant Integer;
110 pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
112 Null_Thread_Id : constant Thread_Id := 0;
113 -- Constant to indicate that the thread identifier has not yet been
114 -- initialized.
116 --------------------
117 -- Local Packages --
118 --------------------
120 package Specific is
122 procedure Initialize;
123 pragma Inline (Initialize);
124 -- Initialize task specific data
126 function Is_Valid_Task return Boolean;
127 pragma Inline (Is_Valid_Task);
128 -- Does executing thread have a TCB?
130 procedure Set (Self_Id : Task_Id);
131 pragma Inline (Set);
132 -- Set the self id for the current task, unless Self_Id is null, in
133 -- which case the task specific data is deleted.
135 function Self return Task_Id;
136 pragma Inline (Self);
137 -- Return a pointer to the Ada Task Control Block of the calling task
139 end Specific;
141 package body Specific is separate;
142 -- The body of this package is target specific
144 ----------------------------------
145 -- ATCB allocation/deallocation --
146 ----------------------------------
148 package body ATCB_Allocation is separate;
149 -- The body of this package is shared across several targets
151 ---------------------------------
152 -- Support for foreign threads --
153 ---------------------------------
155 function Register_Foreign_Thread
156 (Thread : Thread_Id;
157 Sec_Stack_Size : Size_Type := Unspecified_Size) return Task_Id;
158 -- Allocate and initialize a new ATCB for the current Thread. The size of
159 -- the secondary stack can be optionally specified.
161 function Register_Foreign_Thread
162 (Thread : Thread_Id;
163 Sec_Stack_Size : Size_Type := Unspecified_Size)
164 return Task_Id is separate;
166 -----------------------
167 -- Local Subprograms --
168 -----------------------
170 procedure Abort_Handler (signo : Signal);
171 -- Handler for the abort (SIGABRT) signal to handle asynchronous abort
173 procedure Install_Signal_Handlers;
174 -- Install the default signal handlers for the current task
176 function Is_Task_Context return Boolean;
177 -- This function returns True if the current execution is in the context of
178 -- a task, and False if it is an interrupt context.
180 type Set_Stack_Limit_Proc_Acc is access procedure;
181 pragma Convention (C, Set_Stack_Limit_Proc_Acc);
183 Set_Stack_Limit_Hook : Set_Stack_Limit_Proc_Acc;
184 pragma Import (C, Set_Stack_Limit_Hook, "__gnat_set_stack_limit_hook");
185 -- Procedure to be called when a task is created to set stack limit. Used
186 -- only for VxWorks 5 and VxWorks MILS guest OS.
188 function To_Address is
189 new Ada.Unchecked_Conversion (Task_Id, System.Address);
191 -------------------
192 -- Abort_Handler --
193 -------------------
195 procedure Abort_Handler (signo : Signal) is
196 pragma Unreferenced (signo);
198 -- Do not call Self at this point as we're in a signal handler
199 -- and it may not be available, in particular on targets where we
200 -- support ZCX and where we don't do anything here anyway.
201 Self_ID : Task_Id;
202 Old_Set : aliased sigset_t;
203 Unblocked_Mask : aliased sigset_t;
204 Result : int;
205 pragma Warnings (Off, Result);
207 use System.Interrupt_Management;
209 begin
210 -- It is not safe to raise an exception when using ZCX and the GCC
211 -- exception handling mechanism.
213 if ZCX_By_Default then
214 return;
215 end if;
217 Self_ID := Self;
219 if Self_ID.Deferral_Level = 0
220 and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
221 and then not Self_ID.Aborting
222 then
223 Self_ID.Aborting := True;
225 -- Make sure signals used for RTS internal purposes are unmasked
227 Result := sigemptyset (Unblocked_Mask'Access);
228 pragma Assert (Result = 0);
229 Result :=
230 sigaddset
231 (Unblocked_Mask'Access,
232 Signal (Abort_Task_Interrupt));
233 pragma Assert (Result = 0);
234 Result := sigaddset (Unblocked_Mask'Access, SIGBUS);
235 pragma Assert (Result = 0);
236 Result := sigaddset (Unblocked_Mask'Access, SIGFPE);
237 pragma Assert (Result = 0);
238 Result := sigaddset (Unblocked_Mask'Access, SIGILL);
239 pragma Assert (Result = 0);
240 Result := sigaddset (Unblocked_Mask'Access, SIGSEGV);
241 pragma Assert (Result = 0);
243 Result :=
244 pthread_sigmask
245 (SIG_UNBLOCK,
246 Unblocked_Mask'Access,
247 Old_Set'Access);
248 pragma Assert (Result = 0);
250 raise Standard'Abort_Signal;
251 end if;
252 end Abort_Handler;
254 -----------------
255 -- Stack_Guard --
256 -----------------
258 procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
259 pragma Unreferenced (T);
260 pragma Unreferenced (On);
262 begin
263 -- Nothing needed (why not???)
265 null;
266 end Stack_Guard;
268 -------------------
269 -- Get_Thread_Id --
270 -------------------
272 function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
273 begin
274 return T.Common.LL.Thread;
275 end Get_Thread_Id;
277 ----------
278 -- Self --
279 ----------
281 function Self return Task_Id renames Specific.Self;
283 -----------------------------
284 -- Install_Signal_Handlers --
285 -----------------------------
287 procedure Install_Signal_Handlers is
288 act : aliased struct_sigaction;
289 old_act : aliased struct_sigaction;
290 Tmp_Set : aliased sigset_t;
291 Result : int;
293 begin
294 act.sa_flags := 0;
295 act.sa_handler := Abort_Handler'Address;
297 Result := sigemptyset (Tmp_Set'Access);
298 pragma Assert (Result = 0);
299 act.sa_mask := Tmp_Set;
301 Result :=
302 sigaction
303 (Signal (Interrupt_Management.Abort_Task_Interrupt),
304 act'Unchecked_Access,
305 old_act'Unchecked_Access);
306 pragma Assert (Result = 0);
308 Interrupt_Management.Initialize_Interrupts;
309 end Install_Signal_Handlers;
311 ---------------------
312 -- Initialize_Lock --
313 ---------------------
315 procedure Initialize_Lock
316 (Prio : System.Any_Priority;
317 L : not null access Lock)
319 begin
320 L.Mutex := semMCreate (SEM_Q_PRIORITY + SEM_INVERSION_SAFE);
321 L.Prio_Ceiling := int (Prio);
322 L.Protocol := Mutex_Protocol;
323 pragma Assert (L.Mutex /= 0);
324 end Initialize_Lock;
326 procedure Initialize_Lock
327 (L : not null access RTS_Lock;
328 Level : Lock_Level)
330 pragma Unreferenced (Level);
331 begin
332 L.Mutex := semMCreate (SEM_Q_PRIORITY + SEM_INVERSION_SAFE);
333 L.Prio_Ceiling := int (System.Any_Priority'Last);
334 L.Protocol := Mutex_Protocol;
335 pragma Assert (L.Mutex /= 0);
336 end Initialize_Lock;
338 -------------------
339 -- Finalize_Lock --
340 -------------------
342 procedure Finalize_Lock (L : not null access Lock) is
343 Result : STATUS;
344 begin
345 Result := semDelete (L.Mutex);
346 pragma Assert (Result = OK);
347 end Finalize_Lock;
349 procedure Finalize_Lock (L : not null access RTS_Lock) is
350 Result : STATUS;
351 begin
352 Result := semDelete (L.Mutex);
353 pragma Assert (Result = OK);
354 end Finalize_Lock;
356 ----------------
357 -- Write_Lock --
358 ----------------
360 procedure Write_Lock
361 (L : not null access Lock;
362 Ceiling_Violation : out Boolean)
364 Result : STATUS;
366 begin
367 if L.Protocol = Prio_Protect
368 and then int (Self.Common.Current_Priority) > L.Prio_Ceiling
369 then
370 Ceiling_Violation := True;
371 return;
372 else
373 Ceiling_Violation := False;
374 end if;
376 Result := semTake (L.Mutex, WAIT_FOREVER);
377 pragma Assert (Result = OK);
378 end Write_Lock;
380 procedure Write_Lock (L : not null access RTS_Lock) is
381 Result : STATUS;
382 begin
383 Result := semTake (L.Mutex, WAIT_FOREVER);
384 pragma Assert (Result = OK);
385 end Write_Lock;
387 procedure Write_Lock (T : Task_Id) is
388 Result : STATUS;
389 begin
390 Result := semTake (T.Common.LL.L.Mutex, WAIT_FOREVER);
391 pragma Assert (Result = OK);
392 end Write_Lock;
394 ---------------
395 -- Read_Lock --
396 ---------------
398 procedure Read_Lock
399 (L : not null access Lock;
400 Ceiling_Violation : out Boolean) is
401 begin
402 Write_Lock (L, Ceiling_Violation);
403 end Read_Lock;
405 ------------
406 -- Unlock --
407 ------------
409 procedure Unlock (L : not null access Lock) is
410 Result : STATUS;
411 begin
412 Result := semGive (L.Mutex);
413 pragma Assert (Result = OK);
414 end Unlock;
416 procedure Unlock (L : not null access RTS_Lock) is
417 Result : STATUS;
418 begin
419 Result := semGive (L.Mutex);
420 pragma Assert (Result = OK);
421 end Unlock;
423 procedure Unlock (T : Task_Id) is
424 Result : STATUS;
425 begin
426 Result := semGive (T.Common.LL.L.Mutex);
427 pragma Assert (Result = OK);
428 end Unlock;
430 -----------------
431 -- Set_Ceiling --
432 -----------------
434 -- Dynamic priority ceilings are not supported by the underlying system
436 procedure Set_Ceiling
437 (L : not null access Lock;
438 Prio : System.Any_Priority)
440 pragma Unreferenced (L, Prio);
441 begin
442 null;
443 end Set_Ceiling;
445 -----------
446 -- Sleep --
447 -----------
449 procedure Sleep (Self_ID : Task_Id; Reason : System.Tasking.Task_States) is
450 pragma Unreferenced (Reason);
452 Result : STATUS;
454 begin
455 pragma Assert (Self_ID = Self);
457 -- Release the mutex before sleeping
459 Result := semGive (Self_ID.Common.LL.L.Mutex);
460 pragma Assert (Result = OK);
462 -- Perform a blocking operation to take the CV semaphore. Note that a
463 -- blocking operation in VxWorks will reenable task scheduling. When we
464 -- are no longer blocked and control is returned, task scheduling will
465 -- again be disabled.
467 Result := semTake (Self_ID.Common.LL.CV, WAIT_FOREVER);
468 pragma Assert (Result = OK);
470 -- Take the mutex back
472 Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER);
473 pragma Assert (Result = OK);
474 end Sleep;
476 -----------------
477 -- Timed_Sleep --
478 -----------------
480 -- This is for use within the run-time system, so abort is assumed to be
481 -- already deferred, and the caller should be holding its own ATCB lock.
483 procedure Timed_Sleep
484 (Self_ID : Task_Id;
485 Time : Duration;
486 Mode : ST.Delay_Modes;
487 Reason : System.Tasking.Task_States;
488 Timedout : out Boolean;
489 Yielded : out Boolean)
491 pragma Unreferenced (Reason);
493 Orig : constant Duration := Monotonic_Clock;
494 Absolute : Duration;
495 Ticks : int;
496 Result : STATUS;
497 Wakeup : Boolean := False;
499 begin
500 Timedout := False;
501 Yielded := True;
503 if Mode = Relative then
504 Absolute := Orig + Time;
506 -- Systematically add one since the first tick will delay *at most*
507 -- 1 / Rate_Duration seconds, so we need to add one to be on the
508 -- safe side.
510 Ticks := To_Clock_Ticks (Time);
512 if Ticks > 0 and then Ticks < int'Last then
513 Ticks := Ticks + 1;
514 end if;
516 else
517 Absolute := Time;
518 Ticks := To_Clock_Ticks (Time - Monotonic_Clock);
519 end if;
521 if Ticks > 0 then
522 loop
523 -- Release the mutex before sleeping
525 Result := semGive (Self_ID.Common.LL.L.Mutex);
526 pragma Assert (Result = OK);
528 -- Perform a blocking operation to take the CV semaphore. Note
529 -- that a blocking operation in VxWorks will reenable task
530 -- scheduling. When we are no longer blocked and control is
531 -- returned, task scheduling will again be disabled.
533 Result := semTake (Self_ID.Common.LL.CV, Ticks);
535 if Result = OK then
537 -- Somebody may have called Wakeup for us
539 Wakeup := True;
541 else
542 if errno /= S_objLib_OBJ_TIMEOUT then
543 Wakeup := True;
545 else
546 -- If Ticks = int'last, it was most probably truncated so
547 -- let's make another round after recomputing Ticks from
548 -- the absolute time.
550 if Ticks /= int'Last then
551 Timedout := True;
553 else
554 Ticks := To_Clock_Ticks (Absolute - Monotonic_Clock);
556 if Ticks < 0 then
557 Timedout := True;
558 end if;
559 end if;
560 end if;
561 end if;
563 -- Take the mutex back
565 Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER);
566 pragma Assert (Result = OK);
568 exit when Timedout or Wakeup;
569 end loop;
571 else
572 Timedout := True;
574 -- Should never hold a lock while yielding
576 Result := semGive (Self_ID.Common.LL.L.Mutex);
577 Result := taskDelay (0);
578 Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER);
579 end if;
580 end Timed_Sleep;
582 -----------------
583 -- Timed_Delay --
584 -----------------
586 -- This is for use in implementing delay statements, so we assume the
587 -- caller is holding no locks.
589 procedure Timed_Delay
590 (Self_ID : Task_Id;
591 Time : Duration;
592 Mode : ST.Delay_Modes)
594 Orig : constant Duration := Monotonic_Clock;
595 Absolute : Duration;
596 Ticks : int;
597 Timedout : Boolean;
598 Aborted : Boolean := False;
600 Result : STATUS;
601 pragma Warnings (Off, Result);
603 begin
604 if Mode = Relative then
605 Absolute := Orig + Time;
606 Ticks := To_Clock_Ticks (Time);
608 if Ticks > 0 and then Ticks < int'Last then
610 -- First tick will delay anytime between 0 and 1 / sysClkRateGet
611 -- seconds, so we need to add one to be on the safe side.
613 Ticks := Ticks + 1;
614 end if;
616 else
617 Absolute := Time;
618 Ticks := To_Clock_Ticks (Time - Orig);
619 end if;
621 if Ticks > 0 then
623 -- Modifying State, locking the TCB
625 Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER);
627 pragma Assert (Result = OK);
629 Self_ID.Common.State := Delay_Sleep;
630 Timedout := False;
632 loop
633 Aborted := Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
635 -- Release the TCB before sleeping
637 Result := semGive (Self_ID.Common.LL.L.Mutex);
638 pragma Assert (Result = OK);
640 exit when Aborted;
642 Result := semTake (Self_ID.Common.LL.CV, Ticks);
644 if Result /= OK then
646 -- If Ticks = int'last, it was most probably truncated, so make
647 -- another round after recomputing Ticks from absolute time.
649 if errno = S_objLib_OBJ_TIMEOUT and then Ticks /= int'Last then
650 Timedout := True;
651 else
652 Ticks := To_Clock_Ticks (Absolute - Monotonic_Clock);
654 if Ticks < 0 then
655 Timedout := True;
656 end if;
657 end if;
658 end if;
660 -- Take back the lock after having slept, to protect further
661 -- access to Self_ID.
663 Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER);
665 pragma Assert (Result = OK);
667 exit when Timedout;
668 end loop;
670 Self_ID.Common.State := Runnable;
672 Result := semGive (Self_ID.Common.LL.L.Mutex);
674 else
675 Result := taskDelay (0);
676 end if;
677 end Timed_Delay;
679 ---------------------
680 -- Monotonic_Clock --
681 ---------------------
683 function Monotonic_Clock return Duration is
684 TS : aliased timespec;
685 Result : int;
686 begin
687 Result := clock_gettime (OSC.CLOCK_RT_Ada, TS'Unchecked_Access);
688 pragma Assert (Result = 0);
689 return To_Duration (TS);
690 end Monotonic_Clock;
692 -------------------
693 -- RT_Resolution --
694 -------------------
696 function RT_Resolution return Duration is
697 begin
698 return 1.0 / Duration (sysClkRateGet);
699 end RT_Resolution;
701 ------------
702 -- Wakeup --
703 ------------
705 procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
706 pragma Unreferenced (Reason);
707 Result : STATUS;
708 begin
709 Result := semGive (T.Common.LL.CV);
710 pragma Assert (Result = OK);
711 end Wakeup;
713 -----------
714 -- Yield --
715 -----------
717 procedure Yield (Do_Yield : Boolean := True) is
718 pragma Unreferenced (Do_Yield);
719 Result : STATUS;
720 pragma Unreferenced (Result);
721 begin
722 Result := taskDelay (0);
723 end Yield;
725 ------------------
726 -- Set_Priority --
727 ------------------
729 procedure Set_Priority
730 (T : Task_Id;
731 Prio : System.Any_Priority;
732 Loss_Of_Inheritance : Boolean := False)
734 pragma Unreferenced (Loss_Of_Inheritance);
736 Result : STATUS;
738 begin
739 Result :=
740 taskPrioritySet
741 (T.Common.LL.Thread, To_VxWorks_Priority (int (Prio)));
742 pragma Assert (Result = OK);
744 -- Note: in VxWorks 6.6 (or earlier), the task is placed at the end of
745 -- the priority queue instead of the head. This is not the behavior
746 -- required by Annex D (RM D.2.3(5/2)), but we consider it an acceptable
747 -- variation (RM 1.1.3(6)), given this is the built-in behavior of the
748 -- operating system. VxWorks versions starting from 6.7 implement the
749 -- required Annex D semantics.
751 -- In older versions we attempted to better approximate the Annex D
752 -- required behavior, but this simulation was not entirely accurate,
753 -- and it seems better to live with the standard VxWorks semantics.
755 T.Common.Current_Priority := Prio;
756 end Set_Priority;
758 ------------------
759 -- Get_Priority --
760 ------------------
762 function Get_Priority (T : Task_Id) return System.Any_Priority is
763 begin
764 return T.Common.Current_Priority;
765 end Get_Priority;
767 ----------------
768 -- Enter_Task --
769 ----------------
771 procedure Enter_Task (Self_ID : Task_Id) is
772 begin
773 -- Store the user-level task id in the Thread field (to be used
774 -- internally by the run-time system) and the kernel-level task id in
775 -- the LWP field (to be used by the debugger).
777 Self_ID.Common.LL.Thread := taskIdSelf;
778 Self_ID.Common.LL.LWP := getpid;
780 Specific.Set (Self_ID);
782 -- Properly initializes the FPU for PPC/MIPS systems
784 System.Float_Control.Reset;
786 -- Install the signal handlers
788 -- This is called for each task since there is no signal inheritance
789 -- between VxWorks tasks.
791 Install_Signal_Handlers;
793 -- If stack checking is enabled, set the stack limit for this task
795 if Set_Stack_Limit_Hook /= null then
796 Set_Stack_Limit_Hook.all;
797 end if;
798 end Enter_Task;
800 -------------------
801 -- Is_Valid_Task --
802 -------------------
804 function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task;
806 -----------------------------
807 -- Register_Foreign_Thread --
808 -----------------------------
810 function Register_Foreign_Thread return Task_Id is
811 begin
812 if Is_Valid_Task then
813 return Self;
814 else
815 return Register_Foreign_Thread (taskIdSelf);
816 end if;
817 end Register_Foreign_Thread;
819 --------------------
820 -- Initialize_TCB --
821 --------------------
823 procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
824 begin
825 Self_ID.Common.LL.CV := semBCreate (SEM_Q_PRIORITY, SEM_EMPTY);
826 Self_ID.Common.LL.Thread := Null_Thread_Id;
828 if Self_ID.Common.LL.CV = 0 then
829 Succeeded := False;
831 else
832 Succeeded := True;
833 Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level);
834 end if;
835 end Initialize_TCB;
837 -----------------
838 -- Create_Task --
839 -----------------
841 procedure Create_Task
842 (T : Task_Id;
843 Wrapper : System.Address;
844 Stack_Size : System.Parameters.Size_Type;
845 Priority : System.Any_Priority;
846 Succeeded : out Boolean)
848 Adjusted_Stack_Size : size_t;
850 use type System.Multiprocessors.CPU_Range;
852 begin
853 -- Check whether both Dispatching_Domain and CPU are specified for
854 -- the task, and the CPU value is not contained within the range of
855 -- processors for the domain.
857 if T.Common.Domain /= null
858 and then T.Common.Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU
859 and then
860 (T.Common.Base_CPU not in T.Common.Domain'Range
861 or else not T.Common.Domain (T.Common.Base_CPU))
862 then
863 Succeeded := False;
864 return;
865 end if;
867 -- Ask for four extra bytes of stack space so that the ATCB pointer can
868 -- be stored below the stack limit, plus extra space for the frame of
869 -- Task_Wrapper. This is so the user gets the amount of stack requested
870 -- exclusive of the needs.
872 -- We also have to allocate n more bytes for the task name storage and
873 -- enough space for the Wind Task Control Block which is around 0x778
874 -- bytes. VxWorks also seems to carve out additional space, so use 2048
875 -- as a nice round number. We might want to increment to the nearest
876 -- page size in case we ever support VxVMI.
878 -- ??? - we should come back and visit this so we can set the task name
879 -- to something appropriate.
881 Adjusted_Stack_Size := size_t (Stack_Size) + 2048;
883 -- Since the initial signal mask of a thread is inherited from the
884 -- creator, and the Environment task has all its signals masked, we do
885 -- not need to manipulate caller's signal mask at this point. All tasks
886 -- in RTS will have All_Tasks_Mask initially.
888 -- We now compute the VxWorks task name and options, then spawn ...
890 declare
891 Name : aliased String (1 .. T.Common.Task_Image_Len + 1);
892 Name_Address : System.Address;
893 -- Task name we are going to hand down to VxWorks
895 function Get_Task_Options return int;
896 pragma Import (C, Get_Task_Options, "__gnat_get_task_options");
897 -- Function that returns the options to be set for the task that we
898 -- are creating. We fetch the options assigned to the current task,
899 -- so offering some user level control over the options for a task
900 -- hierarchy, and force VX_FP_TASK because it is almost always
901 -- required.
903 begin
904 -- If there is no Ada task name handy, let VxWorks choose one.
905 -- Otherwise, tell VxWorks what the Ada task name is.
907 if T.Common.Task_Image_Len = 0 then
908 Name_Address := System.Null_Address;
909 else
910 Name (1 .. Name'Last - 1) :=
911 T.Common.Task_Image (1 .. T.Common.Task_Image_Len);
912 Name (Name'Last) := ASCII.NUL;
913 Name_Address := Name'Address;
914 end if;
916 -- Now spawn the VxWorks task for real
918 T.Common.LL.Thread :=
919 taskSpawn
920 (Name_Address,
921 To_VxWorks_Priority (int (Priority)),
922 Get_Task_Options,
923 Adjusted_Stack_Size,
924 Wrapper,
925 To_Address (T));
926 end;
928 -- Set processor affinity
930 Set_Task_Affinity (T);
932 -- Only case of failure is if taskSpawn returned 0 (aka Null_Thread_Id)
934 if T.Common.LL.Thread = Null_Thread_Id then
935 Succeeded := False;
936 else
937 Succeeded := True;
938 Task_Creation_Hook (T.Common.LL.Thread);
939 Set_Priority (T, Priority);
940 end if;
941 end Create_Task;
943 ------------------
944 -- Finalize_TCB --
945 ------------------
947 procedure Finalize_TCB (T : Task_Id) is
948 Result : STATUS;
950 begin
951 Result := semDelete (T.Common.LL.L.Mutex);
952 pragma Assert (Result = OK);
954 T.Common.LL.Thread := Null_Thread_Id;
956 Result := semDelete (T.Common.LL.CV);
957 pragma Assert (Result = OK);
959 if T.Known_Tasks_Index /= -1 then
960 Known_Tasks (T.Known_Tasks_Index) := null;
961 end if;
963 ATCB_Allocation.Free_ATCB (T);
964 end Finalize_TCB;
966 ---------------
967 -- Exit_Task --
968 ---------------
970 procedure Exit_Task is
971 begin
972 Specific.Set (null);
973 end Exit_Task;
975 ----------------
976 -- Abort_Task --
977 ----------------
979 procedure Abort_Task (T : Task_Id) is
980 Result : int;
981 begin
982 Result :=
983 kill
984 (T.Common.LL.Thread,
985 Signal (Interrupt_Management.Abort_Task_Interrupt));
986 pragma Assert (Result = 0);
987 end Abort_Task;
989 ----------------
990 -- Initialize --
991 ----------------
993 procedure Initialize (S : in out Suspension_Object) is
994 begin
995 -- Initialize internal state (always to False (RM D.10(6)))
997 S.State := False;
998 S.Waiting := False;
1000 -- Initialize internal mutex
1002 -- Use simpler binary semaphore instead of VxWorks mutual exclusion
1003 -- semaphore, because we don't need the fancier semantics and their
1004 -- overhead.
1006 S.L := semBCreate (SEM_Q_FIFO, SEM_FULL);
1008 -- Initialize internal condition variable
1010 S.CV := semBCreate (SEM_Q_FIFO, SEM_EMPTY);
1011 end Initialize;
1013 --------------
1014 -- Finalize --
1015 --------------
1017 procedure Finalize (S : in out Suspension_Object) is
1018 pragma Unmodified (S);
1019 -- S may be modified on other targets, but not on VxWorks
1021 Result : STATUS;
1023 begin
1024 -- Destroy internal mutex
1026 Result := semDelete (S.L);
1027 pragma Assert (Result = OK);
1029 -- Destroy internal condition variable
1031 Result := semDelete (S.CV);
1032 pragma Assert (Result = OK);
1033 end Finalize;
1035 -------------------
1036 -- Current_State --
1037 -------------------
1039 function Current_State (S : Suspension_Object) return Boolean is
1040 begin
1041 -- We do not want to use lock on this read operation. State is marked
1042 -- as Atomic so that we ensure that the value retrieved is correct.
1044 return S.State;
1045 end Current_State;
1047 ---------------
1048 -- Set_False --
1049 ---------------
1051 procedure Set_False (S : in out Suspension_Object) is
1052 Result : STATUS;
1054 begin
1055 SSL.Abort_Defer.all;
1057 Result := semTake (S.L, WAIT_FOREVER);
1058 pragma Assert (Result = OK);
1060 S.State := False;
1062 Result := semGive (S.L);
1063 pragma Assert (Result = OK);
1065 SSL.Abort_Undefer.all;
1066 end Set_False;
1068 --------------
1069 -- Set_True --
1070 --------------
1072 procedure Set_True (S : in out Suspension_Object) is
1073 Result : STATUS;
1075 begin
1076 -- Set_True can be called from an interrupt context, in which case
1077 -- Abort_Defer is undefined.
1079 if Is_Task_Context then
1080 SSL.Abort_Defer.all;
1081 end if;
1083 Result := semTake (S.L, WAIT_FOREVER);
1084 pragma Assert (Result = OK);
1086 -- If there is already a task waiting on this suspension object then we
1087 -- resume it, leaving the state of the suspension object to False, as it
1088 -- is specified in (RM D.10 (9)). Otherwise, it just leaves the state to
1089 -- True.
1091 if S.Waiting then
1092 S.Waiting := False;
1093 S.State := False;
1095 Result := semGive (S.CV);
1096 pragma Assert (Result = OK);
1097 else
1098 S.State := True;
1099 end if;
1101 Result := semGive (S.L);
1102 pragma Assert (Result = OK);
1104 -- Set_True can be called from an interrupt context, in which case
1105 -- Abort_Undefer is undefined.
1107 if Is_Task_Context then
1108 SSL.Abort_Undefer.all;
1109 end if;
1111 end Set_True;
1113 ------------------------
1114 -- Suspend_Until_True --
1115 ------------------------
1117 procedure Suspend_Until_True (S : in out Suspension_Object) is
1118 Result : STATUS;
1120 begin
1121 SSL.Abort_Defer.all;
1123 Result := semTake (S.L, WAIT_FOREVER);
1125 if S.Waiting then
1127 -- Program_Error must be raised upon calling Suspend_Until_True
1128 -- if another task is already waiting on that suspension object
1129 -- (RM D.10(10)).
1131 Result := semGive (S.L);
1132 pragma Assert (Result = OK);
1134 SSL.Abort_Undefer.all;
1136 raise Program_Error;
1138 else
1139 -- Suspend the task if the state is False. Otherwise, the task
1140 -- continues its execution, and the state of the suspension object
1141 -- is set to False (RM D.10 (9)).
1143 if S.State then
1144 S.State := False;
1146 Result := semGive (S.L);
1147 pragma Assert (Result = OK);
1149 SSL.Abort_Undefer.all;
1151 else
1152 S.Waiting := True;
1154 -- Release the mutex before sleeping
1156 Result := semGive (S.L);
1157 pragma Assert (Result = OK);
1159 SSL.Abort_Undefer.all;
1161 Result := semTake (S.CV, WAIT_FOREVER);
1162 pragma Assert (Result = 0);
1163 end if;
1164 end if;
1165 end Suspend_Until_True;
1167 ----------------
1168 -- Check_Exit --
1169 ----------------
1171 -- Dummy version
1173 function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
1174 pragma Unreferenced (Self_ID);
1175 begin
1176 return True;
1177 end Check_Exit;
1179 --------------------
1180 -- Check_No_Locks --
1181 --------------------
1183 function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
1184 pragma Unreferenced (Self_ID);
1185 begin
1186 return True;
1187 end Check_No_Locks;
1189 ----------------------
1190 -- Environment_Task --
1191 ----------------------
1193 function Environment_Task return Task_Id is
1194 begin
1195 return Environment_Task_Id;
1196 end Environment_Task;
1198 --------------
1199 -- Lock_RTS --
1200 --------------
1202 procedure Lock_RTS is
1203 begin
1204 Write_Lock (Single_RTS_Lock'Access);
1205 end Lock_RTS;
1207 ----------------
1208 -- Unlock_RTS --
1209 ----------------
1211 procedure Unlock_RTS is
1212 begin
1213 Unlock (Single_RTS_Lock'Access);
1214 end Unlock_RTS;
1216 ------------------
1217 -- Suspend_Task --
1218 ------------------
1220 function Suspend_Task
1221 (T : ST.Task_Id;
1222 Thread_Self : Thread_Id) return Boolean
1224 begin
1225 if T.Common.LL.Thread /= Null_Thread_Id
1226 and then T.Common.LL.Thread /= Thread_Self
1227 then
1228 return taskSuspend (T.Common.LL.Thread) = OK;
1229 else
1230 return True;
1231 end if;
1232 end Suspend_Task;
1234 -----------------
1235 -- Resume_Task --
1236 -----------------
1238 function Resume_Task
1239 (T : ST.Task_Id;
1240 Thread_Self : Thread_Id) return Boolean
1242 begin
1243 if T.Common.LL.Thread /= Null_Thread_Id
1244 and then T.Common.LL.Thread /= Thread_Self
1245 then
1246 return taskResume (T.Common.LL.Thread) = OK;
1247 else
1248 return True;
1249 end if;
1250 end Resume_Task;
1252 --------------------
1253 -- Stop_All_Tasks --
1254 --------------------
1256 procedure Stop_All_Tasks
1258 Thread_Self : constant Thread_Id := taskIdSelf;
1259 C : Task_Id;
1261 Dummy : STATUS;
1262 Old : int;
1264 begin
1265 Old := Int_Lock;
1267 C := All_Tasks_List;
1268 while C /= null loop
1269 if C.Common.LL.Thread /= Null_Thread_Id
1270 and then C.Common.LL.Thread /= Thread_Self
1271 then
1272 Dummy := Task_Stop (C.Common.LL.Thread);
1273 end if;
1275 C := C.Common.All_Tasks_Link;
1276 end loop;
1278 Int_Unlock (Old);
1279 end Stop_All_Tasks;
1281 ---------------
1282 -- Stop_Task --
1283 ---------------
1285 function Stop_Task (T : ST.Task_Id) return Boolean is
1286 begin
1287 if T.Common.LL.Thread /= Null_Thread_Id then
1288 return Task_Stop (T.Common.LL.Thread) = OK;
1289 else
1290 return True;
1291 end if;
1292 end Stop_Task;
1294 -------------------
1295 -- Continue_Task --
1296 -------------------
1298 function Continue_Task (T : ST.Task_Id) return Boolean
1300 begin
1301 if T.Common.LL.Thread /= Null_Thread_Id then
1302 return Task_Cont (T.Common.LL.Thread) = OK;
1303 else
1304 return True;
1305 end if;
1306 end Continue_Task;
1308 ---------------------
1309 -- Is_Task_Context --
1310 ---------------------
1312 function Is_Task_Context return Boolean is
1313 begin
1314 return OSI.Interrupt_Context = 0;
1315 end Is_Task_Context;
1317 ----------------
1318 -- Initialize --
1319 ----------------
1321 procedure Initialize (Environment_Task : Task_Id) is
1322 Result : STATUS;
1323 pragma Unreferenced (Result);
1325 begin
1326 Environment_Task_Id := Environment_Task;
1328 Interrupt_Management.Initialize;
1329 Specific.Initialize;
1331 if Locking_Policy = 'C' then
1332 Mutex_Protocol := Prio_Protect;
1333 elsif Locking_Policy = 'I' then
1334 Mutex_Protocol := Prio_Inherit;
1335 else
1336 Mutex_Protocol := Prio_None;
1337 end if;
1339 if Time_Slice_Val > 0 then
1340 Result :=
1341 Set_Time_Slice
1342 (To_Clock_Ticks
1343 (Duration (Time_Slice_Val) / Duration (1_000_000.0)));
1345 elsif Dispatching_Policy = 'R' then
1346 Result := Set_Time_Slice (To_Clock_Ticks (0.01));
1348 end if;
1350 -- Initialize the lock used to synchronize chain of all ATCBs
1352 Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
1354 -- Make environment task known here because it doesn't go through
1355 -- Activate_Tasks, which does it for all other tasks.
1357 Known_Tasks (Known_Tasks'First) := Environment_Task;
1358 Environment_Task.Known_Tasks_Index := Known_Tasks'First;
1360 Enter_Task (Environment_Task);
1362 -- Set processor affinity
1364 Set_Task_Affinity (Environment_Task);
1365 end Initialize;
1367 -----------------------
1368 -- Set_Task_Affinity --
1369 -----------------------
1371 procedure Set_Task_Affinity (T : ST.Task_Id) is
1372 Result : int := 0;
1373 pragma Unreferenced (Result);
1375 use System.Task_Info;
1376 use type System.Multiprocessors.CPU_Range;
1378 begin
1379 -- Do nothing if the underlying thread has not yet been created. If the
1380 -- thread has not yet been created then the proper affinity will be set
1381 -- during its creation.
1383 if T.Common.LL.Thread = Null_Thread_Id then
1384 null;
1386 -- pragma CPU
1388 elsif T.Common.Base_CPU /= Multiprocessors.Not_A_Specific_CPU then
1390 -- Ada 2012 pragma CPU uses CPU numbers starting from 1, while on
1391 -- VxWorks the first CPU is identified by a 0, so we need to adjust.
1393 Result :=
1394 taskCpuAffinitySet
1395 (T.Common.LL.Thread, int (T.Common.Base_CPU) - 1);
1397 -- Task_Info
1399 elsif T.Common.Task_Info /= Unspecified_Task_Info then
1400 Result := taskCpuAffinitySet (T.Common.LL.Thread, T.Common.Task_Info);
1402 -- Handle dispatching domains
1404 elsif T.Common.Domain /= null
1405 and then (T.Common.Domain /= ST.System_Domain
1406 or else T.Common.Domain.all /=
1407 (Multiprocessors.CPU'First ..
1408 Multiprocessors.Number_Of_CPUs => True))
1409 then
1410 declare
1411 CPU_Set : unsigned := 0;
1413 begin
1414 -- Set the affinity to all the processors belonging to the
1415 -- dispatching domain.
1417 for Proc in T.Common.Domain'Range loop
1418 if T.Common.Domain (Proc) then
1420 -- The thread affinity mask is a bit vector in which each
1421 -- bit represents a logical processor.
1423 CPU_Set := CPU_Set + 2 ** (Integer (Proc) - 1);
1424 end if;
1425 end loop;
1427 Result := taskMaskAffinitySet (T.Common.LL.Thread, CPU_Set);
1428 end;
1429 end if;
1430 end Set_Task_Affinity;
1432 end System.Task_Primitives.Operations;