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-2006, Free Software Foundation, Inc. --
11 -- GNARL is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNARL; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- GNARL was developed by the GNARL team at Florida State University. --
30 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
32 ------------------------------------------------------------------------------
34 -- This is a NT (native) 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.OS_Primitives;
47 -- used for Delay_Modes
53 with Interfaces.C.Strings;
56 with System.Task_Info;
57 -- used for Unspecified_Task_Info
59 with Unchecked_Deallocation;
61 package body System.Task_Primitives.Operations is
63 use System.Tasking.Debug;
66 use Interfaces.C.Strings;
67 use System.OS_Interface;
68 use System.Parameters;
69 use System.OS_Primitives;
71 pragma Link_With ("-Xlinker --stack=0x200000,0x1000");
72 -- Change the default stack size (2 MB) for tasking programs on Windows.
73 -- This allows about 1000 tasks running at the same time. Note that
74 -- we set the stack size for non tasking programs on System unit.
75 -- Also note that under Windows XP, we use a Windows XP extension to
76 -- specify the stack size on a per task basis, as done under other OSes.
82 Environment_Task_Id : Task_Id;
83 -- A variable to hold Task_Id for the environment task
85 Single_RTS_Lock : aliased RTS_Lock;
86 -- This is a lock to allow only one thread of control in the RTS at
87 -- a time; it is used to execute in mutual exclusion from all other tasks.
88 -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
90 Time_Slice_Val : Integer;
91 pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
93 Dispatching_Policy : Character;
94 pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
96 Foreign_Task_Elaborated : aliased Boolean := True;
97 -- Used to identified fake tasks (i.e., non-Ada Threads)
99 ------------------------------------
100 -- The thread local storage index --
101 ------------------------------------
104 pragma Export (Ada, TlsIndex);
105 -- To ensure that this variable won't be local to this package, since
106 -- in some cases, inlining forces this variable to be global anyway.
114 function Is_Valid_Task return Boolean;
115 pragma Inline (Is_Valid_Task);
116 -- Does executing thread have a TCB?
118 procedure Set (Self_Id : Task_Id);
120 -- Set the self id for the current task.
124 package body Specific is
126 function Is_Valid_Task return Boolean is
128 return TlsGetValue (TlsIndex) /= System.Null_Address;
131 procedure Set (Self_Id : Task_Id) is
134 Succeeded := TlsSetValue (TlsIndex, To_Address (Self_Id));
135 pragma Assert (Succeeded = True);
140 ---------------------------------
141 -- Support for foreign threads --
142 ---------------------------------
144 function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id;
145 -- Allocate and Initialize a new ATCB for the current Thread.
147 function Register_Foreign_Thread
148 (Thread : Thread_Id) return Task_Id is separate;
150 ----------------------------------
151 -- Condition Variable Functions --
152 ----------------------------------
154 procedure Initialize_Cond (Cond : access Condition_Variable);
155 -- Initialize given condition variable Cond
157 procedure Finalize_Cond (Cond : access Condition_Variable);
158 -- Finalize given condition variable Cond.
160 procedure Cond_Signal (Cond : access Condition_Variable);
161 -- Signal condition variable Cond
164 (Cond : access Condition_Variable;
165 L : access RTS_Lock);
166 -- Wait on conditional variable Cond, using lock L
168 procedure Cond_Timed_Wait
169 (Cond : access Condition_Variable;
172 Timed_Out : out Boolean;
173 Status : out Integer);
174 -- Do timed wait on condition variable Cond using lock L. The duration
175 -- of the timed wait is given by Rel_Time. When the condition is
176 -- signalled, Timed_Out shows whether or not a time out occurred.
177 -- Status is only valid if Timed_Out is False, in which case it
178 -- shows whether Cond_Timed_Wait completed successfully.
180 ---------------------
181 -- Initialize_Cond --
182 ---------------------
184 procedure Initialize_Cond (Cond : access Condition_Variable) is
188 hEvent := CreateEvent (null, True, False, Null_Ptr);
189 pragma Assert (hEvent /= 0);
190 Cond.all := Condition_Variable (hEvent);
197 -- No such problem here, DosCloseEventSem has been derived.
198 -- What does such refer to in above comment???
200 procedure Finalize_Cond (Cond : access Condition_Variable) is
203 Result := CloseHandle (HANDLE (Cond.all));
204 pragma Assert (Result = True);
211 procedure Cond_Signal (Cond : access Condition_Variable) is
214 Result := SetEvent (HANDLE (Cond.all));
215 pragma Assert (Result = True);
222 -- Pre-assertion: Cond is posted
225 -- Post-assertion: Cond is posted
229 (Cond : access Condition_Variable;
236 -- Must reset Cond BEFORE L is unlocked.
238 Result_Bool := ResetEvent (HANDLE (Cond.all));
239 pragma Assert (Result_Bool = True);
242 -- No problem if we are interrupted here: if the condition is signaled,
243 -- WaitForSingleObject will simply not block
245 Result := WaitForSingleObject (HANDLE (Cond.all), Wait_Infinite);
246 pragma Assert (Result = 0);
251 ---------------------
252 -- Cond_Timed_Wait --
253 ---------------------
255 -- Pre-assertion: Cond is posted
258 -- Post-assertion: Cond is posted
261 procedure Cond_Timed_Wait
262 (Cond : access Condition_Variable;
265 Timed_Out : out Boolean;
266 Status : out Integer)
268 Time_Out_Max : constant DWORD := 16#FFFF0000#;
269 -- NT 4 cannot handle timeout values that are too large,
270 -- e.g. DWORD'Last - 1
277 -- Must reset Cond BEFORE L is unlocked.
279 Result := ResetEvent (HANDLE (Cond.all));
280 pragma Assert (Result = True);
283 -- No problem if we are interrupted here: if the condition is signaled,
284 -- WaitForSingleObject will simply not block
286 if Rel_Time <= 0.0 then
291 if Rel_Time >= Duration (Time_Out_Max) / 1000 then
292 Time_Out := Time_Out_Max;
294 Time_Out := DWORD (Rel_Time * 1000);
297 Wait_Result := WaitForSingleObject (HANDLE (Cond.all), Time_Out);
299 if Wait_Result = WAIT_TIMEOUT then
309 -- Ensure post-condition
312 Result := SetEvent (HANDLE (Cond.all));
313 pragma Assert (Result = True);
316 Status := Integer (Wait_Result);
323 -- The underlying thread system sets a guard page at the
324 -- bottom of a thread stack, so nothing is needed.
325 -- ??? Check the comment above
327 procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
328 pragma Warnings (Off, T);
329 pragma Warnings (Off, On);
339 function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
341 return T.Common.LL.Thread;
348 function Self return Task_Id is
349 Self_Id : constant Task_Id := To_Task_Id (TlsGetValue (TlsIndex));
351 if Self_Id = null then
352 return Register_Foreign_Thread (GetCurrentThread);
358 ---------------------
359 -- Initialize_Lock --
360 ---------------------
362 -- Note: mutexes and cond_variables needed per-task basis are
363 -- initialized in Intialize_TCB and the Storage_Error is handled.
364 -- Other mutexes (such as RTS_Lock, Memory_Lock...) used in
365 -- the RTS is initialized before any status change of RTS.
366 -- Therefore raising Storage_Error in the following routines
367 -- should be able to be handled safely.
369 procedure Initialize_Lock
370 (Prio : System.Any_Priority;
374 InitializeCriticalSection (L.Mutex'Access);
375 L.Owner_Priority := 0;
379 procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is
380 pragma Unreferenced (Level);
382 InitializeCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access);
389 procedure Finalize_Lock (L : access Lock) is
391 DeleteCriticalSection (L.Mutex'Access);
394 procedure Finalize_Lock (L : access RTS_Lock) is
396 DeleteCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access);
403 procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
405 L.Owner_Priority := Get_Priority (Self);
407 if L.Priority < L.Owner_Priority then
408 Ceiling_Violation := True;
412 EnterCriticalSection (L.Mutex'Access);
414 Ceiling_Violation := False;
418 (L : access RTS_Lock;
419 Global_Lock : Boolean := False)
422 if not Single_Lock or else Global_Lock then
423 EnterCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access);
427 procedure Write_Lock (T : Task_Id) is
429 if not Single_Lock then
431 (CRITICAL_SECTION (T.Common.LL.L)'Unrestricted_Access);
439 procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
441 Write_Lock (L, Ceiling_Violation);
448 procedure Unlock (L : access Lock) is
450 LeaveCriticalSection (L.Mutex'Access);
453 procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
455 if not Single_Lock or else Global_Lock then
456 LeaveCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access);
460 procedure Unlock (T : Task_Id) is
462 if not Single_Lock then
464 (CRITICAL_SECTION (T.Common.LL.L)'Unrestricted_Access);
474 Reason : System.Tasking.Task_States)
476 pragma Unreferenced (Reason);
479 pragma Assert (Self_ID = Self);
482 Cond_Wait (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
484 Cond_Wait (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
487 if Self_ID.Deferral_Level = 0
488 and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
491 raise Standard'Abort_Signal;
499 -- This is for use within the run-time system, so abort is
500 -- assumed to be already deferred, and the caller should be
501 -- holding its own ATCB lock.
503 procedure Timed_Sleep
506 Mode : ST.Delay_Modes;
507 Reason : System.Tasking.Task_States;
508 Timedout : out Boolean;
509 Yielded : out Boolean)
511 pragma Unreferenced (Reason);
512 Check_Time : Duration := Monotonic_Clock;
517 Local_Timedout : Boolean;
523 if Mode = Relative then
525 Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time;
527 Rel_Time := Time - Check_Time;
531 if Rel_Time > 0.0 then
533 exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
534 or else Self_ID.Pending_Priority_Change;
537 Cond_Timed_Wait (Self_ID.Common.LL.CV'Access,
538 Single_RTS_Lock'Access, Rel_Time, Local_Timedout, Result);
540 Cond_Timed_Wait (Self_ID.Common.LL.CV'Access,
541 Self_ID.Common.LL.L'Access, Rel_Time, Local_Timedout, Result);
544 Check_Time := Monotonic_Clock;
545 exit when Abs_Time <= Check_Time;
547 if not Local_Timedout then
549 -- Somebody may have called Wakeup for us
555 Rel_Time := Abs_Time - Check_Time;
564 procedure Timed_Delay
567 Mode : ST.Delay_Modes)
569 Check_Time : Duration := Monotonic_Clock;
580 Write_Lock (Self_ID);
582 if Mode = Relative then
584 Abs_Time := Time + Check_Time;
586 Rel_Time := Time - Check_Time;
590 if Rel_Time > 0.0 then
591 Self_ID.Common.State := Delay_Sleep;
594 if Self_ID.Pending_Priority_Change then
595 Self_ID.Pending_Priority_Change := False;
596 Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
597 Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
600 exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
603 Cond_Timed_Wait (Self_ID.Common.LL.CV'Access,
604 Single_RTS_Lock'Access, Rel_Time, Timedout, Result);
606 Cond_Timed_Wait (Self_ID.Common.LL.CV'Access,
607 Self_ID.Common.LL.L'Access, Rel_Time, Timedout, Result);
610 Check_Time := Monotonic_Clock;
611 exit when Abs_Time <= Check_Time;
613 Rel_Time := Abs_Time - Check_Time;
616 Self_ID.Common.State := Runnable;
632 procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
633 pragma Unreferenced (Reason);
635 Cond_Signal (T.Common.LL.CV'Access);
642 procedure Yield (Do_Yield : Boolean := True) is
653 type Prio_Array_Type is array (System.Any_Priority) of Integer;
654 pragma Atomic_Components (Prio_Array_Type);
656 Prio_Array : Prio_Array_Type;
657 -- Global array containing the id of the currently running task for
660 -- Note: we assume that we are on a single processor with run-til-blocked
663 procedure Set_Priority
665 Prio : System.Any_Priority;
666 Loss_Of_Inheritance : Boolean := False)
669 Array_Item : Integer;
672 Res := SetThreadPriority
673 (T.Common.LL.Thread, Interfaces.C.int (Underlying_Priorities (Prio)));
674 pragma Assert (Res = True);
676 if Dispatching_Policy = 'F' then
678 -- Annex D requirement [RM D.2.2 par. 9]:
679 -- If the task drops its priority due to the loss of inherited
680 -- priority, it is added at the head of the ready queue for its
681 -- new active priority.
683 if Loss_Of_Inheritance
684 and then Prio < T.Common.Current_Priority
686 Array_Item := Prio_Array (T.Common.Base_Priority) + 1;
687 Prio_Array (T.Common.Base_Priority) := Array_Item;
690 -- Let some processes a chance to arrive
694 -- Then wait for our turn to proceed
696 exit when Array_Item = Prio_Array (T.Common.Base_Priority)
697 or else Prio_Array (T.Common.Base_Priority) = 1;
700 Prio_Array (T.Common.Base_Priority) :=
701 Prio_Array (T.Common.Base_Priority) - 1;
705 T.Common.Current_Priority := Prio;
712 function Get_Priority (T : Task_Id) return System.Any_Priority is
714 return T.Common.Current_Priority;
721 -- There were two paths were we needed to call Enter_Task :
722 -- 1) from System.Task_Primitives.Operations.Initialize
723 -- 2) from System.Tasking.Stages.Task_Wrapper
725 -- The thread initialisation has to be done only for the first case.
727 -- This is because the GetCurrentThread NT call does not return the
728 -- real thread handler but only a "pseudo" one. It is not possible to
729 -- release the thread handle and free the system ressources from this
730 -- "pseudo" handle. So we really want to keep the real thread handle
731 -- set in System.Task_Primitives.Operations.Create_Task during the
734 procedure Enter_Task (Self_ID : Task_Id) is
735 procedure Init_Float;
736 pragma Import (C, Init_Float, "__gnat_init_float");
737 -- Properly initializes the FPU for x86 systems.
740 Specific.Set (Self_ID);
743 Self_ID.Common.LL.Thread_Id := GetCurrentThreadId;
747 for J in Known_Tasks'Range loop
748 if Known_Tasks (J) = null then
749 Known_Tasks (J) := Self_ID;
750 Self_ID.Known_Tasks_Index := J;
762 function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is
764 return new Ada_Task_Control_Block (Entry_Num);
771 function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task;
773 -----------------------------
774 -- Register_Foreign_Thread --
775 -----------------------------
777 function Register_Foreign_Thread return Task_Id is
779 if Is_Valid_Task then
782 return Register_Foreign_Thread (GetCurrentThread);
784 end Register_Foreign_Thread;
790 procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
792 -- Initialize thread ID to 0, this is needed to detect threads that
793 -- are not yet activated.
795 Self_ID.Common.LL.Thread := 0;
797 Initialize_Cond (Self_ID.Common.LL.CV'Access);
799 if not Single_Lock then
800 Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level);
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 Initial_Stack_Size : constant := 1024;
818 -- We set the initial stack size to 1024. On Windows version prior to XP
819 -- there is no way to fix a task stack size. Only the initial stack size
820 -- can be set, the operating system will raise the task stack size if
823 function Is_Windows_XP return Integer;
824 pragma Import (C, Is_Windows_XP, "__gnat_is_windows_xp");
825 -- Returns 1 if running on Windows XP
828 TaskId : aliased DWORD;
829 pTaskParameter : System.OS_Interface.PVOID;
831 Entry_Point : PTHREAD_START_ROUTINE;
834 pTaskParameter := To_Address (T);
836 Entry_Point := To_PTHREAD_START_ROUTINE (Wrapper);
838 if Is_Windows_XP = 1 then
839 hTask := CreateThread
844 DWORD (Create_Suspended) or
845 DWORD (Stack_Size_Param_Is_A_Reservation),
846 TaskId'Unchecked_Access);
848 hTask := CreateThread
853 DWORD (Create_Suspended),
854 TaskId'Unchecked_Access);
857 -- Step 1: Create the thread in blocked mode
863 -- Step 2: set its TCB
865 T.Common.LL.Thread := hTask;
867 -- Step 3: set its priority (child has inherited priority from parent)
869 Set_Priority (T, Priority);
871 if Time_Slice_Val = 0 or else Dispatching_Policy = 'F' then
872 -- Here we need Annex E semantics so we disable the NT priority
873 -- boost. A priority boost is temporarily given by the system to a
874 -- thread when it is taken out of a wait state.
876 SetThreadPriorityBoost (hTask, DisablePriorityBoost => True);
879 -- Step 4: Now, start it for good:
881 Result := ResumeThread (hTask);
882 pragma Assert (Result = 1);
884 Succeeded := Result = 1;
891 procedure Finalize_TCB (T : Task_Id) is
892 Self_ID : Task_Id := T;
895 Is_Self : constant Boolean := T = Self;
897 procedure Free is new
898 Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
901 if not Single_Lock then
902 Finalize_Lock (T.Common.LL.L'Access);
905 Finalize_Cond (T.Common.LL.CV'Access);
907 if T.Known_Tasks_Index /= -1 then
908 Known_Tasks (T.Known_Tasks_Index) := null;
911 if Self_ID.Common.LL.Thread /= 0 then
913 -- This task has been activated. Wait for the thread to terminate
914 -- then close it. this is needed to release system ressources.
916 Result := WaitForSingleObject (T.Common.LL.Thread, Wait_Infinite);
917 pragma Assert (Result /= WAIT_FAILED);
918 Succeeded := CloseHandle (T.Common.LL.Thread);
919 pragma Assert (Succeeded = True);
933 procedure Exit_Task is
942 procedure Abort_Task (T : Task_Id) is
943 pragma Unreferenced (T);
948 ----------------------
949 -- Environment_Task --
950 ----------------------
952 function Environment_Task return Task_Id is
954 return Environment_Task_Id;
955 end Environment_Task;
961 procedure Lock_RTS is
963 Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
970 procedure Unlock_RTS is
972 Unlock (Single_RTS_Lock'Access, Global_Lock => True);
979 procedure Initialize (Environment_Task : Task_Id) is
981 pragma Unreferenced (Discard);
984 Environment_Task_Id := Environment_Task;
985 OS_Primitives.Initialize;
987 if Time_Slice_Val = 0 or else Dispatching_Policy = 'F' then
989 -- Here we need Annex D semantics, switch the current process to the
990 -- High_Priority_Class.
993 OS_Interface.SetPriorityClass
994 (GetCurrentProcess, High_Priority_Class);
996 -- ??? In theory it should be possible to use the priority class
997 -- Realtime_Prioriry_Class but we suspect a bug in the NT scheduler
998 -- which prevents (in some obscure cases) a thread to get on top of
999 -- the running queue by another thread of lower priority. For
1000 -- example cxd8002 ACATS test freeze.
1003 TlsIndex := TlsAlloc;
1005 -- Initialize the lock used to synchronize chain of all ATCBs.
1007 Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
1009 Environment_Task.Common.LL.Thread := GetCurrentThread;
1010 Enter_Task (Environment_Task);
1013 ---------------------
1014 -- Monotonic_Clock --
1015 ---------------------
1017 function Monotonic_Clock return Duration
1018 renames System.OS_Primitives.Monotonic_Clock;
1024 function RT_Resolution return Duration is
1026 return 0.000_001; -- 1 micro-second
1033 procedure Initialize (S : in out Suspension_Object) is
1035 -- Initialize internal state. It is always initialized to False (ARM
1041 -- Initialize internal mutex
1043 InitializeCriticalSection (S.L'Access);
1045 -- Initialize internal condition variable
1047 S.CV := CreateEvent (null, True, False, Null_Ptr);
1048 pragma Assert (S.CV /= 0);
1055 procedure Finalize (S : in out Suspension_Object) is
1058 -- Destroy internal mutex
1060 DeleteCriticalSection (S.L'Access);
1062 -- Destroy internal condition variable
1064 Result := CloseHandle (S.CV);
1065 pragma Assert (Result = True);
1072 function Current_State (S : Suspension_Object) return Boolean is
1074 -- We do not want to use lock on this read operation. State is marked
1075 -- as Atomic so that we ensure that the value retrieved is correct.
1084 procedure Set_False (S : in out Suspension_Object) is
1086 EnterCriticalSection (S.L'Access);
1090 LeaveCriticalSection (S.L'Access);
1097 procedure Set_True (S : in out Suspension_Object) is
1100 EnterCriticalSection (S.L'Access);
1102 -- If there is already a task waiting on this suspension object then
1103 -- we resume it, leaving the state of the suspension object to False,
1104 -- as it is specified in ARM D.10 par. 9. Otherwise, it just leaves
1105 -- the state to True.
1111 Result := SetEvent (S.CV);
1112 pragma Assert (Result = True);
1117 LeaveCriticalSection (S.L'Access);
1120 ------------------------
1121 -- Suspend_Until_True --
1122 ------------------------
1124 procedure Suspend_Until_True (S : in out Suspension_Object) is
1128 EnterCriticalSection (S.L'Access);
1131 -- Program_Error must be raised upon calling Suspend_Until_True
1132 -- if another task is already waiting on that suspension object
1133 -- (ARM D.10 par. 10).
1135 LeaveCriticalSection (S.L'Access);
1137 raise Program_Error;
1139 -- Suspend the task if the state is False. Otherwise, the task
1140 -- continues its execution, and the state of the suspension object
1141 -- is set to False (ARM D.10 par. 9).
1146 LeaveCriticalSection (S.L'Access);
1150 -- Must reset CV BEFORE L is unlocked.
1152 Result_Bool := ResetEvent (S.CV);
1153 pragma Assert (Result_Bool = True);
1155 LeaveCriticalSection (S.L'Access);
1157 Result := WaitForSingleObject (S.CV, Wait_Infinite);
1158 pragma Assert (Result = 0);
1161 end Suspend_Until_True;
1167 -- Dummy versions. The only currently working versions is for solaris
1170 function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
1171 pragma Unreferenced (Self_ID);
1176 --------------------
1177 -- Check_No_Locks --
1178 --------------------
1180 function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
1181 pragma Unreferenced (Self_ID);
1190 function Suspend_Task
1192 Thread_Self : Thread_Id) return Boolean
1195 if T.Common.LL.Thread /= Thread_Self then
1196 return SuspendThread (T.Common.LL.Thread) = NO_ERROR;
1206 function Resume_Task
1208 Thread_Self : Thread_Id) return Boolean
1211 if T.Common.LL.Thread /= Thread_Self then
1212 return ResumeThread (T.Common.LL.Thread) = NO_ERROR;
1218 end System.Task_Primitives.Operations;