1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
5 -- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S --
9 -- Copyright (C) 1992-2005, 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 DEC Unix 4.0d 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.
43 with System.Tasking.Debug;
44 -- used for Known_Tasks
46 with System.Task_Info;
47 -- used for Task_Info_Type
50 -- used for Shift_Left
56 with System.Interrupt_Management;
57 -- used for Keep_Unmasked
58 -- Abort_Task_Interrupt
61 with System.Parameters;
65 -- used for Ada_Task_Control_Block
67 -- ATCB components and types
69 with System.Soft_Links;
70 -- used for Defer/Undefer_Abort
72 -- Note that we do not use System.Tasking.Initialization directly since
73 -- this is a higher level package that we shouldn't depend on. For example
74 -- when using the restricted run time, it is replaced by
75 -- System.Tasking.Restricted.Stages.
77 with System.OS_Primitives;
78 -- used for Delay_Modes
80 with Unchecked_Deallocation;
82 package body System.Task_Primitives.Operations is
84 use System.Tasking.Debug;
87 use System.OS_Interface;
88 use System.Parameters;
89 use System.OS_Primitives;
91 package SSL renames System.Soft_Links;
97 -- The followings are logically constants, but need to be initialized
100 Single_RTS_Lock : aliased RTS_Lock;
101 -- This is a lock to allow only one thread of control in the RTS at
102 -- a time; it is used to execute in mutual exclusion from all other tasks.
103 -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
105 ATCB_Key : aliased pthread_key_t;
106 -- Key used to find the Ada Task_Id associated with a thread
108 Environment_Task_Id : Task_Id;
109 -- A variable to hold Task_Id for the environment task
111 Unblocked_Signal_Mask : aliased sigset_t;
112 -- The set of signals that should unblocked in all tasks
114 Time_Slice_Val : Integer;
115 pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
117 Locking_Policy : Character;
118 pragma Import (C, Locking_Policy, "__gl_locking_policy");
120 Dispatching_Policy : Character;
121 pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
123 FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F';
124 -- Indicates whether FIFO_Within_Priorities is set
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 procedure Abort_Handler (Sig : Signal);
173 -- Signal handler used to implement asynchronous abort
179 procedure Abort_Handler (Sig : Signal) is
180 pragma Unreferenced (Sig);
182 T : constant Task_Id := Self;
183 Result : Interfaces.C.int;
184 Old_Set : aliased sigset_t;
187 -- It is not safe to raise an exception when using ZCX and the GCC
188 -- exception handling mechanism.
190 if ZCX_By_Default and then GCC_ZCX_Support then
194 if T.Deferral_Level = 0
195 and then T.Pending_ATC_Level < T.ATC_Nesting_Level and then
200 -- Make sure signals used for RTS internal purpose are unmasked
202 Result := pthread_sigmask (SIG_UNBLOCK,
203 Unblocked_Signal_Mask'Unchecked_Access, Old_Set'Unchecked_Access);
204 pragma Assert (Result = 0);
206 raise Standard'Abort_Signal;
214 -- The underlying thread system sets a guard page at the
215 -- bottom of a thread stack, so nothing is needed.
217 procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
218 pragma Unreferenced (T);
219 pragma Unreferenced (On);
228 function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
230 return T.Common.LL.Thread;
237 function Self return Task_Id renames Specific.Self;
239 ---------------------
240 -- Initialize_Lock --
241 ---------------------
243 -- Note: mutexes and cond_variables needed per-task basis are
244 -- initialized in Initialize_TCB and the Storage_Error is
245 -- handled. Other mutexes (such as RTS_Lock, Memory_Lock...)
246 -- used in RTS is initialized before any status change of RTS.
247 -- Therefore rasing Storage_Error in the following routines
248 -- should be able to be handled safely.
250 procedure Initialize_Lock
251 (Prio : System.Any_Priority;
254 Attributes : aliased pthread_mutexattr_t;
255 Result : Interfaces.C.int;
258 Result := pthread_mutexattr_init (Attributes'Access);
259 pragma Assert (Result = 0 or else Result = ENOMEM);
261 if Result = ENOMEM then
265 if Locking_Policy = 'C' then
266 L.Ceiling := Interfaces.C.int (Prio);
269 Result := pthread_mutex_init (L.L'Access, Attributes'Access);
270 pragma Assert (Result = 0 or else Result = ENOMEM);
272 if Result = ENOMEM then
273 Result := pthread_mutexattr_destroy (Attributes'Access);
277 Result := pthread_mutexattr_destroy (Attributes'Access);
278 pragma Assert (Result = 0);
281 procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is
282 pragma Unreferenced (Level);
284 Attributes : aliased pthread_mutexattr_t;
285 Result : Interfaces.C.int;
288 Result := pthread_mutexattr_init (Attributes'Access);
289 pragma Assert (Result = 0 or else Result = ENOMEM);
291 if Result = ENOMEM then
295 Result := pthread_mutex_init (L, Attributes'Access);
296 pragma Assert (Result = 0 or else Result = ENOMEM);
298 if Result = ENOMEM then
299 Result := pthread_mutexattr_destroy (Attributes'Access);
303 Result := pthread_mutexattr_destroy (Attributes'Access);
304 pragma Assert (Result = 0);
311 procedure Finalize_Lock (L : access Lock) is
312 Result : Interfaces.C.int;
314 Result := pthread_mutex_destroy (L.L'Access);
315 pragma Assert (Result = 0);
318 procedure Finalize_Lock (L : access RTS_Lock) is
319 Result : Interfaces.C.int;
321 Result := pthread_mutex_destroy (L);
322 pragma Assert (Result = 0);
329 procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
330 Result : Interfaces.C.int;
332 All_Tasks_Link : Task_Id;
333 Current_Prio : System.Any_Priority;
336 -- Perform ceiling checks only when this is the locking policy in use
338 if Locking_Policy = 'C' then
340 All_Tasks_Link := Self_ID.Common.All_Tasks_Link;
341 Current_Prio := Get_Priority (Self_ID);
343 -- If there is no other task, no need to check priorities
345 if All_Tasks_Link /= Null_Task
346 and then L.Ceiling < Interfaces.C.int (Current_Prio)
348 Ceiling_Violation := True;
353 Result := pthread_mutex_lock (L.L'Access);
354 pragma Assert (Result = 0);
356 Ceiling_Violation := False;
360 (L : access RTS_Lock; Global_Lock : Boolean := False)
362 Result : Interfaces.C.int;
364 if not Single_Lock or else Global_Lock then
365 Result := pthread_mutex_lock (L);
366 pragma Assert (Result = 0);
370 procedure Write_Lock (T : Task_Id) is
371 Result : Interfaces.C.int;
373 if not Single_Lock then
374 Result := pthread_mutex_lock (T.Common.LL.L'Access);
375 pragma Assert (Result = 0);
383 procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
385 Write_Lock (L, Ceiling_Violation);
392 procedure Unlock (L : access Lock) is
393 Result : Interfaces.C.int;
395 Result := pthread_mutex_unlock (L.L'Access);
396 pragma Assert (Result = 0);
399 procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
400 Result : Interfaces.C.int;
402 if not Single_Lock or else Global_Lock then
403 Result := pthread_mutex_unlock (L);
404 pragma Assert (Result = 0);
408 procedure Unlock (T : Task_Id) is
409 Result : Interfaces.C.int;
411 if not Single_Lock then
412 Result := pthread_mutex_unlock (T.Common.LL.L'Access);
413 pragma Assert (Result = 0);
423 Reason : System.Tasking.Task_States)
425 pragma Unreferenced (Reason);
427 Result : Interfaces.C.int;
431 Result := pthread_cond_wait
432 (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
434 Result := pthread_cond_wait
435 (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
438 -- EINTR is not considered a failure
440 pragma Assert (Result = 0 or else Result = EINTR);
447 -- This is for use within the run-time system, so abort is
448 -- assumed to be already deferred, and the caller should be
449 -- holding its own ATCB lock.
451 procedure Timed_Sleep
454 Mode : ST.Delay_Modes;
455 Reason : System.Tasking.Task_States;
456 Timedout : out Boolean;
457 Yielded : out Boolean)
459 pragma Unreferenced (Reason);
461 Check_Time : constant Duration := Monotonic_Clock;
463 Request : aliased timespec;
464 Result : Interfaces.C.int;
470 if Mode = Relative then
471 Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time;
473 Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
476 if Abs_Time > Check_Time then
477 Request := To_Timespec (Abs_Time);
480 exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
481 or else Self_ID.Pending_Priority_Change;
484 Result := pthread_cond_timedwait
485 (Self_ID.Common.LL.CV'Access,
486 Single_RTS_Lock'Access,
490 Result := pthread_cond_timedwait
491 (Self_ID.Common.LL.CV'Access,
492 Self_ID.Common.LL.L'Access,
496 exit when Abs_Time <= Monotonic_Clock;
498 if Result = 0 or Result = EINTR then
500 -- Somebody may have called Wakeup for us
506 pragma Assert (Result = ETIMEDOUT);
515 -- This is for use in implementing delay statements, so
516 -- we assume the caller is abort-deferred but is holding
519 procedure Timed_Delay
522 Mode : ST.Delay_Modes)
524 Check_Time : constant Duration := Monotonic_Clock;
526 Request : aliased timespec;
527 Result : Interfaces.C.int;
530 -- Only the little window between deferring abort and
531 -- locking Self_ID is the reason we need to
532 -- check for pending abort and priority change below! :(
540 Write_Lock (Self_ID);
542 if Mode = Relative then
543 Abs_Time := Time + Check_Time;
545 Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
548 if Abs_Time > Check_Time then
549 Request := To_Timespec (Abs_Time);
550 Self_ID.Common.State := Delay_Sleep;
553 if Self_ID.Pending_Priority_Change then
554 Self_ID.Pending_Priority_Change := False;
555 Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
556 Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
559 exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
562 Result := pthread_cond_timedwait
563 (Self_ID.Common.LL.CV'Access,
564 Single_RTS_Lock'Access,
567 Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
568 Self_ID.Common.LL.L'Access, Request'Access);
571 exit when Abs_Time <= Monotonic_Clock;
573 pragma Assert (Result = 0 or else
574 Result = ETIMEDOUT or else
578 Self_ID.Common.State := Runnable;
588 SSL.Abort_Undefer.all;
591 ---------------------
592 -- Monotonic_Clock --
593 ---------------------
595 function Monotonic_Clock return Duration is
596 TS : aliased timespec;
597 Result : Interfaces.C.int;
599 Result := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access);
600 pragma Assert (Result = 0);
601 return To_Duration (TS);
608 function RT_Resolution return Duration is
610 -- Returned value must be an integral multiple of Duration'Small (1 ns)
611 -- The following is the best approximation of 1/1024. The clock on the
612 -- DEC Alpha ticks at 1024 Hz.
614 return 0.000_976_563;
621 procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
622 pragma Unreferenced (Reason);
623 Result : Interfaces.C.int;
625 Result := pthread_cond_signal (T.Common.LL.CV'Access);
626 pragma Assert (Result = 0);
633 procedure Yield (Do_Yield : Boolean := True) is
634 Result : Interfaces.C.int;
635 pragma Unreferenced (Result);
638 Result := sched_yield;
646 procedure Set_Priority
648 Prio : System.Any_Priority;
649 Loss_Of_Inheritance : Boolean := False)
651 pragma Unreferenced (Loss_Of_Inheritance);
653 Result : Interfaces.C.int;
654 Param : aliased struct_sched_param;
657 T.Common.Current_Priority := Prio;
658 Param.sched_priority := Interfaces.C.int (Underlying_Priorities (Prio));
660 if Time_Slice_Val > 0 then
661 Result := pthread_setschedparam
662 (T.Common.LL.Thread, SCHED_RR, Param'Access);
664 elsif FIFO_Within_Priorities or else Time_Slice_Val = 0 then
665 Result := pthread_setschedparam
666 (T.Common.LL.Thread, SCHED_FIFO, Param'Access);
669 Result := pthread_setschedparam
670 (T.Common.LL.Thread, SCHED_OTHER, Param'Access);
673 pragma Assert (Result = 0);
680 function Get_Priority (T : Task_Id) return System.Any_Priority is
682 return T.Common.Current_Priority;
689 procedure Enter_Task (Self_ID : Task_Id) is
692 Self_ID.Common.LL.Thread := pthread_self;
693 Specific.Set (Self_ID);
697 for J in Known_Tasks'Range loop
698 if Known_Tasks (J) = null then
699 Known_Tasks (J) := Self_ID;
700 Self_ID.Known_Tasks_Index := J;
712 function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is
714 return new Ada_Task_Control_Block (Entry_Num);
721 function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task;
723 -----------------------------
724 -- Register_Foreign_Thread --
725 -----------------------------
727 function Register_Foreign_Thread return Task_Id is
729 if Is_Valid_Task then
732 return Register_Foreign_Thread (pthread_self);
734 end Register_Foreign_Thread;
740 procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
741 Mutex_Attr : aliased pthread_mutexattr_t;
742 Result : Interfaces.C.int;
743 Cond_Attr : aliased pthread_condattr_t;
746 if not Single_Lock then
747 Result := pthread_mutexattr_init (Mutex_Attr'Access);
748 pragma Assert (Result = 0 or else Result = ENOMEM);
751 Result := pthread_mutex_init
752 (Self_ID.Common.LL.L'Access, Mutex_Attr'Access);
753 pragma Assert (Result = 0 or else Result = ENOMEM);
761 Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
762 pragma Assert (Result = 0);
765 Result := pthread_condattr_init (Cond_Attr'Access);
766 pragma Assert (Result = 0 or else Result = ENOMEM);
769 Result := pthread_cond_init
770 (Self_ID.Common.LL.CV'Access, Cond_Attr'Access);
771 pragma Assert (Result = 0 or else Result = ENOMEM);
777 if not Single_Lock then
778 Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
779 pragma Assert (Result = 0);
785 Result := pthread_condattr_destroy (Cond_Attr'Access);
786 pragma Assert (Result = 0);
793 procedure Create_Task
795 Wrapper : System.Address;
796 Stack_Size : System.Parameters.Size_Type;
797 Priority : System.Any_Priority;
798 Succeeded : out Boolean)
800 Attributes : aliased pthread_attr_t;
801 Adjusted_Stack_Size : Interfaces.C.size_t;
802 Result : Interfaces.C.int;
803 Param : aliased System.OS_Interface.struct_sched_param;
805 use System.Task_Info;
808 if Stack_Size = Unspecified_Size then
809 Adjusted_Stack_Size := Interfaces.C.size_t (Default_Stack_Size);
811 elsif Stack_Size < Minimum_Stack_Size then
812 Adjusted_Stack_Size := Interfaces.C.size_t (Minimum_Stack_Size);
815 Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size);
818 -- Account for the Yellow Zone (2 pages) and the guard page
819 -- right above. See Hide_Yellow_Zone for the rationale.
821 Adjusted_Stack_Size := Adjusted_Stack_Size + 3 * Get_Page_Size;
823 Result := pthread_attr_init (Attributes'Access);
824 pragma Assert (Result = 0 or else Result = ENOMEM);
831 Result := pthread_attr_setdetachstate
832 (Attributes'Access, PTHREAD_CREATE_DETACHED);
833 pragma Assert (Result = 0);
835 Result := pthread_attr_setstacksize
836 (Attributes'Access, Adjusted_Stack_Size);
837 pragma Assert (Result = 0);
839 Param.sched_priority :=
840 Interfaces.C.int (Underlying_Priorities (Priority));
841 Result := pthread_attr_setschedparam
842 (Attributes'Access, Param'Access);
843 pragma Assert (Result = 0);
845 if Time_Slice_Val > 0 then
846 Result := pthread_attr_setschedpolicy
847 (Attributes'Access, System.OS_Interface.SCHED_RR);
849 elsif FIFO_Within_Priorities or else Time_Slice_Val = 0 then
850 Result := pthread_attr_setschedpolicy
851 (Attributes'Access, System.OS_Interface.SCHED_FIFO);
854 Result := pthread_attr_setschedpolicy
855 (Attributes'Access, System.OS_Interface.SCHED_OTHER);
858 pragma Assert (Result = 0);
860 -- Set the scheduling parameters explicitly, since this is the
861 -- only way to force the OS to take e.g. the sched policy and scope
862 -- attributes into account.
864 Result := pthread_attr_setinheritsched
865 (Attributes'Access, PTHREAD_EXPLICIT_SCHED);
866 pragma Assert (Result = 0);
868 T.Common.Current_Priority := Priority;
870 if T.Common.Task_Info /= null then
871 case T.Common.Task_Info.Contention_Scope is
872 when System.Task_Info.Process_Scope =>
873 Result := pthread_attr_setscope
874 (Attributes'Access, PTHREAD_SCOPE_PROCESS);
876 when System.Task_Info.System_Scope =>
877 Result := pthread_attr_setscope
878 (Attributes'Access, PTHREAD_SCOPE_SYSTEM);
880 when System.Task_Info.Default_Scope =>
884 pragma Assert (Result = 0);
887 -- Since the initial signal mask of a thread is inherited from the
888 -- creator, and the Environment task has all its signals masked, we
889 -- do not need to manipulate caller's signal mask at this point.
890 -- All tasks in RTS will have All_Tasks_Mask initially.
892 Result := pthread_create
893 (T.Common.LL.Thread'Access,
895 Thread_Body_Access (Wrapper),
897 pragma Assert (Result = 0 or else Result = EAGAIN);
899 Succeeded := Result = 0;
901 Result := pthread_attr_destroy (Attributes'Access);
902 pragma Assert (Result = 0);
904 if T.Common.Task_Info /= null then
905 -- ??? We're using a process-wide function to implement a task
906 -- specific characteristic.
908 if T.Common.Task_Info.Bind_To_Cpu_Number = 0 then
909 Result := bind_to_cpu (Curpid, 0);
910 elsif T.Common.Task_Info.Bind_To_Cpu_Number > 0 then
911 Result := bind_to_cpu
913 Interfaces.C.unsigned_long (
914 Interfaces.Shift_Left
915 (Interfaces.Unsigned_64'(1),
916 T.Common.Task_Info.Bind_To_Cpu_Number - 1)));
917 pragma Assert (Result = 0);
926 procedure Finalize_TCB (T : Task_Id) is
927 Result : Interfaces.C.int;
929 Is_Self : constant Boolean := T = Self;
931 procedure Free is new
932 Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
935 if not Single_Lock then
936 Result := pthread_mutex_destroy (T.Common.LL.L'Access);
937 pragma Assert (Result = 0);
940 Result := pthread_cond_destroy (T.Common.LL.CV'Access);
941 pragma Assert (Result = 0);
943 if T.Known_Tasks_Index /= -1 then
944 Known_Tasks (T.Known_Tasks_Index) := null;
958 procedure Exit_Task is
967 procedure Abort_Task (T : Task_Id) is
968 Result : Interfaces.C.int;
970 Result := pthread_kill (T.Common.LL.Thread,
971 Signal (System.Interrupt_Management.Abort_Task_Interrupt));
972 pragma Assert (Result = 0);
979 procedure Initialize (S : in out Suspension_Object) is
980 Mutex_Attr : aliased pthread_mutexattr_t;
981 Cond_Attr : aliased pthread_condattr_t;
982 Result : Interfaces.C.int;
984 -- Initialize internal state. It is always initialized to False (ARM
990 -- Initialize internal mutex
992 Result := pthread_mutexattr_init (Mutex_Attr'Access);
993 pragma Assert (Result = 0 or else Result = ENOMEM);
995 if Result = ENOMEM then
999 Result := pthread_mutex_init (S.L'Access, Mutex_Attr'Access);
1000 pragma Assert (Result = 0 or else Result = ENOMEM);
1002 if Result = ENOMEM then
1003 Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
1004 raise Storage_Error;
1007 Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
1008 pragma Assert (Result = 0);
1010 -- Initialize internal condition variable
1012 Result := pthread_condattr_init (Cond_Attr'Access);
1013 pragma Assert (Result = 0 or else Result = ENOMEM);
1015 Result := pthread_cond_init (S.CV'Access, Cond_Attr'Access);
1017 pragma Assert (Result = 0 or else Result = ENOMEM);
1020 Result := pthread_mutex_destroy (S.L'Access);
1021 pragma Assert (Result = 0);
1023 if Result = ENOMEM then
1024 raise Storage_Error;
1033 procedure Finalize (S : in out Suspension_Object) is
1034 Result : Interfaces.C.int;
1036 -- Destroy internal mutex
1038 Result := pthread_mutex_destroy (S.L'Access);
1039 pragma Assert (Result = 0);
1041 -- Destroy internal condition variable
1043 Result := pthread_cond_destroy (S.CV'Access);
1044 pragma Assert (Result = 0);
1051 function Current_State (S : Suspension_Object) return Boolean is
1053 -- We do not want to use lock on this read operation. State is marked
1054 -- as Atomic so that we ensure that the value retrieved is correct.
1063 procedure Set_False (S : in out Suspension_Object) is
1064 Result : Interfaces.C.int;
1066 Result := pthread_mutex_lock (S.L'Access);
1067 pragma Assert (Result = 0);
1071 Result := pthread_mutex_unlock (S.L'Access);
1072 pragma Assert (Result = 0);
1079 procedure Set_True (S : in out Suspension_Object) is
1080 Result : Interfaces.C.int;
1082 Result := pthread_mutex_lock (S.L'Access);
1083 pragma Assert (Result = 0);
1085 -- If there is already a task waiting on this suspension object then
1086 -- we resume it, leaving the state of the suspension object to False,
1087 -- as it is specified in ARM D.10 par. 9. Otherwise, it just leaves
1088 -- the state to True.
1094 Result := pthread_cond_signal (S.CV'Access);
1095 pragma Assert (Result = 0);
1100 Result := pthread_mutex_unlock (S.L'Access);
1101 pragma Assert (Result = 0);
1104 ------------------------
1105 -- Suspend_Until_True --
1106 ------------------------
1108 procedure Suspend_Until_True (S : in out Suspension_Object) is
1109 Result : Interfaces.C.int;
1111 Result := pthread_mutex_lock (S.L'Access);
1112 pragma Assert (Result = 0);
1115 -- Program_Error must be raised upon calling Suspend_Until_True
1116 -- if another task is already waiting on that suspension object
1117 -- (ARM D.10 par. 10).
1119 Result := pthread_mutex_unlock (S.L'Access);
1120 pragma Assert (Result = 0);
1122 raise Program_Error;
1124 -- Suspend the task if the state is False. Otherwise, the task
1125 -- continues its execution, and the state of the suspension object
1126 -- is set to False (ARM D.10 par. 9).
1132 Result := pthread_cond_wait (S.CV'Access, S.L'Access);
1136 Result := pthread_mutex_unlock (S.L'Access);
1137 pragma Assert (Result = 0);
1138 end Suspend_Until_True;
1146 function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
1147 pragma Unreferenced (Self_ID);
1152 --------------------
1153 -- Check_No_Locks --
1154 --------------------
1156 function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
1157 pragma Unreferenced (Self_ID);
1162 ----------------------
1163 -- Environment_Task --
1164 ----------------------
1166 function Environment_Task return Task_Id is
1168 return Environment_Task_Id;
1169 end Environment_Task;
1175 procedure Lock_RTS is
1177 Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
1184 procedure Unlock_RTS is
1186 Unlock (Single_RTS_Lock'Access, Global_Lock => True);
1193 function Suspend_Task
1195 Thread_Self : Thread_Id) return Boolean
1197 pragma Warnings (Off, T);
1198 pragma Warnings (Off, Thread_Self);
1207 function Resume_Task
1209 Thread_Self : Thread_Id) return Boolean
1211 pragma Warnings (Off, T);
1212 pragma Warnings (Off, Thread_Self);
1221 procedure Initialize (Environment_Task : Task_Id) is
1222 act : aliased struct_sigaction;
1223 old_act : aliased struct_sigaction;
1224 Tmp_Set : aliased sigset_t;
1225 Result : Interfaces.C.int;
1228 (Int : System.Interrupt_Management.Interrupt_ID) return Character;
1229 pragma Import (C, State, "__gnat_get_interrupt_state");
1230 -- Get interrupt state. Defined in a-init.c. The input argument is
1231 -- the interrupt number, and the result is one of the following:
1233 Default : constant Character := 's';
1234 -- 'n' this interrupt not set by any Interrupt_State pragma
1235 -- 'u' Interrupt_State pragma set state to User
1236 -- 'r' Interrupt_State pragma set state to Runtime
1237 -- 's' Interrupt_State pragma set state to System (use "default"
1241 Environment_Task_Id := Environment_Task;
1243 -- Initialize the lock used to synchronize chain of all ATCBs
1245 Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
1247 Specific.Initialize (Environment_Task);
1249 Enter_Task (Environment_Task);
1251 -- Install the abort-signal handler
1253 if State (System.Interrupt_Management.Abort_Task_Interrupt)
1257 act.sa_handler := Abort_Handler'Address;
1259 Result := sigemptyset (Tmp_Set'Access);
1260 pragma Assert (Result = 0);
1261 act.sa_mask := Tmp_Set;
1265 (Signal (System.Interrupt_Management.Abort_Task_Interrupt),
1266 act'Unchecked_Access,
1267 old_act'Unchecked_Access);
1268 pragma Assert (Result = 0);
1274 Result : Interfaces.C.int;
1276 -- Prepare the set of signals that should unblocked in all tasks
1278 Result := sigemptyset (Unblocked_Signal_Mask'Access);
1279 pragma Assert (Result = 0);
1281 for J in Interrupt_Management.Interrupt_ID loop
1282 if System.Interrupt_Management.Keep_Unmasked (J) then
1283 Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J));
1284 pragma Assert (Result = 0);
1290 end System.Task_Primitives.Operations;