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 System.Interrupt_Management;
60 -- used for Initialize
62 with System.Soft_Links;
63 -- used for Abort_Defer/Undefer
65 -- We use System.Soft_Links instead of System.Tasking.Initialization
66 -- because the later is a higher level package that we shouldn't depend on.
67 -- For example when using the restricted run time, it is replaced by
68 -- System.Tasking.Restricted.Stages.
70 with Unchecked_Deallocation;
72 package body System.Task_Primitives.Operations is
74 package SSL renames System.Soft_Links;
76 use System.Tasking.Debug;
79 use Interfaces.C.Strings;
80 use System.OS_Interface;
81 use System.Parameters;
82 use System.OS_Primitives;
84 pragma Link_With ("-Xlinker --stack=0x200000,0x1000");
85 -- Change the default stack size (2 MB) for tasking programs on Windows.
86 -- This allows about 1000 tasks running at the same time. Note that
87 -- we set the stack size for non tasking programs on System unit.
88 -- Also note that under Windows XP, we use a Windows XP extension to
89 -- specify the stack size on a per task basis, as done under other OSes.
95 Environment_Task_Id : Task_Id;
96 -- A variable to hold Task_Id for the environment task
98 Single_RTS_Lock : aliased RTS_Lock;
99 -- This is a lock to allow only one thread of control in the RTS at
100 -- a time; it is used to execute in mutual exclusion from all other tasks.
101 -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
103 Time_Slice_Val : Integer;
104 pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
106 Dispatching_Policy : Character;
107 pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
109 function Get_Policy (Prio : System.Any_Priority) return Character;
110 pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching");
111 -- Get priority specific dispatching policy
113 Foreign_Task_Elaborated : aliased Boolean := True;
114 -- Used to identified fake tasks (i.e., non-Ada Threads)
116 ------------------------------------
117 -- The thread local storage index --
118 ------------------------------------
121 pragma Export (Ada, TlsIndex);
122 -- To ensure that this variable won't be local to this package, since
123 -- in some cases, inlining forces this variable to be global anyway.
131 function Is_Valid_Task return Boolean;
132 pragma Inline (Is_Valid_Task);
133 -- Does executing thread have a TCB?
135 procedure Set (Self_Id : Task_Id);
137 -- Set the self id for the current task
141 package body Specific is
143 function Is_Valid_Task return Boolean is
145 return TlsGetValue (TlsIndex) /= System.Null_Address;
148 procedure Set (Self_Id : Task_Id) is
151 Succeeded := TlsSetValue (TlsIndex, To_Address (Self_Id));
152 pragma Assert (Succeeded = True);
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 -- Condition Variable Functions --
169 ----------------------------------
171 procedure Initialize_Cond (Cond : access Condition_Variable);
172 -- Initialize given condition variable Cond
174 procedure Finalize_Cond (Cond : access Condition_Variable);
175 -- Finalize given condition variable Cond
177 procedure Cond_Signal (Cond : access Condition_Variable);
178 -- Signal condition variable Cond
181 (Cond : access Condition_Variable;
182 L : access RTS_Lock);
183 -- Wait on conditional variable Cond, using lock L
185 procedure Cond_Timed_Wait
186 (Cond : access Condition_Variable;
189 Timed_Out : out Boolean;
190 Status : out Integer);
191 -- Do timed wait on condition variable Cond using lock L. The duration
192 -- of the timed wait is given by Rel_Time. When the condition is
193 -- signalled, Timed_Out shows whether or not a time out occurred.
194 -- Status is only valid if Timed_Out is False, in which case it
195 -- shows whether Cond_Timed_Wait completed successfully.
197 ---------------------
198 -- Initialize_Cond --
199 ---------------------
201 procedure Initialize_Cond (Cond : access Condition_Variable) is
205 hEvent := CreateEvent (null, True, False, Null_Ptr);
206 pragma Assert (hEvent /= 0);
207 Cond.all := Condition_Variable (hEvent);
214 -- No such problem here, DosCloseEventSem has been derived.
215 -- What does such refer to in above comment???
217 procedure Finalize_Cond (Cond : access Condition_Variable) is
220 Result := CloseHandle (HANDLE (Cond.all));
221 pragma Assert (Result = True);
228 procedure Cond_Signal (Cond : access Condition_Variable) is
231 Result := SetEvent (HANDLE (Cond.all));
232 pragma Assert (Result = True);
239 -- Pre-assertion: Cond is posted
242 -- Post-assertion: Cond is posted
246 (Cond : access Condition_Variable;
253 -- Must reset Cond BEFORE L is unlocked
255 Result_Bool := ResetEvent (HANDLE (Cond.all));
256 pragma Assert (Result_Bool = True);
259 -- No problem if we are interrupted here: if the condition is signaled,
260 -- WaitForSingleObject will simply not block
262 Result := WaitForSingleObject (HANDLE (Cond.all), Wait_Infinite);
263 pragma Assert (Result = 0);
268 ---------------------
269 -- Cond_Timed_Wait --
270 ---------------------
272 -- Pre-assertion: Cond is posted
275 -- Post-assertion: Cond is posted
278 procedure Cond_Timed_Wait
279 (Cond : access Condition_Variable;
282 Timed_Out : out Boolean;
283 Status : out Integer)
285 Time_Out_Max : constant DWORD := 16#FFFF0000#;
286 -- NT 4 cannot handle timeout values that are too large,
287 -- e.g. DWORD'Last - 1
294 -- Must reset Cond BEFORE L is unlocked
296 Result := ResetEvent (HANDLE (Cond.all));
297 pragma Assert (Result = True);
300 -- No problem if we are interrupted here: if the condition is signaled,
301 -- WaitForSingleObject will simply not block
303 if Rel_Time <= 0.0 then
308 if Rel_Time >= Duration (Time_Out_Max) / 1000 then
309 Time_Out := Time_Out_Max;
311 Time_Out := DWORD (Rel_Time * 1000);
314 Wait_Result := WaitForSingleObject (HANDLE (Cond.all), Time_Out);
316 if Wait_Result = WAIT_TIMEOUT then
326 -- Ensure post-condition
329 Result := SetEvent (HANDLE (Cond.all));
330 pragma Assert (Result = True);
333 Status := Integer (Wait_Result);
340 -- The underlying thread system sets a guard page at the
341 -- bottom of a thread stack, so nothing is needed.
342 -- ??? Check the comment above
344 procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
345 pragma Warnings (Off, T);
346 pragma Warnings (Off, On);
356 function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
358 return T.Common.LL.Thread;
365 function Self return Task_Id is
366 Self_Id : constant Task_Id := To_Task_Id (TlsGetValue (TlsIndex));
368 if Self_Id = null then
369 return Register_Foreign_Thread (GetCurrentThread);
375 ---------------------
376 -- Initialize_Lock --
377 ---------------------
379 -- Note: mutexes and cond_variables needed per-task basis are
380 -- initialized in Intialize_TCB and the Storage_Error is handled.
381 -- Other mutexes (such as RTS_Lock, Memory_Lock...) used in
382 -- the RTS is initialized before any status change of RTS.
383 -- Therefore raising Storage_Error in the following routines
384 -- should be able to be handled safely.
386 procedure Initialize_Lock
387 (Prio : System.Any_Priority;
391 InitializeCriticalSection (L.Mutex'Access);
392 L.Owner_Priority := 0;
396 procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is
397 pragma Unreferenced (Level);
399 InitializeCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access);
406 procedure Finalize_Lock (L : access Lock) is
408 DeleteCriticalSection (L.Mutex'Access);
411 procedure Finalize_Lock (L : access RTS_Lock) is
413 DeleteCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access);
420 procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
422 L.Owner_Priority := Get_Priority (Self);
424 if L.Priority < L.Owner_Priority then
425 Ceiling_Violation := True;
429 EnterCriticalSection (L.Mutex'Access);
431 Ceiling_Violation := False;
435 (L : access RTS_Lock;
436 Global_Lock : Boolean := False)
439 if not Single_Lock or else Global_Lock then
440 EnterCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access);
444 procedure Write_Lock (T : Task_Id) is
446 if not Single_Lock then
448 (CRITICAL_SECTION (T.Common.LL.L)'Unrestricted_Access);
456 procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
458 Write_Lock (L, Ceiling_Violation);
465 procedure Unlock (L : access Lock) is
467 LeaveCriticalSection (L.Mutex'Access);
470 procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
472 if not Single_Lock or else Global_Lock then
473 LeaveCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access);
477 procedure Unlock (T : Task_Id) is
479 if not Single_Lock then
481 (CRITICAL_SECTION (T.Common.LL.L)'Unrestricted_Access);
491 Reason : System.Tasking.Task_States)
493 pragma Unreferenced (Reason);
496 pragma Assert (Self_ID = Self);
499 Cond_Wait (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
501 Cond_Wait (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
504 if Self_ID.Deferral_Level = 0
505 and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
508 raise Standard'Abort_Signal;
516 -- This is for use within the run-time system, so abort is
517 -- assumed to be already deferred, and the caller should be
518 -- holding its own ATCB lock.
520 procedure Timed_Sleep
523 Mode : ST.Delay_Modes;
524 Reason : System.Tasking.Task_States;
525 Timedout : out Boolean;
526 Yielded : out Boolean)
528 pragma Unreferenced (Reason);
529 Check_Time : Duration := Monotonic_Clock;
534 Local_Timedout : Boolean;
540 if Mode = Relative then
542 Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time;
544 Rel_Time := Time - Check_Time;
548 if Rel_Time > 0.0 then
550 exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
551 or else Self_ID.Pending_Priority_Change;
554 Cond_Timed_Wait (Self_ID.Common.LL.CV'Access,
555 Single_RTS_Lock'Access, Rel_Time, Local_Timedout, Result);
557 Cond_Timed_Wait (Self_ID.Common.LL.CV'Access,
558 Self_ID.Common.LL.L'Access, Rel_Time, Local_Timedout, Result);
561 Check_Time := Monotonic_Clock;
562 exit when Abs_Time <= Check_Time;
564 if not Local_Timedout then
566 -- Somebody may have called Wakeup for us
572 Rel_Time := Abs_Time - Check_Time;
581 procedure Timed_Delay
584 Mode : ST.Delay_Modes)
586 Check_Time : Duration := Monotonic_Clock;
592 pragma Warnings (Off, Integer);
599 Write_Lock (Self_ID);
601 if Mode = Relative then
603 Abs_Time := Time + Check_Time;
605 Rel_Time := Time - Check_Time;
609 if Rel_Time > 0.0 then
610 Self_ID.Common.State := Delay_Sleep;
613 if Self_ID.Pending_Priority_Change then
614 Self_ID.Pending_Priority_Change := False;
615 Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
616 Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
619 exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
622 Cond_Timed_Wait (Self_ID.Common.LL.CV'Access,
623 Single_RTS_Lock'Access,
624 Rel_Time, Timedout, Result);
626 Cond_Timed_Wait (Self_ID.Common.LL.CV'Access,
627 Self_ID.Common.LL.L'Access,
628 Rel_Time, Timedout, Result);
631 Check_Time := Monotonic_Clock;
632 exit when Abs_Time <= Check_Time;
634 Rel_Time := Abs_Time - Check_Time;
637 Self_ID.Common.State := Runnable;
653 procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
654 pragma Unreferenced (Reason);
656 Cond_Signal (T.Common.LL.CV'Access);
663 procedure Yield (Do_Yield : Boolean := True) is
674 type Prio_Array_Type is array (System.Any_Priority) of Integer;
675 pragma Atomic_Components (Prio_Array_Type);
677 Prio_Array : Prio_Array_Type;
678 -- Global array containing the id of the currently running task for
681 -- Note: we assume that we are on a single processor with run-til-blocked
684 procedure Set_Priority
686 Prio : System.Any_Priority;
687 Loss_Of_Inheritance : Boolean := False)
690 Array_Item : Integer;
693 Res := SetThreadPriority
694 (T.Common.LL.Thread, Interfaces.C.int (Underlying_Priorities (Prio)));
695 pragma Assert (Res = True);
697 if Dispatching_Policy = 'F' or else Get_Policy (Prio) = 'F' then
699 -- Annex D requirement [RM D.2.2 par. 9]:
700 -- If the task drops its priority due to the loss of inherited
701 -- priority, it is added at the head of the ready queue for its
702 -- new active priority.
704 if Loss_Of_Inheritance
705 and then Prio < T.Common.Current_Priority
707 Array_Item := Prio_Array (T.Common.Base_Priority) + 1;
708 Prio_Array (T.Common.Base_Priority) := Array_Item;
711 -- Let some processes a chance to arrive
715 -- Then wait for our turn to proceed
717 exit when Array_Item = Prio_Array (T.Common.Base_Priority)
718 or else Prio_Array (T.Common.Base_Priority) = 1;
721 Prio_Array (T.Common.Base_Priority) :=
722 Prio_Array (T.Common.Base_Priority) - 1;
726 T.Common.Current_Priority := Prio;
733 function Get_Priority (T : Task_Id) return System.Any_Priority is
735 return T.Common.Current_Priority;
742 -- There were two paths were we needed to call Enter_Task :
743 -- 1) from System.Task_Primitives.Operations.Initialize
744 -- 2) from System.Tasking.Stages.Task_Wrapper
746 -- The thread initialisation has to be done only for the first case.
748 -- This is because the GetCurrentThread NT call does not return the real
749 -- thread handler but only a "pseudo" one. It is not possible to release
750 -- the thread handle and free the system ressources from this "pseudo"
751 -- handle. So we really want to keep the real thread handle set in
752 -- System.Task_Primitives.Operations.Create_Task during thread creation.
754 procedure Enter_Task (Self_ID : Task_Id) is
755 procedure Init_Float;
756 pragma Import (C, Init_Float, "__gnat_init_float");
757 -- Properly initializes the FPU for x86 systems
760 Specific.Set (Self_ID);
763 Self_ID.Common.LL.Thread_Id := GetCurrentThreadId;
767 for J in Known_Tasks'Range loop
768 if Known_Tasks (J) = null then
769 Known_Tasks (J) := Self_ID;
770 Self_ID.Known_Tasks_Index := J;
782 function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is
784 return new Ada_Task_Control_Block (Entry_Num);
791 function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task;
793 -----------------------------
794 -- Register_Foreign_Thread --
795 -----------------------------
797 function Register_Foreign_Thread return Task_Id is
799 if Is_Valid_Task then
802 return Register_Foreign_Thread (GetCurrentThread);
804 end Register_Foreign_Thread;
810 procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
812 -- Initialize thread ID to 0, this is needed to detect threads that
813 -- are not yet activated.
815 Self_ID.Common.LL.Thread := 0;
817 Initialize_Cond (Self_ID.Common.LL.CV'Access);
819 if not Single_Lock then
820 Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level);
830 procedure Create_Task
832 Wrapper : System.Address;
833 Stack_Size : System.Parameters.Size_Type;
834 Priority : System.Any_Priority;
835 Succeeded : out Boolean)
837 Initial_Stack_Size : constant := 1024;
838 -- We set the initial stack size to 1024. On Windows version prior to XP
839 -- there is no way to fix a task stack size. Only the initial stack size
840 -- can be set, the operating system will raise the task stack size if
843 function Is_Windows_XP return Integer;
844 pragma Import (C, Is_Windows_XP, "__gnat_is_windows_xp");
845 -- Returns 1 if running on Windows XP
848 TaskId : aliased DWORD;
849 pTaskParameter : System.OS_Interface.PVOID;
851 Entry_Point : PTHREAD_START_ROUTINE;
854 pTaskParameter := To_Address (T);
856 Entry_Point := To_PTHREAD_START_ROUTINE (Wrapper);
858 if Is_Windows_XP = 1 then
859 hTask := CreateThread
864 DWORD (Create_Suspended) or
865 DWORD (Stack_Size_Param_Is_A_Reservation),
866 TaskId'Unchecked_Access);
868 hTask := CreateThread
873 DWORD (Create_Suspended),
874 TaskId'Unchecked_Access);
877 -- Step 1: Create the thread in blocked mode
883 -- Step 2: set its TCB
885 T.Common.LL.Thread := hTask;
887 -- Step 3: set its priority (child has inherited priority from parent)
889 Set_Priority (T, Priority);
891 if Time_Slice_Val = 0
892 or else Dispatching_Policy = 'F'
893 or else Get_Policy (Priority) = 'F'
895 -- Here we need Annex D semantics so we disable the NT priority
896 -- boost. A priority boost is temporarily given by the system to a
897 -- thread when it is taken out of a wait state.
899 SetThreadPriorityBoost (hTask, DisablePriorityBoost => True);
902 -- Step 4: Now, start it for good:
904 Result := ResumeThread (hTask);
905 pragma Assert (Result = 1);
907 Succeeded := Result = 1;
914 procedure Finalize_TCB (T : Task_Id) is
915 Self_ID : Task_Id := T;
918 Is_Self : constant Boolean := T = Self;
920 procedure Free is new
921 Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
924 if not Single_Lock then
925 Finalize_Lock (T.Common.LL.L'Access);
928 Finalize_Cond (T.Common.LL.CV'Access);
930 if T.Known_Tasks_Index /= -1 then
931 Known_Tasks (T.Known_Tasks_Index) := null;
934 if Self_ID.Common.LL.Thread /= 0 then
936 -- This task has been activated. Wait for the thread to terminate
937 -- then close it. this is needed to release system ressources.
939 Result := WaitForSingleObject (T.Common.LL.Thread, Wait_Infinite);
940 pragma Assert (Result /= WAIT_FAILED);
941 Succeeded := CloseHandle (T.Common.LL.Thread);
942 pragma Assert (Succeeded = True);
956 procedure Exit_Task is
965 procedure Abort_Task (T : Task_Id) is
966 pragma Unreferenced (T);
971 ----------------------
972 -- Environment_Task --
973 ----------------------
975 function Environment_Task return Task_Id is
977 return Environment_Task_Id;
978 end Environment_Task;
984 procedure Lock_RTS is
986 Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
993 procedure Unlock_RTS is
995 Unlock (Single_RTS_Lock'Access, Global_Lock => True);
1002 procedure Initialize (Environment_Task : Task_Id) is
1004 pragma Unreferenced (Discard);
1007 Environment_Task_Id := Environment_Task;
1008 OS_Primitives.Initialize;
1009 Interrupt_Management.Initialize;
1011 if Time_Slice_Val = 0 or else Dispatching_Policy = 'F' then
1013 -- Here we need Annex D semantics, switch the current process to the
1014 -- High_Priority_Class.
1017 OS_Interface.SetPriorityClass
1018 (GetCurrentProcess, High_Priority_Class);
1020 -- ??? In theory it should be possible to use the priority class
1021 -- Realtime_Priority_Class but we suspect a bug in the NT scheduler
1022 -- which prevents (in some obscure cases) a thread to get on top of
1023 -- the running queue by another thread of lower priority. For
1024 -- example cxd8002 ACATS test freeze.
1027 TlsIndex := TlsAlloc;
1029 -- Initialize the lock used to synchronize chain of all ATCBs
1031 Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
1033 Environment_Task.Common.LL.Thread := GetCurrentThread;
1034 Enter_Task (Environment_Task);
1037 ---------------------
1038 -- Monotonic_Clock --
1039 ---------------------
1041 function Monotonic_Clock return Duration
1042 renames System.OS_Primitives.Monotonic_Clock;
1048 function RT_Resolution return Duration is
1050 return 0.000_001; -- 1 micro-second
1057 procedure Initialize (S : in out Suspension_Object) is
1059 -- Initialize internal state. It is always initialized to False (ARM
1065 -- Initialize internal mutex
1067 InitializeCriticalSection (S.L'Access);
1069 -- Initialize internal condition variable
1071 S.CV := CreateEvent (null, True, False, Null_Ptr);
1072 pragma Assert (S.CV /= 0);
1079 procedure Finalize (S : in out Suspension_Object) is
1082 -- Destroy internal mutex
1084 DeleteCriticalSection (S.L'Access);
1086 -- Destroy internal condition variable
1088 Result := CloseHandle (S.CV);
1089 pragma Assert (Result = True);
1096 function Current_State (S : Suspension_Object) return Boolean is
1098 -- We do not want to use lock on this read operation. State is marked
1099 -- as Atomic so that we ensure that the value retrieved is correct.
1108 procedure Set_False (S : in out Suspension_Object) is
1110 SSL.Abort_Defer.all;
1112 EnterCriticalSection (S.L'Access);
1116 LeaveCriticalSection (S.L'Access);
1118 SSL.Abort_Undefer.all;
1125 procedure Set_True (S : in out Suspension_Object) is
1128 SSL.Abort_Defer.all;
1130 EnterCriticalSection (S.L'Access);
1132 -- If there is already a task waiting on this suspension object then
1133 -- we resume it, leaving the state of the suspension object to False,
1134 -- as it is specified in ARM D.10 par. 9. Otherwise, it just leaves
1135 -- the state to True.
1141 Result := SetEvent (S.CV);
1142 pragma Assert (Result = True);
1147 LeaveCriticalSection (S.L'Access);
1149 SSL.Abort_Undefer.all;
1152 ------------------------
1153 -- Suspend_Until_True --
1154 ------------------------
1156 procedure Suspend_Until_True (S : in out Suspension_Object) is
1160 SSL.Abort_Defer.all;
1162 EnterCriticalSection (S.L'Access);
1165 -- Program_Error must be raised upon calling Suspend_Until_True
1166 -- if another task is already waiting on that suspension object
1167 -- (ARM D.10 par. 10).
1169 LeaveCriticalSection (S.L'Access);
1171 SSL.Abort_Undefer.all;
1173 raise Program_Error;
1175 -- Suspend the task if the state is False. Otherwise, the task
1176 -- continues its execution, and the state of the suspension object
1177 -- is set to False (ARM D.10 par. 9).
1182 LeaveCriticalSection (S.L'Access);
1184 SSL.Abort_Undefer.all;
1188 -- Must reset CV BEFORE L is unlocked
1190 Result_Bool := ResetEvent (S.CV);
1191 pragma Assert (Result_Bool = True);
1193 LeaveCriticalSection (S.L'Access);
1195 SSL.Abort_Undefer.all;
1197 Result := WaitForSingleObject (S.CV, Wait_Infinite);
1198 pragma Assert (Result = 0);
1201 end Suspend_Until_True;
1207 -- Dummy versions. The only currently working versions is for solaris
1210 function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
1211 pragma Unreferenced (Self_ID);
1216 --------------------
1217 -- Check_No_Locks --
1218 --------------------
1220 function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
1221 pragma Unreferenced (Self_ID);
1230 function Suspend_Task
1232 Thread_Self : Thread_Id) return Boolean
1235 if T.Common.LL.Thread /= Thread_Self then
1236 return SuspendThread (T.Common.LL.Thread) = NO_ERROR;
1246 function Resume_Task
1248 Thread_Self : Thread_Id) return Boolean
1251 if T.Common.LL.Thread /= Thread_Self then
1252 return ResumeThread (T.Common.LL.Thread) = NO_ERROR;
1258 end System.Task_Primitives.Operations;