1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
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 --
9 -- Copyright (C) 1992-2024, Free Software Foundation, Inc. --
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. --
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. --
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/>. --
27 -- GNARL was developed by the GNARL team at Florida State University. --
28 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
30 ------------------------------------------------------------------------------
32 -- This is the VxWorks version of this package
34 -- This package contains all the GNULL primitives that interface directly with
37 with Ada
.Unchecked_Conversion
;
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
;
63 use System
.Parameters
;
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;
85 -- The followings are logically constants, but need to be initialized at
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
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
);
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
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
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
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
);
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.
202 Old_Set
: aliased sigset_t
;
203 Unblocked_Mask
: aliased sigset_t
;
205 pragma Warnings
(Off
, Result
);
207 use System
.Interrupt_Management
;
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
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
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);
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);
246 Unblocked_Mask
'Access,
248 pragma Assert
(Result
= 0);
250 raise Standard
'Abort_Signal;
258 procedure Stack_Guard
(T
: ST
.Task_Id
; On
: Boolean) is
259 pragma Unreferenced
(T
);
260 pragma Unreferenced
(On
);
263 -- Nothing needed (why not???)
272 function Get_Thread_Id
(T
: ST
.Task_Id
) return OSI
.Thread_Id
is
274 return T
.Common
.LL
.Thread
;
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
;
295 act
.sa_handler
:= Abort_Handler
'Address;
297 Result
:= sigemptyset
(Tmp_Set
'Access);
298 pragma Assert
(Result
= 0);
299 act
.sa_mask
:= Tmp_Set
;
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
)
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);
326 procedure Initialize_Lock
327 (L
: not null access RTS_Lock
;
330 pragma Unreferenced
(Level
);
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);
342 procedure Finalize_Lock
(L
: not null access Lock
) is
345 Result
:= semDelete
(L
.Mutex
);
346 pragma Assert
(Result
= OK
);
349 procedure Finalize_Lock
(L
: not null access RTS_Lock
) is
352 Result
:= semDelete
(L
.Mutex
);
353 pragma Assert
(Result
= OK
);
361 (L
: not null access Lock
;
362 Ceiling_Violation
: out Boolean)
367 if L
.Protocol
= Prio_Protect
368 and then int
(Self
.Common
.Current_Priority
) > L
.Prio_Ceiling
370 Ceiling_Violation
:= True;
373 Ceiling_Violation
:= False;
376 Result
:= semTake
(L
.Mutex
, WAIT_FOREVER
);
377 pragma Assert
(Result
= OK
);
380 procedure Write_Lock
(L
: not null access RTS_Lock
) is
383 Result
:= semTake
(L
.Mutex
, WAIT_FOREVER
);
384 pragma Assert
(Result
= OK
);
387 procedure Write_Lock
(T
: Task_Id
) is
390 Result
:= semTake
(T
.Common
.LL
.L
.Mutex
, WAIT_FOREVER
);
391 pragma Assert
(Result
= OK
);
399 (L
: not null access Lock
;
400 Ceiling_Violation
: out Boolean) is
402 Write_Lock
(L
, Ceiling_Violation
);
409 procedure Unlock
(L
: not null access Lock
) is
412 Result
:= semGive
(L
.Mutex
);
413 pragma Assert
(Result
= OK
);
416 procedure Unlock
(L
: not null access RTS_Lock
) is
419 Result
:= semGive
(L
.Mutex
);
420 pragma Assert
(Result
= OK
);
423 procedure Unlock
(T
: Task_Id
) is
426 Result
:= semGive
(T
.Common
.LL
.L
.Mutex
);
427 pragma Assert
(Result
= OK
);
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
);
449 procedure Sleep
(Self_ID
: Task_Id
; Reason
: System
.Tasking
.Task_States
) is
450 pragma Unreferenced
(Reason
);
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
);
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
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
;
497 Wakeup
: Boolean := False;
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
510 Ticks
:= To_Clock_Ticks
(Time
);
512 if Ticks
> 0 and then Ticks
< int
'Last then
518 Ticks
:= To_Clock_Ticks
(Time
- Monotonic_Clock
);
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
);
537 -- Somebody may have called Wakeup for us
542 if errno
/= S_objLib_OBJ_TIMEOUT
then
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
554 Ticks
:= To_Clock_Ticks
(Absolute
- Monotonic_Clock
);
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
;
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
);
586 -- This is for use in implementing delay statements, so we assume the
587 -- caller is holding no locks.
589 procedure Timed_Delay
592 Mode
: ST
.Delay_Modes
)
594 Orig
: constant Duration := Monotonic_Clock
;
598 Aborted
: Boolean := False;
601 pragma Warnings
(Off
, Result
);
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.
618 Ticks
:= To_Clock_Ticks
(Time
- Orig
);
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
;
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
);
642 Result
:= semTake
(Self_ID
.Common
.LL
.CV
, Ticks
);
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
652 Ticks
:= To_Clock_Ticks
(Absolute
- Monotonic_Clock
);
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
);
670 Self_ID
.Common
.State
:= Runnable
;
672 Result
:= semGive
(Self_ID
.Common
.LL
.L
.Mutex
);
675 Result
:= taskDelay
(0);
679 ---------------------
680 -- Monotonic_Clock --
681 ---------------------
683 function Monotonic_Clock
return Duration is
684 TS
: aliased timespec
;
687 Result
:= clock_gettime
(OSC
.CLOCK_RT_Ada
, TS
'Unchecked_Access);
688 pragma Assert
(Result
= 0);
689 return To_Duration
(TS
);
696 function RT_Resolution
return Duration is
698 return 1.0 / Duration (sysClkRateGet
);
705 procedure Wakeup
(T
: Task_Id
; Reason
: System
.Tasking
.Task_States
) is
706 pragma Unreferenced
(Reason
);
709 Result
:= semGive
(T
.Common
.LL
.CV
);
710 pragma Assert
(Result
= OK
);
717 procedure Yield
(Do_Yield
: Boolean := True) is
718 pragma Unreferenced
(Do_Yield
);
720 pragma Unreferenced
(Result
);
722 Result
:= taskDelay
(0);
729 procedure Set_Priority
731 Prio
: System
.Any_Priority
;
732 Loss_Of_Inheritance
: Boolean := False)
734 pragma Unreferenced
(Loss_Of_Inheritance
);
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
;
762 function Get_Priority
(T
: Task_Id
) return System
.Any_Priority
is
764 return T
.Common
.Current_Priority
;
771 procedure Enter_Task
(Self_ID
: Task_Id
) is
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;
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
812 if Is_Valid_Task
then
815 return Register_Foreign_Thread
(taskIdSelf
);
817 end Register_Foreign_Thread
;
823 procedure Initialize_TCB
(Self_ID
: Task_Id
; Succeeded
: out Boolean) is
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
833 Initialize_Lock
(Self_ID
.Common
.LL
.L
'Access, ATCB_Level
);
841 procedure Create_Task
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
;
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
860 (T
.Common
.Base_CPU
not in T
.Common
.Domain
'Range
861 or else not T
.Common
.Domain
(T
.Common
.Base_CPU
))
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 ...
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
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
;
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;
916 -- Now spawn the VxWorks task for real
918 T
.Common
.LL
.Thread
:=
921 To_VxWorks_Priority
(int
(Priority
)),
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
938 Task_Creation_Hook
(T
.Common
.LL
.Thread
);
939 Set_Priority
(T
, Priority
);
947 procedure Finalize_TCB
(T
: Task_Id
) is
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;
963 ATCB_Allocation
.Free_ATCB
(T
);
970 procedure Exit_Task
is
979 procedure Abort_Task
(T
: Task_Id
) is
985 Signal
(Interrupt_Management
.Abort_Task_Interrupt
));
986 pragma Assert
(Result
= 0);
993 procedure Initialize
(S
: in out Suspension_Object
) is
995 -- Initialize internal state (always to False (RM D.10(6)))
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
1006 S
.L
:= semBCreate
(SEM_Q_FIFO
, SEM_FULL
);
1008 -- Initialize internal condition variable
1010 S
.CV
:= semBCreate
(SEM_Q_FIFO
, SEM_EMPTY
);
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
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
);
1039 function Current_State
(S
: Suspension_Object
) return Boolean is
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.
1051 procedure Set_False
(S
: in out Suspension_Object
) is
1055 SSL
.Abort_Defer
.all;
1057 Result
:= semTake
(S
.L
, WAIT_FOREVER
);
1058 pragma Assert
(Result
= OK
);
1062 Result
:= semGive
(S
.L
);
1063 pragma Assert
(Result
= OK
);
1065 SSL
.Abort_Undefer
.all;
1072 procedure Set_True
(S
: in out Suspension_Object
) is
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;
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
1095 Result
:= semGive
(S
.CV
);
1096 pragma Assert
(Result
= OK
);
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;
1113 ------------------------
1114 -- Suspend_Until_True --
1115 ------------------------
1117 procedure Suspend_Until_True
(S
: in out Suspension_Object
) is
1121 SSL
.Abort_Defer
.all;
1123 Result
:= semTake
(S
.L
, WAIT_FOREVER
);
1127 -- Program_Error must be raised upon calling Suspend_Until_True
1128 -- if another task is already waiting on that suspension object
1131 Result
:= semGive
(S
.L
);
1132 pragma Assert
(Result
= OK
);
1134 SSL
.Abort_Undefer
.all;
1136 raise Program_Error
;
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)).
1146 Result
:= semGive
(S
.L
);
1147 pragma Assert
(Result
= OK
);
1149 SSL
.Abort_Undefer
.all;
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);
1165 end Suspend_Until_True
;
1173 function Check_Exit
(Self_ID
: ST
.Task_Id
) return Boolean is
1174 pragma Unreferenced
(Self_ID
);
1179 --------------------
1180 -- Check_No_Locks --
1181 --------------------
1183 function Check_No_Locks
(Self_ID
: ST
.Task_Id
) return Boolean is
1184 pragma Unreferenced
(Self_ID
);
1189 ----------------------
1190 -- Environment_Task --
1191 ----------------------
1193 function Environment_Task
return Task_Id
is
1195 return Environment_Task_Id
;
1196 end Environment_Task
;
1202 procedure Lock_RTS
is
1204 Write_Lock
(Single_RTS_Lock
'Access);
1211 procedure Unlock_RTS
is
1213 Unlock
(Single_RTS_Lock
'Access);
1220 function Suspend_Task
1222 Thread_Self
: Thread_Id
) return Boolean
1225 if T
.Common
.LL
.Thread
/= Null_Thread_Id
1226 and then T
.Common
.LL
.Thread
/= Thread_Self
1228 return taskSuspend
(T
.Common
.LL
.Thread
) = OK
;
1238 function Resume_Task
1240 Thread_Self
: Thread_Id
) return Boolean
1243 if T
.Common
.LL
.Thread
/= Null_Thread_Id
1244 and then T
.Common
.LL
.Thread
/= Thread_Self
1246 return taskResume
(T
.Common
.LL
.Thread
) = OK
;
1252 --------------------
1253 -- Stop_All_Tasks --
1254 --------------------
1256 procedure Stop_All_Tasks
1258 Thread_Self
: constant Thread_Id
:= taskIdSelf
;
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
1272 Dummy
:= Task_Stop
(C
.Common
.LL
.Thread
);
1275 C
:= C
.Common
.All_Tasks_Link
;
1285 function Stop_Task
(T
: ST
.Task_Id
) return Boolean is
1287 if T
.Common
.LL
.Thread
/= Null_Thread_Id
then
1288 return Task_Stop
(T
.Common
.LL
.Thread
) = OK
;
1298 function Continue_Task
(T
: ST
.Task_Id
) return Boolean
1301 if T
.Common
.LL
.Thread
/= Null_Thread_Id
then
1302 return Task_Cont
(T
.Common
.LL
.Thread
) = OK
;
1308 ---------------------
1309 -- Is_Task_Context --
1310 ---------------------
1312 function Is_Task_Context
return Boolean is
1314 return OSI
.Interrupt_Context
= 0;
1315 end Is_Task_Context
;
1321 procedure Initialize
(Environment_Task
: Task_Id
) is
1323 pragma Unreferenced
(Result
);
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
;
1336 Mutex_Protocol
:= Prio_None
;
1339 if Time_Slice_Val
> 0 then
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));
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
);
1367 -----------------------
1368 -- Set_Task_Affinity --
1369 -----------------------
1371 procedure Set_Task_Affinity
(T
: ST
.Task_Id
) is
1373 pragma Unreferenced
(Result
);
1375 use System
.Task_Info
;
1376 use type System
.Multiprocessors
.CPU_Range
;
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
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.
1395 (T
.Common
.LL
.Thread
, int
(T
.Common
.Base_CPU
) - 1);
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))
1411 CPU_Set
: unsigned
:= 0;
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);
1427 Result
:= taskMaskAffinitySet
(T
.Common
.LL
.Thread
, CPU_Set
);
1430 end Set_Task_Affinity
;
1432 end System
.Task_Primitives
.Operations
;