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, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, 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 IRIX (pthread library) 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.Task_Info;
49 with System.Tasking.Debug;
50 -- used for Known_Tasks
55 with System.Interrupt_Management;
56 -- used for Keep_Unmasked
57 -- Abort_Task_Interrupt
60 with System.Parameters;
64 -- used for Ada_Task_Control_Block
67 with System.Soft_Links;
68 -- used for Defer/Undefer_Abort
70 -- Note that we do not use System.Tasking.Initialization directly since
71 -- this is a higher level package that we shouldn't depend on. For example
72 -- when using the restricted run time, it is replaced by
73 -- System.Tasking.Restricted.Stages.
75 with System.Program_Info;
76 -- used for Default_Task_Stack
79 -- Pthread_Sched_Signal
82 with System.OS_Interface;
83 -- used for various type, constant, and operations
85 with System.OS_Primitives;
86 -- used for Delay_Modes
88 with Unchecked_Conversion;
89 with Unchecked_Deallocation;
91 package body System.Task_Primitives.Operations is
94 use System.Tasking.Debug;
96 use System.OS_Interface;
97 use System.OS_Primitives;
98 use System.Parameters;
100 package SSL renames System.Soft_Links;
106 -- The followings are logically constants, but need to be initialized
109 Single_RTS_Lock : aliased RTS_Lock;
110 -- This is a lock to allow only one thread of control in the RTS at
111 -- a time; it is used to execute in mutual exclusion from all other tasks.
112 -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
114 ATCB_Key : aliased pthread_key_t;
115 -- Key used to find the Ada Task_Id associated with a thread
117 Environment_Task_Id : Task_Id;
118 -- A variable to hold Task_Id for the environment task
120 Locking_Policy : Character;
121 pragma Import (C, Locking_Policy, "__gl_locking_policy");
123 Real_Time_Clock_Id : constant clockid_t := CLOCK_REALTIME;
125 Unblocked_Signal_Mask : aliased sigset_t;
127 Foreign_Task_Elaborated : aliased Boolean := True;
128 -- Used to identified fake tasks (i.e., non-Ada Threads)
136 procedure Initialize (Environment_Task : Task_Id);
137 pragma Inline (Initialize);
138 -- Initialize various data needed by this package
140 function Is_Valid_Task return Boolean;
141 pragma Inline (Is_Valid_Task);
142 -- Does executing thread have a TCB?
144 procedure Set (Self_Id : Task_Id);
146 -- Set the self id for the current task
148 function Self return Task_Id;
149 pragma Inline (Self);
150 -- Return a pointer to the Ada Task Control Block of the calling task
154 package body Specific is separate;
155 -- The body of this package is target specific
157 ---------------------------------
158 -- Support for foreign threads --
159 ---------------------------------
161 function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id;
162 -- Allocate and Initialize a new ATCB for the current Thread
164 function Register_Foreign_Thread
165 (Thread : Thread_Id) return Task_Id is separate;
167 -----------------------
168 -- Local Subprograms --
169 -----------------------
171 function To_Address is new Unchecked_Conversion (Task_Id, System.Address);
173 procedure Abort_Handler (Sig : Signal);
174 -- Signal handler used to implement asynchronous abort
180 procedure Abort_Handler (Sig : Signal) is
181 pragma Unreferenced (Sig);
183 T : constant Task_Id := Self;
184 Result : Interfaces.C.int;
185 Old_Set : aliased sigset_t;
188 -- It is not safe to raise an exception when using ZCX and the GCC
189 -- exception handling mechanism.
191 if ZCX_By_Default and then GCC_ZCX_Support then
195 if T.Deferral_Level = 0
196 and then T.Pending_ATC_Level < T.ATC_Nesting_Level
198 -- Make sure signals used for RTS internal purpose are unmasked
200 Result := pthread_sigmask
202 Unblocked_Signal_Mask'Unchecked_Access,
203 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 (On);
219 pragma Unreferenced (T);
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 Result := pthread_mutexattr_setprotocol
267 (Attributes'Access, PTHREAD_PRIO_PROTECT);
268 pragma Assert (Result = 0);
270 Result := pthread_mutexattr_setprioceiling
271 (Attributes'Access, Interfaces.C.int (Prio));
272 pragma Assert (Result = 0);
275 Result := pthread_mutex_init (L, Attributes'Access);
276 pragma Assert (Result = 0 or else Result = ENOMEM);
278 if Result = ENOMEM then
279 Result := pthread_mutexattr_destroy (Attributes'Access);
283 Result := pthread_mutexattr_destroy (Attributes'Access);
284 pragma Assert (Result = 0);
287 procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is
288 pragma Unreferenced (Level);
290 Attributes : aliased pthread_mutexattr_t;
291 Result : Interfaces.C.int;
294 Result := pthread_mutexattr_init (Attributes'Access);
295 pragma Assert (Result = 0 or else Result = ENOMEM);
297 if Result = ENOMEM then
301 if Locking_Policy = 'C' then
302 Result := pthread_mutexattr_setprotocol
303 (Attributes'Access, PTHREAD_PRIO_PROTECT);
304 pragma Assert (Result = 0);
306 Result := pthread_mutexattr_setprioceiling
307 (Attributes'Access, Interfaces.C.int (System.Any_Priority'Last));
308 pragma Assert (Result = 0);
311 Result := pthread_mutex_init (L, Attributes'Access);
313 pragma Assert (Result = 0 or else Result = ENOMEM);
315 if Result = ENOMEM then
316 Result := pthread_mutexattr_destroy (Attributes'Access);
320 Result := pthread_mutexattr_destroy (Attributes'Access);
327 procedure Finalize_Lock (L : access Lock) is
328 Result : Interfaces.C.int;
330 Result := pthread_mutex_destroy (L);
331 pragma Assert (Result = 0);
334 procedure Finalize_Lock (L : access RTS_Lock) is
335 Result : Interfaces.C.int;
337 Result := pthread_mutex_destroy (L);
338 pragma Assert (Result = 0);
345 procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
346 Result : Interfaces.C.int;
348 Result := pthread_mutex_lock (L);
349 Ceiling_Violation := Result = EINVAL;
351 -- Assumes the cause of EINVAL is a priority ceiling violation
353 pragma Assert (Result = 0 or else Result = EINVAL);
357 (L : access RTS_Lock;
358 Global_Lock : Boolean := False)
360 Result : Interfaces.C.int;
362 if not Single_Lock or else Global_Lock then
363 Result := pthread_mutex_lock (L);
364 pragma Assert (Result = 0);
368 procedure Write_Lock (T : Task_Id) is
369 Result : Interfaces.C.int;
371 if not Single_Lock then
372 Result := pthread_mutex_lock (T.Common.LL.L'Access);
373 pragma Assert (Result = 0);
381 procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
383 Write_Lock (L, Ceiling_Violation);
390 procedure Unlock (L : access Lock) is
391 Result : Interfaces.C.int;
393 Result := pthread_mutex_unlock (L);
394 pragma Assert (Result = 0);
397 procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
398 Result : Interfaces.C.int;
401 if not Single_Lock or else Global_Lock then
402 Result := pthread_mutex_unlock (L);
403 pragma Assert (Result = 0);
407 procedure Unlock (T : Task_Id) is
408 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);
422 (Self_ID : ST.Task_Id;
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 procedure Timed_Sleep
450 Mode : ST.Delay_Modes;
451 Reason : Task_States;
452 Timedout : out Boolean;
453 Yielded : out Boolean)
455 pragma Unreferenced (Reason);
457 Check_Time : constant Duration := Monotonic_Clock;
459 Request : aliased timespec;
460 Result : Interfaces.C.int;
466 if Mode = Relative then
467 Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time;
469 Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
472 if Abs_Time > Check_Time then
473 Request := To_Timespec (Abs_Time);
476 exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
477 or else Self_ID.Pending_Priority_Change;
480 Result := pthread_cond_timedwait
481 (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access,
485 Result := pthread_cond_timedwait
486 (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access,
490 exit when Abs_Time <= Monotonic_Clock;
492 if Result = 0 or else errno = EINTR then
504 -- This is for use in implementing delay statements, so we assume
505 -- the caller is abort-deferred but is holding no locks.
507 procedure Timed_Delay
510 Mode : ST.Delay_Modes)
512 Check_Time : constant Duration := Monotonic_Clock;
514 Request : aliased timespec;
515 Result : Interfaces.C.int;
518 -- The little window between deferring abort and locking Self_ID is
519 -- the only reason we need to check for pending abort and priority
528 Write_Lock (Self_ID);
530 if Mode = Relative then
531 Abs_Time := Time + Check_Time;
533 Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
536 if Abs_Time > Check_Time then
537 Request := To_Timespec (Abs_Time);
538 Self_ID.Common.State := Delay_Sleep;
541 if Self_ID.Pending_Priority_Change then
542 Self_ID.Pending_Priority_Change := False;
543 Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
544 Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
547 exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
549 Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
550 Self_ID.Common.LL.L'Access, Request'Access);
551 exit when Abs_Time <= Monotonic_Clock;
553 pragma Assert (Result = 0
554 or else Result = ETIMEDOUT
555 or else Result = EINTR);
558 Self_ID.Common.State := Runnable;
568 SSL.Abort_Undefer.all;
571 ---------------------
572 -- Monotonic_Clock --
573 ---------------------
575 function Monotonic_Clock return Duration is
576 TS : aliased timespec;
577 Result : Interfaces.C.int;
579 Result := clock_gettime (Real_Time_Clock_Id, TS'Unchecked_Access);
580 pragma Assert (Result = 0);
581 return To_Duration (TS);
588 function RT_Resolution return Duration is
590 -- The clock_getres (Real_Time_Clock_Id) function appears to return
591 -- the interrupt resolution of the realtime clock and not the actual
592 -- resolution of reading the clock. Even though this last value is
593 -- only guaranteed to be 100 Hz, at least the Origin 200 appears to
594 -- have a microsecond resolution or better.
596 -- ??? We should figure out a method to return the right value on
606 procedure Wakeup (T : ST.Task_Id; Reason : System.Tasking.Task_States) is
607 pragma Unreferenced (Reason);
608 Result : Interfaces.C.int;
610 Result := pthread_cond_signal (T.Common.LL.CV'Access);
611 pragma Assert (Result = 0);
618 procedure Yield (Do_Yield : Boolean := True) is
619 Result : Interfaces.C.int;
620 pragma Unreferenced (Result);
623 Result := sched_yield;
631 procedure Set_Priority
633 Prio : System.Any_Priority;
634 Loss_Of_Inheritance : Boolean := False)
636 pragma Unreferenced (Loss_Of_Inheritance);
638 Result : Interfaces.C.int;
639 Param : aliased struct_sched_param;
640 Sched_Policy : Interfaces.C.int;
642 use type System.Task_Info.Task_Info_Type;
644 function To_Int is new Unchecked_Conversion
645 (System.Task_Info.Thread_Scheduling_Policy, Interfaces.C.int);
648 T.Common.Current_Priority := Prio;
649 Param.sched_priority := Interfaces.C.int (Prio);
651 if T.Common.Task_Info /= null then
652 Sched_Policy := To_Int (T.Common.Task_Info.Policy);
654 Sched_Policy := SCHED_FIFO;
657 Result := pthread_setschedparam (T.Common.LL.Thread, Sched_Policy,
659 pragma Assert (Result = 0);
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
676 Result : Interfaces.C.int;
678 function To_Int is new Unchecked_Conversion
679 (System.Task_Info.CPU_Number, Interfaces.C.int);
681 use System.Task_Info;
684 Self_ID.Common.LL.Thread := pthread_self;
685 Specific.Set (Self_ID);
687 if Self_ID.Common.Task_Info /= null
688 and then Self_ID.Common.Task_Info.Scope = PTHREAD_SCOPE_SYSTEM
689 and then Self_ID.Common.Task_Info.Runon_CPU /= ANY_CPU
691 Result := pthread_setrunon_np
692 (To_Int (Self_ID.Common.Task_Info.Runon_CPU));
693 pragma Assert (Result = 0);
698 for J in Known_Tasks'Range loop
699 if Known_Tasks (J) = null then
700 Known_Tasks (J) := Self_ID;
701 Self_ID.Known_Tasks_Index := J;
713 function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is
715 return new Ada_Task_Control_Block (Entry_Num);
722 function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task;
724 -----------------------------
725 -- Register_Foreign_Thread --
726 -----------------------------
728 function Register_Foreign_Thread return Task_Id is
730 if Is_Valid_Task then
733 return Register_Foreign_Thread (pthread_self);
735 end Register_Foreign_Thread;
741 procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
742 Result : Interfaces.C.int;
743 Cond_Attr : aliased pthread_condattr_t;
746 if not Single_Lock then
747 Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level);
750 Result := pthread_condattr_init (Cond_Attr'Access);
751 pragma Assert (Result = 0 or else Result = ENOMEM);
754 Result := pthread_cond_init (Self_ID.Common.LL.CV'Access,
756 pragma Assert (Result = 0 or else Result = ENOMEM);
762 if not Single_Lock then
763 Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
764 pragma Assert (Result = 0);
770 Result := pthread_condattr_destroy (Cond_Attr'Access);
771 pragma Assert (Result = 0);
778 procedure Create_Task
780 Wrapper : System.Address;
781 Stack_Size : System.Parameters.Size_Type;
782 Priority : System.Any_Priority;
783 Succeeded : out Boolean)
785 use System.Task_Info;
787 Attributes : aliased pthread_attr_t;
788 Sched_Param : aliased struct_sched_param;
789 Adjusted_Stack_Size : Interfaces.C.size_t;
790 Result : Interfaces.C.int;
792 function Thread_Body_Access is new
793 Unchecked_Conversion (System.Address, Thread_Body);
795 function To_Int is new Unchecked_Conversion
796 (System.Task_Info.Thread_Scheduling_Scope, Interfaces.C.int);
797 function To_Int is new Unchecked_Conversion
798 (System.Task_Info.Thread_Scheduling_Inheritance, Interfaces.C.int);
799 function To_Int is new Unchecked_Conversion
800 (System.Task_Info.Thread_Scheduling_Policy, Interfaces.C.int);
803 if Stack_Size = System.Parameters.Unspecified_Size then
804 Adjusted_Stack_Size :=
805 Interfaces.C.size_t (System.Program_Info.Default_Task_Stack);
807 elsif Stack_Size < Size_Type (Minimum_Stack_Size) then
808 Adjusted_Stack_Size :=
809 Interfaces.C.size_t (Minimum_Stack_Size);
812 Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size);
815 Result := pthread_attr_init (Attributes'Access);
816 pragma Assert (Result = 0 or else Result = ENOMEM);
823 Result := pthread_attr_setdetachstate
824 (Attributes'Access, PTHREAD_CREATE_DETACHED);
825 pragma Assert (Result = 0);
827 Result := pthread_attr_setstacksize
828 (Attributes'Access, Adjusted_Stack_Size);
829 pragma Assert (Result = 0);
831 if T.Common.Task_Info /= null then
832 Result := pthread_attr_setscope
833 (Attributes'Access, To_Int (T.Common.Task_Info.Scope));
834 pragma Assert (Result = 0);
836 Result := pthread_attr_setinheritsched
837 (Attributes'Access, To_Int (T.Common.Task_Info.Inheritance));
838 pragma Assert (Result = 0);
840 Result := pthread_attr_setschedpolicy
841 (Attributes'Access, To_Int (T.Common.Task_Info.Policy));
842 pragma Assert (Result = 0);
844 Sched_Param.sched_priority :=
845 Interfaces.C.int (T.Common.Task_Info.Priority);
847 Result := pthread_attr_setschedparam
848 (Attributes'Access, Sched_Param'Access);
849 pragma Assert (Result = 0);
852 -- Since the initial signal mask of a thread is inherited from the
853 -- creator, and the Environment task has all its signals masked, we
854 -- do not need to manipulate caller's signal mask at this point.
855 -- All tasks in RTS will have All_Tasks_Mask initially.
857 Result := pthread_create
858 (T.Common.LL.Thread'Access,
860 Thread_Body_Access (Wrapper),
864 and then T.Common.Task_Info /= null
865 and then T.Common.Task_Info.Scope = PTHREAD_SCOPE_SYSTEM
867 -- The pthread_create call may have failed because we
868 -- asked for a system scope pthread and none were
869 -- available (probably because the program was not executed
870 -- by the superuser). Let's try for a process scope pthread
871 -- instead of raising Tasking_Error.
874 ("Request for PTHREAD_SCOPE_SYSTEM in Task_Info pragma for task");
875 System.IO.Put ("""");
876 System.IO.Put (T.Common.Task_Image (1 .. T.Common.Task_Image_Len));
877 System.IO.Put_Line (""" could not be honored. ");
878 System.IO.Put_Line ("Scope changed to PTHREAD_SCOPE_PROCESS");
880 T.Common.Task_Info.Scope := PTHREAD_SCOPE_PROCESS;
881 Result := pthread_attr_setscope
882 (Attributes'Access, To_Int (T.Common.Task_Info.Scope));
883 pragma Assert (Result = 0);
885 Result := pthread_create
886 (T.Common.LL.Thread'Access,
888 Thread_Body_Access (Wrapper),
892 pragma Assert (Result = 0 or else Result = EAGAIN);
894 Succeeded := Result = 0;
896 -- The following needs significant commenting ???
898 if T.Common.Task_Info /= null then
899 T.Common.Base_Priority := T.Common.Task_Info.Priority;
900 Set_Priority (T, T.Common.Task_Info.Priority);
902 Set_Priority (T, Priority);
905 Result := pthread_attr_destroy (Attributes'Access);
906 pragma Assert (Result = 0);
913 procedure Finalize_TCB (T : Task_Id) is
914 Result : Interfaces.C.int;
916 Is_Self : constant Boolean := T = Self;
918 procedure Free is new
919 Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
922 if not Single_Lock then
923 Result := pthread_mutex_destroy (T.Common.LL.L'Access);
924 pragma Assert (Result = 0);
927 Result := pthread_cond_destroy (T.Common.LL.CV'Access);
928 pragma Assert (Result = 0);
930 if T.Known_Tasks_Index /= -1 then
931 Known_Tasks (T.Known_Tasks_Index) := null;
945 procedure Exit_Task is
954 procedure Abort_Task (T : Task_Id) is
955 Result : Interfaces.C.int;
957 Result := pthread_kill (T.Common.LL.Thread,
958 Signal (System.Interrupt_Management.Abort_Task_Interrupt));
959 pragma Assert (Result = 0);
966 procedure Initialize (S : in out Suspension_Object) is
967 Mutex_Attr : aliased pthread_mutexattr_t;
968 Cond_Attr : aliased pthread_condattr_t;
969 Result : Interfaces.C.int;
971 -- Initialize internal state. It is always initialized to False (ARM
977 -- Initialize internal mutex
979 Result := pthread_mutexattr_init (Mutex_Attr'Access);
980 pragma Assert (Result = 0 or else Result = ENOMEM);
982 if Result = ENOMEM then
986 Result := pthread_mutex_init (S.L'Access, Mutex_Attr'Access);
987 pragma Assert (Result = 0 or else Result = ENOMEM);
989 if Result = ENOMEM then
990 Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
991 pragma Assert (Result = 0);
996 Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
997 pragma Assert (Result = 0);
999 -- Initialize internal condition variable
1001 Result := pthread_condattr_init (Cond_Attr'Access);
1002 pragma Assert (Result = 0 or else Result = ENOMEM);
1005 Result := pthread_mutex_destroy (S.L'Access);
1006 pragma Assert (Result = 0);
1008 if Result = ENOMEM then
1009 raise Storage_Error;
1013 Result := pthread_cond_init (S.CV'Access, Cond_Attr'Access);
1014 pragma Assert (Result = 0 or else Result = ENOMEM);
1017 Result := pthread_mutex_destroy (S.L'Access);
1018 pragma Assert (Result = 0);
1020 if Result = ENOMEM then
1021 Result := pthread_condattr_destroy (Cond_Attr'Access);
1022 pragma Assert (Result = 0);
1024 raise Storage_Error;
1028 Result := pthread_condattr_destroy (Cond_Attr'Access);
1029 pragma Assert (Result = 0);
1036 procedure Finalize (S : in out Suspension_Object) is
1037 Result : Interfaces.C.int;
1039 -- Destroy internal mutex
1041 Result := pthread_mutex_destroy (S.L'Access);
1042 pragma Assert (Result = 0);
1044 -- Destroy internal condition variable
1046 Result := pthread_cond_destroy (S.CV'Access);
1047 pragma Assert (Result = 0);
1054 function Current_State (S : Suspension_Object) return Boolean is
1056 -- We do not want to use lock on this read operation. State is marked
1057 -- as Atomic so that we ensure that the value retrieved is correct.
1066 procedure Set_False (S : in out Suspension_Object) is
1067 Result : Interfaces.C.int;
1069 Result := pthread_mutex_lock (S.L'Access);
1070 pragma Assert (Result = 0);
1074 Result := pthread_mutex_unlock (S.L'Access);
1075 pragma Assert (Result = 0);
1082 procedure Set_True (S : in out Suspension_Object) is
1083 Result : Interfaces.C.int;
1085 Result := pthread_mutex_lock (S.L'Access);
1086 pragma Assert (Result = 0);
1088 -- If there is already a task waiting on this suspension object then
1089 -- we resume it, leaving the state of the suspension object to False,
1090 -- as it is specified in ARM D.10 par. 9. Otherwise, it just leaves
1091 -- the state to True.
1097 Result := pthread_cond_signal (S.CV'Access);
1098 pragma Assert (Result = 0);
1103 Result := pthread_mutex_unlock (S.L'Access);
1104 pragma Assert (Result = 0);
1107 ------------------------
1108 -- Suspend_Until_True --
1109 ------------------------
1111 procedure Suspend_Until_True (S : in out Suspension_Object) is
1112 Result : Interfaces.C.int;
1114 Result := pthread_mutex_lock (S.L'Access);
1115 pragma Assert (Result = 0);
1118 -- Program_Error must be raised upon calling Suspend_Until_True
1119 -- if another task is already waiting on that suspension object
1120 -- (ARM D.10 par. 10).
1122 Result := pthread_mutex_unlock (S.L'Access);
1123 pragma Assert (Result = 0);
1125 raise Program_Error;
1127 -- Suspend the task if the state is False. Otherwise, the task
1128 -- continues its execution, and the state of the suspension object
1129 -- is set to False (ARM D.10 par. 9).
1135 Result := pthread_cond_wait (S.CV'Access, S.L'Access);
1139 Result := pthread_mutex_unlock (S.L'Access);
1140 pragma Assert (Result = 0);
1141 end Suspend_Until_True;
1149 function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
1150 pragma Unreferenced (Self_ID);
1155 --------------------
1156 -- Check_No_Locks --
1157 --------------------
1159 function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
1160 pragma Unreferenced (Self_ID);
1165 ----------------------
1166 -- Environment_Task --
1167 ----------------------
1169 function Environment_Task return Task_Id is
1171 return Environment_Task_Id;
1172 end Environment_Task;
1178 procedure Lock_RTS is
1180 Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
1187 procedure Unlock_RTS is
1189 Unlock (Single_RTS_Lock'Access, Global_Lock => True);
1196 function Suspend_Task
1198 Thread_Self : Thread_Id) return Boolean
1200 pragma Unreferenced (T);
1201 pragma Unreferenced (Thread_Self);
1210 function Resume_Task
1212 Thread_Self : Thread_Id) return Boolean
1214 pragma Unreferenced (T);
1215 pragma Unreferenced (Thread_Self);
1224 procedure Initialize (Environment_Task : Task_Id) is
1225 act : aliased struct_sigaction;
1226 old_act : aliased struct_sigaction;
1227 Tmp_Set : aliased sigset_t;
1228 Result : Interfaces.C.int;
1231 (Int : System.Interrupt_Management.Interrupt_ID) return Character;
1232 pragma Import (C, State, "__gnat_get_interrupt_state");
1233 -- Get interrupt state. Defined in a-init.c. The input argument is
1234 -- the interrupt number, and the result is one of the following:
1236 Default : constant Character := 's';
1237 -- 'n' this interrupt not set by any Interrupt_State pragma
1238 -- 'u' Interrupt_State pragma set state to User
1239 -- 'r' Interrupt_State pragma set state to Runtime
1240 -- 's' Interrupt_State pragma set state to System (use "default"
1244 Environment_Task_Id := Environment_Task;
1246 -- Initialize the lock used to synchronize chain of all ATCBs.
1248 Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
1250 Specific.Initialize (Environment_Task);
1252 Enter_Task (Environment_Task);
1254 -- Install the abort-signal handler
1256 if State (System.Interrupt_Management.Abort_Task_Interrupt)
1260 act.sa_handler := Abort_Handler'Address;
1262 Result := sigemptyset (Tmp_Set'Access);
1263 pragma Assert (Result = 0);
1264 act.sa_mask := Tmp_Set;
1268 Signal (System.Interrupt_Management.Abort_Task_Interrupt),
1269 act'Unchecked_Access,
1270 old_act'Unchecked_Access);
1271 pragma Assert (Result = 0);
1277 Result : Interfaces.C.int;
1279 -- Prepare the set of signals that should unblocked in all tasks
1281 Result := sigemptyset (Unblocked_Signal_Mask'Access);
1282 pragma Assert (Result = 0);
1284 for J in Interrupt_Management.Interrupt_ID loop
1285 if System.Interrupt_Management.Keep_Unmasked (J) then
1286 Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J));
1287 pragma Assert (Result = 0);
1291 -- Pick the highest resolution Clock for Clock_Realtime
1293 -- ??? This code currently doesn't work (see c94007[ab] for example)
1295 -- if syssgi (SGI_CYCLECNTR_SIZE) = 64 then
1296 -- Real_Time_Clock_Id := CLOCK_SGI_CYCLE;
1298 -- Real_Time_Clock_Id := CLOCK_REALTIME;
1301 end System.Task_Primitives.Operations;