1 ------------------------------------------------------------------------------
3 -- GNU ADA 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-2023, 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 a GNU/Linux (GNU/LinuxThreads) version of this package
34 -- This package contains all the GNULL primitives that interface directly with
37 with Interfaces
.C
; use Interfaces
; use type Interfaces
.C
.int
;
39 with System
.Task_Info
;
40 with System
.Tasking
.Debug
;
41 with System
.Interrupt_Management
;
42 with System
.OS_Constants
;
43 with System
.OS_Primitives
;
44 with System
.Multiprocessors
;
46 with System
.Soft_Links
;
47 -- We use System.Soft_Links instead of System.Tasking.Initialization
48 -- because the later is a higher level package that we shouldn't depend on.
49 -- For example when using the restricted run time, it is replaced by
50 -- System.Tasking.Restricted.Stages.
52 package body System
.Task_Primitives
.Operations
is
54 package OSC
renames System
.OS_Constants
;
55 package SSL
renames System
.Soft_Links
;
57 use System
.Tasking
.Debug
;
59 use System
.OS_Interface
;
60 use System
.Parameters
;
61 use System
.OS_Primitives
;
68 -- The followings are logically constants, but need to be initialized
71 Single_RTS_Lock
: aliased RTS_Lock
;
72 -- This is a lock to allow only one thread of control in the RTS at
73 -- a time; it is used to execute in mutual exclusion from all other tasks.
74 -- Used to protect All_Tasks_List
76 Environment_Task_Id
: Task_Id
;
77 -- A variable to hold Task_Id for the environment task
79 Unblocked_Signal_Mask
: aliased sigset_t
;
80 -- The set of signals that should be unblocked in all tasks
82 -- The followings are internal configuration constants needed
84 Next_Serial_Number
: Task_Serial_Number
:= 100;
85 -- We start at 100 (reserve some special values for using in error checks)
87 Time_Slice_Val
: constant Integer;
88 pragma Import
(C
, Time_Slice_Val
, "__gl_time_slice_val");
90 Dispatching_Policy
: constant Character;
91 pragma Import
(C
, Dispatching_Policy
, "__gl_task_dispatching_policy");
93 Locking_Policy
: constant Character;
94 pragma Import
(C
, Locking_Policy
, "__gl_locking_policy");
96 Foreign_Task_Elaborated
: aliased Boolean := True;
97 -- Used to identified fake tasks (i.e., non-Ada Threads)
99 Use_Alternate_Stack
: Boolean := Alternate_Stack_Size
/= 0;
100 -- Whether to use an alternate signal stack for stack overflows
102 Abort_Handler_Installed
: Boolean := False;
103 -- True if a handler for the abort signal is installed
105 Null_Thread_Id
: constant pthread_t
:= pthread_t
'Last;
106 -- Constant to indicate that the thread identifier has not yet been
115 procedure Initialize
(Environment_Task
: Task_Id
);
116 pragma Inline
(Initialize
);
117 -- Initialize various data needed by this package
119 function Is_Valid_Task
return Boolean;
120 pragma Inline
(Is_Valid_Task
);
121 -- Does executing thread have a TCB?
123 procedure Set
(Self_Id
: Task_Id
);
125 -- Set the self id for the current task
127 function Self
return Task_Id
;
128 pragma Inline
(Self
);
129 -- Return a pointer to the Ada Task Control Block of the calling task
133 package body Specific
is separate;
134 -- The body of this package is target specific
138 function Monotonic_Clock
return Duration;
139 pragma Inline
(Monotonic_Clock
);
140 -- Returns an absolute time, represented as an offset relative to some
141 -- unspecified starting point, typically system boot time. This clock is
142 -- not affected by discontinuous jumps in the system time.
144 function RT_Resolution
return Duration;
145 pragma Inline
(RT_Resolution
);
146 -- Returns resolution of the underlying clock used to implement RT_Clock
148 procedure Timed_Sleep
149 (Self_ID
: ST
.Task_Id
;
151 Mode
: ST
.Delay_Modes
;
152 Reason
: System
.Tasking
.Task_States
;
153 Timedout
: out Boolean;
154 Yielded
: out Boolean);
155 -- Combination of Sleep (above) and Timed_Delay
157 procedure Timed_Delay
158 (Self_ID
: ST
.Task_Id
;
160 Mode
: ST
.Delay_Modes
);
161 -- Implement the semantics of the delay statement.
162 -- The caller should be abort-deferred and should not hold any locks.
166 package body Monotonic
is separate;
168 ----------------------------------
169 -- ATCB allocation/deallocation --
170 ----------------------------------
172 package body ATCB_Allocation
is separate;
173 -- The body of this package is shared across several targets
175 ---------------------------------
176 -- Support for foreign threads --
177 ---------------------------------
179 function Register_Foreign_Thread
181 Sec_Stack_Size
: Size_Type
:= Unspecified_Size
) return Task_Id
;
182 -- Allocate and initialize a new ATCB for the current Thread. The size of
183 -- the secondary stack can be optionally specified.
185 function Register_Foreign_Thread
187 Sec_Stack_Size
: Size_Type
:= Unspecified_Size
)
188 return Task_Id
is separate;
190 -----------------------
191 -- Local Subprograms --
192 -----------------------
194 procedure Abort_Handler
(signo
: Signal
);
196 function GNAT_pthread_condattr_setup
197 (attr
: access pthread_condattr_t
) return C
.int
;
199 (C
, GNAT_pthread_condattr_setup
, "__gnat_pthread_condattr_setup");
201 function GNAT_has_cap_sys_nice
return C
.int
;
203 (C
, GNAT_has_cap_sys_nice
, "__gnat_has_cap_sys_nice");
204 -- We do not have pragma Linker_Options ("-lcap"); here, because this
205 -- library is not present on many Linux systems. 'libcap' is the Linux
206 -- "capabilities" library, called by __gnat_has_cap_sys_nice.
208 function Prio_To_Linux_Prio
(Prio
: Any_Priority
) return C
.int
is
210 -- Convert Ada priority to Linux priority. Priorities are 1 .. 99 on
211 -- GNU/Linux, so we map 0 .. 98 to 1 .. 99.
213 function Get_Ceiling_Support
return Boolean;
214 -- Get the value of the Ceiling_Support constant (see below).
215 -- Note well: If this function or related code is modified, it should be
216 -- tested by hand, because automated testing doesn't exercise it.
218 -------------------------
219 -- Get_Ceiling_Support --
220 -------------------------
222 function Get_Ceiling_Support
return Boolean is
223 Ceiling_Support
: Boolean := False;
225 if Locking_Policy
/= 'C' then
230 function geteuid
return Integer;
231 pragma Import
(C
, geteuid
, "geteuid");
232 Superuser
: constant Boolean := geteuid
= 0;
233 Has_Cap
: constant C
.int
:= GNAT_has_cap_sys_nice
;
234 pragma Assert
(Has_Cap
in 0 |
1);
236 Ceiling_Support
:= Superuser
or else Has_Cap
= 1;
239 return Ceiling_Support
;
240 end Get_Ceiling_Support
;
242 pragma Warnings
(Off
, "non-preelaborable call not allowed*");
243 Ceiling_Support
: constant Boolean := Get_Ceiling_Support
;
244 pragma Warnings
(On
, "non-preelaborable call not allowed*");
245 -- True if the locking policy is Ceiling_Locking, and the current process
246 -- has permission to use this policy. The process has permission if it is
247 -- running as 'root', or if the capability was set by the setcap command,
248 -- as in "sudo /sbin/setcap cap_sys_nice=ep exe_file". If it doesn't have
249 -- permission, then a request for Ceiling_Locking is ignored.
251 type RTS_Lock_Ptr
is not null access all RTS_Lock
;
253 function Init_Mutex
(L
: RTS_Lock_Ptr
; Prio
: Any_Priority
) return C
.int
;
254 -- Initialize the mutex L. If Ceiling_Support is True, then set the ceiling
255 -- to Prio. Returns 0 for success, or ENOMEM for out-of-memory.
261 procedure Abort_Handler
(signo
: Signal
) is
262 pragma Unreferenced
(signo
);
264 Self_Id
: constant Task_Id
:= Self
;
266 Old_Set
: aliased sigset_t
;
269 -- It's not safe to raise an exception when using GCC ZCX mechanism.
270 -- Note that we still need to install a signal handler, since in some
271 -- cases (e.g. shutdown of the Server_Task in System.Interrupts) we
272 -- need to send the Abort signal to a task.
274 if ZCX_By_Default
then
278 if Self_Id
.Deferral_Level
= 0
279 and then Self_Id
.Pending_ATC_Level
< Self_Id
.ATC_Nesting_Level
280 and then not Self_Id
.Aborting
282 Self_Id
.Aborting
:= True;
284 -- Make sure signals used for RTS internal purpose are unmasked
289 Unblocked_Signal_Mask
'Access,
291 pragma Assert
(Result
= 0);
293 raise Standard
'Abort_Signal;
301 procedure Lock_RTS
is
303 Write_Lock
(Single_RTS_Lock
'Access);
310 procedure Unlock_RTS
is
312 Unlock
(Single_RTS_Lock
'Access);
319 -- The underlying thread system extends the memory (up to 2MB) when needed
321 procedure Stack_Guard
(T
: ST
.Task_Id
; On
: Boolean) is
322 pragma Unreferenced
(T
);
323 pragma Unreferenced
(On
);
332 function Get_Thread_Id
(T
: ST
.Task_Id
) return OSI
.Thread_Id
is
334 return T
.Common
.LL
.Thread
;
341 function Self
return Task_Id
renames Specific
.Self
;
347 function Init_Mutex
(L
: RTS_Lock_Ptr
; Prio
: Any_Priority
) return C
.int
is
348 Mutex_Attr
: aliased pthread_mutexattr_t
;
349 Result
, Result_2
: C
.int
;
352 Result
:= pthread_mutexattr_init
(Mutex_Attr
'Access);
353 pragma Assert
(Result
in 0 | ENOMEM
);
355 if Result
= ENOMEM
then
359 if Ceiling_Support
then
360 Result
:= pthread_mutexattr_setprotocol
361 (Mutex_Attr
'Access, PTHREAD_PRIO_PROTECT
);
362 pragma Assert
(Result
= 0);
364 Result
:= pthread_mutexattr_setprioceiling
365 (Mutex_Attr
'Access, Prio_To_Linux_Prio
(Prio
));
366 pragma Assert
(Result
= 0);
368 elsif Locking_Policy
= 'I' then
369 Result
:= pthread_mutexattr_setprotocol
370 (Mutex_Attr
'Access, PTHREAD_PRIO_INHERIT
);
371 pragma Assert
(Result
= 0);
374 Result
:= pthread_mutex_init
(L
, Mutex_Attr
'Access);
375 pragma Assert
(Result
in 0 | ENOMEM
);
377 Result_2
:= pthread_mutexattr_destroy
(Mutex_Attr
'Access);
378 pragma Assert
(Result_2
= 0);
379 return Result
; -- of pthread_mutex_init, not pthread_mutexattr_destroy
382 ---------------------
383 -- Initialize_Lock --
384 ---------------------
386 -- Note: mutexes and cond_variables needed per-task basis are initialized
387 -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such
388 -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any
389 -- status change of RTS. Therefore raising Storage_Error in the following
390 -- routines should be able to be handled safely.
392 procedure Initialize_Lock
393 (Prio
: Any_Priority
;
394 L
: not null access Lock
)
397 if Locking_Policy
= 'R' then
399 RWlock_Attr
: aliased pthread_rwlockattr_t
;
403 -- Set the rwlock to prefer writer to avoid writers starvation
405 Result
:= pthread_rwlockattr_init
(RWlock_Attr
'Access);
406 pragma Assert
(Result
= 0);
408 Result
:= pthread_rwlockattr_setkind_np
410 PTHREAD_RWLOCK_PREFER_WRITER_NONRECURSIVE_NP
);
411 pragma Assert
(Result
= 0);
413 Result
:= pthread_rwlock_init
(L
.RW
'Access, RWlock_Attr
'Access);
415 pragma Assert
(Result
in 0 | ENOMEM
);
417 if Result
= ENOMEM
then
418 raise Storage_Error
with "Failed to allocate a lock";
423 if Init_Mutex
(L
.WO
'Access, Prio
) = ENOMEM
then
424 raise Storage_Error
with "Failed to allocate a lock";
429 procedure Initialize_Lock
430 (L
: not null access RTS_Lock
; Level
: Lock_Level
)
432 pragma Unreferenced
(Level
);
434 if Init_Mutex
(L
.all'Access, Any_Priority
'Last) = ENOMEM
then
435 raise Storage_Error
with "Failed to allocate a lock";
443 procedure Finalize_Lock
(L
: not null access Lock
) is
446 if Locking_Policy
= 'R' then
447 Result
:= pthread_rwlock_destroy
(L
.RW
'Access);
449 Result
:= pthread_mutex_destroy
(L
.WO
'Access);
451 pragma Assert
(Result
= 0);
454 procedure Finalize_Lock
(L
: not null access RTS_Lock
) is
457 Result
:= pthread_mutex_destroy
(L
);
458 pragma Assert
(Result
= 0);
466 (L
: not null access Lock
;
467 Ceiling_Violation
: out Boolean)
471 if Locking_Policy
= 'R' then
472 Result
:= pthread_rwlock_wrlock
(L
.RW
'Access);
474 Result
:= pthread_mutex_lock
(L
.WO
'Access);
477 -- The cause of EINVAL is a priority ceiling violation
479 pragma Assert
(Result
in 0 | EINVAL
);
480 Ceiling_Violation
:= Result
= EINVAL
;
483 procedure Write_Lock
(L
: not null access RTS_Lock
) is
486 Result
:= pthread_mutex_lock
(L
);
487 pragma Assert
(Result
= 0);
490 procedure Write_Lock
(T
: Task_Id
) is
493 Result
:= pthread_mutex_lock
(T
.Common
.LL
.L
'Access);
494 pragma Assert
(Result
= 0);
502 (L
: not null access Lock
;
503 Ceiling_Violation
: out Boolean)
507 if Locking_Policy
= 'R' then
508 Result
:= pthread_rwlock_rdlock
(L
.RW
'Access);
510 Result
:= pthread_mutex_lock
(L
.WO
'Access);
513 -- The cause of EINVAL is a priority ceiling violation
515 pragma Assert
(Result
in 0 | EINVAL
);
516 Ceiling_Violation
:= Result
= EINVAL
;
523 procedure Unlock
(L
: not null access Lock
) is
526 if Locking_Policy
= 'R' then
527 Result
:= pthread_rwlock_unlock
(L
.RW
'Access);
529 Result
:= pthread_mutex_unlock
(L
.WO
'Access);
531 pragma Assert
(Result
= 0);
534 procedure Unlock
(L
: not null access RTS_Lock
) is
537 Result
:= pthread_mutex_unlock
(L
);
538 pragma Assert
(Result
= 0);
541 procedure Unlock
(T
: Task_Id
) is
544 Result
:= pthread_mutex_unlock
(T
.Common
.LL
.L
'Access);
545 pragma Assert
(Result
= 0);
552 -- Dynamic priority ceilings are not supported by the underlying system
554 procedure Set_Ceiling
555 (L
: not null access Lock
;
558 pragma Unreferenced
(L
, Prio
);
569 Reason
: System
.Tasking
.Task_States
)
571 pragma Unreferenced
(Reason
);
576 pragma Assert
(Self_ID
= Self
);
580 (cond
=> Self_ID
.Common
.LL
.CV
'Access,
581 mutex
=> Self_ID
.Common
.LL
.L
'Access);
583 -- EINTR is not considered a failure
585 pragma Assert
(Result
in 0 | EINTR
);
592 -- This is for use within the run-time system, so abort is
593 -- assumed to be already deferred, and the caller should be
594 -- holding its own ATCB lock.
596 procedure Timed_Sleep
599 Mode
: ST
.Delay_Modes
;
600 Reason
: System
.Tasking
.Task_States
;
601 Timedout
: out Boolean;
602 Yielded
: out Boolean) renames Monotonic
.Timed_Sleep
;
608 -- This is for use in implementing delay statements, so we assume the
609 -- caller is abort-deferred but is holding no locks.
611 procedure Timed_Delay
614 Mode
: ST
.Delay_Modes
) renames Monotonic
.Timed_Delay
;
616 ---------------------
617 -- Monotonic_Clock --
618 ---------------------
620 function Monotonic_Clock
return Duration renames Monotonic
.Monotonic_Clock
;
626 function RT_Resolution
return Duration renames Monotonic
.RT_Resolution
;
632 procedure Wakeup
(T
: Task_Id
; Reason
: System
.Tasking
.Task_States
) is
633 pragma Unreferenced
(Reason
);
636 Result
:= pthread_cond_signal
(T
.Common
.LL
.CV
'Access);
637 pragma Assert
(Result
= 0);
644 procedure Yield
(Do_Yield
: Boolean := True) is
646 pragma Unreferenced
(Result
);
649 Result
:= sched_yield
;
657 procedure Set_Priority
660 Loss_Of_Inheritance
: Boolean := False)
662 pragma Unreferenced
(Loss_Of_Inheritance
);
665 Param
: aliased struct_sched_param
;
667 function Get_Policy
(Prio
: Any_Priority
) return Character;
668 pragma Import
(C
, Get_Policy
, "__gnat_get_specific_dispatching");
669 -- Get priority specific dispatching policy
671 Priority_Specific_Policy
: constant Character := Get_Policy
(Prio
);
672 -- Upper case first character of the policy name corresponding to the
673 -- task as set by a Priority_Specific_Dispatching pragma.
676 T
.Common
.Current_Priority
:= Prio
;
678 Param
.sched_priority
:= Prio_To_Linux_Prio
(Prio
);
680 if Dispatching_Policy
= 'R'
681 or else Priority_Specific_Policy
= 'R'
682 or else Time_Slice_Val
> 0
685 pthread_setschedparam
686 (T
.Common
.LL
.Thread
, SCHED_RR
, Param
'Access);
688 elsif Dispatching_Policy
= 'F'
689 or else Priority_Specific_Policy
= 'F'
690 or else Time_Slice_Val
= 0
693 pthread_setschedparam
694 (T
.Common
.LL
.Thread
, SCHED_FIFO
, Param
'Access);
697 Param
.sched_priority
:= 0;
699 pthread_setschedparam
701 SCHED_OTHER
, Param
'Access);
704 pragma Assert
(Result
in 0 | EPERM | EINVAL
);
711 function Get_Priority
(T
: Task_Id
) return Any_Priority
is
713 return T
.Common
.Current_Priority
;
720 procedure Enter_Task
(Self_ID
: Task_Id
) is
722 if Self_ID
.Common
.Task_Info
/= null
723 and then Self_ID
.Common
.Task_Info
.CPU_Affinity
= No_CPU
725 raise Invalid_CPU_Number
;
728 Self_ID
.Common
.LL
.Thread
:= pthread_self
;
729 Self_ID
.Common
.LL
.LWP
:= lwp_self
;
731 -- Set thread name to ease debugging. If the name of the task is
732 -- "foreign thread" (as set by Register_Foreign_Thread) retrieve
733 -- the name of the thread and update the name of the task instead.
735 if Self_ID
.Common
.Task_Image_Len
= 14
736 and then Self_ID
.Common
.Task_Image
(1 .. 14) = "foreign thread"
739 Thread_Name
: String (1 .. 16);
740 -- PR_GET_NAME returns a string of up to 16 bytes
743 -- Length of the task name contained in Task_Name
746 -- Result from the prctl call
748 Result
:= prctl
(PR_GET_NAME
, unsigned_long
(Thread_Name
'Address));
749 pragma Assert
(Result
= 0);
751 -- Find the length of the given name
753 for J
in Thread_Name
'Range loop
754 if Thread_Name
(J
) /= ASCII
.NUL
then
761 -- Cover the odd situation where someone decides to change
762 -- Parameters.Max_Task_Image_Length to less than 16 characters.
764 if Len
> Parameters
.Max_Task_Image_Length
then
765 Len
:= Parameters
.Max_Task_Image_Length
;
768 -- Copy the name of the thread to the task's ATCB
770 Self_ID
.Common
.Task_Image
(1 .. Len
) := Thread_Name
(1 .. Len
);
771 Self_ID
.Common
.Task_Image_Len
:= Len
;
774 elsif Self_ID
.Common
.Task_Image_Len
> 0 then
776 Task_Name
: String (1 .. Parameters
.Max_Task_Image_Length
+ 1);
780 Task_Name
(1 .. Self_ID
.Common
.Task_Image_Len
) :=
781 Self_ID
.Common
.Task_Image
(1 .. Self_ID
.Common
.Task_Image_Len
);
782 Task_Name
(Self_ID
.Common
.Task_Image_Len
+ 1) := ASCII
.NUL
;
784 Result
:= prctl
(PR_SET_NAME
, unsigned_long
(Task_Name
'Address));
785 pragma Assert
(Result
= 0);
789 Specific
.Set
(Self_ID
);
791 if Use_Alternate_Stack
792 and then Self_ID
.Common
.Task_Alternate_Stack
/= Null_Address
795 Stack
: aliased stack_t
;
798 Stack
.ss_sp
:= Self_ID
.Common
.Task_Alternate_Stack
;
799 Stack
.ss_size
:= Alternate_Stack_Size
;
801 Result
:= sigaltstack
(Stack
'Access, null);
802 pragma Assert
(Result
= 0);
811 function Is_Valid_Task
return Boolean renames Specific
.Is_Valid_Task
;
813 -----------------------------
814 -- Register_Foreign_Thread --
815 -----------------------------
817 function Register_Foreign_Thread
return Task_Id
is
819 if Is_Valid_Task
then
822 return Register_Foreign_Thread
(pthread_self
);
824 end Register_Foreign_Thread
;
830 procedure Initialize_TCB
(Self_ID
: Task_Id
; Succeeded
: out Boolean) is
832 Cond_Attr
: aliased pthread_condattr_t
;
835 -- Give the task a unique serial number
837 Self_ID
.Serial_Number
:= Next_Serial_Number
;
838 Next_Serial_Number
:= Next_Serial_Number
+ 1;
839 pragma Assert
(Next_Serial_Number
/= 0);
841 Self_ID
.Common
.LL
.Thread
:= Null_Thread_Id
;
843 if Init_Mutex
(Self_ID
.Common
.LL
.L
'Access, Any_Priority
'Last) /= 0 then
848 Result
:= pthread_condattr_init
(Cond_Attr
'Access);
849 pragma Assert
(Result
in 0 | ENOMEM
);
852 Result
:= GNAT_pthread_condattr_setup
(Cond_Attr
'Access);
853 pragma Assert
(Result
= 0);
857 (Self_ID
.Common
.LL
.CV
'Access, Cond_Attr
'Access);
858 pragma Assert
(Result
in 0 | ENOMEM
);
864 Result
:= pthread_mutex_destroy
(Self_ID
.Common
.LL
.L
'Access);
865 pragma Assert
(Result
= 0);
870 Result
:= pthread_condattr_destroy
(Cond_Attr
'Access);
871 pragma Assert
(Result
= 0);
878 procedure Create_Task
880 Wrapper
: System
.Address
;
881 Stack_Size
: System
.Parameters
.Size_Type
;
882 Priority
: Any_Priority
;
883 Succeeded
: out Boolean)
885 Thread_Attr
: aliased pthread_attr_t
;
886 Adjusted_Stack_Size
: C
.size_t
;
889 use type Multiprocessors
.CPU_Range
, Interfaces
.C
.size_t
;
892 -- Check whether both Dispatching_Domain and CPU are specified for
893 -- the task, and the CPU value is not contained within the range of
894 -- processors for the domain.
896 if T
.Common
.Domain
/= null
897 and then T
.Common
.Base_CPU
/= Multiprocessors
.Not_A_Specific_CPU
899 (T
.Common
.Base_CPU
not in T
.Common
.Domain
'Range
900 or else not T
.Common
.Domain
(T
.Common
.Base_CPU
))
906 Adjusted_Stack_Size
:= C
.size_t
(Stack_Size
+ Alternate_Stack_Size
);
908 Result
:= pthread_attr_init
(Thread_Attr
'Access);
909 pragma Assert
(Result
in 0 | ENOMEM
);
917 pthread_attr_setstacksize
(Thread_Attr
'Access, Adjusted_Stack_Size
);
918 pragma Assert
(Result
= 0);
921 pthread_attr_setdetachstate
922 (Thread_Attr
'Access, PTHREAD_CREATE_DETACHED
);
923 pragma Assert
(Result
= 0);
925 -- Set the required attributes for the creation of the thread
927 -- Note: Previously, we called pthread_setaffinity_np (after thread
928 -- creation but before thread activation) to set the affinity but it was
929 -- not behaving as expected. Setting the required attributes for the
930 -- creation of the thread works correctly and it is more appropriate.
932 -- Do nothing if required support not provided by the operating system
934 if pthread_attr_setaffinity_np
'Address = Null_Address
then
937 -- Support is available
939 elsif T
.Common
.Base_CPU
/= Multiprocessors
.Not_A_Specific_CPU
then
941 CPUs
: constant size_t
:=
942 C
.size_t
(Multiprocessors
.Number_Of_CPUs
);
943 CPU_Set
: constant cpu_set_t_ptr
:= CPU_ALLOC
(CPUs
);
944 Size
: constant size_t
:= CPU_ALLOC_SIZE
(CPUs
);
947 CPU_ZERO
(Size
, CPU_Set
);
948 System
.OS_Interface
.CPU_SET
949 (int
(T
.Common
.Base_CPU
), Size
, CPU_Set
);
951 pthread_attr_setaffinity_np
(Thread_Attr
'Access, Size
, CPU_Set
);
952 pragma Assert
(Result
= 0);
959 elsif T
.Common
.Task_Info
/= null then
961 pthread_attr_setaffinity_np
964 T
.Common
.Task_Info
.CPU_Affinity
'Access);
965 pragma Assert
(Result
= 0);
967 -- Handle dispatching domains
971 CPUs
: constant size_t
:=
972 C
.size_t
(Multiprocessors
.Number_Of_CPUs
);
973 CPU_Set
: constant cpu_set_t_ptr
:= CPU_ALLOC
(CPUs
);
974 Size
: constant size_t
:= CPU_ALLOC_SIZE
(CPUs
);
977 CPU_ZERO
(Size
, CPU_Set
);
979 -- Set the affinity to all the processors belonging to the
980 -- dispatching domain.
982 for Proc
in T
.Common
.Domain
'Range loop
983 if T
.Common
.Domain
(Proc
) then
984 System
.OS_Interface
.CPU_SET
(int
(Proc
), Size
, CPU_Set
);
989 pthread_attr_setaffinity_np
(Thread_Attr
'Access, Size
, CPU_Set
);
990 pragma Assert
(Result
= 0);
996 -- Since the initial signal mask of a thread is inherited from the
997 -- creator, and the Environment task has all its signals masked, we
998 -- do not need to manipulate caller's signal mask at this point.
999 -- All tasks in RTS will have All_Tasks_Mask initially.
1001 -- Note: the use of Unrestricted_Access in the following call is needed
1002 -- because otherwise we have an error of getting a access-to-volatile
1003 -- value which points to a non-volatile object. But in this case it is
1004 -- safe to do this, since we know we have no problems with aliasing and
1005 -- Unrestricted_Access bypasses this check.
1007 Result
:= pthread_create
1008 (T
.Common
.LL
.Thread
'Unrestricted_Access,
1010 Thread_Body_Access
(Wrapper
),
1013 pragma Assert
(Result
in 0 | EAGAIN | ENOMEM
);
1017 Result
:= pthread_attr_destroy
(Thread_Attr
'Access);
1018 pragma Assert
(Result
= 0);
1024 Result
:= pthread_attr_destroy
(Thread_Attr
'Access);
1025 pragma Assert
(Result
= 0);
1027 Set_Priority
(T
, Priority
);
1034 procedure Finalize_TCB
(T
: Task_Id
) is
1038 Result
:= pthread_mutex_destroy
(T
.Common
.LL
.L
'Access);
1039 pragma Assert
(Result
= 0);
1041 Result
:= pthread_cond_destroy
(T
.Common
.LL
.CV
'Access);
1042 pragma Assert
(Result
= 0);
1044 if T
.Known_Tasks_Index
/= -1 then
1045 Known_Tasks
(T
.Known_Tasks_Index
) := null;
1048 ATCB_Allocation
.Free_ATCB
(T
);
1055 procedure Exit_Task
is
1057 Specific
.Set
(null);
1064 procedure Abort_Task
(T
: Task_Id
) is
1067 ESRCH
: constant := 3; -- No such process
1068 -- It can happen that T has already vanished, in which case pthread_kill
1069 -- returns ESRCH, so we don't consider that to be an error.
1072 if Abort_Handler_Installed
then
1075 (T
.Common
.LL
.Thread
,
1076 Signal
(System
.Interrupt_Management
.Abort_Task_Interrupt
));
1077 pragma Assert
(Result
in 0 | ESRCH
);
1085 procedure Initialize
(S
: in out Suspension_Object
) is
1089 -- Initialize internal state (always to False (RM D.10(6)))
1094 -- Initialize internal mutex
1096 Result
:= pthread_mutex_init
(S
.L
'Access, null);
1098 pragma Assert
(Result
in 0 | ENOMEM
);
1100 if Result
= ENOMEM
then
1101 raise Storage_Error
;
1104 -- Initialize internal condition variable
1106 Result
:= pthread_cond_init
(S
.CV
'Access, null);
1108 pragma Assert
(Result
in 0 | ENOMEM
);
1111 Result
:= pthread_mutex_destroy
(S
.L
'Access);
1112 pragma Assert
(Result
= 0);
1114 if Result
= ENOMEM
then
1115 raise Storage_Error
;
1124 procedure Finalize
(S
: in out Suspension_Object
) is
1128 -- Destroy internal mutex
1130 Result
:= pthread_mutex_destroy
(S
.L
'Access);
1131 pragma Assert
(Result
= 0);
1133 -- Destroy internal condition variable
1135 Result
:= pthread_cond_destroy
(S
.CV
'Access);
1136 pragma Assert
(Result
= 0);
1143 function Current_State
(S
: Suspension_Object
) return Boolean is
1145 -- We do not want to use lock on this read operation. State is marked
1146 -- as Atomic so that we ensure that the value retrieved is correct.
1155 procedure Set_False
(S
: in out Suspension_Object
) is
1159 SSL
.Abort_Defer
.all;
1161 Result
:= pthread_mutex_lock
(S
.L
'Access);
1162 pragma Assert
(Result
= 0);
1166 Result
:= pthread_mutex_unlock
(S
.L
'Access);
1167 pragma Assert
(Result
= 0);
1169 SSL
.Abort_Undefer
.all;
1176 procedure Set_True
(S
: in out Suspension_Object
) is
1180 SSL
.Abort_Defer
.all;
1182 Result
:= pthread_mutex_lock
(S
.L
'Access);
1183 pragma Assert
(Result
= 0);
1185 -- If there is already a task waiting on this suspension object then
1186 -- we resume it, leaving the state of the suspension object to False,
1187 -- as it is specified in ARM D.10 par. 9. Otherwise, it just leaves
1188 -- the state to True.
1194 Result
:= pthread_cond_signal
(S
.CV
'Access);
1195 pragma Assert
(Result
= 0);
1201 Result
:= pthread_mutex_unlock
(S
.L
'Access);
1202 pragma Assert
(Result
= 0);
1204 SSL
.Abort_Undefer
.all;
1207 ------------------------
1208 -- Suspend_Until_True --
1209 ------------------------
1211 procedure Suspend_Until_True
(S
: in out Suspension_Object
) is
1215 SSL
.Abort_Defer
.all;
1217 Result
:= pthread_mutex_lock
(S
.L
'Access);
1218 pragma Assert
(Result
= 0);
1222 -- Program_Error must be raised upon calling Suspend_Until_True
1223 -- if another task is already waiting on that suspension object
1226 Result
:= pthread_mutex_unlock
(S
.L
'Access);
1227 pragma Assert
(Result
= 0);
1229 SSL
.Abort_Undefer
.all;
1231 raise Program_Error
;
1234 -- Suspend the task if the state is False. Otherwise, the task
1235 -- continues its execution, and the state of the suspension object
1236 -- is set to False (ARM D.10 par. 9).
1244 -- Loop in case pthread_cond_wait returns earlier than expected
1245 -- (e.g. in case of EINTR caused by a signal). This should not
1246 -- happen with the current Linux implementation of pthread, but
1247 -- POSIX does not guarantee it so this may change in future.
1249 Result
:= pthread_cond_wait
(S
.CV
'Access, S
.L
'Access);
1250 pragma Assert
(Result
in 0 | EINTR
);
1252 exit when not S
.Waiting
;
1256 Result
:= pthread_mutex_unlock
(S
.L
'Access);
1257 pragma Assert
(Result
= 0);
1259 SSL
.Abort_Undefer
.all;
1261 end Suspend_Until_True
;
1269 function Check_Exit
(Self_ID
: ST
.Task_Id
) return Boolean is
1270 pragma Unreferenced
(Self_ID
);
1275 --------------------
1276 -- Check_No_Locks --
1277 --------------------
1279 function Check_No_Locks
(Self_ID
: ST
.Task_Id
) return Boolean is
1280 pragma Unreferenced
(Self_ID
);
1285 ----------------------
1286 -- Environment_Task --
1287 ----------------------
1289 function Environment_Task
return Task_Id
is
1291 return Environment_Task_Id
;
1292 end Environment_Task
;
1298 function Suspend_Task
1300 Thread_Self
: Thread_Id
) return Boolean
1303 if T
.Common
.LL
.Thread
/= Thread_Self
then
1304 return pthread_kill
(T
.Common
.LL
.Thread
, SIGSTOP
) = 0;
1314 function Resume_Task
1316 Thread_Self
: Thread_Id
) return Boolean
1319 if T
.Common
.LL
.Thread
/= Thread_Self
then
1320 return pthread_kill
(T
.Common
.LL
.Thread
, SIGCONT
) = 0;
1326 --------------------
1327 -- Stop_All_Tasks --
1328 --------------------
1330 procedure Stop_All_Tasks
is
1339 function Stop_Task
(T
: ST
.Task_Id
) return Boolean is
1340 pragma Unreferenced
(T
);
1349 function Continue_Task
(T
: ST
.Task_Id
) return Boolean is
1350 pragma Unreferenced
(T
);
1359 procedure Initialize
(Environment_Task
: Task_Id
) is
1360 act
: aliased struct_sigaction
;
1361 old_act
: aliased struct_sigaction
;
1362 Tmp_Set
: aliased sigset_t
;
1364 -- Whether to use an alternate signal stack for stack overflows
1367 (Int
: System
.Interrupt_Management
.Interrupt_ID
) return Character;
1368 pragma Import
(C
, State
, "__gnat_get_interrupt_state");
1369 -- Get interrupt state. Defined in init.c.
1370 -- The input argument is the interrupt number, and the result is one of
1373 Default
: constant Character := 's';
1374 -- 'n' this interrupt not set by any Interrupt_State pragma
1375 -- 'u' Interrupt_State pragma set state to User
1376 -- 'r' Interrupt_State pragma set state to Runtime
1377 -- 's' Interrupt_State pragma set state to System (use "default"
1381 Environment_Task_Id
:= Environment_Task
;
1383 Interrupt_Management
.Initialize
;
1385 -- Prepare the set of signals that should be unblocked in all tasks
1387 Result
:= sigemptyset
(Unblocked_Signal_Mask
'Access);
1388 pragma Assert
(Result
= 0);
1390 for J
in Interrupt_Management
.Interrupt_ID
loop
1391 if System
.Interrupt_Management
.Keep_Unmasked
(J
) then
1392 Result
:= sigaddset
(Unblocked_Signal_Mask
'Access, Signal
(J
));
1393 pragma Assert
(Result
= 0);
1397 Initialize_Lock
(Single_RTS_Lock
'Access, RTS_Lock_Level
);
1399 -- Initialize the global RTS lock
1401 Specific
.Initialize
(Environment_Task
);
1403 -- Do not use an alternate stack if no handler for SEGV is installed
1405 if State
(SIGSEGV
) = Default
then
1406 Use_Alternate_Stack
:= False;
1409 if Use_Alternate_Stack
then
1410 Environment_Task
.Common
.Task_Alternate_Stack
:=
1411 Alternate_Stack
'Address;
1414 -- Make environment task known here because it doesn't go through
1415 -- Activate_Tasks, which does it for all other tasks.
1417 Known_Tasks
(Known_Tasks
'First) := Environment_Task
;
1418 Environment_Task
.Known_Tasks_Index
:= Known_Tasks
'First;
1420 Enter_Task
(Environment_Task
);
1423 (System
.Interrupt_Management
.Abort_Task_Interrupt
) /= Default
1426 act
.sa_handler
:= Abort_Handler
'Address;
1428 Result
:= sigemptyset
(Tmp_Set
'Access);
1429 pragma Assert
(Result
= 0);
1430 act
.sa_mask
:= Tmp_Set
;
1434 (Signal
(Interrupt_Management
.Abort_Task_Interrupt
),
1435 act
'Unchecked_Access,
1436 old_act
'Unchecked_Access);
1437 pragma Assert
(Result
= 0);
1438 Abort_Handler_Installed
:= True;
1441 -- pragma CPU and dispatching domains for the environment task
1443 Set_Task_Affinity
(Environment_Task
);
1446 -----------------------
1447 -- Set_Task_Affinity --
1448 -----------------------
1450 procedure Set_Task_Affinity
(T
: ST
.Task_Id
) is
1451 use type Multiprocessors
.CPU_Range
;
1454 -- Do nothing if there is no support for setting affinities or the
1455 -- underlying thread has not yet been created. If the thread has not
1456 -- yet been created then the proper affinity will be set during its
1459 if pthread_setaffinity_np
'Address /= Null_Address
1460 and then T
.Common
.LL
.Thread
/= Null_Thread_Id
1463 CPUs
: constant size_t
:=
1464 C
.size_t
(Multiprocessors
.Number_Of_CPUs
);
1465 CPU_Set
: cpu_set_t_ptr
:= null;
1466 Size
: constant size_t
:= CPU_ALLOC_SIZE
(CPUs
);
1471 -- We look at the specific CPU (Base_CPU) first, then at the
1472 -- Task_Info field, and finally at the assigned dispatching
1475 if T
.Common
.Base_CPU
/= Multiprocessors
.Not_A_Specific_CPU
then
1477 -- Set the affinity to an unique CPU
1479 CPU_Set
:= CPU_ALLOC
(CPUs
);
1480 System
.OS_Interface
.CPU_ZERO
(Size
, CPU_Set
);
1481 System
.OS_Interface
.CPU_SET
1482 (int
(T
.Common
.Base_CPU
), Size
, CPU_Set
);
1486 elsif T
.Common
.Task_Info
/= null then
1487 CPU_Set
:= T
.Common
.Task_Info
.CPU_Affinity
'Access;
1489 -- Handle dispatching domains
1492 -- Set the affinity to all the processors belonging to the
1493 -- dispatching domain.
1495 CPU_Set
:= CPU_ALLOC
(CPUs
);
1496 System
.OS_Interface
.CPU_ZERO
(Size
, CPU_Set
);
1498 for Proc
in T
.Common
.Domain
'Range loop
1499 if T
.Common
.Domain
(Proc
) then
1500 System
.OS_Interface
.CPU_SET
(int
(Proc
), Size
, CPU_Set
);
1506 pthread_setaffinity_np
(T
.Common
.LL
.Thread
, Size
, CPU_Set
);
1507 pragma Assert
(Result
= 0);
1512 end Set_Task_Affinity
;
1514 end System
.Task_Primitives
.Operations
;