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 POSIX-like version of this package
36 -- This package contains all the GNULL primitives that interface directly
37 -- with the underlying OS.
39 -- Note: this file can only be used for POSIX compliant systems that
40 -- implement SCHED_FIFO and Ceiling Locking correctly.
42 -- For configurations where SCHED_FIFO and priority ceiling are not a
43 -- requirement, this file can also be used (e.g AiX threads)
46 -- Turn off polling, we do not want ATC polling to take place during
47 -- tasking operations. It causes infinite loops and other problems.
49 with System.Tasking.Debug;
50 -- used for Known_Tasks
52 with System.Task_Info;
53 -- used for Task_Info_Type
59 with System.Interrupt_Management;
60 -- used for Keep_Unmasked
61 -- Abort_Task_Interrupt
64 with System.Parameters;
68 -- used for Ada_Task_Control_Block
71 with System.Soft_Links;
72 -- used for Defer/Undefer_Abort
74 -- Note that we do not use System.Tasking.Initialization directly since
75 -- this is a higher level package that we shouldn't depend on. For example
76 -- when using the restricted run time, it is replaced by
77 -- System.Tasking.Restricted.Stages.
79 with System.OS_Primitives;
80 -- used for Delay_Modes
82 with Unchecked_Conversion;
83 with Unchecked_Deallocation;
85 package body System.Task_Primitives.Operations is
87 use System.Tasking.Debug;
90 use System.OS_Interface;
91 use System.Parameters;
92 use System.OS_Primitives;
94 package SSL renames System.Soft_Links;
100 -- The followings are logically constants, but need to be initialized
103 Single_RTS_Lock : aliased RTS_Lock;
104 -- This is a lock to allow only one thread of control in the RTS at
105 -- a time; it is used to execute in mutual exclusion from all other tasks.
106 -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
108 ATCB_Key : aliased pthread_key_t;
109 -- Key used to find the Ada Task_Id associated with a thread
111 Environment_Task_Id : Task_Id;
112 -- A variable to hold Task_Id for the environment task.
114 Locking_Policy : Character;
115 pragma Import (C, Locking_Policy, "__gl_locking_policy");
116 -- Value of the pragma Locking_Policy:
117 -- 'C' for Ceiling_Locking
118 -- 'I' for Inherit_Locking
121 Unblocked_Signal_Mask : aliased sigset_t;
122 -- The set of signals that should unblocked in all tasks
124 -- The followings are internal configuration constants needed.
126 Next_Serial_Number : Task_Serial_Number := 100;
127 -- We start at 100, to reserve some special values for
128 -- using in error checking.
130 Time_Slice_Val : Integer;
131 pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
133 Dispatching_Policy : Character;
134 pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
136 FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F';
137 -- Indicates whether FIFO_Within_Priorities is set.
139 Foreign_Task_Elaborated : aliased Boolean := True;
140 -- Used to identified fake tasks (i.e., non-Ada Threads).
148 procedure Initialize (Environment_Task : Task_Id);
149 pragma Inline (Initialize);
150 -- Initialize various data needed by this package.
152 function Is_Valid_Task return Boolean;
153 pragma Inline (Is_Valid_Task);
154 -- Does executing thread have a TCB?
156 procedure Set (Self_Id : Task_Id);
158 -- Set the self id for the current task.
160 function Self return Task_Id;
161 pragma Inline (Self);
162 -- Return a pointer to the Ada Task Control Block of the calling task.
166 package body Specific is separate;
167 -- The body of this package is target specific.
169 ---------------------------------
170 -- Support for foreign threads --
171 ---------------------------------
173 function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id;
174 -- Allocate and Initialize a new ATCB for the current Thread.
176 function Register_Foreign_Thread
177 (Thread : Thread_Id) return Task_Id is separate;
179 -----------------------
180 -- Local Subprograms --
181 -----------------------
183 procedure Abort_Handler (Sig : Signal);
184 -- Signal handler used to implement asynchronous abort.
185 -- See also comment before body, below.
187 function To_Address is new Unchecked_Conversion (Task_Id, System.Address);
193 -- Target-dependent binding of inter-thread Abort signal to
194 -- the raising of the Abort_Signal exception.
196 -- The technical issues and alternatives here are essentially
197 -- the same as for raising exceptions in response to other
198 -- signals (e.g. Storage_Error). See code and comments in
199 -- the package body System.Interrupt_Management.
201 -- Some implementations may not allow an exception to be propagated
202 -- out of a handler, and others might leave the signal or
203 -- interrupt that invoked this handler masked after the exceptional
204 -- return to the application code.
206 -- GNAT exceptions are originally implemented using setjmp()/longjmp().
207 -- On most UNIX systems, this will allow transfer out of a signal handler,
208 -- which is usually the only mechanism available for implementing
209 -- asynchronous handlers of this kind. However, some
210 -- systems do not restore the signal mask on longjmp(), leaving the
211 -- abort signal masked.
213 procedure Abort_Handler (Sig : Signal) is
214 pragma Warnings (Off, Sig);
216 T : constant Task_Id := Self;
217 Result : Interfaces.C.int;
218 Old_Set : aliased sigset_t;
221 -- It is not safe to raise an exception when using ZCX and the GCC
222 -- exception handling mechanism.
224 if ZCX_By_Default and then GCC_ZCX_Support then
228 if T.Deferral_Level = 0
229 and then T.Pending_ATC_Level < T.ATC_Nesting_Level and then
234 -- Make sure signals used for RTS internal purpose are unmasked
236 Result := pthread_sigmask (SIG_UNBLOCK,
237 Unblocked_Signal_Mask'Unchecked_Access, Old_Set'Unchecked_Access);
238 pragma Assert (Result = 0);
240 raise Standard'Abort_Signal;
248 procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
249 Stack_Base : constant Address := Get_Stack_Base (T.Common.LL.Thread);
250 Guard_Page_Address : Address;
252 Res : Interfaces.C.int;
255 if Stack_Base_Available then
257 -- Compute the guard page address
259 Guard_Page_Address :=
260 Stack_Base - (Stack_Base mod Get_Page_Size) + Get_Page_Size;
263 Res := mprotect (Guard_Page_Address, Get_Page_Size, PROT_ON);
265 Res := mprotect (Guard_Page_Address, Get_Page_Size, PROT_OFF);
268 pragma Assert (Res = 0);
276 function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
278 return T.Common.LL.Thread;
285 function Self return Task_Id renames Specific.Self;
287 ---------------------
288 -- Initialize_Lock --
289 ---------------------
291 -- Note: mutexes and cond_variables needed per-task basis are
292 -- initialized in Intialize_TCB and the Storage_Error is
293 -- handled. Other mutexes (such as RTS_Lock, Memory_Lock...)
294 -- used in RTS is initialized before any status change of RTS.
295 -- Therefore rasing Storage_Error in the following routines
296 -- should be able to be handled safely.
298 procedure Initialize_Lock
299 (Prio : System.Any_Priority;
302 Attributes : aliased pthread_mutexattr_t;
303 Result : Interfaces.C.int;
306 Result := pthread_mutexattr_init (Attributes'Access);
307 pragma Assert (Result = 0 or else Result = ENOMEM);
309 if Result = ENOMEM then
313 if Locking_Policy = 'C' then
314 Result := pthread_mutexattr_setprotocol
315 (Attributes'Access, PTHREAD_PRIO_PROTECT);
316 pragma Assert (Result = 0);
318 Result := pthread_mutexattr_setprioceiling
319 (Attributes'Access, Interfaces.C.int (Prio));
320 pragma Assert (Result = 0);
322 elsif Locking_Policy = 'I' then
323 Result := pthread_mutexattr_setprotocol
324 (Attributes'Access, PTHREAD_PRIO_INHERIT);
325 pragma Assert (Result = 0);
328 Result := pthread_mutex_init (L, Attributes'Access);
329 pragma Assert (Result = 0 or else Result = ENOMEM);
331 if Result = ENOMEM then
335 Result := pthread_mutexattr_destroy (Attributes'Access);
336 pragma Assert (Result = 0);
339 procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is
340 pragma Warnings (Off, Level);
342 Attributes : aliased pthread_mutexattr_t;
343 Result : Interfaces.C.int;
346 Result := pthread_mutexattr_init (Attributes'Access);
347 pragma Assert (Result = 0 or else Result = ENOMEM);
349 if Result = ENOMEM then
353 if Locking_Policy = 'C' then
354 Result := pthread_mutexattr_setprotocol
355 (Attributes'Access, PTHREAD_PRIO_PROTECT);
356 pragma Assert (Result = 0);
358 Result := pthread_mutexattr_setprioceiling
359 (Attributes'Access, Interfaces.C.int (System.Any_Priority'Last));
360 pragma Assert (Result = 0);
362 elsif Locking_Policy = 'I' then
363 Result := pthread_mutexattr_setprotocol
364 (Attributes'Access, PTHREAD_PRIO_INHERIT);
365 pragma Assert (Result = 0);
368 Result := pthread_mutex_init (L, Attributes'Access);
369 pragma Assert (Result = 0 or else Result = ENOMEM);
371 if Result = ENOMEM then
372 Result := pthread_mutexattr_destroy (Attributes'Access);
376 Result := pthread_mutexattr_destroy (Attributes'Access);
377 pragma Assert (Result = 0);
384 procedure Finalize_Lock (L : access Lock) is
385 Result : Interfaces.C.int;
388 Result := pthread_mutex_destroy (L);
389 pragma Assert (Result = 0);
392 procedure Finalize_Lock (L : access RTS_Lock) is
393 Result : Interfaces.C.int;
396 Result := pthread_mutex_destroy (L);
397 pragma Assert (Result = 0);
404 procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
405 Result : Interfaces.C.int;
408 Result := pthread_mutex_lock (L);
410 -- Assume that the cause of EINVAL is a priority ceiling violation
412 Ceiling_Violation := (Result = EINVAL);
413 pragma Assert (Result = 0 or else Result = EINVAL);
417 (L : access RTS_Lock;
418 Global_Lock : Boolean := False)
420 Result : Interfaces.C.int;
423 if not Single_Lock or else Global_Lock then
424 Result := pthread_mutex_lock (L);
425 pragma Assert (Result = 0);
429 procedure Write_Lock (T : Task_Id) is
430 Result : Interfaces.C.int;
433 if not Single_Lock then
434 Result := pthread_mutex_lock (T.Common.LL.L'Access);
435 pragma Assert (Result = 0);
443 procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
445 Write_Lock (L, Ceiling_Violation);
452 procedure Unlock (L : access Lock) is
453 Result : Interfaces.C.int;
456 Result := pthread_mutex_unlock (L);
457 pragma Assert (Result = 0);
460 procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
461 Result : Interfaces.C.int;
464 if not Single_Lock or else Global_Lock then
465 Result := pthread_mutex_unlock (L);
466 pragma Assert (Result = 0);
470 procedure Unlock (T : Task_Id) is
471 Result : Interfaces.C.int;
474 if not Single_Lock then
475 Result := pthread_mutex_unlock (T.Common.LL.L'Access);
476 pragma Assert (Result = 0);
486 Reason : System.Tasking.Task_States)
488 pragma Warnings (Off, Reason);
490 Result : Interfaces.C.int;
494 Result := pthread_cond_wait
495 (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
497 Result := pthread_cond_wait
498 (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
501 -- EINTR is not considered a failure.
503 pragma Assert (Result = 0 or else Result = EINTR);
510 -- This is for use within the run-time system, so abort is
511 -- assumed to be already deferred, and the caller should be
512 -- holding its own ATCB lock.
514 procedure Timed_Sleep
517 Mode : ST.Delay_Modes;
518 Reason : Task_States;
519 Timedout : out Boolean;
520 Yielded : out Boolean)
522 pragma Warnings (Off, Reason);
524 Check_Time : constant Duration := Monotonic_Clock;
527 Request : aliased timespec;
528 Result : Interfaces.C.int;
534 if Mode = Relative then
535 Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time;
537 if Relative_Timed_Wait then
538 Rel_Time := Duration'Min (Max_Sensible_Delay, Time);
542 Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
544 if Relative_Timed_Wait then
545 Rel_Time := Duration'Min (Max_Sensible_Delay, Time - Check_Time);
549 if Abs_Time > Check_Time then
550 if Relative_Timed_Wait then
551 Request := To_Timespec (Rel_Time);
553 Request := To_Timespec (Abs_Time);
557 exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
558 or else Self_ID.Pending_Priority_Change;
561 Result := pthread_cond_timedwait
562 (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access,
566 Result := pthread_cond_timedwait
567 (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access,
571 exit when Abs_Time <= Monotonic_Clock;
573 if Result = 0 or Result = EINTR then
575 -- Somebody may have called Wakeup for us
581 pragma Assert (Result = ETIMEDOUT);
590 -- This is for use in implementing delay statements, so
591 -- we assume the caller is abort-deferred but is holding
594 procedure Timed_Delay
597 Mode : ST.Delay_Modes)
599 Check_Time : constant Duration := Monotonic_Clock;
602 Request : aliased timespec;
603 Result : Interfaces.C.int;
606 -- Only the little window between deferring abort and
607 -- locking Self_ID is the reason we need to
608 -- check for pending abort and priority change below! :(
616 Write_Lock (Self_ID);
618 if Mode = Relative then
619 Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time;
621 if Relative_Timed_Wait then
622 Rel_Time := Duration'Min (Max_Sensible_Delay, Time);
626 Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
628 if Relative_Timed_Wait then
629 Rel_Time := Duration'Min (Max_Sensible_Delay, Time - Check_Time);
633 if Abs_Time > Check_Time then
634 if Relative_Timed_Wait then
635 Request := To_Timespec (Rel_Time);
637 Request := To_Timespec (Abs_Time);
640 Self_ID.Common.State := Delay_Sleep;
643 if Self_ID.Pending_Priority_Change then
644 Self_ID.Pending_Priority_Change := False;
645 Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
646 Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
649 exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
652 Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
653 Single_RTS_Lock'Access, Request'Access);
655 Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
656 Self_ID.Common.LL.L'Access, Request'Access);
659 exit when Abs_Time <= Monotonic_Clock;
661 pragma Assert (Result = 0
662 or else Result = ETIMEDOUT
663 or else Result = EINTR);
666 Self_ID.Common.State := Runnable;
675 Result := sched_yield;
676 SSL.Abort_Undefer.all;
679 ---------------------
680 -- Monotonic_Clock --
681 ---------------------
683 function Monotonic_Clock return Duration is
684 TS : aliased timespec;
685 Result : Interfaces.C.int;
687 Result := clock_gettime
688 (clock_id => CLOCK_REALTIME, tp => TS'Unchecked_Access);
689 pragma Assert (Result = 0);
690 return To_Duration (TS);
697 function RT_Resolution return Duration is
706 procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
707 pragma Warnings (Off, Reason);
708 Result : Interfaces.C.int;
710 Result := pthread_cond_signal (T.Common.LL.CV'Access);
711 pragma Assert (Result = 0);
718 procedure Yield (Do_Yield : Boolean := True) is
719 Result : Interfaces.C.int;
720 pragma Unreferenced (Result);
723 Result := sched_yield;
731 procedure Set_Priority
733 Prio : System.Any_Priority;
734 Loss_Of_Inheritance : Boolean := False)
736 pragma Warnings (Off, Loss_Of_Inheritance);
738 Result : Interfaces.C.int;
739 Param : aliased struct_sched_param;
742 T.Common.Current_Priority := Prio;
743 Param.sched_priority := Interfaces.C.int (Prio);
745 if Time_Slice_Supported and then Time_Slice_Val > 0 then
746 Result := pthread_setschedparam
747 (T.Common.LL.Thread, SCHED_RR, Param'Access);
749 elsif FIFO_Within_Priorities or else Time_Slice_Val = 0 then
750 Result := pthread_setschedparam
751 (T.Common.LL.Thread, SCHED_FIFO, Param'Access);
754 Result := pthread_setschedparam
755 (T.Common.LL.Thread, SCHED_OTHER, Param'Access);
758 pragma Assert (Result = 0);
765 function Get_Priority (T : Task_Id) return System.Any_Priority is
767 return T.Common.Current_Priority;
774 procedure Enter_Task (Self_ID : Task_Id) is
776 Self_ID.Common.LL.Thread := pthread_self;
777 Self_ID.Common.LL.LWP := lwp_self;
779 Specific.Set (Self_ID);
783 for J in Known_Tasks'Range loop
784 if Known_Tasks (J) = null then
785 Known_Tasks (J) := Self_ID;
786 Self_ID.Known_Tasks_Index := J;
798 function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is
800 return new Ada_Task_Control_Block (Entry_Num);
807 function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task;
809 -----------------------------
810 -- Register_Foreign_Thread --
811 -----------------------------
813 function Register_Foreign_Thread return Task_Id is
815 if Is_Valid_Task then
818 return Register_Foreign_Thread (pthread_self);
820 end Register_Foreign_Thread;
826 procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
827 Mutex_Attr : aliased pthread_mutexattr_t;
828 Result : Interfaces.C.int;
829 Cond_Attr : aliased pthread_condattr_t;
832 -- Give the task a unique serial number.
834 Self_ID.Serial_Number := Next_Serial_Number;
835 Next_Serial_Number := Next_Serial_Number + 1;
836 pragma Assert (Next_Serial_Number /= 0);
838 if not Single_Lock then
839 Result := pthread_mutexattr_init (Mutex_Attr'Access);
840 pragma Assert (Result = 0 or else Result = ENOMEM);
843 if Locking_Policy = 'C' then
844 Result := pthread_mutexattr_setprotocol
845 (Mutex_Attr'Access, PTHREAD_PRIO_PROTECT);
846 pragma Assert (Result = 0);
848 Result := pthread_mutexattr_setprioceiling
850 Interfaces.C.int (System.Any_Priority'Last));
851 pragma Assert (Result = 0);
853 elsif Locking_Policy = 'I' then
854 Result := pthread_mutexattr_setprotocol
855 (Mutex_Attr'Access, PTHREAD_PRIO_INHERIT);
856 pragma Assert (Result = 0);
859 Result := pthread_mutex_init (Self_ID.Common.LL.L'Access,
861 pragma Assert (Result = 0 or else Result = ENOMEM);
869 Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
870 pragma Assert (Result = 0);
873 Result := pthread_condattr_init (Cond_Attr'Access);
874 pragma Assert (Result = 0 or else Result = ENOMEM);
877 Result := pthread_cond_init (Self_ID.Common.LL.CV'Access,
879 pragma Assert (Result = 0 or else Result = ENOMEM);
885 if not Single_Lock then
886 Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
887 pragma Assert (Result = 0);
893 Result := pthread_condattr_destroy (Cond_Attr'Access);
894 pragma Assert (Result = 0);
901 procedure Create_Task
903 Wrapper : System.Address;
904 Stack_Size : System.Parameters.Size_Type;
905 Priority : System.Any_Priority;
906 Succeeded : out Boolean)
908 Attributes : aliased pthread_attr_t;
909 Adjusted_Stack_Size : Interfaces.C.size_t;
910 Result : Interfaces.C.int;
912 function Thread_Body_Access is new
913 Unchecked_Conversion (System.Address, Thread_Body);
915 use System.Task_Info;
918 if Stack_Size = Unspecified_Size then
919 Adjusted_Stack_Size := Interfaces.C.size_t (Default_Stack_Size);
921 elsif Stack_Size < Minimum_Stack_Size then
922 Adjusted_Stack_Size := Interfaces.C.size_t (Minimum_Stack_Size);
925 Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size);
928 if Stack_Base_Available then
929 -- If Stack Checking is supported then allocate 2 additional pages:
931 -- In the worst case, stack is allocated at something like
932 -- N * Get_Page_Size - epsilon, we need to add the size for 2 pages
933 -- to be sure the effective stack size is greater than what
936 Adjusted_Stack_Size := Adjusted_Stack_Size + 2 * Get_Page_Size;
939 Result := pthread_attr_init (Attributes'Access);
940 pragma Assert (Result = 0 or else Result = ENOMEM);
947 Result := pthread_attr_setdetachstate
948 (Attributes'Access, PTHREAD_CREATE_DETACHED);
949 pragma Assert (Result = 0);
951 Result := pthread_attr_setstacksize
952 (Attributes'Access, Adjusted_Stack_Size);
953 pragma Assert (Result = 0);
955 if T.Common.Task_Info /= Default_Scope then
957 -- We are assuming that Scope_Type has the same values than the
958 -- corresponding C macros
960 Result := pthread_attr_setscope
961 (Attributes'Access, Task_Info_Type'Pos (T.Common.Task_Info));
962 pragma Assert (Result = 0);
965 -- Since the initial signal mask of a thread is inherited from the
966 -- creator, and the Environment task has all its signals masked, we
967 -- do not need to manipulate caller's signal mask at this point.
968 -- All tasks in RTS will have All_Tasks_Mask initially.
970 Result := pthread_create
971 (T.Common.LL.Thread'Access,
973 Thread_Body_Access (Wrapper),
975 pragma Assert (Result = 0 or else Result = EAGAIN);
977 Succeeded := Result = 0;
979 Result := pthread_attr_destroy (Attributes'Access);
980 pragma Assert (Result = 0);
982 Set_Priority (T, Priority);
989 procedure Finalize_TCB (T : Task_Id) is
990 Result : Interfaces.C.int;
992 Is_Self : constant Boolean := T = Self;
994 procedure Free is new
995 Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
998 if not Single_Lock then
999 Result := pthread_mutex_destroy (T.Common.LL.L'Access);
1000 pragma Assert (Result = 0);
1003 Result := pthread_cond_destroy (T.Common.LL.CV'Access);
1004 pragma Assert (Result = 0);
1006 if T.Known_Tasks_Index /= -1 then
1007 Known_Tasks (T.Known_Tasks_Index) := null;
1013 Specific.Set (null);
1021 procedure Exit_Task is
1023 -- Mark this task as unknown, so that if Self is called, it won't
1024 -- return a dangling pointer.
1026 Specific.Set (null);
1033 procedure Abort_Task (T : Task_Id) is
1034 Result : Interfaces.C.int;
1036 Result := pthread_kill (T.Common.LL.Thread,
1037 Signal (System.Interrupt_Management.Abort_Task_Interrupt));
1038 pragma Assert (Result = 0);
1045 procedure Initialize (S : in out Suspension_Object) is
1046 Mutex_Attr : aliased pthread_mutexattr_t;
1047 Cond_Attr : aliased pthread_condattr_t;
1048 Result : Interfaces.C.int;
1050 -- Initialize internal state. It is always initialized to False (ARM
1056 -- Initialize internal mutex
1058 Result := pthread_mutexattr_init (Mutex_Attr'Access);
1059 pragma Assert (Result = 0 or else Result = ENOMEM);
1061 if Result = ENOMEM then
1062 raise Storage_Error;
1065 Result := pthread_mutex_init (S.L'Access, Mutex_Attr'Access);
1066 pragma Assert (Result = 0 or else Result = ENOMEM);
1068 if Result = ENOMEM then
1069 Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
1070 pragma Assert (Result = 0);
1072 raise Storage_Error;
1075 Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
1076 pragma Assert (Result = 0);
1078 -- Initialize internal condition variable
1080 Result := pthread_condattr_init (Cond_Attr'Access);
1081 pragma Assert (Result = 0 or else Result = ENOMEM);
1084 Result := pthread_mutex_destroy (S.L'Access);
1085 pragma Assert (Result = 0);
1087 if Result = ENOMEM then
1088 raise Storage_Error;
1092 Result := pthread_cond_init (S.CV'Access, Cond_Attr'Access);
1093 pragma Assert (Result = 0 or else Result = ENOMEM);
1096 Result := pthread_mutex_destroy (S.L'Access);
1097 pragma Assert (Result = 0);
1099 if Result = ENOMEM then
1100 Result := pthread_condattr_destroy (Cond_Attr'Access);
1101 pragma Assert (Result = 0);
1103 raise Storage_Error;
1107 Result := pthread_condattr_destroy (Cond_Attr'Access);
1108 pragma Assert (Result = 0);
1115 procedure Finalize (S : in out Suspension_Object) is
1116 Result : Interfaces.C.int;
1118 -- Destroy internal mutex
1120 Result := pthread_mutex_destroy (S.L'Access);
1121 pragma Assert (Result = 0);
1123 -- Destroy internal condition variable
1125 Result := pthread_cond_destroy (S.CV'Access);
1126 pragma Assert (Result = 0);
1133 function Current_State (S : Suspension_Object) return Boolean is
1135 -- We do not want to use lock on this read operation. State is marked
1136 -- as Atomic so that we ensure that the value retrieved is correct.
1145 procedure Set_False (S : in out Suspension_Object) is
1146 Result : Interfaces.C.int;
1148 Result := pthread_mutex_lock (S.L'Access);
1149 pragma Assert (Result = 0);
1153 Result := pthread_mutex_unlock (S.L'Access);
1154 pragma Assert (Result = 0);
1161 procedure Set_True (S : in out Suspension_Object) is
1162 Result : Interfaces.C.int;
1164 Result := pthread_mutex_lock (S.L'Access);
1165 pragma Assert (Result = 0);
1167 -- If there is already a task waiting on this suspension object then
1168 -- we resume it, leaving the state of the suspension object to False,
1169 -- as it is specified in ARM D.10 par. 9. Otherwise, it just leaves
1170 -- the state to True.
1176 Result := pthread_cond_signal (S.CV'Access);
1177 pragma Assert (Result = 0);
1182 Result := pthread_mutex_unlock (S.L'Access);
1183 pragma Assert (Result = 0);
1186 ------------------------
1187 -- Suspend_Until_True --
1188 ------------------------
1190 procedure Suspend_Until_True (S : in out Suspension_Object) is
1191 Result : Interfaces.C.int;
1193 Result := pthread_mutex_lock (S.L'Access);
1194 pragma Assert (Result = 0);
1197 -- Program_Error must be raised upon calling Suspend_Until_True
1198 -- if another task is already waiting on that suspension object
1199 -- (ARM D.10 par. 10).
1201 Result := pthread_mutex_unlock (S.L'Access);
1202 pragma Assert (Result = 0);
1204 raise Program_Error;
1206 -- Suspend the task if the state is False. Otherwise, the task
1207 -- continues its execution, and the state of the suspension object
1208 -- is set to False (ARM D.10 par. 9).
1214 Result := pthread_cond_wait (S.CV'Access, S.L'Access);
1218 Result := pthread_mutex_unlock (S.L'Access);
1219 pragma Assert (Result = 0);
1220 end Suspend_Until_True;
1228 function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
1229 pragma Warnings (Off, Self_ID);
1234 --------------------
1235 -- Check_No_Locks --
1236 --------------------
1238 function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
1239 pragma Warnings (Off, Self_ID);
1244 ----------------------
1245 -- Environment_Task --
1246 ----------------------
1248 function Environment_Task return Task_Id is
1250 return Environment_Task_Id;
1251 end Environment_Task;
1257 procedure Lock_RTS is
1259 Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
1266 procedure Unlock_RTS is
1268 Unlock (Single_RTS_Lock'Access, Global_Lock => True);
1275 function Suspend_Task
1277 Thread_Self : Thread_Id) return Boolean
1279 pragma Warnings (Off, T);
1280 pragma Warnings (Off, Thread_Self);
1289 function Resume_Task
1291 Thread_Self : Thread_Id) return Boolean
1293 pragma Warnings (Off, T);
1294 pragma Warnings (Off, Thread_Self);
1303 procedure Initialize (Environment_Task : Task_Id) is
1304 act : aliased struct_sigaction;
1305 old_act : aliased struct_sigaction;
1306 Tmp_Set : aliased sigset_t;
1307 Result : Interfaces.C.int;
1310 (Int : System.Interrupt_Management.Interrupt_ID) return Character;
1311 pragma Import (C, State, "__gnat_get_interrupt_state");
1312 -- Get interrupt state. Defined in a-init.c
1313 -- The input argument is the interrupt number,
1314 -- and the result is one of the following:
1316 Default : constant Character := 's';
1317 -- 'n' this interrupt not set by any Interrupt_State pragma
1318 -- 'u' Interrupt_State pragma set state to User
1319 -- 'r' Interrupt_State pragma set state to Runtime
1320 -- 's' Interrupt_State pragma set state to System (use "default"
1324 Environment_Task_Id := Environment_Task;
1326 -- Initialize the lock used to synchronize chain of all ATCBs.
1328 Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
1330 Specific.Initialize (Environment_Task);
1332 Enter_Task (Environment_Task);
1334 -- Install the abort-signal handler
1336 if State (System.Interrupt_Management.Abort_Task_Interrupt)
1340 act.sa_handler := Abort_Handler'Address;
1342 Result := sigemptyset (Tmp_Set'Access);
1343 pragma Assert (Result = 0);
1344 act.sa_mask := Tmp_Set;
1348 (Signal (System.Interrupt_Management.Abort_Task_Interrupt),
1349 act'Unchecked_Access,
1350 old_act'Unchecked_Access);
1351 pragma Assert (Result = 0);
1357 Result : Interfaces.C.int;
1359 -- Prepare the set of signals that should unblocked in all tasks
1361 Result := sigemptyset (Unblocked_Signal_Mask'Access);
1362 pragma Assert (Result = 0);
1364 for J in Interrupt_Management.Interrupt_ID loop
1365 if System.Interrupt_Management.Keep_Unmasked (J) then
1366 Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J));
1367 pragma Assert (Result = 0);
1371 end System.Task_Primitives.Operations;