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-2010, 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 3, or (at your option) any later ver- --
14 -- sion. GNAT 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. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- GNARL was developed by the GNARL team at Florida State University. --
28 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
30 ------------------------------------------------------------------------------
32 -- This is a NT (native) version of this package
34 -- This package contains all the GNULL primitives that interface directly with
38 -- Turn off polling, we do not want ATC polling to take place during tasking
39 -- operations. It causes infinite loops and other problems.
41 with Ada
.Unchecked_Deallocation
;
44 with Interfaces
.C
.Strings
;
46 with System
.Multiprocessors
;
47 with System
.Tasking
.Debug
;
48 with System
.OS_Primitives
;
49 with System
.Task_Info
;
50 with System
.Interrupt_Management
;
51 with System
.Win32
.Ext
;
53 with System
.Soft_Links
;
54 -- We use System.Soft_Links instead of System.Tasking.Initialization because
55 -- the later is a higher level package that we shouldn't depend on. For
56 -- example when using the restricted run time, it is replaced by
57 -- System.Tasking.Restricted.Stages.
59 package body System
.Task_Primitives
.Operations
is
61 package SSL
renames System
.Soft_Links
;
63 use System
.Tasking
.Debug
;
66 use Interfaces
.C
.Strings
;
67 use System
.OS_Interface
;
68 use System
.Parameters
;
69 use System
.OS_Primitives
;
74 pragma Link_With
("-Xlinker --stack=0x200000,0x1000");
75 -- Change the default stack size (2 MB) for tasking programs on Windows.
76 -- This allows about 1000 tasks running at the same time. Note that
77 -- we set the stack size for non tasking programs on System unit.
78 -- Also note that under Windows XP, we use a Windows XP extension to
79 -- specify the stack size on a per task basis, as done under other OSes.
85 procedure InitializeCriticalSection
(pCriticalSection
: access RTS_Lock
);
86 procedure InitializeCriticalSection
87 (pCriticalSection
: access CRITICAL_SECTION
);
89 (Stdcall
, InitializeCriticalSection
, "InitializeCriticalSection");
91 procedure EnterCriticalSection
(pCriticalSection
: access RTS_Lock
);
92 procedure EnterCriticalSection
93 (pCriticalSection
: access CRITICAL_SECTION
);
94 pragma Import
(Stdcall
, EnterCriticalSection
, "EnterCriticalSection");
96 procedure LeaveCriticalSection
(pCriticalSection
: access RTS_Lock
);
97 procedure LeaveCriticalSection
(pCriticalSection
: access CRITICAL_SECTION
);
98 pragma Import
(Stdcall
, LeaveCriticalSection
, "LeaveCriticalSection");
100 procedure DeleteCriticalSection
(pCriticalSection
: access RTS_Lock
);
101 procedure DeleteCriticalSection
102 (pCriticalSection
: access CRITICAL_SECTION
);
103 pragma Import
(Stdcall
, DeleteCriticalSection
, "DeleteCriticalSection");
109 Environment_Task_Id
: Task_Id
;
110 -- A variable to hold Task_Id for the environment task
112 Single_RTS_Lock
: aliased RTS_Lock
;
113 -- This is a lock to allow only one thread of control in the RTS at
114 -- a time; it is used to execute in mutual exclusion from all other tasks.
115 -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
117 Time_Slice_Val
: Integer;
118 pragma Import
(C
, Time_Slice_Val
, "__gl_time_slice_val");
120 Dispatching_Policy
: Character;
121 pragma Import
(C
, Dispatching_Policy
, "__gl_task_dispatching_policy");
123 function Get_Policy
(Prio
: System
.Any_Priority
) return Character;
124 pragma Import
(C
, Get_Policy
, "__gnat_get_specific_dispatching");
125 -- Get priority specific dispatching policy
127 Foreign_Task_Elaborated
: aliased Boolean := True;
128 -- Used to identified fake tasks (i.e., non-Ada Threads)
130 Annex_D
: Boolean := False;
131 -- Set to True if running with Annex-D semantics
133 ------------------------------------
134 -- The thread local storage index --
135 ------------------------------------
138 pragma Export
(Ada
, TlsIndex
);
139 -- To ensure that this variable won't be local to this package, since
140 -- in some cases, inlining forces this variable to be global anyway.
148 function Is_Valid_Task
return Boolean;
149 pragma Inline
(Is_Valid_Task
);
150 -- Does executing thread have a TCB?
152 procedure Set
(Self_Id
: Task_Id
);
154 -- Set the self id for the current task
158 package body Specific
is
160 function Is_Valid_Task
return Boolean is
162 return TlsGetValue
(TlsIndex
) /= System
.Null_Address
;
165 procedure Set
(Self_Id
: Task_Id
) is
168 Succeeded
:= TlsSetValue
(TlsIndex
, To_Address
(Self_Id
));
169 pragma Assert
(Succeeded
= Win32
.TRUE);
174 ---------------------------------
175 -- Support for foreign threads --
176 ---------------------------------
178 function Register_Foreign_Thread
(Thread
: Thread_Id
) return Task_Id
;
179 -- Allocate and Initialize a new ATCB for the current Thread
181 function Register_Foreign_Thread
182 (Thread
: Thread_Id
) return Task_Id
is separate;
184 ----------------------------------
185 -- Condition Variable Functions --
186 ----------------------------------
188 procedure Initialize_Cond
(Cond
: not null access Condition_Variable
);
189 -- Initialize given condition variable Cond
191 procedure Finalize_Cond
(Cond
: not null access Condition_Variable
);
192 -- Finalize given condition variable Cond
194 procedure Cond_Signal
(Cond
: not null access Condition_Variable
);
195 -- Signal condition variable Cond
198 (Cond
: not null access Condition_Variable
;
199 L
: not null access RTS_Lock
);
200 -- Wait on conditional variable Cond, using lock L
202 procedure Cond_Timed_Wait
203 (Cond
: not null access Condition_Variable
;
204 L
: not null access RTS_Lock
;
206 Timed_Out
: out Boolean;
207 Status
: out Integer);
208 -- Do timed wait on condition variable Cond using lock L. The duration
209 -- of the timed wait is given by Rel_Time. When the condition is
210 -- signalled, Timed_Out shows whether or not a time out occurred.
211 -- Status is only valid if Timed_Out is False, in which case it
212 -- shows whether Cond_Timed_Wait completed successfully.
214 ---------------------
215 -- Initialize_Cond --
216 ---------------------
218 procedure Initialize_Cond
(Cond
: not null access Condition_Variable
) is
221 hEvent
:= CreateEvent
(null, Win32
.TRUE, Win32
.FALSE, Null_Ptr
);
222 pragma Assert
(hEvent
/= 0);
223 Cond
.all := Condition_Variable
(hEvent
);
230 -- No such problem here, DosCloseEventSem has been derived.
231 -- What does such refer to in above comment???
233 procedure Finalize_Cond
(Cond
: not null access Condition_Variable
) is
236 Result
:= CloseHandle
(HANDLE
(Cond
.all));
237 pragma Assert
(Result
= Win32
.TRUE);
244 procedure Cond_Signal
(Cond
: not null access Condition_Variable
) is
247 Result
:= SetEvent
(HANDLE
(Cond
.all));
248 pragma Assert
(Result
= Win32
.TRUE);
255 -- Pre-condition: Cond is posted
258 -- Post-condition: Cond is posted
262 (Cond
: not null access Condition_Variable
;
263 L
: not null access RTS_Lock
)
269 -- Must reset Cond BEFORE L is unlocked
271 Result_Bool
:= ResetEvent
(HANDLE
(Cond
.all));
272 pragma Assert
(Result_Bool
= Win32
.TRUE);
273 Unlock
(L
, Global_Lock
=> True);
275 -- No problem if we are interrupted here: if the condition is signaled,
276 -- WaitForSingleObject will simply not block
278 Result
:= WaitForSingleObject
(HANDLE
(Cond
.all), Wait_Infinite
);
279 pragma Assert
(Result
= 0);
281 Write_Lock
(L
, Global_Lock
=> True);
284 ---------------------
285 -- Cond_Timed_Wait --
286 ---------------------
288 -- Pre-condition: Cond is posted
291 -- Post-condition: Cond is posted
294 procedure Cond_Timed_Wait
295 (Cond
: not null access Condition_Variable
;
296 L
: not null access RTS_Lock
;
298 Timed_Out
: out Boolean;
299 Status
: out Integer)
301 Time_Out_Max
: constant DWORD
:= 16#FFFF0000#
;
302 -- NT 4 can't handle excessive timeout values (e.g. DWORD'Last - 1)
309 -- Must reset Cond BEFORE L is unlocked
311 Result
:= ResetEvent
(HANDLE
(Cond
.all));
312 pragma Assert
(Result
= Win32
.TRUE);
313 Unlock
(L
, Global_Lock
=> True);
315 -- No problem if we are interrupted here: if the condition is signaled,
316 -- WaitForSingleObject will simply not block.
318 if Rel_Time
<= 0.0 then
324 (if Rel_Time
>= Duration (Time_Out_Max
) / 1000
326 else DWORD
(Rel_Time
* 1000));
328 Wait_Result
:= WaitForSingleObject
(HANDLE
(Cond
.all), Time_Out
);
330 if Wait_Result
= WAIT_TIMEOUT
then
338 Write_Lock
(L
, Global_Lock
=> True);
340 -- Ensure post-condition
343 Result
:= SetEvent
(HANDLE
(Cond
.all));
344 pragma Assert
(Result
= Win32
.TRUE);
347 Status
:= Integer (Wait_Result
);
354 -- The underlying thread system sets a guard page at the bottom of a thread
355 -- stack, so nothing is needed.
356 -- ??? Check the comment above
358 procedure Stack_Guard
(T
: ST
.Task_Id
; On
: Boolean) is
359 pragma Unreferenced
(T
, On
);
368 function Get_Thread_Id
(T
: ST
.Task_Id
) return OSI
.Thread_Id
is
370 return T
.Common
.LL
.Thread
;
377 function Self
return Task_Id
is
378 Self_Id
: constant Task_Id
:= To_Task_Id
(TlsGetValue
(TlsIndex
));
380 if Self_Id
= null then
381 return Register_Foreign_Thread
(GetCurrentThread
);
387 ---------------------
388 -- Initialize_Lock --
389 ---------------------
391 -- Note: mutexes and cond_variables needed per-task basis are initialized
392 -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such
393 -- as RTS_Lock, Memory_Lock...) used in the RTS is initialized before any
394 -- status change of RTS. Therefore raising Storage_Error in the following
395 -- routines should be able to be handled safely.
397 procedure Initialize_Lock
398 (Prio
: System
.Any_Priority
;
399 L
: not null access Lock
)
402 InitializeCriticalSection
(L
.Mutex
'Access);
403 L
.Owner_Priority
:= 0;
407 procedure Initialize_Lock
408 (L
: not null access RTS_Lock
; Level
: Lock_Level
)
410 pragma Unreferenced
(Level
);
412 InitializeCriticalSection
(L
);
419 procedure Finalize_Lock
(L
: not null access Lock
) is
421 DeleteCriticalSection
(L
.Mutex
'Access);
424 procedure Finalize_Lock
(L
: not null access RTS_Lock
) is
426 DeleteCriticalSection
(L
);
434 (L
: not null access Lock
; Ceiling_Violation
: out Boolean) is
436 L
.Owner_Priority
:= Get_Priority
(Self
);
438 if L
.Priority
< L
.Owner_Priority
then
439 Ceiling_Violation
:= True;
443 EnterCriticalSection
(L
.Mutex
'Access);
445 Ceiling_Violation
:= False;
449 (L
: not null access RTS_Lock
;
450 Global_Lock
: Boolean := False)
453 if not Single_Lock
or else Global_Lock
then
454 EnterCriticalSection
(L
);
458 procedure Write_Lock
(T
: Task_Id
) is
460 if not Single_Lock
then
461 EnterCriticalSection
(T
.Common
.LL
.L
'Access);
470 (L
: not null access Lock
; Ceiling_Violation
: out Boolean) is
472 Write_Lock
(L
, Ceiling_Violation
);
479 procedure Unlock
(L
: not null access Lock
) is
481 LeaveCriticalSection
(L
.Mutex
'Access);
485 (L
: not null access RTS_Lock
; Global_Lock
: Boolean := False) is
487 if not Single_Lock
or else Global_Lock
then
488 LeaveCriticalSection
(L
);
492 procedure Unlock
(T
: Task_Id
) is
494 if not Single_Lock
then
495 LeaveCriticalSection
(T
.Common
.LL
.L
'Access);
503 -- Dynamic priority ceilings are not supported by the underlying system
505 procedure Set_Ceiling
506 (L
: not null access Lock
;
507 Prio
: System
.Any_Priority
)
509 pragma Unreferenced
(L
, Prio
);
520 Reason
: System
.Tasking
.Task_States
)
522 pragma Unreferenced
(Reason
);
525 pragma Assert
(Self_ID
= Self
);
528 Cond_Wait
(Self_ID
.Common
.LL
.CV
'Access, Single_RTS_Lock
'Access);
530 Cond_Wait
(Self_ID
.Common
.LL
.CV
'Access, Self_ID
.Common
.LL
.L
'Access);
533 if Self_ID
.Deferral_Level
= 0
534 and then Self_ID
.Pending_ATC_Level
< Self_ID
.ATC_Nesting_Level
537 raise Standard
'Abort_Signal;
545 -- This is for use within the run-time system, so abort is assumed to be
546 -- already deferred, and the caller should be holding its own ATCB lock.
548 procedure Timed_Sleep
551 Mode
: ST
.Delay_Modes
;
552 Reason
: System
.Tasking
.Task_States
;
553 Timedout
: out Boolean;
554 Yielded
: out Boolean)
556 pragma Unreferenced
(Reason
);
557 Check_Time
: Duration := Monotonic_Clock
;
562 pragma Unreferenced
(Result
);
564 Local_Timedout
: Boolean;
570 if Mode
= Relative
then
572 Abs_Time
:= Duration'Min (Time
, Max_Sensible_Delay
) + Check_Time
;
574 Rel_Time
:= Time
- Check_Time
;
578 if Rel_Time
> 0.0 then
580 exit when Self_ID
.Pending_ATC_Level
< Self_ID
.ATC_Nesting_Level
;
584 (Self_ID
.Common
.LL
.CV
'Access,
585 Single_RTS_Lock
'Access,
586 Rel_Time
, Local_Timedout
, Result
);
589 (Self_ID
.Common
.LL
.CV
'Access,
590 Self_ID
.Common
.LL
.L
'Access,
591 Rel_Time
, Local_Timedout
, Result
);
594 Check_Time
:= Monotonic_Clock
;
595 exit when Abs_Time
<= Check_Time
;
597 if not Local_Timedout
then
599 -- Somebody may have called Wakeup for us
605 Rel_Time
:= Abs_Time
- Check_Time
;
614 procedure Timed_Delay
617 Mode
: ST
.Delay_Modes
)
619 Check_Time
: Duration := Monotonic_Clock
;
625 pragma Unreferenced
(Timedout
, Result
);
632 Write_Lock
(Self_ID
);
634 if Mode
= Relative
then
636 Abs_Time
:= Time
+ Check_Time
;
638 Rel_Time
:= Time
- Check_Time
;
642 if Rel_Time
> 0.0 then
643 Self_ID
.Common
.State
:= Delay_Sleep
;
646 exit when Self_ID
.Pending_ATC_Level
< Self_ID
.ATC_Nesting_Level
;
650 (Self_ID
.Common
.LL
.CV
'Access,
651 Single_RTS_Lock
'Access,
652 Rel_Time
, Timedout
, Result
);
655 (Self_ID
.Common
.LL
.CV
'Access,
656 Self_ID
.Common
.LL
.L
'Access,
657 Rel_Time
, Timedout
, Result
);
660 Check_Time
:= Monotonic_Clock
;
661 exit when Abs_Time
<= Check_Time
;
663 Rel_Time
:= Abs_Time
- Check_Time
;
666 Self_ID
.Common
.State
:= Runnable
;
682 procedure Wakeup
(T
: Task_Id
; Reason
: System
.Tasking
.Task_States
) is
683 pragma Unreferenced
(Reason
);
685 Cond_Signal
(T
.Common
.LL
.CV
'Access);
692 procedure Yield
(Do_Yield
: Boolean := True) is
698 -- If running with Annex-D semantics we need a delay
699 -- above 0 milliseconds here otherwise processes give
700 -- enough time to the other tasks to have a chance to
703 -- This makes cxd8002 ACATS pass on Windows.
713 type Prio_Array_Type
is array (System
.Any_Priority
) of Integer;
714 pragma Atomic_Components
(Prio_Array_Type
);
716 Prio_Array
: Prio_Array_Type
;
717 -- Global array containing the id of the currently running task for
720 -- Note: we assume that we are on a single processor with run-til-blocked
723 procedure Set_Priority
725 Prio
: System
.Any_Priority
;
726 Loss_Of_Inheritance
: Boolean := False)
729 Array_Item
: Integer;
732 Res
:= SetThreadPriority
733 (T
.Common
.LL
.Thread
, Interfaces
.C
.int
(Underlying_Priorities
(Prio
)));
734 pragma Assert
(Res
= Win32
.TRUE);
736 if Dispatching_Policy
= 'F' or else Get_Policy
(Prio
) = 'F' then
738 -- Annex D requirement [RM D.2.2 par. 9]:
739 -- If the task drops its priority due to the loss of inherited
740 -- priority, it is added at the head of the ready queue for its
741 -- new active priority.
743 if Loss_Of_Inheritance
744 and then Prio
< T
.Common
.Current_Priority
746 Array_Item
:= Prio_Array
(T
.Common
.Base_Priority
) + 1;
747 Prio_Array
(T
.Common
.Base_Priority
) := Array_Item
;
750 -- Let some processes a chance to arrive
754 -- Then wait for our turn to proceed
756 exit when Array_Item
= Prio_Array
(T
.Common
.Base_Priority
)
757 or else Prio_Array
(T
.Common
.Base_Priority
) = 1;
760 Prio_Array
(T
.Common
.Base_Priority
) :=
761 Prio_Array
(T
.Common
.Base_Priority
) - 1;
765 T
.Common
.Current_Priority
:= Prio
;
772 function Get_Priority
(T
: Task_Id
) return System
.Any_Priority
is
774 return T
.Common
.Current_Priority
;
781 -- There were two paths were we needed to call Enter_Task :
782 -- 1) from System.Task_Primitives.Operations.Initialize
783 -- 2) from System.Tasking.Stages.Task_Wrapper
785 -- The thread initialisation has to be done only for the first case
787 -- This is because the GetCurrentThread NT call does not return the real
788 -- thread handler but only a "pseudo" one. It is not possible to release
789 -- the thread handle and free the system resources from this "pseudo"
790 -- handle. So we really want to keep the real thread handle set in
791 -- System.Task_Primitives.Operations.Create_Task during thread creation.
793 procedure Enter_Task
(Self_ID
: Task_Id
) is
794 procedure Init_Float
;
795 pragma Import
(C
, Init_Float
, "__gnat_init_float");
796 -- Properly initializes the FPU for x86 systems
798 procedure Get_Stack_Bounds
(Base
: Address
; Limit
: Address
);
799 pragma Import
(C
, Get_Stack_Bounds
, "__gnat_get_stack_bounds");
800 -- Get stack boundaries
802 Specific
.Set
(Self_ID
);
805 if Self_ID
.Common
.Task_Info
/= null
807 Self_ID
.Common
.Task_Info
.CPU
>= CPU_Number
(Number_Of_Processors
)
809 raise Invalid_CPU_Number
;
812 Self_ID
.Common
.LL
.Thread_Id
:= GetCurrentThreadId
;
815 (Self_ID
.Common
.Compiler_Data
.Pri_Stack_Info
.Base
'Address,
816 Self_ID
.Common
.Compiler_Data
.Pri_Stack_Info
.Limit
'Address);
823 function New_ATCB
(Entry_Num
: Task_Entry_Index
) return Task_Id
is
825 return new Ada_Task_Control_Block
(Entry_Num
);
832 function Is_Valid_Task
return Boolean renames Specific
.Is_Valid_Task
;
834 -----------------------------
835 -- Register_Foreign_Thread --
836 -----------------------------
838 function Register_Foreign_Thread
return Task_Id
is
840 if Is_Valid_Task
then
843 return Register_Foreign_Thread
(GetCurrentThread
);
845 end Register_Foreign_Thread
;
851 procedure Initialize_TCB
(Self_ID
: Task_Id
; Succeeded
: out Boolean) is
853 -- Initialize thread ID to 0, this is needed to detect threads that
854 -- are not yet activated.
856 Self_ID
.Common
.LL
.Thread
:= 0;
858 Initialize_Cond
(Self_ID
.Common
.LL
.CV
'Access);
860 if not Single_Lock
then
861 Initialize_Lock
(Self_ID
.Common
.LL
.L
'Access, ATCB_Level
);
871 procedure Create_Task
873 Wrapper
: System
.Address
;
874 Stack_Size
: System
.Parameters
.Size_Type
;
875 Priority
: System
.Any_Priority
;
876 Succeeded
: out Boolean)
878 Initial_Stack_Size
: constant := 1024;
879 -- We set the initial stack size to 1024. On Windows version prior to XP
880 -- there is no way to fix a task stack size. Only the initial stack size
881 -- can be set, the operating system will raise the task stack size if
884 function Is_Windows_XP
return Integer;
885 pragma Import
(C
, Is_Windows_XP
, "__gnat_is_windows_xp");
886 -- Returns 1 if running on Windows XP
889 TaskId
: aliased DWORD
;
890 pTaskParameter
: Win32
.PVOID
;
892 Entry_Point
: PTHREAD_START_ROUTINE
;
894 use type System
.Multiprocessors
.CPU_Range
;
897 pTaskParameter
:= To_Address
(T
);
899 Entry_Point
:= To_PTHREAD_START_ROUTINE
(Wrapper
);
901 if Is_Windows_XP
= 1 then
902 hTask
:= CreateThread
907 DWORD
(Create_Suspended
) or
908 DWORD
(Stack_Size_Param_Is_A_Reservation
),
909 TaskId
'Unchecked_Access);
911 hTask
:= CreateThread
916 DWORD
(Create_Suspended
),
917 TaskId
'Unchecked_Access);
920 -- Step 1: Create the thread in blocked mode
927 -- Step 2: set its TCB
929 T
.Common
.LL
.Thread
:= hTask
;
931 -- Note: it would be useful to initialize Thread_Id right away to avoid
932 -- a race condition in gdb where Thread_ID may not have the right value
933 -- yet, but GetThreadId is a Vista specific API, not available under XP:
934 -- T.Common.LL.Thread_Id := GetThreadId (hTask); so instead we set the
935 -- field to 0 to avoid having a random value. Thread_Id is initialized
936 -- in Enter_Task anyway.
938 T
.Common
.LL
.Thread_Id
:= 0;
940 -- Step 3: set its priority (child has inherited priority from parent)
942 Set_Priority
(T
, Priority
);
944 if Time_Slice_Val
= 0
945 or else Dispatching_Policy
= 'F'
946 or else Get_Policy
(Priority
) = 'F'
948 -- Here we need Annex D semantics so we disable the NT priority
949 -- boost. A priority boost is temporarily given by the system to
950 -- a thread when it is taken out of a wait state.
952 SetThreadPriorityBoost
(hTask
, DisablePriorityBoost
=> Win32
.TRUE);
955 -- Step 4: Handle pragma CPU and Task_Info
957 if T
.Common
.Base_CPU
/= System
.Multiprocessors
.Not_A_Specific_CPU
then
959 -- The CPU numbering in pragma CPU starts at 1 while the subprogram
960 -- to set the affinity starts at 0, therefore we must subtract 1.
962 Result
:= SetThreadIdealProcessor
963 (hTask
, ProcessorId
(T
.Common
.Base_CPU
) - 1);
964 pragma Assert
(Result
= 1);
966 elsif T
.Common
.Task_Info
/= null then
967 if T
.Common
.Task_Info
.CPU
/= Task_Info
.Any_CPU
then
968 Result
:= SetThreadIdealProcessor
(hTask
, T
.Common
.Task_Info
.CPU
);
969 pragma Assert
(Result
= 1);
973 -- Step 5: Now, start it for good
975 Result
:= ResumeThread
(hTask
);
976 pragma Assert
(Result
= 1);
978 Succeeded
:= Result
= 1;
985 procedure Finalize_TCB
(T
: Task_Id
) is
986 Self_ID
: Task_Id
:= T
;
989 Is_Self
: constant Boolean := T
= Self
;
991 procedure Free
is new
992 Ada
.Unchecked_Deallocation
(Ada_Task_Control_Block
, Task_Id
);
995 if not Single_Lock
then
996 Finalize_Lock
(T
.Common
.LL
.L
'Access);
999 Finalize_Cond
(T
.Common
.LL
.CV
'Access);
1001 if T
.Known_Tasks_Index
/= -1 then
1002 Known_Tasks
(T
.Known_Tasks_Index
) := null;
1005 if Self_ID
.Common
.LL
.Thread
/= 0 then
1007 -- This task has been activated. Wait for the thread to terminate
1008 -- then close it. This is needed to release system resources.
1010 Result
:= WaitForSingleObject
(T
.Common
.LL
.Thread
, Wait_Infinite
);
1011 pragma Assert
(Result
/= WAIT_FAILED
);
1012 Succeeded
:= CloseHandle
(T
.Common
.LL
.Thread
);
1013 pragma Assert
(Succeeded
= Win32
.TRUE);
1019 Specific
.Set
(null);
1027 procedure Exit_Task
is
1029 Specific
.Set
(null);
1036 procedure Abort_Task
(T
: Task_Id
) is
1037 pragma Unreferenced
(T
);
1042 ----------------------
1043 -- Environment_Task --
1044 ----------------------
1046 function Environment_Task
return Task_Id
is
1048 return Environment_Task_Id
;
1049 end Environment_Task
;
1055 procedure Lock_RTS
is
1057 Write_Lock
(Single_RTS_Lock
'Access, Global_Lock
=> True);
1064 procedure Unlock_RTS
is
1066 Unlock
(Single_RTS_Lock
'Access, Global_Lock
=> True);
1073 procedure Initialize
(Environment_Task
: Task_Id
) is
1075 pragma Unreferenced
(Discard
);
1079 use type System
.Multiprocessors
.CPU_Range
;
1082 Environment_Task_Id
:= Environment_Task
;
1083 OS_Primitives
.Initialize
;
1084 Interrupt_Management
.Initialize
;
1086 if Time_Slice_Val
= 0 or else Dispatching_Policy
= 'F' then
1087 -- Here we need Annex D semantics, switch the current process to the
1088 -- Realtime_Priority_Class.
1090 Discard
:= OS_Interface
.SetPriorityClass
1091 (GetCurrentProcess
, Realtime_Priority_Class
);
1096 TlsIndex
:= TlsAlloc
;
1098 -- Initialize the lock used to synchronize chain of all ATCBs
1100 Initialize_Lock
(Single_RTS_Lock
'Access, RTS_Lock_Level
);
1102 Environment_Task
.Common
.LL
.Thread
:= GetCurrentThread
;
1104 -- Make environment task known here because it doesn't go through
1105 -- Activate_Tasks, which does it for all other tasks.
1107 Known_Tasks
(Known_Tasks
'First) := Environment_Task
;
1108 Environment_Task
.Known_Tasks_Index
:= Known_Tasks
'First;
1110 Enter_Task
(Environment_Task
);
1112 -- pragma CPU for the environment task
1114 if Environment_Task
.Common
.Base_CPU
/=
1115 System
.Multiprocessors
.Not_A_Specific_CPU
1117 -- The CPU numbering in pragma CPU starts at 1 while the subprogram
1118 -- to set the affinity starts at 0, therefore we must subtract 1.
1121 SetThreadIdealProcessor
1122 (Environment_Task
.Common
.LL
.Thread
,
1123 ProcessorId
(Environment_Task
.Common
.Base_CPU
) - 1);
1124 pragma Assert
(Result
= 1);
1128 ---------------------
1129 -- Monotonic_Clock --
1130 ---------------------
1132 function Monotonic_Clock
return Duration
1133 renames System
.OS_Primitives
.Monotonic_Clock
;
1139 function RT_Resolution
return Duration is
1141 return 0.000_001
; -- 1 micro-second
1148 procedure Initialize
(S
: in out Suspension_Object
) is
1150 -- Initialize internal state. It is always initialized to False (ARM
1156 -- Initialize internal mutex
1158 InitializeCriticalSection
(S
.L
'Access);
1160 -- Initialize internal condition variable
1162 S
.CV
:= CreateEvent
(null, Win32
.TRUE, Win32
.FALSE, Null_Ptr
);
1163 pragma Assert
(S
.CV
/= 0);
1170 procedure Finalize
(S
: in out Suspension_Object
) is
1174 -- Destroy internal mutex
1176 DeleteCriticalSection
(S
.L
'Access);
1178 -- Destroy internal condition variable
1180 Result
:= CloseHandle
(S
.CV
);
1181 pragma Assert
(Result
= Win32
.TRUE);
1188 function Current_State
(S
: Suspension_Object
) return Boolean is
1190 -- We do not want to use lock on this read operation. State is marked
1191 -- as Atomic so that we ensure that the value retrieved is correct.
1200 procedure Set_False
(S
: in out Suspension_Object
) is
1202 SSL
.Abort_Defer
.all;
1204 EnterCriticalSection
(S
.L
'Access);
1208 LeaveCriticalSection
(S
.L
'Access);
1210 SSL
.Abort_Undefer
.all;
1217 procedure Set_True
(S
: in out Suspension_Object
) is
1220 SSL
.Abort_Defer
.all;
1222 EnterCriticalSection
(S
.L
'Access);
1224 -- If there is already a task waiting on this suspension object then
1225 -- we resume it, leaving the state of the suspension object to False,
1226 -- as it is specified in ARM D.10 par. 9. Otherwise, it just leaves
1227 -- the state to True.
1233 Result
:= SetEvent
(S
.CV
);
1234 pragma Assert
(Result
= Win32
.TRUE);
1239 LeaveCriticalSection
(S
.L
'Access);
1241 SSL
.Abort_Undefer
.all;
1244 ------------------------
1245 -- Suspend_Until_True --
1246 ------------------------
1248 procedure Suspend_Until_True
(S
: in out Suspension_Object
) is
1253 SSL
.Abort_Defer
.all;
1255 EnterCriticalSection
(S
.L
'Access);
1258 -- Program_Error must be raised upon calling Suspend_Until_True
1259 -- if another task is already waiting on that suspension object
1260 -- (ARM D.10 par. 10).
1262 LeaveCriticalSection
(S
.L
'Access);
1264 SSL
.Abort_Undefer
.all;
1266 raise Program_Error
;
1268 -- Suspend the task if the state is False. Otherwise, the task
1269 -- continues its execution, and the state of the suspension object
1270 -- is set to False (ARM D.10 par. 9).
1275 LeaveCriticalSection
(S
.L
'Access);
1277 SSL
.Abort_Undefer
.all;
1281 -- Must reset CV BEFORE L is unlocked
1283 Result_Bool
:= ResetEvent
(S
.CV
);
1284 pragma Assert
(Result_Bool
= Win32
.TRUE);
1286 LeaveCriticalSection
(S
.L
'Access);
1288 SSL
.Abort_Undefer
.all;
1290 Result
:= WaitForSingleObject
(S
.CV
, Wait_Infinite
);
1291 pragma Assert
(Result
= 0);
1294 end Suspend_Until_True
;
1300 -- Dummy versions. The only currently working versions is for solaris
1303 function Check_Exit
(Self_ID
: ST
.Task_Id
) return Boolean is
1304 pragma Unreferenced
(Self_ID
);
1309 --------------------
1310 -- Check_No_Locks --
1311 --------------------
1313 function Check_No_Locks
(Self_ID
: ST
.Task_Id
) return Boolean is
1314 pragma Unreferenced
(Self_ID
);
1323 function Suspend_Task
1325 Thread_Self
: Thread_Id
) return Boolean
1328 if T
.Common
.LL
.Thread
/= Thread_Self
then
1329 return SuspendThread
(T
.Common
.LL
.Thread
) = NO_ERROR
;
1339 function Resume_Task
1341 Thread_Self
: Thread_Id
) return Boolean
1344 if T
.Common
.LL
.Thread
/= Thread_Self
then
1345 return ResumeThread
(T
.Common
.LL
.Thread
) = NO_ERROR
;
1351 --------------------
1352 -- Stop_All_Tasks --
1353 --------------------
1355 procedure Stop_All_Tasks
is
1364 function Stop_Task
(T
: ST
.Task_Id
) return Boolean is
1365 pragma Unreferenced
(T
);
1374 function Continue_Task
(T
: ST
.Task_Id
) return Boolean is
1375 pragma Unreferenced
(T
);
1380 end System
.Task_Primitives
.Operations
;