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-2008, 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 OpenVMS/Alpha version of this package
36 -- This package contains all the GNULL primitives that interface directly with
40 -- Turn off polling, we do not want ATC polling to take place during tasking
41 -- operations. It causes infinite loops and other problems.
43 with Ada.Unchecked_Conversion;
44 with Ada.Unchecked_Deallocation;
48 with System.Tasking.Debug;
49 with System.OS_Primitives;
50 with System.Soft_Links;
53 package body System.Task_Primitives.Operations is
55 use System.Tasking.Debug;
58 use System.OS_Interface;
59 use System.Parameters;
60 use System.OS_Primitives;
61 use type System.OS_Primitives.OS_Time;
63 package SSL renames System.Soft_Links;
69 -- The followings are logically constants, but need to be initialized
72 Single_RTS_Lock : aliased RTS_Lock;
73 -- This is a lock to allow only one thread of control in the RTS at
74 -- a time; it is used to execute in mutual exclusion from all other tasks.
75 -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
77 ATCB_Key : aliased pthread_key_t;
78 -- Key used to find the Ada Task_Id associated with a thread
80 Environment_Task_Id : Task_Id;
81 -- A variable to hold Task_Id for the environment task
83 Time_Slice_Val : Integer;
84 pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
86 Dispatching_Policy : Character;
87 pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
89 Foreign_Task_Elaborated : aliased Boolean := True;
90 -- Used to identified fake tasks (i.e., non-Ada Threads)
98 procedure Initialize (Environment_Task : Task_Id);
99 pragma Inline (Initialize);
100 -- Initialize various data needed by this package
102 function Is_Valid_Task return Boolean;
103 pragma Inline (Is_Valid_Task);
104 -- Does executing thread have a TCB?
106 procedure Set (Self_Id : Task_Id);
108 -- Set the self id for the current task
110 function Self return Task_Id;
111 pragma Inline (Self);
112 -- Return a pointer to the Ada Task Control Block of the calling task
116 package body Specific is separate;
117 -- The body of this package is target specific
119 ---------------------------------
120 -- Support for foreign threads --
121 ---------------------------------
123 function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id;
124 -- Allocate and Initialize a new ATCB for the current Thread
126 function Register_Foreign_Thread
127 (Thread : Thread_Id) return Task_Id is separate;
129 -----------------------
130 -- Local Subprograms --
131 -----------------------
133 function To_Task_Id is
134 new Ada.Unchecked_Conversion
135 (System.Task_Primitives.Task_Address, Task_Id);
137 function To_Address is
138 new Ada.Unchecked_Conversion
139 (Task_Id, System.Task_Primitives.Task_Address);
141 function Get_Exc_Stack_Addr return Address;
142 -- Replace System.Soft_Links.Get_Exc_Stack_Addr_NT
144 procedure Timer_Sleep_AST (ID : Address);
145 pragma Convention (C, Timer_Sleep_AST);
146 -- Signal the condition variable when AST fires
148 procedure Timer_Sleep_AST (ID : Address) is
149 Result : Interfaces.C.int;
150 pragma Warnings (Off, Result);
151 Self_ID : constant Task_Id := To_Task_Id (ID);
153 Self_ID.Common.LL.AST_Pending := False;
154 Result := pthread_cond_signal_int_np (Self_ID.Common.LL.CV'Access);
155 pragma Assert (Result = 0);
162 -- The underlying thread system sets a guard page at the bottom of a thread
163 -- stack, so nothing is needed.
164 -- ??? Check the comment above
166 procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
167 pragma Unreferenced (T);
168 pragma Unreferenced (On);
177 function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
179 return T.Common.LL.Thread;
186 function Self return Task_Id renames Specific.Self;
188 ---------------------
189 -- Initialize_Lock --
190 ---------------------
192 -- Note: mutexes and cond_variables needed per-task basis are initialized
193 -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such
194 -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any
195 -- status change of RTS. Therefore raising Storage_Error in the following
196 -- routines should be able to be handled safely.
198 procedure Initialize_Lock
199 (Prio : System.Any_Priority;
200 L : not null access Lock)
202 Attributes : aliased pthread_mutexattr_t;
203 Result : Interfaces.C.int;
206 Result := pthread_mutexattr_init (Attributes'Access);
207 pragma Assert (Result = 0 or else Result = ENOMEM);
209 if Result = ENOMEM then
214 L.Prio := Interfaces.C.int (Prio);
216 Result := pthread_mutex_init (L.L'Access, Attributes'Access);
217 pragma Assert (Result = 0 or else Result = ENOMEM);
219 if Result = ENOMEM then
223 Result := pthread_mutexattr_destroy (Attributes'Access);
224 pragma Assert (Result = 0);
227 procedure Initialize_Lock
228 (L : not null access RTS_Lock;
231 pragma Unreferenced (Level);
233 Attributes : aliased pthread_mutexattr_t;
234 Result : Interfaces.C.int;
237 Result := pthread_mutexattr_init (Attributes'Access);
238 pragma Assert (Result = 0 or else Result = ENOMEM);
240 if Result = ENOMEM then
244 -- Don't use, see comment in s-osinte.ads about ERRORCHECK mutexes???
245 -- Result := pthread_mutexattr_settype_np
246 -- (Attributes'Access, PTHREAD_MUTEX_ERRORCHECK_NP);
247 -- pragma Assert (Result = 0);
249 -- Result := pthread_mutexattr_setprotocol
250 -- (Attributes'Access, PTHREAD_PRIO_PROTECT);
251 -- pragma Assert (Result = 0);
253 -- Result := pthread_mutexattr_setprioceiling
254 -- (Attributes'Access, Interfaces.C.int (System.Any_Priority'Last));
255 -- pragma Assert (Result = 0);
257 Result := pthread_mutex_init (L, Attributes'Access);
259 pragma Assert (Result = 0 or else Result = ENOMEM);
261 if Result = ENOMEM then
265 Result := pthread_mutexattr_destroy (Attributes'Access);
266 pragma Assert (Result = 0);
273 procedure Finalize_Lock (L : not null access Lock) is
274 Result : Interfaces.C.int;
276 Result := pthread_mutex_destroy (L.L'Access);
277 pragma Assert (Result = 0);
280 procedure Finalize_Lock (L : not null access RTS_Lock) is
281 Result : Interfaces.C.int;
283 Result := pthread_mutex_destroy (L);
284 pragma Assert (Result = 0);
292 (L : not null access Lock;
293 Ceiling_Violation : out Boolean)
295 Self_ID : constant Task_Id := Self;
296 All_Tasks_Link : constant Task_Id := Self.Common.All_Tasks_Link;
297 Current_Prio : System.Any_Priority;
298 Result : Interfaces.C.int;
301 Current_Prio := Get_Priority (Self_ID);
303 -- If there is no other tasks, no need to check priorities
305 if All_Tasks_Link /= Null_Task
306 and then L.Prio < Interfaces.C.int (Current_Prio)
308 Ceiling_Violation := True;
312 Result := pthread_mutex_lock (L.L'Access);
313 pragma Assert (Result = 0);
315 Ceiling_Violation := False;
316 -- Why is this commented out ???
317 -- L.Prio_Save := Interfaces.C.int (Current_Prio);
318 -- Set_Priority (Self_ID, System.Any_Priority (L.Prio));
322 (L : not null access RTS_Lock;
323 Global_Lock : Boolean := False)
325 Result : Interfaces.C.int;
327 if not Single_Lock or else Global_Lock then
328 Result := pthread_mutex_lock (L);
329 pragma Assert (Result = 0);
333 procedure Write_Lock (T : Task_Id) is
334 Result : Interfaces.C.int;
336 if not Single_Lock then
337 Result := pthread_mutex_lock (T.Common.LL.L'Access);
338 pragma Assert (Result = 0);
347 (L : not null access Lock;
348 Ceiling_Violation : out Boolean)
351 Write_Lock (L, Ceiling_Violation);
358 procedure Unlock (L : not null access Lock) is
359 Result : Interfaces.C.int;
361 Result := pthread_mutex_unlock (L.L'Access);
362 pragma Assert (Result = 0);
366 (L : not null access RTS_Lock;
367 Global_Lock : Boolean := False)
369 Result : Interfaces.C.int;
371 if not Single_Lock or else Global_Lock then
372 Result := pthread_mutex_unlock (L);
373 pragma Assert (Result = 0);
377 procedure Unlock (T : Task_Id) is
378 Result : Interfaces.C.int;
380 if not Single_Lock then
381 Result := pthread_mutex_unlock (T.Common.LL.L'Access);
382 pragma Assert (Result = 0);
390 -- Dynamic priority ceilings are not supported by the underlying system
392 procedure Set_Ceiling
393 (L : not null access Lock;
394 Prio : System.Any_Priority)
396 pragma Unreferenced (L, Prio);
407 Reason : System.Tasking.Task_States)
409 pragma Unreferenced (Reason);
410 Result : Interfaces.C.int;
416 (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
420 (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
423 -- EINTR is not considered a failure
425 pragma Assert (Result = 0 or else Result = EINTR);
427 if Self_ID.Deferral_Level = 0
428 and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
431 raise Standard'Abort_Signal;
439 procedure Timed_Sleep
442 Mode : ST.Delay_Modes;
443 Reason : System.Tasking.Task_States;
444 Timedout : out Boolean;
445 Yielded : out Boolean)
447 pragma Unreferenced (Reason);
449 Sleep_Time : OS_Time;
450 Result : Interfaces.C.int;
451 Status : Cond_Value_Type;
453 -- The body below requires more comments ???
459 Sleep_Time := To_OS_Time (Time, Mode);
461 if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level then
465 Self_ID.Common.LL.AST_Pending := True;
468 (Status, 0, Sleep_Time,
469 Timer_Sleep_AST'Access, To_Address (Self_ID), 0);
471 if (Status and 1) /= 1 then
478 (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
479 pragma Assert (Result = 0);
484 (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
485 pragma Assert (Result = 0);
490 if not Self_ID.Common.LL.AST_Pending then
493 Sys_Cantim (Status, To_Address (Self_ID), 0);
494 pragma Assert ((Status and 1) = 1);
502 procedure Timed_Delay
505 Mode : ST.Delay_Modes)
507 Sleep_Time : OS_Time;
508 Result : Interfaces.C.int;
509 Status : Cond_Value_Type;
510 Yielded : Boolean := False;
517 -- More comments required in body below ???
519 Write_Lock (Self_ID);
521 if Time /= 0.0 or else Mode /= Relative then
522 Sleep_Time := To_OS_Time (Time, Mode);
524 if Mode = Relative or else OS_Clock <= Sleep_Time then
525 Self_ID.Common.State := Delay_Sleep;
526 Self_ID.Common.LL.AST_Pending := True;
529 (Status, 0, Sleep_Time,
530 Timer_Sleep_AST'Access, To_Address (Self_ID), 0);
532 -- Comment following test
534 if (Status and 1) /= 1 then
539 if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level then
540 Sys_Cantim (Status, To_Address (Self_ID), 0);
541 pragma Assert ((Status and 1) = 1);
548 (Self_ID.Common.LL.CV'Access,
549 Single_RTS_Lock'Access);
550 pragma Assert (Result = 0);
554 (Self_ID.Common.LL.CV'Access,
555 Self_ID.Common.LL.L'Access);
556 pragma Assert (Result = 0);
561 exit when not Self_ID.Common.LL.AST_Pending;
564 Self_ID.Common.State := Runnable;
575 Result := sched_yield;
576 pragma Assert (Result = 0);
580 ---------------------
581 -- Monotonic_Clock --
582 ---------------------
584 function Monotonic_Clock return Duration
585 renames System.OS_Primitives.Monotonic_Clock;
591 function RT_Resolution return Duration is
593 -- Document origin of this magic constant ???
601 procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
602 pragma Unreferenced (Reason);
603 Result : Interfaces.C.int;
605 Result := pthread_cond_signal (T.Common.LL.CV'Access);
606 pragma Assert (Result = 0);
613 procedure Yield (Do_Yield : Boolean := True) is
614 Result : Interfaces.C.int;
615 pragma Unreferenced (Result);
618 Result := sched_yield;
626 procedure Set_Priority
628 Prio : System.Any_Priority;
629 Loss_Of_Inheritance : Boolean := False)
631 pragma Unreferenced (Loss_Of_Inheritance);
633 Result : Interfaces.C.int;
634 Param : aliased struct_sched_param;
636 function Get_Policy (Prio : System.Any_Priority) return Character;
637 pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching");
638 -- Get priority specific dispatching policy
640 Priority_Specific_Policy : constant Character := Get_Policy (Prio);
641 -- Upper case first character of the policy name corresponding to the
642 -- task as set by a Priority_Specific_Dispatching pragma.
645 T.Common.Current_Priority := Prio;
646 Param.sched_priority := Interfaces.C.int (Underlying_Priorities (Prio));
648 if Dispatching_Policy = 'R'
649 or else Priority_Specific_Policy = 'R'
650 or else Time_Slice_Val > 0
653 pthread_setschedparam
654 (T.Common.LL.Thread, SCHED_RR, Param'Access);
656 elsif Dispatching_Policy = 'F'
657 or else Priority_Specific_Policy = 'F'
658 or else Time_Slice_Val = 0
661 pthread_setschedparam
662 (T.Common.LL.Thread, SCHED_FIFO, Param'Access);
665 -- SCHED_OTHER priorities are restricted to the range 8 - 15.
666 -- Since the translation from Underlying priorities results
667 -- in a range of 16 - 31, dividing by 2 gives the correct result.
669 Param.sched_priority := Param.sched_priority / 2;
671 pthread_setschedparam
672 (T.Common.LL.Thread, SCHED_OTHER, Param'Access);
675 pragma Assert (Result = 0);
682 function Get_Priority (T : Task_Id) return System.Any_Priority is
684 return T.Common.Current_Priority;
691 procedure Enter_Task (Self_ID : Task_Id) is
693 Self_ID.Common.LL.Thread := pthread_self;
695 Specific.Set (Self_ID);
699 for J in Known_Tasks'Range loop
700 if Known_Tasks (J) = null then
701 Known_Tasks (J) := Self_ID;
702 Self_ID.Known_Tasks_Index := J;
714 function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is
716 return new Ada_Task_Control_Block (Entry_Num);
723 function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task;
725 -----------------------------
726 -- Register_Foreign_Thread --
727 -----------------------------
729 function Register_Foreign_Thread return Task_Id is
731 if Is_Valid_Task then
734 return Register_Foreign_Thread (pthread_self);
736 end Register_Foreign_Thread;
742 procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
743 Mutex_Attr : aliased pthread_mutexattr_t;
744 Result : Interfaces.C.int;
745 Cond_Attr : aliased pthread_condattr_t;
748 -- More comments required in body below ???
750 if not Single_Lock then
751 Result := pthread_mutexattr_init (Mutex_Attr'Access);
752 pragma Assert (Result = 0 or else Result = ENOMEM);
757 (Self_ID.Common.LL.L'Access, Mutex_Attr'Access);
758 pragma Assert (Result = 0 or else Result = ENOMEM);
766 Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
767 pragma Assert (Result = 0);
770 Result := pthread_condattr_init (Cond_Attr'Access);
771 pragma Assert (Result = 0 or else Result = ENOMEM);
776 (Self_ID.Common.LL.CV'Access, Cond_Attr'Access);
777 pragma Assert (Result = 0 or else Result = ENOMEM);
782 Self_ID.Common.LL.Exc_Stack_Ptr := new Exc_Stack_T;
785 if not Single_Lock then
786 Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
787 pragma Assert (Result = 0);
793 Result := pthread_condattr_destroy (Cond_Attr'Access);
794 pragma Assert (Result = 0);
797 ------------------------
798 -- Get_Exc_Stack_Addr --
799 ------------------------
801 function Get_Exc_Stack_Addr return Address is
803 return Self.Common.LL.Exc_Stack_Ptr (Exc_Stack_T'Last)'Address;
804 end Get_Exc_Stack_Addr;
810 procedure Create_Task
812 Wrapper : System.Address;
813 Stack_Size : System.Parameters.Size_Type;
814 Priority : System.Any_Priority;
815 Succeeded : out Boolean)
817 Attributes : aliased pthread_attr_t;
818 Result : Interfaces.C.int;
820 function Thread_Body_Access is new
821 Ada.Unchecked_Conversion (System.Aux_DEC.Short_Address, Thread_Body);
824 -- Since the initial signal mask of a thread is inherited from the
825 -- creator, we need to set our local signal mask to mask all signals
826 -- during the creation operation, to make sure the new thread is
827 -- not disturbed by signals before it has set its own Task_Id.
829 Result := pthread_attr_init (Attributes'Access);
830 pragma Assert (Result = 0 or else Result = ENOMEM);
837 Result := pthread_attr_setdetachstate
838 (Attributes'Access, PTHREAD_CREATE_DETACHED);
839 pragma Assert (Result = 0);
841 Result := pthread_attr_setstacksize
842 (Attributes'Access, Interfaces.C.size_t (Stack_Size));
843 pragma Assert (Result = 0);
845 -- This call may be unnecessary, not sure. ???
848 pthread_attr_setinheritsched
849 (Attributes'Access, PTHREAD_EXPLICIT_SCHED);
850 pragma Assert (Result = 0);
854 (T.Common.LL.Thread'Access,
856 Thread_Body_Access (Wrapper),
859 -- ENOMEM is a valid run-time error -- do not shut down
861 pragma Assert (Result = 0
862 or else Result = EAGAIN or else Result = ENOMEM);
864 Succeeded := Result = 0;
866 Result := pthread_attr_destroy (Attributes'Access);
867 pragma Assert (Result = 0);
870 Set_Priority (T, Priority);
878 procedure Finalize_TCB (T : Task_Id) is
879 Result : Interfaces.C.int;
881 Is_Self : constant Boolean := T = Self;
883 procedure Free is new
884 Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
886 procedure Free is new Ada.Unchecked_Deallocation
887 (Exc_Stack_T, Exc_Stack_Ptr_T);
890 if not Single_Lock then
891 Result := pthread_mutex_destroy (T.Common.LL.L'Access);
892 pragma Assert (Result = 0);
895 Result := pthread_cond_destroy (T.Common.LL.CV'Access);
896 pragma Assert (Result = 0);
898 if T.Known_Tasks_Index /= -1 then
899 Known_Tasks (T.Known_Tasks_Index) := null;
902 Free (T.Common.LL.Exc_Stack_Ptr);
914 procedure Exit_Task is
923 procedure Abort_Task (T : Task_Id) is
925 -- Interrupt Server_Tasks may be waiting on an event flag
927 if T.Common.State = Interrupt_Server_Blocked_On_Event_Flag then
928 Wakeup (T, Interrupt_Server_Blocked_On_Event_Flag);
936 procedure Initialize (S : in out Suspension_Object) is
937 Mutex_Attr : aliased pthread_mutexattr_t;
938 Cond_Attr : aliased pthread_condattr_t;
939 Result : Interfaces.C.int;
941 -- Initialize internal state (always to False (D.10 (6)))
946 -- Initialize internal mutex
948 Result := pthread_mutexattr_init (Mutex_Attr'Access);
949 pragma Assert (Result = 0 or else Result = ENOMEM);
951 if Result = ENOMEM then
955 Result := pthread_mutex_init (S.L'Access, Mutex_Attr'Access);
956 pragma Assert (Result = 0 or else Result = ENOMEM);
958 if Result = ENOMEM then
959 Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
960 pragma Assert (Result = 0);
965 Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
966 pragma Assert (Result = 0);
968 -- Initialize internal condition variable
970 Result := pthread_condattr_init (Cond_Attr'Access);
971 pragma Assert (Result = 0 or else Result = ENOMEM);
974 Result := pthread_mutex_destroy (S.L'Access);
975 pragma Assert (Result = 0);
977 if Result = ENOMEM then
982 Result := pthread_cond_init (S.CV'Access, Cond_Attr'Access);
983 pragma Assert (Result = 0 or else Result = ENOMEM);
986 Result := pthread_mutex_destroy (S.L'Access);
987 pragma Assert (Result = 0);
989 if Result = ENOMEM then
990 Result := pthread_condattr_destroy (Cond_Attr'Access);
991 pragma Assert (Result = 0);
997 Result := pthread_condattr_destroy (Cond_Attr'Access);
998 pragma Assert (Result = 0);
1005 procedure Finalize (S : in out Suspension_Object) is
1006 Result : Interfaces.C.int;
1009 -- Destroy internal mutex
1011 Result := pthread_mutex_destroy (S.L'Access);
1012 pragma Assert (Result = 0);
1014 -- Destroy internal condition variable
1016 Result := pthread_cond_destroy (S.CV'Access);
1017 pragma Assert (Result = 0);
1024 function Current_State (S : Suspension_Object) return Boolean is
1026 -- We do not want to use lock on this read operation. State is marked
1027 -- as Atomic so that we ensure that the value retrieved is correct.
1036 procedure Set_False (S : in out Suspension_Object) is
1037 Result : Interfaces.C.int;
1040 SSL.Abort_Defer.all;
1042 Result := pthread_mutex_lock (S.L'Access);
1043 pragma Assert (Result = 0);
1047 Result := pthread_mutex_unlock (S.L'Access);
1048 pragma Assert (Result = 0);
1050 SSL.Abort_Undefer.all;
1057 procedure Set_True (S : in out Suspension_Object) is
1058 Result : Interfaces.C.int;
1061 SSL.Abort_Defer.all;
1063 Result := pthread_mutex_lock (S.L'Access);
1064 pragma Assert (Result = 0);
1066 -- If there is already a task waiting on this suspension object then
1067 -- we resume it, leaving the state of the suspension object to False,
1068 -- as specified in (RM D.10(9)), otherwise leave state set to True.
1074 Result := pthread_cond_signal (S.CV'Access);
1075 pragma Assert (Result = 0);
1081 Result := pthread_mutex_unlock (S.L'Access);
1082 pragma Assert (Result = 0);
1084 SSL.Abort_Undefer.all;
1087 ------------------------
1088 -- Suspend_Until_True --
1089 ------------------------
1091 procedure Suspend_Until_True (S : in out Suspension_Object) is
1092 Result : Interfaces.C.int;
1095 SSL.Abort_Defer.all;
1097 Result := pthread_mutex_lock (S.L'Access);
1098 pragma Assert (Result = 0);
1102 -- Program_Error must be raised upon calling Suspend_Until_True
1103 -- if another task is already waiting on that suspension object
1106 Result := pthread_mutex_unlock (S.L'Access);
1107 pragma Assert (Result = 0);
1109 SSL.Abort_Undefer.all;
1111 raise Program_Error;
1114 -- Suspend the task if the state is False. Otherwise, the task
1115 -- continues its execution, and the state of the suspension object
1116 -- is set to False (ARM D.10 par. 9).
1122 Result := pthread_cond_wait (S.CV'Access, S.L'Access);
1125 Result := pthread_mutex_unlock (S.L'Access);
1126 pragma Assert (Result = 0);
1128 SSL.Abort_Undefer.all;
1130 end Suspend_Until_True;
1138 function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
1139 pragma Unreferenced (Self_ID);
1144 --------------------
1145 -- Check_No_Locks --
1146 --------------------
1148 function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
1149 pragma Unreferenced (Self_ID);
1154 ----------------------
1155 -- Environment_Task --
1156 ----------------------
1158 function Environment_Task return Task_Id is
1160 return Environment_Task_Id;
1161 end Environment_Task;
1167 procedure Lock_RTS is
1169 Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
1176 procedure Unlock_RTS is
1178 Unlock (Single_RTS_Lock'Access, Global_Lock => True);
1185 function Suspend_Task
1187 Thread_Self : Thread_Id) return Boolean
1189 pragma Unreferenced (T);
1190 pragma Unreferenced (Thread_Self);
1199 function Resume_Task
1201 Thread_Self : Thread_Id) return Boolean
1203 pragma Unreferenced (T);
1204 pragma Unreferenced (Thread_Self);
1209 --------------------
1210 -- Stop_All_Tasks --
1211 --------------------
1213 procedure Stop_All_Tasks is
1222 function Stop_Task (T : ST.Task_Id) return Boolean is
1223 pragma Unreferenced (T);
1232 function Continue_Task (T : ST.Task_Id) return Boolean is
1233 pragma Unreferenced (T);
1242 procedure Initialize (Environment_Task : Task_Id) is
1244 Environment_Task_Id := Environment_Task;
1246 SSL.Get_Exc_Stack_Addr := Get_Exc_Stack_Addr'Access;
1248 -- Initialize the lock used to synchronize chain of all ATCBs
1250 Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
1252 Specific.Initialize (Environment_Task);
1254 Enter_Task (Environment_Task);
1257 end System.Task_Primitives.Operations;