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-2006, 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 2, or (at your option) any later ver- --
14 -- sion. GNARL 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. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNARL; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- GNARL was developed by the GNARL team at Florida State University. --
30 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
32 ------------------------------------------------------------------------------
34 -- This is a GNU/Linux (GNU/LinuxThreads) version of this package
36 -- This package contains all the GNULL primitives that interface directly
37 -- with the underlying OS.
40 -- Turn off polling, we do not want ATC polling to take place during
41 -- tasking operations. It causes infinite loops and other problems.
47 with System
.Tasking
.Debug
;
48 -- used for Known_Tasks
50 with System
.Interrupt_Management
;
51 -- used for Keep_Unmasked
52 -- Abort_Task_Interrupt
55 with System
.OS_Primitives
;
56 -- used for Delay_Modes
58 with System
.Soft_Links
;
59 -- used for Abort_Defer/Undefer
61 -- We use System.Soft_Links instead of System.Tasking.Initialization
62 -- because the later is a higher level package that we shouldn't depend on.
63 -- For example when using the restricted run time, it is replaced by
64 -- System.Tasking.Restricted.Stages.
66 with System
.Stack_Checking
.Operations
;
67 -- Used for Invalidate_Stack_Cache;
70 -- used for Raise_Exception
71 -- Raise_From_Signal_Handler
74 with Unchecked_Conversion
;
75 with Unchecked_Deallocation
;
77 package body System
.Task_Primitives
.Operations
is
79 package SSL
renames System
.Soft_Links
;
80 package SC
renames System
.Stack_Checking
.Operations
;
82 use System
.Tasking
.Debug
;
85 use System
.OS_Interface
;
86 use System
.Parameters
;
87 use System
.OS_Primitives
;
93 -- The followings are logically constants, but need to be initialized
96 Single_RTS_Lock
: aliased RTS_Lock
;
97 -- This is a lock to allow only one thread of control in the RTS at
98 -- a time; it is used to execute in mutual exclusion from all other tasks.
99 -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
101 ATCB_Key
: aliased pthread_key_t
;
102 -- Key used to find the Ada Task_Id associated with a thread
104 Environment_Task_Id
: Task_Id
;
105 -- A variable to hold Task_Id for the environment task
107 Unblocked_Signal_Mask
: aliased sigset_t
;
108 -- The set of signals that should be unblocked in all tasks
110 -- The followings are internal configuration constants needed
112 Next_Serial_Number
: Task_Serial_Number
:= 100;
113 -- We start at 100, to reserve some special values for
114 -- using in error checking.
116 Time_Slice_Val
: Integer;
117 pragma Import
(C
, Time_Slice_Val
, "__gl_time_slice_val");
119 Dispatching_Policy
: Character;
120 pragma Import
(C
, Dispatching_Policy
, "__gl_task_dispatching_policy");
122 -- The following are effectively constants, but they need to
123 -- be initialized by calling a pthread_ function.
125 Mutex_Attr
: aliased pthread_mutexattr_t
;
126 Cond_Attr
: aliased pthread_condattr_t
;
128 Foreign_Task_Elaborated
: aliased Boolean := True;
129 -- Used to identified fake tasks (i.e., non-Ada Threads)
137 procedure Initialize
(Environment_Task
: Task_Id
);
138 pragma Inline
(Initialize
);
139 -- Initialize various data needed by this package
141 function Is_Valid_Task
return Boolean;
142 pragma Inline
(Is_Valid_Task
);
143 -- Does executing thread have a TCB?
145 procedure Set
(Self_Id
: Task_Id
);
147 -- Set the self id for the current task
149 function Self
return Task_Id
;
150 pragma Inline
(Self
);
151 -- Return a pointer to the Ada Task Control Block of the calling task
155 package body Specific
is separate;
156 -- The body of this package is target specific
158 ---------------------------------
159 -- Support for foreign threads --
160 ---------------------------------
162 function Register_Foreign_Thread
(Thread
: Thread_Id
) return Task_Id
;
163 -- Allocate and Initialize a new ATCB for the current Thread
165 function Register_Foreign_Thread
166 (Thread
: Thread_Id
) return Task_Id
is separate;
168 -----------------------
169 -- Local Subprograms --
170 -----------------------
172 subtype unsigned_long
is Interfaces
.C
.unsigned_long
;
174 procedure Abort_Handler
(signo
: Signal
);
176 function To_pthread_t
is new Unchecked_Conversion
177 (unsigned_long
, System
.OS_Interface
.pthread_t
);
183 procedure Abort_Handler
(signo
: Signal
) is
184 pragma Unreferenced
(signo
);
186 Self_Id
: constant Task_Id
:= Self
;
187 Result
: Interfaces
.C
.int
;
188 Old_Set
: aliased sigset_t
;
191 if ZCX_By_Default
and then GCC_ZCX_Support
then
195 if Self_Id
.Deferral_Level
= 0
196 and then Self_Id
.Pending_ATC_Level
< Self_Id
.ATC_Nesting_Level
197 and then not Self_Id
.Aborting
199 Self_Id
.Aborting
:= True;
201 -- Make sure signals used for RTS internal purpose are unmasked
203 Result
:= pthread_sigmask
(SIG_UNBLOCK
,
204 Unblocked_Signal_Mask
'Unchecked_Access, Old_Set
'Unchecked_Access);
205 pragma Assert
(Result
= 0);
207 raise Standard
'Abort_Signal;
215 procedure Lock_RTS
is
217 Write_Lock
(Single_RTS_Lock
'Access, Global_Lock
=> True);
224 procedure Unlock_RTS
is
226 Unlock
(Single_RTS_Lock
'Access, Global_Lock
=> True);
233 -- The underlying thread system extends the memory (up to 2MB) when needed
235 procedure Stack_Guard
(T
: ST
.Task_Id
; On
: Boolean) is
236 pragma Unreferenced
(T
);
237 pragma Unreferenced
(On
);
246 function Get_Thread_Id
(T
: ST
.Task_Id
) return OSI
.Thread_Id
is
248 return T
.Common
.LL
.Thread
;
255 function Self
return Task_Id
renames Specific
.Self
;
257 ---------------------
258 -- Initialize_Lock --
259 ---------------------
261 -- Note: mutexes and cond_variables needed per-task basis are
262 -- initialized in Initialize_TCB and the Storage_Error is
263 -- handled. Other mutexes (such as RTS_Lock, Memory_Lock...)
264 -- used in RTS is initialized before any status change of RTS.
265 -- Therefore rasing Storage_Error in the following routines
266 -- should be able to be handled safely.
268 procedure Initialize_Lock
269 (Prio
: System
.Any_Priority
;
272 pragma Unreferenced
(Prio
);
274 Result
: Interfaces
.C
.int
;
276 Result
:= pthread_mutex_init
(L
, Mutex_Attr
'Access);
278 pragma Assert
(Result
= 0 or else Result
= ENOMEM
);
280 if Result
= ENOMEM
then
281 Ada
.Exceptions
.Raise_Exception
(Storage_Error
'Identity,
282 "Failed to allocate a lock");
286 procedure Initialize_Lock
(L
: access RTS_Lock
; Level
: Lock_Level
) is
287 pragma Unreferenced
(Level
);
289 Result
: Interfaces
.C
.int
;
292 Result
:= pthread_mutex_init
(L
, Mutex_Attr
'Access);
294 pragma Assert
(Result
= 0 or else Result
= ENOMEM
);
296 if Result
= ENOMEM
then
305 procedure Finalize_Lock
(L
: access Lock
) is
306 Result
: Interfaces
.C
.int
;
308 Result
:= pthread_mutex_destroy
(L
);
309 pragma Assert
(Result
= 0);
312 procedure Finalize_Lock
(L
: access RTS_Lock
) is
313 Result
: Interfaces
.C
.int
;
315 Result
:= pthread_mutex_destroy
(L
);
316 pragma Assert
(Result
= 0);
323 procedure Write_Lock
(L
: access Lock
; Ceiling_Violation
: out Boolean) is
324 Result
: Interfaces
.C
.int
;
326 Result
:= pthread_mutex_lock
(L
);
327 Ceiling_Violation
:= Result
= EINVAL
;
329 -- Assume the cause of EINVAL is a priority ceiling violation
331 pragma Assert
(Result
= 0 or else Result
= EINVAL
);
335 (L
: access RTS_Lock
;
336 Global_Lock
: Boolean := False)
338 Result
: Interfaces
.C
.int
;
340 if not Single_Lock
or else Global_Lock
then
341 Result
:= pthread_mutex_lock
(L
);
342 pragma Assert
(Result
= 0);
346 procedure Write_Lock
(T
: Task_Id
) is
347 Result
: Interfaces
.C
.int
;
349 if not Single_Lock
then
350 Result
:= pthread_mutex_lock
(T
.Common
.LL
.L
'Access);
351 pragma Assert
(Result
= 0);
359 procedure Read_Lock
(L
: access Lock
; Ceiling_Violation
: out Boolean) is
361 Write_Lock
(L
, Ceiling_Violation
);
368 procedure Unlock
(L
: access Lock
) is
369 Result
: Interfaces
.C
.int
;
371 Result
:= pthread_mutex_unlock
(L
);
372 pragma Assert
(Result
= 0);
375 procedure Unlock
(L
: access RTS_Lock
; Global_Lock
: Boolean := False) is
376 Result
: Interfaces
.C
.int
;
378 if not Single_Lock
or else Global_Lock
then
379 Result
:= pthread_mutex_unlock
(L
);
380 pragma Assert
(Result
= 0);
384 procedure Unlock
(T
: Task_Id
) is
385 Result
: Interfaces
.C
.int
;
387 if not Single_Lock
then
388 Result
:= pthread_mutex_unlock
(T
.Common
.LL
.L
'Access);
389 pragma Assert
(Result
= 0);
399 Reason
: System
.Tasking
.Task_States
)
401 pragma Unreferenced
(Reason
);
403 Result
: Interfaces
.C
.int
;
406 pragma Assert
(Self_ID
= Self
);
409 Result
:= pthread_cond_wait
410 (Self_ID
.Common
.LL
.CV
'Access, Single_RTS_Lock
'Access);
412 Result
:= pthread_cond_wait
413 (Self_ID
.Common
.LL
.CV
'Access, Self_ID
.Common
.LL
.L
'Access);
416 -- EINTR is not considered a failure
418 pragma Assert
(Result
= 0 or else Result
= EINTR
);
425 -- This is for use within the run-time system, so abort is
426 -- assumed to be already deferred, and the caller should be
427 -- holding its own ATCB lock.
429 procedure Timed_Sleep
432 Mode
: ST
.Delay_Modes
;
433 Reason
: System
.Tasking
.Task_States
;
434 Timedout
: out Boolean;
435 Yielded
: out Boolean)
437 pragma Unreferenced
(Reason
);
439 Check_Time
: constant Duration := Monotonic_Clock
;
441 Request
: aliased timespec
;
442 Result
: Interfaces
.C
.int
;
448 if Mode
= Relative
then
449 Abs_Time
:= Duration'Min (Time
, Max_Sensible_Delay
) + Check_Time
;
451 Abs_Time
:= Duration'Min (Check_Time
+ Max_Sensible_Delay
, Time
);
454 if Abs_Time
> Check_Time
then
455 Request
:= To_Timespec
(Abs_Time
);
458 exit when Self_ID
.Pending_ATC_Level
< Self_ID
.ATC_Nesting_Level
459 or else Self_ID
.Pending_Priority_Change
;
462 Result
:= pthread_cond_timedwait
463 (Self_ID
.Common
.LL
.CV
'Access, Single_RTS_Lock
'Access,
467 Result
:= pthread_cond_timedwait
468 (Self_ID
.Common
.LL
.CV
'Access, Self_ID
.Common
.LL
.L
'Access,
472 exit when Abs_Time
<= Monotonic_Clock
;
474 if Result
= 0 or Result
= EINTR
then
475 -- somebody may have called Wakeup for us
480 pragma Assert
(Result
= ETIMEDOUT
);
489 -- This is for use in implementing delay statements, so
490 -- we assume the caller is abort-deferred but is holding
493 procedure Timed_Delay
496 Mode
: ST
.Delay_Modes
)
498 Check_Time
: constant Duration := Monotonic_Clock
;
500 Request
: aliased timespec
;
502 Result
: Interfaces
.C
.int
;
503 pragma Warnings
(Off
, Result
);
510 Write_Lock
(Self_ID
);
512 if Mode
= Relative
then
513 Abs_Time
:= Time
+ Check_Time
;
515 Abs_Time
:= Duration'Min (Check_Time
+ Max_Sensible_Delay
, Time
);
518 if Abs_Time
> Check_Time
then
519 Request
:= To_Timespec
(Abs_Time
);
520 Self_ID
.Common
.State
:= Delay_Sleep
;
523 if Self_ID
.Pending_Priority_Change
then
524 Self_ID
.Pending_Priority_Change
:= False;
525 Self_ID
.Common
.Base_Priority
:= Self_ID
.New_Base_Priority
;
526 Set_Priority
(Self_ID
, Self_ID
.Common
.Base_Priority
);
529 exit when Self_ID
.Pending_ATC_Level
< Self_ID
.ATC_Nesting_Level
;
532 Result
:= pthread_cond_timedwait
533 (Self_ID
.Common
.LL
.CV
'Access,
534 Single_RTS_Lock
'Access,
537 Result
:= pthread_cond_timedwait
538 (Self_ID
.Common
.LL
.CV
'Access,
539 Self_ID
.Common
.LL
.L
'Access,
543 exit when Abs_Time
<= Monotonic_Clock
;
545 pragma Assert
(Result
= 0 or else
546 Result
= ETIMEDOUT
or else
550 Self_ID
.Common
.State
:= Runnable
;
559 Result
:= sched_yield
;
562 ---------------------
563 -- Monotonic_Clock --
564 ---------------------
566 function Monotonic_Clock
return Duration is
567 TV
: aliased struct_timeval
;
568 Result
: Interfaces
.C
.int
;
570 Result
:= gettimeofday
(TV
'Access, System
.Null_Address
);
571 pragma Assert
(Result
= 0);
572 return To_Duration
(TV
);
579 function RT_Resolution
return Duration is
588 procedure Wakeup
(T
: Task_Id
; Reason
: System
.Tasking
.Task_States
) is
589 pragma Unreferenced
(Reason
);
590 Result
: Interfaces
.C
.int
;
592 Result
:= pthread_cond_signal
(T
.Common
.LL
.CV
'Access);
593 pragma Assert
(Result
= 0);
600 procedure Yield
(Do_Yield
: Boolean := True) is
601 Result
: Interfaces
.C
.int
;
602 pragma Unreferenced
(Result
);
605 Result
:= sched_yield
;
613 procedure Set_Priority
615 Prio
: System
.Any_Priority
;
616 Loss_Of_Inheritance
: Boolean := False)
618 pragma Unreferenced
(Loss_Of_Inheritance
);
620 Result
: Interfaces
.C
.int
;
621 Param
: aliased struct_sched_param
;
623 function Get_Policy
(Prio
: System
.Any_Priority
) return Character;
624 pragma Import
(C
, Get_Policy
, "__gnat_get_specific_dispatching");
625 -- Get priority specific dispatching policy
627 Priority_Specific_Policy
: constant Character := Get_Policy
(Prio
);
628 -- Upper case first character of the policy name corresponding to the
629 -- task as set by a Priority_Specific_Dispatching pragma.
632 T
.Common
.Current_Priority
:= Prio
;
634 -- Priorities are in range 1 .. 99 on GNU/Linux, so we map
635 -- map 0 .. 98 to 1 .. 99
637 Param
.sched_priority
:= Interfaces
.C
.int
(Prio
) + 1;
639 if Dispatching_Policy
= 'R'
640 or else Priority_Specific_Policy
= 'R'
641 or else Time_Slice_Val
> 0
643 Result
:= pthread_setschedparam
644 (T
.Common
.LL
.Thread
, SCHED_RR
, Param
'Access);
646 elsif Dispatching_Policy
= 'F'
647 or else Priority_Specific_Policy
= 'F'
648 or else Time_Slice_Val
= 0
650 Result
:= pthread_setschedparam
651 (T
.Common
.LL
.Thread
, SCHED_FIFO
, Param
'Access);
654 Param
.sched_priority
:= 0;
655 Result
:= pthread_setschedparam
656 (T
.Common
.LL
.Thread
, SCHED_OTHER
, Param
'Access);
659 pragma Assert
(Result
= 0 or else Result
= EPERM
);
666 function Get_Priority
(T
: Task_Id
) return System
.Any_Priority
is
668 return T
.Common
.Current_Priority
;
675 procedure Enter_Task
(Self_ID
: Task_Id
) is
677 Self_ID
.Common
.LL
.Thread
:= pthread_self
;
679 Specific
.Set
(Self_ID
);
683 for J
in Known_Tasks
'Range loop
684 if Known_Tasks
(J
) = null then
685 Known_Tasks
(J
) := Self_ID
;
686 Self_ID
.Known_Tasks_Index
:= J
;
698 function New_ATCB
(Entry_Num
: Task_Entry_Index
) return Task_Id
is
700 return new Ada_Task_Control_Block
(Entry_Num
);
707 function Is_Valid_Task
return Boolean renames Specific
.Is_Valid_Task
;
709 -----------------------------
710 -- Register_Foreign_Thread --
711 -----------------------------
713 function Register_Foreign_Thread
return Task_Id
is
715 if Is_Valid_Task
then
718 return Register_Foreign_Thread
(pthread_self
);
720 end Register_Foreign_Thread
;
726 procedure Initialize_TCB
(Self_ID
: Task_Id
; Succeeded
: out Boolean) is
727 Result
: Interfaces
.C
.int
;
730 -- Give the task a unique serial number
732 Self_ID
.Serial_Number
:= Next_Serial_Number
;
733 Next_Serial_Number
:= Next_Serial_Number
+ 1;
734 pragma Assert
(Next_Serial_Number
/= 0);
736 Self_ID
.Common
.LL
.Thread
:= To_pthread_t
(-1);
738 if not Single_Lock
then
739 Result
:= pthread_mutex_init
(Self_ID
.Common
.LL
.L
'Access,
741 pragma Assert
(Result
= 0 or else Result
= ENOMEM
);
749 Result
:= pthread_cond_init
(Self_ID
.Common
.LL
.CV
'Access,
751 pragma Assert
(Result
= 0 or else Result
= ENOMEM
);
756 if not Single_Lock
then
757 Result
:= pthread_mutex_destroy
(Self_ID
.Common
.LL
.L
'Access);
758 pragma Assert
(Result
= 0);
769 procedure Create_Task
771 Wrapper
: System
.Address
;
772 Stack_Size
: System
.Parameters
.Size_Type
;
773 Priority
: System
.Any_Priority
;
774 Succeeded
: out Boolean)
776 Attributes
: aliased pthread_attr_t
;
777 Result
: Interfaces
.C
.int
;
780 Result
:= pthread_attr_init
(Attributes
'Access);
781 pragma Assert
(Result
= 0 or else Result
= ENOMEM
);
789 pthread_attr_setstacksize
790 (Attributes
'Access, Interfaces
.C
.size_t
(Stack_Size
));
791 pragma Assert
(Result
= 0);
794 pthread_attr_setdetachstate
795 (Attributes
'Access, PTHREAD_CREATE_DETACHED
);
796 pragma Assert
(Result
= 0);
798 -- Since the initial signal mask of a thread is inherited from the
799 -- creator, and the Environment task has all its signals masked, we
800 -- do not need to manipulate caller's signal mask at this point.
801 -- All tasks in RTS will have All_Tasks_Mask initially.
803 Result
:= pthread_create
804 (T
.Common
.LL
.Thread
'Access,
806 Thread_Body_Access
(Wrapper
),
808 pragma Assert
(Result
= 0 or else Result
= EAGAIN
);
810 Succeeded
:= Result
= 0;
812 Result
:= pthread_attr_destroy
(Attributes
'Access);
813 pragma Assert
(Result
= 0);
815 Set_Priority
(T
, Priority
);
822 procedure Finalize_TCB
(T
: Task_Id
) is
823 Result
: Interfaces
.C
.int
;
825 Is_Self
: constant Boolean := T
= Self
;
827 procedure Free
is new
828 Unchecked_Deallocation
(Ada_Task_Control_Block
, Task_Id
);
831 if not Single_Lock
then
832 Result
:= pthread_mutex_destroy
(T
.Common
.LL
.L
'Access);
833 pragma Assert
(Result
= 0);
836 Result
:= pthread_cond_destroy
(T
.Common
.LL
.CV
'Access);
837 pragma Assert
(Result
= 0);
839 if T
.Known_Tasks_Index
/= -1 then
840 Known_Tasks
(T
.Known_Tasks_Index
) := null;
842 SC
.Invalidate_Stack_Cache
(T
.Common
.Compiler_Data
.Pri_Stack_Info
'Access);
854 procedure Exit_Task
is
863 procedure Abort_Task
(T
: Task_Id
) is
864 Result
: Interfaces
.C
.int
;
866 Result
:= pthread_kill
(T
.Common
.LL
.Thread
,
867 Signal
(System
.Interrupt_Management
.Abort_Task_Interrupt
));
868 pragma Assert
(Result
= 0);
875 procedure Initialize
(S
: in out Suspension_Object
) is
876 Result
: Interfaces
.C
.int
;
878 -- Initialize internal state. It is always initialized to False (ARM
884 -- Initialize internal mutex
886 Result
:= pthread_mutex_init
(S
.L
'Access, Mutex_Attr
'Access);
888 pragma Assert
(Result
= 0 or else Result
= ENOMEM
);
890 if Result
= ENOMEM
then
894 -- Initialize internal condition variable
896 Result
:= pthread_cond_init
(S
.CV
'Access, Cond_Attr
'Access);
898 pragma Assert
(Result
= 0 or else Result
= ENOMEM
);
901 Result
:= pthread_mutex_destroy
(S
.L
'Access);
902 pragma Assert
(Result
= 0);
904 if Result
= ENOMEM
then
914 procedure Finalize
(S
: in out Suspension_Object
) is
915 Result
: Interfaces
.C
.int
;
917 -- Destroy internal mutex
919 Result
:= pthread_mutex_destroy
(S
.L
'Access);
920 pragma Assert
(Result
= 0);
922 -- Destroy internal condition variable
924 Result
:= pthread_cond_destroy
(S
.CV
'Access);
925 pragma Assert
(Result
= 0);
932 function Current_State
(S
: Suspension_Object
) return Boolean is
934 -- We do not want to use lock on this read operation. State is marked
935 -- as Atomic so that we ensure that the value retrieved is correct.
944 procedure Set_False
(S
: in out Suspension_Object
) is
945 Result
: Interfaces
.C
.int
;
949 Result
:= pthread_mutex_lock
(S
.L
'Access);
950 pragma Assert
(Result
= 0);
954 Result
:= pthread_mutex_unlock
(S
.L
'Access);
955 pragma Assert
(Result
= 0);
957 SSL
.Abort_Undefer
.all;
964 procedure Set_True
(S
: in out Suspension_Object
) is
965 Result
: Interfaces
.C
.int
;
969 Result
:= pthread_mutex_lock
(S
.L
'Access);
970 pragma Assert
(Result
= 0);
972 -- If there is already a task waiting on this suspension object then
973 -- we resume it, leaving the state of the suspension object to False,
974 -- as it is specified in ARM D.10 par. 9. Otherwise, it just leaves
975 -- the state to True.
981 Result
:= pthread_cond_signal
(S
.CV
'Access);
982 pragma Assert
(Result
= 0);
987 Result
:= pthread_mutex_unlock
(S
.L
'Access);
988 pragma Assert
(Result
= 0);
990 SSL
.Abort_Undefer
.all;
993 ------------------------
994 -- Suspend_Until_True --
995 ------------------------
997 procedure Suspend_Until_True
(S
: in out Suspension_Object
) is
998 Result
: Interfaces
.C
.int
;
1000 SSL
.Abort_Defer
.all;
1002 Result
:= pthread_mutex_lock
(S
.L
'Access);
1003 pragma Assert
(Result
= 0);
1006 -- Program_Error must be raised upon calling Suspend_Until_True
1007 -- if another task is already waiting on that suspension object
1008 -- (ARM D.10 par. 10).
1010 Result
:= pthread_mutex_unlock
(S
.L
'Access);
1011 pragma Assert
(Result
= 0);
1013 SSL
.Abort_Undefer
.all;
1015 raise Program_Error
;
1017 -- Suspend the task if the state is False. Otherwise, the task
1018 -- continues its execution, and the state of the suspension object
1019 -- is set to False (ARM D.10 par. 9).
1025 Result
:= pthread_cond_wait
(S
.CV
'Access, S
.L
'Access);
1028 Result
:= pthread_mutex_unlock
(S
.L
'Access);
1029 pragma Assert
(Result
= 0);
1031 SSL
.Abort_Undefer
.all;
1033 end Suspend_Until_True
;
1041 function Check_Exit
(Self_ID
: ST
.Task_Id
) return Boolean is
1042 pragma Unreferenced
(Self_ID
);
1047 --------------------
1048 -- Check_No_Locks --
1049 --------------------
1051 function Check_No_Locks
(Self_ID
: ST
.Task_Id
) return Boolean is
1052 pragma Unreferenced
(Self_ID
);
1057 ----------------------
1058 -- Environment_Task --
1059 ----------------------
1061 function Environment_Task
return Task_Id
is
1063 return Environment_Task_Id
;
1064 end Environment_Task
;
1070 function Suspend_Task
1072 Thread_Self
: Thread_Id
) return Boolean
1075 if T
.Common
.LL
.Thread
/= Thread_Self
then
1076 return pthread_kill
(T
.Common
.LL
.Thread
, SIGSTOP
) = 0;
1086 function Resume_Task
1088 Thread_Self
: Thread_Id
) return Boolean
1091 if T
.Common
.LL
.Thread
/= Thread_Self
then
1092 return pthread_kill
(T
.Common
.LL
.Thread
, SIGCONT
) = 0;
1102 procedure Initialize
(Environment_Task
: Task_Id
) is
1103 act
: aliased struct_sigaction
;
1104 old_act
: aliased struct_sigaction
;
1105 Tmp_Set
: aliased sigset_t
;
1106 Result
: Interfaces
.C
.int
;
1109 (Int
: System
.Interrupt_Management
.Interrupt_ID
) return Character;
1110 pragma Import
(C
, State
, "__gnat_get_interrupt_state");
1111 -- Get interrupt state. Defined in a-init.c
1112 -- The input argument is the interrupt number,
1113 -- and the result is one of the following:
1115 Default
: constant Character := 's';
1116 -- 'n' this interrupt not set by any Interrupt_State pragma
1117 -- 'u' Interrupt_State pragma set state to User
1118 -- 'r' Interrupt_State pragma set state to Runtime
1119 -- 's' Interrupt_State pragma set state to System (use "default"
1123 Environment_Task_Id
:= Environment_Task
;
1125 Interrupt_Management
.Initialize
;
1127 -- Prepare the set of signals that should be unblocked in all tasks
1129 Result
:= sigemptyset
(Unblocked_Signal_Mask
'Access);
1130 pragma Assert
(Result
= 0);
1132 for J
in Interrupt_Management
.Interrupt_ID
loop
1133 if System
.Interrupt_Management
.Keep_Unmasked
(J
) then
1134 Result
:= sigaddset
(Unblocked_Signal_Mask
'Access, Signal
(J
));
1135 pragma Assert
(Result
= 0);
1139 Result
:= pthread_mutexattr_init
(Mutex_Attr
'Access);
1140 pragma Assert
(Result
= 0);
1142 Result
:= pthread_condattr_init
(Cond_Attr
'Access);
1143 pragma Assert
(Result
= 0);
1145 Initialize_Lock
(Single_RTS_Lock
'Access, RTS_Lock_Level
);
1147 -- Initialize the global RTS lock
1149 Specific
.Initialize
(Environment_Task
);
1151 Enter_Task
(Environment_Task
);
1153 -- Install the abort-signal handler
1155 if State
(System
.Interrupt_Management
.Abort_Task_Interrupt
)
1159 act
.sa_handler
:= Abort_Handler
'Address;
1161 Result
:= sigemptyset
(Tmp_Set
'Access);
1162 pragma Assert
(Result
= 0);
1163 act
.sa_mask
:= Tmp_Set
;
1167 (Signal
(Interrupt_Management
.Abort_Task_Interrupt
),
1168 act
'Unchecked_Access,
1169 old_act
'Unchecked_Access);
1170 pragma Assert
(Result
= 0);
1174 end System
.Task_Primitives
.Operations
;