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-2014, 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
38 -- Turn off polling, we do not want ATC polling to take place during tasking
39 -- operations. It causes infinite loops and other problems.
42 with Interfaces
.C
.Extensions
;
44 with System
.Task_Info
;
45 with System
.Tasking
.Debug
;
46 with System
.Interrupt_Management
;
47 with System
.OS_Primitives
;
48 with System
.Stack_Checking
.Operations
;
49 with System
.Multiprocessors
;
51 with System
.Soft_Links
;
52 -- We use System.Soft_Links instead of System.Tasking.Initialization
53 -- because the later is a higher level package that we shouldn't depend on.
54 -- For example when using the restricted run time, it is replaced by
55 -- System.Tasking.Restricted.Stages.
57 package body System
.Task_Primitives
.Operations
is
59 package SSL
renames System
.Soft_Links
;
60 package SC
renames System
.Stack_Checking
.Operations
;
62 use System
.Tasking
.Debug
;
65 use Interfaces
.C
.Extensions
;
66 use System
.OS_Interface
;
67 use System
.Parameters
;
68 use System
.OS_Primitives
;
75 -- The followings are logically constants, but need to be initialized
78 Single_RTS_Lock
: aliased RTS_Lock
;
79 -- This is a lock to allow only one thread of control in the RTS at
80 -- a time; it is used to execute in mutual exclusion from all other tasks.
81 -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
83 Environment_Task_Id
: Task_Id
;
84 -- A variable to hold Task_Id for the environment task
86 Unblocked_Signal_Mask
: aliased sigset_t
;
87 -- The set of signals that should be unblocked in all tasks
89 -- The followings are internal configuration constants needed
91 Next_Serial_Number
: Task_Serial_Number
:= 100;
92 -- We start at 100 (reserve some special values for using in error checks)
94 Time_Slice_Val
: Integer;
95 pragma Import
(C
, Time_Slice_Val
, "__gl_time_slice_val");
97 Dispatching_Policy
: Character;
98 pragma Import
(C
, Dispatching_Policy
, "__gl_task_dispatching_policy");
100 Locking_Policy
: Character;
101 pragma Import
(C
, Locking_Policy
, "__gl_locking_policy");
103 Foreign_Task_Elaborated
: aliased Boolean := True;
104 -- Used to identified fake tasks (i.e., non-Ada Threads)
106 Use_Alternate_Stack
: constant Boolean := Alternate_Stack_Size
/= 0;
107 -- Whether to use an alternate signal stack for stack overflows
109 Abort_Handler_Installed
: Boolean := False;
110 -- True if a handler for the abort signal is installed
112 Null_Thread_Id
: constant pthread_t
:= pthread_t
'Last;
113 -- Constant to indicate that the thread identifier has not yet been
122 procedure Initialize
(Environment_Task
: Task_Id
);
123 pragma Inline
(Initialize
);
124 -- Initialize various data needed by this package
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
134 function Self
return Task_Id
;
135 pragma Inline
(Self
);
136 -- Return a pointer to the Ada Task Control Block of the calling task
140 package body Specific
is separate;
141 -- The body of this package is target specific
143 ----------------------------------
144 -- ATCB allocation/deallocation --
145 ----------------------------------
147 package body ATCB_Allocation
is separate;
148 -- The body of this package is shared across several targets
150 ---------------------------------
151 -- Support for foreign threads --
152 ---------------------------------
154 function Register_Foreign_Thread
(Thread
: Thread_Id
) return Task_Id
;
155 -- Allocate and Initialize a new ATCB for the current Thread
157 function Register_Foreign_Thread
158 (Thread
: Thread_Id
) return Task_Id
is separate;
160 -----------------------
161 -- Local Subprograms --
162 -----------------------
164 procedure Abort_Handler
(signo
: Signal
);
170 procedure Abort_Handler
(signo
: Signal
) is
171 pragma Unreferenced
(signo
);
173 Self_Id
: constant Task_Id
:= Self
;
174 Result
: Interfaces
.C
.int
;
175 Old_Set
: aliased sigset_t
;
178 -- It's not safe to raise an exception when using GCC ZCX mechanism.
179 -- Note that we still need to install a signal handler, since in some
180 -- cases (e.g. shutdown of the Server_Task in System.Interrupts) we
181 -- need to send the Abort signal to a task.
183 if ZCX_By_Default
then
187 if Self_Id
.Deferral_Level
= 0
188 and then Self_Id
.Pending_ATC_Level
< Self_Id
.ATC_Nesting_Level
189 and then not Self_Id
.Aborting
191 Self_Id
.Aborting
:= True;
193 -- Make sure signals used for RTS internal purpose are unmasked
198 Unblocked_Signal_Mask
'Access,
200 pragma Assert
(Result
= 0);
202 raise Standard
'Abort_Signal;
210 procedure Lock_RTS
is
212 Write_Lock
(Single_RTS_Lock
'Access, Global_Lock
=> True);
219 procedure Unlock_RTS
is
221 Unlock
(Single_RTS_Lock
'Access, Global_Lock
=> True);
228 -- The underlying thread system extends the memory (up to 2MB) when needed
230 procedure Stack_Guard
(T
: ST
.Task_Id
; On
: Boolean) is
231 pragma Unreferenced
(T
);
232 pragma Unreferenced
(On
);
241 function Get_Thread_Id
(T
: ST
.Task_Id
) return OSI
.Thread_Id
is
243 return T
.Common
.LL
.Thread
;
250 function Self
return Task_Id
renames Specific
.Self
;
252 ---------------------
253 -- Initialize_Lock --
254 ---------------------
256 -- Note: mutexes and cond_variables needed per-task basis are initialized
257 -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such
258 -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any
259 -- status change of RTS. Therefore raising Storage_Error in the following
260 -- routines should be able to be handled safely.
262 procedure Initialize_Lock
263 (Prio
: System
.Any_Priority
;
264 L
: not null access Lock
)
266 pragma Unreferenced
(Prio
);
269 if Locking_Policy
= 'R' then
271 RWlock_Attr
: aliased pthread_rwlockattr_t
;
272 Result
: Interfaces
.C
.int
;
275 -- Set the rwlock to prefer writer to avoid writers starvation
277 Result
:= pthread_rwlockattr_init
(RWlock_Attr
'Access);
278 pragma Assert
(Result
= 0);
280 Result
:= pthread_rwlockattr_setkind_np
282 PTHREAD_RWLOCK_PREFER_WRITER_NONRECURSIVE_NP
);
283 pragma Assert
(Result
= 0);
285 Result
:= pthread_rwlock_init
(L
.RW
'Access, RWlock_Attr
'Access);
287 pragma Assert
(Result
= 0 or else Result
= ENOMEM
);
289 if Result
= ENOMEM
then
290 raise Storage_Error
with "Failed to allocate a lock";
296 Result
: Interfaces
.C
.int
;
299 Result
:= pthread_mutex_init
(L
.WO
'Access, null);
301 pragma Assert
(Result
= 0 or else Result
= ENOMEM
);
303 if Result
= ENOMEM
then
304 raise Storage_Error
with "Failed to allocate a lock";
310 procedure Initialize_Lock
311 (L
: not null access RTS_Lock
;
314 pragma Unreferenced
(Level
);
316 Result
: Interfaces
.C
.int
;
319 Result
:= pthread_mutex_init
(L
, null);
321 pragma Assert
(Result
= 0 or else Result
= ENOMEM
);
323 if Result
= ENOMEM
then
332 procedure Finalize_Lock
(L
: not null access Lock
) is
333 Result
: Interfaces
.C
.int
;
335 if Locking_Policy
= 'R' then
336 Result
:= pthread_rwlock_destroy
(L
.RW
'Access);
338 Result
:= pthread_mutex_destroy
(L
.WO
'Access);
340 pragma Assert
(Result
= 0);
343 procedure Finalize_Lock
(L
: not null access RTS_Lock
) is
344 Result
: Interfaces
.C
.int
;
346 Result
:= pthread_mutex_destroy
(L
);
347 pragma Assert
(Result
= 0);
355 (L
: not null access Lock
;
356 Ceiling_Violation
: out Boolean)
358 Result
: Interfaces
.C
.int
;
360 if Locking_Policy
= 'R' then
361 Result
:= pthread_rwlock_wrlock
(L
.RW
'Access);
363 Result
:= pthread_mutex_lock
(L
.WO
'Access);
366 Ceiling_Violation
:= Result
= EINVAL
;
368 -- Assume the cause of EINVAL is a priority ceiling violation
370 pragma Assert
(Result
= 0 or else Result
= EINVAL
);
374 (L
: not null access RTS_Lock
;
375 Global_Lock
: Boolean := False)
377 Result
: Interfaces
.C
.int
;
379 if not Single_Lock
or else Global_Lock
then
380 Result
:= pthread_mutex_lock
(L
);
381 pragma Assert
(Result
= 0);
385 procedure Write_Lock
(T
: Task_Id
) is
386 Result
: Interfaces
.C
.int
;
388 if not Single_Lock
then
389 Result
:= pthread_mutex_lock
(T
.Common
.LL
.L
'Access);
390 pragma Assert
(Result
= 0);
399 (L
: not null access Lock
;
400 Ceiling_Violation
: out Boolean)
402 Result
: Interfaces
.C
.int
;
404 if Locking_Policy
= 'R' then
405 Result
:= pthread_rwlock_rdlock
(L
.RW
'Access);
407 Result
:= pthread_mutex_lock
(L
.WO
'Access);
410 Ceiling_Violation
:= Result
= EINVAL
;
412 -- Assume the cause of EINVAL is a priority ceiling violation
414 pragma Assert
(Result
= 0 or else Result
= EINVAL
);
421 procedure Unlock
(L
: not null access Lock
) is
422 Result
: Interfaces
.C
.int
;
424 if Locking_Policy
= 'R' then
425 Result
:= pthread_rwlock_unlock
(L
.RW
'Access);
427 Result
:= pthread_mutex_unlock
(L
.WO
'Access);
429 pragma Assert
(Result
= 0);
433 (L
: not null access RTS_Lock
;
434 Global_Lock
: Boolean := False)
436 Result
: Interfaces
.C
.int
;
438 if not Single_Lock
or else Global_Lock
then
439 Result
:= pthread_mutex_unlock
(L
);
440 pragma Assert
(Result
= 0);
444 procedure Unlock
(T
: Task_Id
) is
445 Result
: Interfaces
.C
.int
;
447 if not Single_Lock
then
448 Result
:= pthread_mutex_unlock
(T
.Common
.LL
.L
'Access);
449 pragma Assert
(Result
= 0);
457 -- Dynamic priority ceilings are not supported by the underlying system
459 procedure Set_Ceiling
460 (L
: not null access Lock
;
461 Prio
: System
.Any_Priority
)
463 pragma Unreferenced
(L
, Prio
);
474 Reason
: System
.Tasking
.Task_States
)
476 pragma Unreferenced
(Reason
);
478 Result
: Interfaces
.C
.int
;
481 pragma Assert
(Self_ID
= Self
);
485 (cond
=> Self_ID
.Common
.LL
.CV
'Access,
486 mutex
=> (if Single_Lock
487 then Single_RTS_Lock
'Access
488 else Self_ID
.Common
.LL
.L
'Access));
490 -- EINTR is not considered a failure
492 pragma Assert
(Result
= 0 or else Result
= EINTR
);
499 -- This is for use within the run-time system, so abort is
500 -- assumed to be already deferred, and the caller should be
501 -- holding its own ATCB lock.
503 procedure Timed_Sleep
506 Mode
: ST
.Delay_Modes
;
507 Reason
: System
.Tasking
.Task_States
;
508 Timedout
: out Boolean;
509 Yielded
: out Boolean)
511 pragma Unreferenced
(Reason
);
513 Base_Time
: constant Duration := Monotonic_Clock
;
514 Check_Time
: Duration := Base_Time
;
516 Request
: aliased timespec
;
517 Result
: Interfaces
.C
.int
;
525 then Duration'Min (Time
, Max_Sensible_Delay
) + Check_Time
526 else Duration'Min (Check_Time
+ Max_Sensible_Delay
, Time
));
528 if Abs_Time
> Check_Time
then
529 Request
:= To_Timespec
(Abs_Time
);
532 exit when Self_ID
.Pending_ATC_Level
< Self_ID
.ATC_Nesting_Level
;
535 pthread_cond_timedwait
536 (cond
=> Self_ID
.Common
.LL
.CV
'Access,
537 mutex
=> (if Single_Lock
538 then Single_RTS_Lock
'Access
539 else Self_ID
.Common
.LL
.L
'Access),
540 abstime
=> Request
'Access);
542 Check_Time
:= Monotonic_Clock
;
543 exit when Abs_Time
<= Check_Time
or else Check_Time
< Base_Time
;
545 if Result
= 0 or else Result
= EINTR
then
547 -- Somebody may have called Wakeup for us
553 pragma Assert
(Result
= ETIMEDOUT
);
562 -- This is for use in implementing delay statements, so we assume the
563 -- caller is abort-deferred but is holding no locks.
565 procedure Timed_Delay
568 Mode
: ST
.Delay_Modes
)
570 Base_Time
: constant Duration := Monotonic_Clock
;
571 Check_Time
: Duration := Base_Time
;
573 Request
: aliased timespec
;
575 Result
: Interfaces
.C
.int
;
576 pragma Warnings
(Off
, Result
);
583 Write_Lock
(Self_ID
);
587 then Time
+ Check_Time
588 else Duration'Min (Check_Time
+ Max_Sensible_Delay
, Time
));
590 if Abs_Time
> Check_Time
then
591 Request
:= To_Timespec
(Abs_Time
);
592 Self_ID
.Common
.State
:= Delay_Sleep
;
595 exit when Self_ID
.Pending_ATC_Level
< Self_ID
.ATC_Nesting_Level
;
598 pthread_cond_timedwait
599 (cond
=> Self_ID
.Common
.LL
.CV
'Access,
600 mutex
=> (if Single_Lock
601 then Single_RTS_Lock
'Access
602 else Self_ID
.Common
.LL
.L
'Access),
603 abstime
=> Request
'Access);
605 Check_Time
:= Monotonic_Clock
;
606 exit when Abs_Time
<= Check_Time
or else Check_Time
< Base_Time
;
608 pragma Assert
(Result
= 0 or else
609 Result
= ETIMEDOUT
or else
613 Self_ID
.Common
.State
:= Runnable
;
622 Result
:= sched_yield
;
625 ---------------------
626 -- Monotonic_Clock --
627 ---------------------
629 function Monotonic_Clock
return Duration is
632 procedure timeval_to_duration
633 (T
: not null access timeval
;
634 sec
: not null access C
.Extensions
.long_long
;
635 usec
: not null access C
.long
);
636 pragma Import
(C
, timeval_to_duration
, "__gnat_timeval_to_duration");
638 Micro
: constant := 10**6;
639 sec
: aliased C
.Extensions
.long_long
;
640 usec
: aliased C
.long
;
641 TV
: aliased timeval
;
644 function gettimeofday
645 (Tv
: access timeval
;
646 Tz
: System
.Address
:= System
.Null_Address
) return int
;
647 pragma Import
(C
, gettimeofday
, "gettimeofday");
650 Result
:= gettimeofday
(TV
'Access, System
.Null_Address
);
651 pragma Assert
(Result
= 0);
652 timeval_to_duration
(TV
'Access, sec
'Access, usec
'Access);
653 return Duration (sec
) + Duration (usec
) / Micro
;
660 function RT_Resolution
return Duration is
669 procedure Wakeup
(T
: Task_Id
; Reason
: System
.Tasking
.Task_States
) is
670 pragma Unreferenced
(Reason
);
671 Result
: Interfaces
.C
.int
;
673 Result
:= pthread_cond_signal
(T
.Common
.LL
.CV
'Access);
674 pragma Assert
(Result
= 0);
681 procedure Yield
(Do_Yield
: Boolean := True) is
682 Result
: Interfaces
.C
.int
;
683 pragma Unreferenced
(Result
);
686 Result
:= sched_yield
;
694 procedure Set_Priority
696 Prio
: System
.Any_Priority
;
697 Loss_Of_Inheritance
: Boolean := False)
699 pragma Unreferenced
(Loss_Of_Inheritance
);
701 Result
: Interfaces
.C
.int
;
702 Param
: aliased struct_sched_param
;
704 function Get_Policy
(Prio
: System
.Any_Priority
) return Character;
705 pragma Import
(C
, Get_Policy
, "__gnat_get_specific_dispatching");
706 -- Get priority specific dispatching policy
708 Priority_Specific_Policy
: constant Character := Get_Policy
(Prio
);
709 -- Upper case first character of the policy name corresponding to the
710 -- task as set by a Priority_Specific_Dispatching pragma.
713 T
.Common
.Current_Priority
:= Prio
;
715 -- Priorities are 1 .. 99 on GNU/Linux, so we map 0 .. 98 to 1 .. 99
717 Param
.sched_priority
:= Interfaces
.C
.int
(Prio
) + 1;
719 if Dispatching_Policy
= 'R'
720 or else Priority_Specific_Policy
= 'R'
721 or else Time_Slice_Val
> 0
724 pthread_setschedparam
725 (T
.Common
.LL
.Thread
, SCHED_RR
, Param
'Access);
727 elsif Dispatching_Policy
= 'F'
728 or else Priority_Specific_Policy
= 'F'
729 or else Time_Slice_Val
= 0
732 pthread_setschedparam
733 (T
.Common
.LL
.Thread
, SCHED_FIFO
, Param
'Access);
736 Param
.sched_priority
:= 0;
738 pthread_setschedparam
740 SCHED_OTHER
, Param
'Access);
743 pragma Assert
(Result
= 0 or else Result
= EPERM
);
750 function Get_Priority
(T
: Task_Id
) return System
.Any_Priority
is
752 return T
.Common
.Current_Priority
;
759 procedure Enter_Task
(Self_ID
: Task_Id
) is
761 if Self_ID
.Common
.Task_Info
/= null
762 and then Self_ID
.Common
.Task_Info
.CPU_Affinity
= No_CPU
764 raise Invalid_CPU_Number
;
767 Self_ID
.Common
.LL
.Thread
:= pthread_self
;
768 Self_ID
.Common
.LL
.LWP
:= lwp_self
;
770 if Self_ID
.Common
.Task_Image_Len
> 0 then
772 Task_Name
: String (1 .. Parameters
.Max_Task_Image_Length
+ 1);
776 -- Set thread name to ease debugging
778 Task_Name
(1 .. Self_ID
.Common
.Task_Image_Len
) :=
779 Self_ID
.Common
.Task_Image
(1 .. Self_ID
.Common
.Task_Image_Len
);
780 Task_Name
(Self_ID
.Common
.Task_Image_Len
+ 1) := ASCII
.NUL
;
782 Result
:= prctl
(PR_SET_NAME
, unsigned_long
(Task_Name
'Address));
783 pragma Assert
(Result
= 0);
787 Specific
.Set
(Self_ID
);
789 if Use_Alternate_Stack
790 and then Self_ID
.Common
.Task_Alternate_Stack
/= Null_Address
793 Stack
: aliased stack_t
;
794 Result
: Interfaces
.C
.int
;
796 Stack
.ss_sp
:= Self_ID
.Common
.Task_Alternate_Stack
;
797 Stack
.ss_size
:= Alternate_Stack_Size
;
799 Result
:= sigaltstack
(Stack
'Access, null);
800 pragma Assert
(Result
= 0);
809 function Is_Valid_Task
return Boolean renames Specific
.Is_Valid_Task
;
811 -----------------------------
812 -- Register_Foreign_Thread --
813 -----------------------------
815 function Register_Foreign_Thread
return Task_Id
is
817 if Is_Valid_Task
then
820 return Register_Foreign_Thread
(pthread_self
);
822 end Register_Foreign_Thread
;
828 procedure Initialize_TCB
(Self_ID
: Task_Id
; Succeeded
: out Boolean) is
829 Cond_Attr
: aliased pthread_condattr_t
;
830 Result
: Interfaces
.C
.int
;
833 -- Give the task a unique serial number
835 Self_ID
.Serial_Number
:= Next_Serial_Number
;
836 Next_Serial_Number
:= Next_Serial_Number
+ 1;
837 pragma Assert
(Next_Serial_Number
/= 0);
839 Self_ID
.Common
.LL
.Thread
:= Null_Thread_Id
;
841 if not Single_Lock
then
843 pthread_mutex_init
(Self_ID
.Common
.LL
.L
'Access, null);
844 pragma Assert
(Result
= 0 or else Result
= ENOMEM
);
852 Result
:= pthread_condattr_init
(Cond_Attr
'Access);
853 pragma Assert
(Result
= 0);
856 pthread_cond_init
(Self_ID
.Common
.LL
.CV
'Access, Cond_Attr
'Access);
857 pragma Assert
(Result
= 0 or else Result
= ENOMEM
);
862 if not Single_Lock
then
863 Result
:= pthread_mutex_destroy
(Self_ID
.Common
.LL
.L
'Access);
864 pragma Assert
(Result
= 0);
875 procedure Create_Task
877 Wrapper
: System
.Address
;
878 Stack_Size
: System
.Parameters
.Size_Type
;
879 Priority
: System
.Any_Priority
;
880 Succeeded
: out Boolean)
882 Attributes
: aliased pthread_attr_t
;
883 Adjusted_Stack_Size
: Interfaces
.C
.size_t
;
884 Result
: Interfaces
.C
.int
;
886 use type System
.Multiprocessors
.CPU_Range
;
889 -- Check whether both Dispatching_Domain and CPU are specified for
890 -- the task, and the CPU value is not contained within the range of
891 -- processors for the domain.
893 if T
.Common
.Domain
/= null
894 and then T
.Common
.Base_CPU
/= System
.Multiprocessors
.Not_A_Specific_CPU
896 (T
.Common
.Base_CPU
not in T
.Common
.Domain
'Range
897 or else not T
.Common
.Domain
(T
.Common
.Base_CPU
))
903 Adjusted_Stack_Size
:=
904 Interfaces
.C
.size_t
(Stack_Size
+ Alternate_Stack_Size
);
906 Result
:= pthread_attr_init
(Attributes
'Access);
907 pragma Assert
(Result
= 0 or else Result
= ENOMEM
);
915 pthread_attr_setstacksize
(Attributes
'Access, Adjusted_Stack_Size
);
916 pragma Assert
(Result
= 0);
919 pthread_attr_setdetachstate
920 (Attributes
'Access, PTHREAD_CREATE_DETACHED
);
921 pragma Assert
(Result
= 0);
923 -- Set the required attributes for the creation of the thread
925 -- Note: Previously, we called pthread_setaffinity_np (after thread
926 -- creation but before thread activation) to set the affinity but it was
927 -- not behaving as expected. Setting the required attributes for the
928 -- creation of the thread works correctly and it is more appropriate.
930 -- Do nothing if required support not provided by the operating system
932 if pthread_attr_setaffinity_np
'Address = System
.Null_Address
then
935 -- Support is available
937 elsif T
.Common
.Base_CPU
/= System
.Multiprocessors
.Not_A_Specific_CPU
then
939 CPUs
: constant size_t
:=
941 (System
.Multiprocessors
.Number_Of_CPUs
);
942 CPU_Set
: constant cpu_set_t_ptr
:= CPU_ALLOC
(CPUs
);
943 Size
: constant size_t
:= CPU_ALLOC_SIZE
(CPUs
);
946 CPU_ZERO
(Size
, CPU_Set
);
947 System
.OS_Interface
.CPU_SET
948 (int
(T
.Common
.Base_CPU
), Size
, CPU_Set
);
950 pthread_attr_setaffinity_np
(Attributes
'Access, Size
, CPU_Set
);
951 pragma Assert
(Result
= 0);
958 elsif T
.Common
.Task_Info
/= null then
960 pthread_attr_setaffinity_np
963 T
.Common
.Task_Info
.CPU_Affinity
'Access);
964 pragma Assert
(Result
= 0);
966 -- Handle dispatching domains
968 -- To avoid changing CPU affinities when not needed, we set the
969 -- affinity only when assigning to a domain other than the default
970 -- one, or when the default one has been modified.
972 elsif T
.Common
.Domain
/= null and then
973 (T
.Common
.Domain
/= ST
.System_Domain
974 or else T
.Common
.Domain
.all /=
975 (Multiprocessors
.CPU
'First ..
976 Multiprocessors
.Number_Of_CPUs
=> True))
979 CPUs
: constant size_t
:=
981 (System
.Multiprocessors
.Number_Of_CPUs
);
982 CPU_Set
: constant cpu_set_t_ptr
:= CPU_ALLOC
(CPUs
);
983 Size
: constant size_t
:= CPU_ALLOC_SIZE
(CPUs
);
986 CPU_ZERO
(Size
, CPU_Set
);
988 -- Set the affinity to all the processors belonging to the
989 -- dispatching domain.
991 for Proc
in T
.Common
.Domain
'Range loop
992 if T
.Common
.Domain
(Proc
) then
993 System
.OS_Interface
.CPU_SET
(int
(Proc
), Size
, CPU_Set
);
998 pthread_attr_setaffinity_np
(Attributes
'Access, Size
, CPU_Set
);
999 pragma Assert
(Result
= 0);
1005 -- Since the initial signal mask of a thread is inherited from the
1006 -- creator, and the Environment task has all its signals masked, we
1007 -- do not need to manipulate caller's signal mask at this point.
1008 -- All tasks in RTS will have All_Tasks_Mask initially.
1010 -- Note: the use of Unrestricted_Access in the following call is needed
1011 -- because otherwise we have an error of getting a access-to-volatile
1012 -- value which points to a non-volatile object. But in this case it is
1013 -- safe to do this, since we know we have no problems with aliasing and
1014 -- Unrestricted_Access bypasses this check.
1018 (T
.Common
.LL
.Thread
'Unrestricted_Access,
1020 Thread_Body_Access
(Wrapper
),
1024 (Result
= 0 or else Result
= EAGAIN
or else Result
= ENOMEM
);
1028 Result
:= pthread_attr_destroy
(Attributes
'Access);
1029 pragma Assert
(Result
= 0);
1035 Result
:= pthread_attr_destroy
(Attributes
'Access);
1036 pragma Assert
(Result
= 0);
1038 Set_Priority
(T
, Priority
);
1045 procedure Finalize_TCB
(T
: Task_Id
) is
1046 Result
: Interfaces
.C
.int
;
1049 if not Single_Lock
then
1050 Result
:= pthread_mutex_destroy
(T
.Common
.LL
.L
'Access);
1051 pragma Assert
(Result
= 0);
1054 Result
:= pthread_cond_destroy
(T
.Common
.LL
.CV
'Access);
1055 pragma Assert
(Result
= 0);
1057 if T
.Known_Tasks_Index
/= -1 then
1058 Known_Tasks
(T
.Known_Tasks_Index
) := null;
1061 SC
.Invalidate_Stack_Cache
(T
.Common
.Compiler_Data
.Pri_Stack_Info
'Access);
1063 ATCB_Allocation
.Free_ATCB
(T
);
1070 procedure Exit_Task
is
1072 Specific
.Set
(null);
1079 procedure Abort_Task
(T
: Task_Id
) is
1080 Result
: Interfaces
.C
.int
;
1082 ESRCH
: constant := 3; -- No such process
1083 -- It can happen that T has already vanished, in which case pthread_kill
1084 -- returns ESRCH, so we don't consider that to be an error.
1087 if Abort_Handler_Installed
then
1090 (T
.Common
.LL
.Thread
,
1091 Signal
(System
.Interrupt_Management
.Abort_Task_Interrupt
));
1092 pragma Assert
(Result
= 0 or else Result
= ESRCH
);
1100 procedure Initialize
(S
: in out Suspension_Object
) is
1101 Result
: Interfaces
.C
.int
;
1104 -- Initialize internal state (always to False (RM D.10(6)))
1109 -- Initialize internal mutex
1111 Result
:= pthread_mutex_init
(S
.L
'Access, null);
1113 pragma Assert
(Result
= 0 or else Result
= ENOMEM
);
1115 if Result
= ENOMEM
then
1116 raise Storage_Error
;
1119 -- Initialize internal condition variable
1121 Result
:= pthread_cond_init
(S
.CV
'Access, null);
1123 pragma Assert
(Result
= 0 or else Result
= ENOMEM
);
1126 Result
:= pthread_mutex_destroy
(S
.L
'Access);
1127 pragma Assert
(Result
= 0);
1129 if Result
= ENOMEM
then
1130 raise Storage_Error
;
1139 procedure Finalize
(S
: in out Suspension_Object
) is
1140 Result
: Interfaces
.C
.int
;
1143 -- Destroy internal mutex
1145 Result
:= pthread_mutex_destroy
(S
.L
'Access);
1146 pragma Assert
(Result
= 0);
1148 -- Destroy internal condition variable
1150 Result
:= pthread_cond_destroy
(S
.CV
'Access);
1151 pragma Assert
(Result
= 0);
1158 function Current_State
(S
: Suspension_Object
) return Boolean is
1160 -- We do not want to use lock on this read operation. State is marked
1161 -- as Atomic so that we ensure that the value retrieved is correct.
1170 procedure Set_False
(S
: in out Suspension_Object
) is
1171 Result
: Interfaces
.C
.int
;
1174 SSL
.Abort_Defer
.all;
1176 Result
:= pthread_mutex_lock
(S
.L
'Access);
1177 pragma Assert
(Result
= 0);
1181 Result
:= pthread_mutex_unlock
(S
.L
'Access);
1182 pragma Assert
(Result
= 0);
1184 SSL
.Abort_Undefer
.all;
1191 procedure Set_True
(S
: in out Suspension_Object
) is
1192 Result
: Interfaces
.C
.int
;
1195 SSL
.Abort_Defer
.all;
1197 Result
:= pthread_mutex_lock
(S
.L
'Access);
1198 pragma Assert
(Result
= 0);
1200 -- If there is already a task waiting on this suspension object then
1201 -- we resume it, leaving the state of the suspension object to False,
1202 -- as it is specified in ARM D.10 par. 9. Otherwise, it just leaves
1203 -- the state to True.
1209 Result
:= pthread_cond_signal
(S
.CV
'Access);
1210 pragma Assert
(Result
= 0);
1216 Result
:= pthread_mutex_unlock
(S
.L
'Access);
1217 pragma Assert
(Result
= 0);
1219 SSL
.Abort_Undefer
.all;
1222 ------------------------
1223 -- Suspend_Until_True --
1224 ------------------------
1226 procedure Suspend_Until_True
(S
: in out Suspension_Object
) is
1227 Result
: Interfaces
.C
.int
;
1230 SSL
.Abort_Defer
.all;
1232 Result
:= pthread_mutex_lock
(S
.L
'Access);
1233 pragma Assert
(Result
= 0);
1237 -- Program_Error must be raised upon calling Suspend_Until_True
1238 -- if another task is already waiting on that suspension object
1241 Result
:= pthread_mutex_unlock
(S
.L
'Access);
1242 pragma Assert
(Result
= 0);
1244 SSL
.Abort_Undefer
.all;
1246 raise Program_Error
;
1249 -- Suspend the task if the state is False. Otherwise, the task
1250 -- continues its execution, and the state of the suspension object
1251 -- is set to False (ARM D.10 par. 9).
1259 -- Loop in case pthread_cond_wait returns earlier than expected
1260 -- (e.g. in case of EINTR caused by a signal). This should not
1261 -- happen with the current Linux implementation of pthread, but
1262 -- POSIX does not guarantee it so this may change in future.
1264 Result
:= pthread_cond_wait
(S
.CV
'Access, S
.L
'Access);
1265 pragma Assert
(Result
= 0 or else Result
= EINTR
);
1267 exit when not S
.Waiting
;
1271 Result
:= pthread_mutex_unlock
(S
.L
'Access);
1272 pragma Assert
(Result
= 0);
1274 SSL
.Abort_Undefer
.all;
1276 end Suspend_Until_True
;
1284 function Check_Exit
(Self_ID
: ST
.Task_Id
) return Boolean is
1285 pragma Unreferenced
(Self_ID
);
1290 --------------------
1291 -- Check_No_Locks --
1292 --------------------
1294 function Check_No_Locks
(Self_ID
: ST
.Task_Id
) return Boolean is
1295 pragma Unreferenced
(Self_ID
);
1300 ----------------------
1301 -- Environment_Task --
1302 ----------------------
1304 function Environment_Task
return Task_Id
is
1306 return Environment_Task_Id
;
1307 end Environment_Task
;
1313 function Suspend_Task
1315 Thread_Self
: Thread_Id
) return Boolean
1318 if T
.Common
.LL
.Thread
/= Thread_Self
then
1319 return pthread_kill
(T
.Common
.LL
.Thread
, SIGSTOP
) = 0;
1329 function Resume_Task
1331 Thread_Self
: Thread_Id
) return Boolean
1334 if T
.Common
.LL
.Thread
/= Thread_Self
then
1335 return pthread_kill
(T
.Common
.LL
.Thread
, SIGCONT
) = 0;
1341 --------------------
1342 -- Stop_All_Tasks --
1343 --------------------
1345 procedure Stop_All_Tasks
is
1354 function Stop_Task
(T
: ST
.Task_Id
) return Boolean is
1355 pragma Unreferenced
(T
);
1364 function Continue_Task
(T
: ST
.Task_Id
) return Boolean is
1365 pragma Unreferenced
(T
);
1374 procedure Initialize
(Environment_Task
: Task_Id
) is
1375 act
: aliased struct_sigaction
;
1376 old_act
: aliased struct_sigaction
;
1377 Tmp_Set
: aliased sigset_t
;
1378 Result
: Interfaces
.C
.int
;
1379 -- Whether to use an alternate signal stack for stack overflows
1382 (Int
: System
.Interrupt_Management
.Interrupt_ID
) return Character;
1383 pragma Import
(C
, State
, "__gnat_get_interrupt_state");
1384 -- Get interrupt state. Defined in a-init.c
1385 -- The input argument is the interrupt number,
1386 -- and the result is one of the following:
1388 Default
: constant Character := 's';
1389 -- 'n' this interrupt not set by any Interrupt_State pragma
1390 -- 'u' Interrupt_State pragma set state to User
1391 -- 'r' Interrupt_State pragma set state to Runtime
1392 -- 's' Interrupt_State pragma set state to System (use "default"
1395 use type System
.Multiprocessors
.CPU_Range
;
1398 Environment_Task_Id
:= Environment_Task
;
1400 Interrupt_Management
.Initialize
;
1402 -- Prepare the set of signals that should be unblocked in all tasks
1404 Result
:= sigemptyset
(Unblocked_Signal_Mask
'Access);
1405 pragma Assert
(Result
= 0);
1407 for J
in Interrupt_Management
.Interrupt_ID
loop
1408 if System
.Interrupt_Management
.Keep_Unmasked
(J
) then
1409 Result
:= sigaddset
(Unblocked_Signal_Mask
'Access, Signal
(J
));
1410 pragma Assert
(Result
= 0);
1414 Initialize_Lock
(Single_RTS_Lock
'Access, RTS_Lock_Level
);
1416 -- Initialize the global RTS lock
1418 Specific
.Initialize
(Environment_Task
);
1420 if Use_Alternate_Stack
then
1421 Environment_Task
.Common
.Task_Alternate_Stack
:=
1422 Alternate_Stack
'Address;
1425 -- Make environment task known here because it doesn't go through
1426 -- Activate_Tasks, which does it for all other tasks.
1428 Known_Tasks
(Known_Tasks
'First) := Environment_Task
;
1429 Environment_Task
.Known_Tasks_Index
:= Known_Tasks
'First;
1431 Enter_Task
(Environment_Task
);
1434 (System
.Interrupt_Management
.Abort_Task_Interrupt
) /= Default
1437 act
.sa_handler
:= Abort_Handler
'Address;
1439 Result
:= sigemptyset
(Tmp_Set
'Access);
1440 pragma Assert
(Result
= 0);
1441 act
.sa_mask
:= Tmp_Set
;
1445 (Signal
(Interrupt_Management
.Abort_Task_Interrupt
),
1446 act
'Unchecked_Access,
1447 old_act
'Unchecked_Access);
1448 pragma Assert
(Result
= 0);
1449 Abort_Handler_Installed
:= True;
1452 -- pragma CPU and dispatching domains for the environment task
1454 Set_Task_Affinity
(Environment_Task
);
1457 -----------------------
1458 -- Set_Task_Affinity --
1459 -----------------------
1461 procedure Set_Task_Affinity
(T
: ST
.Task_Id
) is
1462 use type System
.Multiprocessors
.CPU_Range
;
1465 -- Do nothing if there is no support for setting affinities or the
1466 -- underlying thread has not yet been created. If the thread has not
1467 -- yet been created then the proper affinity will be set during its
1470 if pthread_setaffinity_np
'Address /= System
.Null_Address
1471 and then T
.Common
.LL
.Thread
/= Null_Thread_Id
1474 CPUs
: constant size_t
:=
1476 (System
.Multiprocessors
.Number_Of_CPUs
);
1477 CPU_Set
: cpu_set_t_ptr
:= null;
1478 Size
: constant size_t
:= CPU_ALLOC_SIZE
(CPUs
);
1480 Result
: Interfaces
.C
.int
;
1483 -- We look at the specific CPU (Base_CPU) first, then at the
1484 -- Task_Info field, and finally at the assigned dispatching
1487 if T
.Common
.Base_CPU
/= Multiprocessors
.Not_A_Specific_CPU
then
1489 -- Set the affinity to an unique CPU
1491 CPU_Set
:= CPU_ALLOC
(CPUs
);
1492 System
.OS_Interface
.CPU_ZERO
(Size
, CPU_Set
);
1493 System
.OS_Interface
.CPU_SET
1494 (int
(T
.Common
.Base_CPU
), Size
, CPU_Set
);
1498 elsif T
.Common
.Task_Info
/= null then
1499 CPU_Set
:= T
.Common
.Task_Info
.CPU_Affinity
'Access;
1501 -- Handle dispatching domains
1503 elsif T
.Common
.Domain
/= null and then
1504 (T
.Common
.Domain
/= ST
.System_Domain
1505 or else T
.Common
.Domain
.all /=
1506 (Multiprocessors
.CPU
'First ..
1507 Multiprocessors
.Number_Of_CPUs
=> True))
1509 -- Set the affinity to all the processors belonging to the
1510 -- dispatching domain. To avoid changing CPU affinities when
1511 -- not needed, we set the affinity only when assigning to a
1512 -- domain other than the default one, or when the default one
1513 -- has been modified.
1515 CPU_Set
:= CPU_ALLOC
(CPUs
);
1516 System
.OS_Interface
.CPU_ZERO
(Size
, CPU_Set
);
1518 for Proc
in T
.Common
.Domain
'Range loop
1519 if T
.Common
.Domain
(Proc
) then
1520 System
.OS_Interface
.CPU_SET
(int
(Proc
), Size
, CPU_Set
);
1525 -- We set the new affinity if needed. Otherwise, the new task
1526 -- will inherit its creator's CPU affinity mask (according to
1527 -- the documentation of pthread_setaffinity_np), which is
1528 -- consistent with Ada's required semantics.
1530 if CPU_Set
/= null then
1532 pthread_setaffinity_np
(T
.Common
.LL
.Thread
, Size
, CPU_Set
);
1533 pragma Assert
(Result
= 0);
1539 end Set_Task_Affinity
;
1541 end System
.Task_Primitives
.Operations
;