File : s-taprop-mingw.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
4 -- --
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 --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
10 -- --
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. --
17 -- --
18 -- --
19 -- --
20 -- --
21 -- --
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/>. --
26 -- --
27 -- GNARL was developed by the GNARL team at Florida State University. --
28 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
29 -- --
30 ------------------------------------------------------------------------------
31
32 -- This is a NT (native) version of this package
33
34 -- This package contains all the GNULL primitives that interface directly with
35 -- the underlying OS.
36
37 pragma Polling (Off);
38 -- Turn off polling, we do not want ATC polling to take place during tasking
39 -- operations. It causes infinite loops and other problems.
40
41 with Interfaces.C;
42 with Interfaces.C.Strings;
43
44 with System.Float_Control;
45 with System.Interrupt_Management;
46 with System.Multiprocessors;
47 with System.OS_Primitives;
48 with System.Task_Info;
49 with System.Tasking.Debug;
50 with System.Win32.Ext;
51
52 with System.Soft_Links;
53 -- We use System.Soft_Links instead of System.Tasking.Initialization because
54 -- the later is a higher level package that we shouldn't depend on. For
55 -- example when using the restricted run time, it is replaced by
56 -- System.Tasking.Restricted.Stages.
57
58 package body System.Task_Primitives.Operations is
59
60 package SSL renames System.Soft_Links;
61
62 use Interfaces.C;
63 use Interfaces.C.Strings;
64 use System.OS_Interface;
65 use System.OS_Primitives;
66 use System.Parameters;
67 use System.Task_Info;
68 use System.Tasking;
69 use System.Tasking.Debug;
70 use System.Win32;
71 use System.Win32.Ext;
72
73 pragma Link_With ("-Xlinker --stack=0x200000,0x1000");
74 -- Change the default stack size (2 MB) for tasking programs on Windows.
75 -- This allows about 1000 tasks running at the same time. Note that
76 -- we set the stack size for non tasking programs on System unit.
77 -- Also note that under Windows XP, we use a Windows XP extension to
78 -- specify the stack size on a per task basis, as done under other OSes.
79
80 ---------------------
81 -- Local Functions --
82 ---------------------
83
84 procedure InitializeCriticalSection (pCriticalSection : access RTS_Lock);
85 procedure InitializeCriticalSection
86 (pCriticalSection : access CRITICAL_SECTION);
87 pragma Import
88 (Stdcall, InitializeCriticalSection, "InitializeCriticalSection");
89
90 procedure EnterCriticalSection (pCriticalSection : access RTS_Lock);
91 procedure EnterCriticalSection
92 (pCriticalSection : access CRITICAL_SECTION);
93 pragma Import (Stdcall, EnterCriticalSection, "EnterCriticalSection");
94
95 procedure LeaveCriticalSection (pCriticalSection : access RTS_Lock);
96 procedure LeaveCriticalSection (pCriticalSection : access CRITICAL_SECTION);
97 pragma Import (Stdcall, LeaveCriticalSection, "LeaveCriticalSection");
98
99 procedure DeleteCriticalSection (pCriticalSection : access RTS_Lock);
100 procedure DeleteCriticalSection
101 (pCriticalSection : access CRITICAL_SECTION);
102 pragma Import (Stdcall, DeleteCriticalSection, "DeleteCriticalSection");
103
104 ----------------
105 -- Local Data --
106 ----------------
107
108 Environment_Task_Id : Task_Id;
109 -- A variable to hold Task_Id for the environment task
110
111 Single_RTS_Lock : aliased RTS_Lock;
112 -- This is a lock to allow only one thread of control in the RTS at
113 -- a time; it is used to execute in mutual exclusion from all other tasks.
114 -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
115
116 Time_Slice_Val : Integer;
117 pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
118
119 Dispatching_Policy : Character;
120 pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
121
122 function Get_Policy (Prio : System.Any_Priority) return Character;
123 pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching");
124 -- Get priority specific dispatching policy
125
126 Foreign_Task_Elaborated : aliased Boolean := True;
127 -- Used to identified fake tasks (i.e., non-Ada Threads)
128
129 Null_Thread_Id : constant Thread_Id := 0;
130 -- Constant to indicate that the thread identifier has not yet been
131 -- initialized.
132
133 ------------------------------------
134 -- The thread local storage index --
135 ------------------------------------
136
137 TlsIndex : DWORD;
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.
141
142 --------------------
143 -- Local Packages --
144 --------------------
145
146 package Specific is
147
148 function Is_Valid_Task return Boolean;
149 pragma Inline (Is_Valid_Task);
150 -- Does executing thread have a TCB?
151
152 procedure Set (Self_Id : Task_Id);
153 pragma Inline (Set);
154 -- Set the self id for the current task
155
156 end Specific;
157
158 package body Specific is
159
160 function Is_Valid_Task return Boolean is
161 begin
162 return TlsGetValue (TlsIndex) /= System.Null_Address;
163 end Is_Valid_Task;
164
165 procedure Set (Self_Id : Task_Id) is
166 Succeeded : BOOL;
167 begin
168 Succeeded := TlsSetValue (TlsIndex, To_Address (Self_Id));
169 pragma Assert (Succeeded = Win32.TRUE);
170 end Set;
171
172 end Specific;
173
174 ----------------------------------
175 -- ATCB allocation/deallocation --
176 ----------------------------------
177
178 package body ATCB_Allocation is separate;
179 -- The body of this package is shared across several targets
180
181 ---------------------------------
182 -- Support for foreign threads --
183 ---------------------------------
184
185 function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id;
186 -- Allocate and Initialize a new ATCB for the current Thread
187
188 function Register_Foreign_Thread
189 (Thread : Thread_Id) return Task_Id is separate;
190
191 ----------------------------------
192 -- Condition Variable Functions --
193 ----------------------------------
194
195 procedure Initialize_Cond (Cond : not null access Condition_Variable);
196 -- Initialize given condition variable Cond
197
198 procedure Finalize_Cond (Cond : not null access Condition_Variable);
199 -- Finalize given condition variable Cond
200
201 procedure Cond_Signal (Cond : not null access Condition_Variable);
202 -- Signal condition variable Cond
203
204 procedure Cond_Wait
205 (Cond : not null access Condition_Variable;
206 L : not null access RTS_Lock);
207 -- Wait on conditional variable Cond, using lock L
208
209 procedure Cond_Timed_Wait
210 (Cond : not null access Condition_Variable;
211 L : not null access RTS_Lock;
212 Rel_Time : Duration;
213 Timed_Out : out Boolean;
214 Status : out Integer);
215 -- Do timed wait on condition variable Cond using lock L. The duration
216 -- of the timed wait is given by Rel_Time. When the condition is
217 -- signalled, Timed_Out shows whether or not a time out occurred.
218 -- Status is only valid if Timed_Out is False, in which case it
219 -- shows whether Cond_Timed_Wait completed successfully.
220
221 ---------------------
222 -- Initialize_Cond --
223 ---------------------
224
225 procedure Initialize_Cond (Cond : not null access Condition_Variable) is
226 hEvent : HANDLE;
227 begin
228 hEvent := CreateEvent (null, Win32.TRUE, Win32.FALSE, Null_Ptr);
229 pragma Assert (hEvent /= 0);
230 Cond.all := Condition_Variable (hEvent);
231 end Initialize_Cond;
232
233 -------------------
234 -- Finalize_Cond --
235 -------------------
236
237 -- No such problem here, DosCloseEventSem has been derived.
238 -- What does such refer to in above comment???
239
240 procedure Finalize_Cond (Cond : not null access Condition_Variable) is
241 Result : BOOL;
242 begin
243 Result := CloseHandle (HANDLE (Cond.all));
244 pragma Assert (Result = Win32.TRUE);
245 end Finalize_Cond;
246
247 -----------------
248 -- Cond_Signal --
249 -----------------
250
251 procedure Cond_Signal (Cond : not null access Condition_Variable) is
252 Result : BOOL;
253 begin
254 Result := SetEvent (HANDLE (Cond.all));
255 pragma Assert (Result = Win32.TRUE);
256 end Cond_Signal;
257
258 ---------------
259 -- Cond_Wait --
260 ---------------
261
262 -- Pre-condition: Cond is posted
263 -- L is locked.
264
265 -- Post-condition: Cond is posted
266 -- L is locked.
267
268 procedure Cond_Wait
269 (Cond : not null access Condition_Variable;
270 L : not null access RTS_Lock)
271 is
272 Result : DWORD;
273 Result_Bool : BOOL;
274
275 begin
276 -- Must reset Cond BEFORE L is unlocked
277
278 Result_Bool := ResetEvent (HANDLE (Cond.all));
279 pragma Assert (Result_Bool = Win32.TRUE);
280 Unlock (L, Global_Lock => True);
281
282 -- No problem if we are interrupted here: if the condition is signaled,
283 -- WaitForSingleObject will simply not block
284
285 Result := WaitForSingleObject (HANDLE (Cond.all), Wait_Infinite);
286 pragma Assert (Result = 0);
287
288 Write_Lock (L, Global_Lock => True);
289 end Cond_Wait;
290
291 ---------------------
292 -- Cond_Timed_Wait --
293 ---------------------
294
295 -- Pre-condition: Cond is posted
296 -- L is locked.
297
298 -- Post-condition: Cond is posted
299 -- L is locked.
300
301 procedure Cond_Timed_Wait
302 (Cond : not null access Condition_Variable;
303 L : not null access RTS_Lock;
304 Rel_Time : Duration;
305 Timed_Out : out Boolean;
306 Status : out Integer)
307 is
308 Time_Out_Max : constant DWORD := 16#FFFF0000#;
309 -- NT 4 can't handle excessive timeout values (e.g. DWORD'Last - 1)
310
311 Time_Out : DWORD;
312 Result : BOOL;
313 Wait_Result : DWORD;
314
315 begin
316 -- Must reset Cond BEFORE L is unlocked
317
318 Result := ResetEvent (HANDLE (Cond.all));
319 pragma Assert (Result = Win32.TRUE);
320 Unlock (L, Global_Lock => True);
321
322 -- No problem if we are interrupted here: if the condition is signaled,
323 -- WaitForSingleObject will simply not block.
324
325 if Rel_Time <= 0.0 then
326 Timed_Out := True;
327 Wait_Result := 0;
328
329 else
330 Time_Out :=
331 (if Rel_Time >= Duration (Time_Out_Max) / 1000
332 then Time_Out_Max
333 else DWORD (Rel_Time * 1000));
334
335 Wait_Result := WaitForSingleObject (HANDLE (Cond.all), Time_Out);
336
337 if Wait_Result = WAIT_TIMEOUT then
338 Timed_Out := True;
339 Wait_Result := 0;
340 else
341 Timed_Out := False;
342 end if;
343 end if;
344
345 Write_Lock (L, Global_Lock => True);
346
347 -- Ensure post-condition
348
349 if Timed_Out then
350 Result := SetEvent (HANDLE (Cond.all));
351 pragma Assert (Result = Win32.TRUE);
352 end if;
353
354 Status := Integer (Wait_Result);
355 end Cond_Timed_Wait;
356
357 ------------------
358 -- Stack_Guard --
359 ------------------
360
361 -- The underlying thread system sets a guard page at the bottom of a thread
362 -- stack, so nothing is needed.
363 -- ??? Check the comment above
364
365 procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
366 pragma Unreferenced (T, On);
367 begin
368 null;
369 end Stack_Guard;
370
371 --------------------
372 -- Get_Thread_Id --
373 --------------------
374
375 function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
376 begin
377 return T.Common.LL.Thread;
378 end Get_Thread_Id;
379
380 ----------
381 -- Self --
382 ----------
383
384 function Self return Task_Id is
385 Self_Id : constant Task_Id := To_Task_Id (TlsGetValue (TlsIndex));
386 begin
387 if Self_Id = null then
388 return Register_Foreign_Thread (GetCurrentThread);
389 else
390 return Self_Id;
391 end if;
392 end Self;
393
394 ---------------------
395 -- Initialize_Lock --
396 ---------------------
397
398 -- Note: mutexes and cond_variables needed per-task basis are initialized
399 -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such
400 -- as RTS_Lock, Memory_Lock...) used in the RTS is initialized before any
401 -- status change of RTS. Therefore raising Storage_Error in the following
402 -- routines should be able to be handled safely.
403
404 procedure Initialize_Lock
405 (Prio : System.Any_Priority;
406 L : not null access Lock)
407 is
408 begin
409 InitializeCriticalSection (L.Mutex'Access);
410 L.Owner_Priority := 0;
411 L.Priority := Prio;
412 end Initialize_Lock;
413
414 procedure Initialize_Lock
415 (L : not null access RTS_Lock; Level : Lock_Level)
416 is
417 pragma Unreferenced (Level);
418 begin
419 InitializeCriticalSection (L);
420 end Initialize_Lock;
421
422 -------------------
423 -- Finalize_Lock --
424 -------------------
425
426 procedure Finalize_Lock (L : not null access Lock) is
427 begin
428 DeleteCriticalSection (L.Mutex'Access);
429 end Finalize_Lock;
430
431 procedure Finalize_Lock (L : not null access RTS_Lock) is
432 begin
433 DeleteCriticalSection (L);
434 end Finalize_Lock;
435
436 ----------------
437 -- Write_Lock --
438 ----------------
439
440 procedure Write_Lock
441 (L : not null access Lock; Ceiling_Violation : out Boolean) is
442 begin
443 L.Owner_Priority := Get_Priority (Self);
444
445 if L.Priority < L.Owner_Priority then
446 Ceiling_Violation := True;
447 return;
448 end if;
449
450 EnterCriticalSection (L.Mutex'Access);
451
452 Ceiling_Violation := False;
453 end Write_Lock;
454
455 procedure Write_Lock
456 (L : not null access RTS_Lock;
457 Global_Lock : Boolean := False)
458 is
459 begin
460 if not Single_Lock or else Global_Lock then
461 EnterCriticalSection (L);
462 end if;
463 end Write_Lock;
464
465 procedure Write_Lock (T : Task_Id) is
466 begin
467 if not Single_Lock then
468 EnterCriticalSection (T.Common.LL.L'Access);
469 end if;
470 end Write_Lock;
471
472 ---------------
473 -- Read_Lock --
474 ---------------
475
476 procedure Read_Lock
477 (L : not null access Lock; Ceiling_Violation : out Boolean) is
478 begin
479 Write_Lock (L, Ceiling_Violation);
480 end Read_Lock;
481
482 ------------
483 -- Unlock --
484 ------------
485
486 procedure Unlock (L : not null access Lock) is
487 begin
488 LeaveCriticalSection (L.Mutex'Access);
489 end Unlock;
490
491 procedure Unlock
492 (L : not null access RTS_Lock; Global_Lock : Boolean := False) is
493 begin
494 if not Single_Lock or else Global_Lock then
495 LeaveCriticalSection (L);
496 end if;
497 end Unlock;
498
499 procedure Unlock (T : Task_Id) is
500 begin
501 if not Single_Lock then
502 LeaveCriticalSection (T.Common.LL.L'Access);
503 end if;
504 end Unlock;
505
506 -----------------
507 -- Set_Ceiling --
508 -----------------
509
510 -- Dynamic priority ceilings are not supported by the underlying system
511
512 procedure Set_Ceiling
513 (L : not null access Lock;
514 Prio : System.Any_Priority)
515 is
516 pragma Unreferenced (L, Prio);
517 begin
518 null;
519 end Set_Ceiling;
520
521 -----------
522 -- Sleep --
523 -----------
524
525 procedure Sleep
526 (Self_ID : Task_Id;
527 Reason : System.Tasking.Task_States)
528 is
529 pragma Unreferenced (Reason);
530
531 begin
532 pragma Assert (Self_ID = Self);
533
534 if Single_Lock then
535 Cond_Wait (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
536 else
537 Cond_Wait (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
538 end if;
539
540 if Self_ID.Deferral_Level = 0
541 and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
542 then
543 Unlock (Self_ID);
544 raise Standard'Abort_Signal;
545 end if;
546 end Sleep;
547
548 -----------------
549 -- Timed_Sleep --
550 -----------------
551
552 -- This is for use within the run-time system, so abort is assumed to be
553 -- already deferred, and the caller should be holding its own ATCB lock.
554
555 procedure Timed_Sleep
556 (Self_ID : Task_Id;
557 Time : Duration;
558 Mode : ST.Delay_Modes;
559 Reason : System.Tasking.Task_States;
560 Timedout : out Boolean;
561 Yielded : out Boolean)
562 is
563 pragma Unreferenced (Reason);
564 Check_Time : Duration := Monotonic_Clock;
565 Rel_Time : Duration;
566 Abs_Time : Duration;
567
568 Result : Integer;
569 pragma Unreferenced (Result);
570
571 Local_Timedout : Boolean;
572
573 begin
574 Timedout := True;
575 Yielded := False;
576
577 if Mode = Relative then
578 Rel_Time := Time;
579 Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time;
580 else
581 Rel_Time := Time - Check_Time;
582 Abs_Time := Time;
583 end if;
584
585 if Rel_Time > 0.0 then
586 loop
587 exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
588
589 if Single_Lock then
590 Cond_Timed_Wait
591 (Self_ID.Common.LL.CV'Access,
592 Single_RTS_Lock'Access,
593 Rel_Time, Local_Timedout, Result);
594 else
595 Cond_Timed_Wait
596 (Self_ID.Common.LL.CV'Access,
597 Self_ID.Common.LL.L'Access,
598 Rel_Time, Local_Timedout, Result);
599 end if;
600
601 Check_Time := Monotonic_Clock;
602 exit when Abs_Time <= Check_Time;
603
604 if not Local_Timedout then
605
606 -- Somebody may have called Wakeup for us
607
608 Timedout := False;
609 exit;
610 end if;
611
612 Rel_Time := Abs_Time - Check_Time;
613 end loop;
614 end if;
615 end Timed_Sleep;
616
617 -----------------
618 -- Timed_Delay --
619 -----------------
620
621 procedure Timed_Delay
622 (Self_ID : Task_Id;
623 Time : Duration;
624 Mode : ST.Delay_Modes)
625 is
626 Check_Time : Duration := Monotonic_Clock;
627 Rel_Time : Duration;
628 Abs_Time : Duration;
629
630 Timedout : Boolean;
631 Result : Integer;
632 pragma Unreferenced (Timedout, Result);
633
634 begin
635 if Single_Lock then
636 Lock_RTS;
637 end if;
638
639 Write_Lock (Self_ID);
640
641 if Mode = Relative then
642 Rel_Time := Time;
643 Abs_Time := Time + Check_Time;
644 else
645 Rel_Time := Time - Check_Time;
646 Abs_Time := Time;
647 end if;
648
649 if Rel_Time > 0.0 then
650 Self_ID.Common.State := Delay_Sleep;
651
652 loop
653 exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
654
655 if Single_Lock then
656 Cond_Timed_Wait
657 (Self_ID.Common.LL.CV'Access,
658 Single_RTS_Lock'Access,
659 Rel_Time, Timedout, Result);
660 else
661 Cond_Timed_Wait
662 (Self_ID.Common.LL.CV'Access,
663 Self_ID.Common.LL.L'Access,
664 Rel_Time, Timedout, Result);
665 end if;
666
667 Check_Time := Monotonic_Clock;
668 exit when Abs_Time <= Check_Time;
669
670 Rel_Time := Abs_Time - Check_Time;
671 end loop;
672
673 Self_ID.Common.State := Runnable;
674 end if;
675
676 Unlock (Self_ID);
677
678 if Single_Lock then
679 Unlock_RTS;
680 end if;
681
682 Yield;
683 end Timed_Delay;
684
685 ------------
686 -- Wakeup --
687 ------------
688
689 procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
690 pragma Unreferenced (Reason);
691 begin
692 Cond_Signal (T.Common.LL.CV'Access);
693 end Wakeup;
694
695 -----------
696 -- Yield --
697 -----------
698
699 procedure Yield (Do_Yield : Boolean := True) is
700 begin
701 -- Note: in a previous implementation if Do_Yield was False, then we
702 -- introduced a delay of 1 millisecond in an attempt to get closer to
703 -- annex D semantics, and in particular to make ACATS CXD8002 pass. But
704 -- this change introduced a huge performance regression evaluating the
705 -- Count attribute. So we decided to remove this processing.
706
707 -- Moreover, CXD8002 appears to pass on Windows (although we do not
708 -- guarantee full Annex D compliance on Windows in any case).
709
710 if Do_Yield then
711 SwitchToThread;
712 end if;
713 end Yield;
714
715 ------------------
716 -- Set_Priority --
717 ------------------
718
719 procedure Set_Priority
720 (T : Task_Id;
721 Prio : System.Any_Priority;
722 Loss_Of_Inheritance : Boolean := False)
723 is
724 Res : BOOL;
725 pragma Unreferenced (Loss_Of_Inheritance);
726
727 begin
728 Res :=
729 SetThreadPriority
730 (T.Common.LL.Thread,
731 Interfaces.C.int (Underlying_Priorities (Prio)));
732 pragma Assert (Res = Win32.TRUE);
733
734 -- Note: Annex D (RM D.2.3(5/2)) requires the task to be placed at the
735 -- head of its priority queue when decreasing its priority as a result
736 -- of a loss of inherited priority. This is not the case, but we
737 -- consider it an acceptable variation (RM 1.1.3(6)), given this is
738 -- the built-in behavior offered by the Windows operating system.
739
740 -- In older versions we attempted to better approximate the Annex D
741 -- required behavior, but this simulation was not entirely accurate,
742 -- and it seems better to live with the standard Windows semantics.
743
744 T.Common.Current_Priority := Prio;
745 end Set_Priority;
746
747 ------------------
748 -- Get_Priority --
749 ------------------
750
751 function Get_Priority (T : Task_Id) return System.Any_Priority is
752 begin
753 return T.Common.Current_Priority;
754 end Get_Priority;
755
756 ----------------
757 -- Enter_Task --
758 ----------------
759
760 -- There were two paths were we needed to call Enter_Task :
761 -- 1) from System.Task_Primitives.Operations.Initialize
762 -- 2) from System.Tasking.Stages.Task_Wrapper
763
764 -- The thread initialisation has to be done only for the first case
765
766 -- This is because the GetCurrentThread NT call does not return the real
767 -- thread handler but only a "pseudo" one. It is not possible to release
768 -- the thread handle and free the system resources from this "pseudo"
769 -- handle. So we really want to keep the real thread handle set in
770 -- System.Task_Primitives.Operations.Create_Task during thread creation.
771
772 procedure Enter_Task (Self_ID : Task_Id) is
773 procedure Get_Stack_Bounds (Base : Address; Limit : Address);
774 pragma Import (C, Get_Stack_Bounds, "__gnat_get_stack_bounds");
775 -- Get stack boundaries
776 begin
777 Specific.Set (Self_ID);
778
779 -- Properly initializes the FPU for x86 systems
780
781 System.Float_Control.Reset;
782
783 if Self_ID.Common.Task_Info /= null
784 and then
785 Self_ID.Common.Task_Info.CPU >= CPU_Number (Number_Of_Processors)
786 then
787 raise Invalid_CPU_Number;
788 end if;
789
790 Self_ID.Common.LL.Thread_Id := GetCurrentThreadId;
791
792 Get_Stack_Bounds
793 (Self_ID.Common.Compiler_Data.Pri_Stack_Info.Base'Address,
794 Self_ID.Common.Compiler_Data.Pri_Stack_Info.Limit'Address);
795 end Enter_Task;
796
797 -------------------
798 -- Is_Valid_Task --
799 -------------------
800
801 function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task;
802
803 -----------------------------
804 -- Register_Foreign_Thread --
805 -----------------------------
806
807 function Register_Foreign_Thread return Task_Id is
808 begin
809 if Is_Valid_Task then
810 return Self;
811 else
812 return Register_Foreign_Thread (GetCurrentThread);
813 end if;
814 end Register_Foreign_Thread;
815
816 --------------------
817 -- Initialize_TCB --
818 --------------------
819
820 procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
821 begin
822 -- Initialize thread ID to 0, this is needed to detect threads that
823 -- are not yet activated.
824
825 Self_ID.Common.LL.Thread := Null_Thread_Id;
826
827 Initialize_Cond (Self_ID.Common.LL.CV'Access);
828
829 if not Single_Lock then
830 Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level);
831 end if;
832
833 Succeeded := True;
834 end Initialize_TCB;
835
836 -----------------
837 -- Create_Task --
838 -----------------
839
840 procedure Create_Task
841 (T : Task_Id;
842 Wrapper : System.Address;
843 Stack_Size : System.Parameters.Size_Type;
844 Priority : System.Any_Priority;
845 Succeeded : out Boolean)
846 is
847 Initial_Stack_Size : constant := 1024;
848 -- We set the initial stack size to 1024. On Windows version prior to XP
849 -- there is no way to fix a task stack size. Only the initial stack size
850 -- can be set, the operating system will raise the task stack size if
851 -- needed.
852
853 function Is_Windows_XP return Integer;
854 pragma Import (C, Is_Windows_XP, "__gnat_is_windows_xp");
855 -- Returns 1 if running on Windows XP
856
857 hTask : HANDLE;
858 TaskId : aliased DWORD;
859 pTaskParameter : Win32.PVOID;
860 Result : DWORD;
861 Entry_Point : PTHREAD_START_ROUTINE;
862
863 use type System.Multiprocessors.CPU_Range;
864
865 begin
866 -- Check whether both Dispatching_Domain and CPU are specified for the
867 -- task, and the CPU value is not contained within the range of
868 -- processors for the domain.
869
870 if T.Common.Domain /= null
871 and then T.Common.Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU
872 and then
873 (T.Common.Base_CPU not in T.Common.Domain'Range
874 or else not T.Common.Domain (T.Common.Base_CPU))
875 then
876 Succeeded := False;
877 return;
878 end if;
879
880 pTaskParameter := To_Address (T);
881
882 Entry_Point := To_PTHREAD_START_ROUTINE (Wrapper);
883
884 if Is_Windows_XP = 1 then
885 hTask := CreateThread
886 (null,
887 DWORD (Stack_Size),
888 Entry_Point,
889 pTaskParameter,
890 DWORD (Create_Suspended) or
891 DWORD (Stack_Size_Param_Is_A_Reservation),
892 TaskId'Unchecked_Access);
893 else
894 hTask := CreateThread
895 (null,
896 Initial_Stack_Size,
897 Entry_Point,
898 pTaskParameter,
899 DWORD (Create_Suspended),
900 TaskId'Unchecked_Access);
901 end if;
902
903 -- Step 1: Create the thread in blocked mode
904
905 if hTask = 0 then
906 Succeeded := False;
907 return;
908 end if;
909
910 -- Step 2: set its TCB
911
912 T.Common.LL.Thread := hTask;
913
914 -- Note: it would be useful to initialize Thread_Id right away to avoid
915 -- a race condition in gdb where Thread_ID may not have the right value
916 -- yet, but GetThreadId is a Vista specific API, not available under XP:
917 -- T.Common.LL.Thread_Id := GetThreadId (hTask); so instead we set the
918 -- field to 0 to avoid having a random value. Thread_Id is initialized
919 -- in Enter_Task anyway.
920
921 T.Common.LL.Thread_Id := 0;
922
923 -- Step 3: set its priority (child has inherited priority from parent)
924
925 Set_Priority (T, Priority);
926
927 if Time_Slice_Val = 0
928 or else Dispatching_Policy = 'F'
929 or else Get_Policy (Priority) = 'F'
930 then
931 -- Here we need Annex D semantics so we disable the NT priority
932 -- boost. A priority boost is temporarily given by the system to
933 -- a thread when it is taken out of a wait state.
934
935 SetThreadPriorityBoost (hTask, DisablePriorityBoost => Win32.TRUE);
936 end if;
937
938 -- Step 4: Handle pragma CPU and Task_Info
939
940 Set_Task_Affinity (T);
941
942 -- Step 5: Now, start it for good
943
944 Result := ResumeThread (hTask);
945 pragma Assert (Result = 1);
946
947 Succeeded := Result = 1;
948 end Create_Task;
949
950 ------------------
951 -- Finalize_TCB --
952 ------------------
953
954 procedure Finalize_TCB (T : Task_Id) is
955 Succeeded : BOOL;
956
957 begin
958 if not Single_Lock then
959 Finalize_Lock (T.Common.LL.L'Access);
960 end if;
961
962 Finalize_Cond (T.Common.LL.CV'Access);
963
964 if T.Known_Tasks_Index /= -1 then
965 Known_Tasks (T.Known_Tasks_Index) := null;
966 end if;
967
968 if T.Common.LL.Thread /= 0 then
969
970 -- This task has been activated. Close the thread handle. This
971 -- is needed to release system resources.
972
973 Succeeded := CloseHandle (T.Common.LL.Thread);
974 pragma Assert (Succeeded = Win32.TRUE);
975 end if;
976
977 ATCB_Allocation.Free_ATCB (T);
978 end Finalize_TCB;
979
980 ---------------
981 -- Exit_Task --
982 ---------------
983
984 procedure Exit_Task is
985 begin
986 Specific.Set (null);
987 end Exit_Task;
988
989 ----------------
990 -- Abort_Task --
991 ----------------
992
993 procedure Abort_Task (T : Task_Id) is
994 pragma Unreferenced (T);
995 begin
996 null;
997 end Abort_Task;
998
999 ----------------------
1000 -- Environment_Task --
1001 ----------------------
1002
1003 function Environment_Task return Task_Id is
1004 begin
1005 return Environment_Task_Id;
1006 end Environment_Task;
1007
1008 --------------
1009 -- Lock_RTS --
1010 --------------
1011
1012 procedure Lock_RTS is
1013 begin
1014 Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
1015 end Lock_RTS;
1016
1017 ----------------
1018 -- Unlock_RTS --
1019 ----------------
1020
1021 procedure Unlock_RTS is
1022 begin
1023 Unlock (Single_RTS_Lock'Access, Global_Lock => True);
1024 end Unlock_RTS;
1025
1026 ----------------
1027 -- Initialize --
1028 ----------------
1029
1030 procedure Initialize (Environment_Task : Task_Id) is
1031 Discard : BOOL;
1032
1033 begin
1034 Environment_Task_Id := Environment_Task;
1035 OS_Primitives.Initialize;
1036 Interrupt_Management.Initialize;
1037
1038 if Time_Slice_Val = 0 or else Dispatching_Policy = 'F' then
1039 -- Here we need Annex D semantics, switch the current process to the
1040 -- Realtime_Priority_Class.
1041
1042 Discard := OS_Interface.SetPriorityClass
1043 (GetCurrentProcess, Realtime_Priority_Class);
1044 end if;
1045
1046 TlsIndex := TlsAlloc;
1047
1048 -- Initialize the lock used to synchronize chain of all ATCBs
1049
1050 Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
1051
1052 Environment_Task.Common.LL.Thread := GetCurrentThread;
1053
1054 -- Make environment task known here because it doesn't go through
1055 -- Activate_Tasks, which does it for all other tasks.
1056
1057 Known_Tasks (Known_Tasks'First) := Environment_Task;
1058 Environment_Task.Known_Tasks_Index := Known_Tasks'First;
1059
1060 Enter_Task (Environment_Task);
1061
1062 -- pragma CPU and dispatching domains for the environment task
1063
1064 Set_Task_Affinity (Environment_Task);
1065 end Initialize;
1066
1067 ---------------------
1068 -- Monotonic_Clock --
1069 ---------------------
1070
1071 function Monotonic_Clock return Duration is
1072 function Internal_Clock return Duration;
1073 pragma Import (Ada, Internal_Clock, "__gnat_monotonic_clock");
1074 begin
1075 return Internal_Clock;
1076 end Monotonic_Clock;
1077
1078 -------------------
1079 -- RT_Resolution --
1080 -------------------
1081
1082 function RT_Resolution return Duration is
1083 Ticks_Per_Second : aliased LARGE_INTEGER;
1084 begin
1085 QueryPerformanceFrequency (Ticks_Per_Second'Access);
1086 return Duration (1.0 / Ticks_Per_Second);
1087 end RT_Resolution;
1088
1089 ----------------
1090 -- Initialize --
1091 ----------------
1092
1093 procedure Initialize (S : in out Suspension_Object) is
1094 begin
1095 -- Initialize internal state. It is always initialized to False (ARM
1096 -- D.10 par. 6).
1097
1098 S.State := False;
1099 S.Waiting := False;
1100
1101 -- Initialize internal mutex
1102
1103 InitializeCriticalSection (S.L'Access);
1104
1105 -- Initialize internal condition variable
1106
1107 S.CV := CreateEvent (null, Win32.TRUE, Win32.FALSE, Null_Ptr);
1108 pragma Assert (S.CV /= 0);
1109 end Initialize;
1110
1111 --------------
1112 -- Finalize --
1113 --------------
1114
1115 procedure Finalize (S : in out Suspension_Object) is
1116 Result : BOOL;
1117
1118 begin
1119 -- Destroy internal mutex
1120
1121 DeleteCriticalSection (S.L'Access);
1122
1123 -- Destroy internal condition variable
1124
1125 Result := CloseHandle (S.CV);
1126 pragma Assert (Result = Win32.TRUE);
1127 end Finalize;
1128
1129 -------------------
1130 -- Current_State --
1131 -------------------
1132
1133 function Current_State (S : Suspension_Object) return Boolean is
1134 begin
1135 -- We do not want to use lock on this read operation. State is marked
1136 -- as Atomic so that we ensure that the value retrieved is correct.
1137
1138 return S.State;
1139 end Current_State;
1140
1141 ---------------
1142 -- Set_False --
1143 ---------------
1144
1145 procedure Set_False (S : in out Suspension_Object) is
1146 begin
1147 SSL.Abort_Defer.all;
1148
1149 EnterCriticalSection (S.L'Access);
1150
1151 S.State := False;
1152
1153 LeaveCriticalSection (S.L'Access);
1154
1155 SSL.Abort_Undefer.all;
1156 end Set_False;
1157
1158 --------------
1159 -- Set_True --
1160 --------------
1161
1162 procedure Set_True (S : in out Suspension_Object) is
1163 Result : BOOL;
1164
1165 begin
1166 SSL.Abort_Defer.all;
1167
1168 EnterCriticalSection (S.L'Access);
1169
1170 -- If there is already a task waiting on this suspension object then
1171 -- we resume it, leaving the state of the suspension object to False,
1172 -- as it is specified in ARM D.10 par. 9. Otherwise, it just leaves
1173 -- the state to True.
1174
1175 if S.Waiting then
1176 S.Waiting := False;
1177 S.State := False;
1178
1179 Result := SetEvent (S.CV);
1180 pragma Assert (Result = Win32.TRUE);
1181
1182 else
1183 S.State := True;
1184 end if;
1185
1186 LeaveCriticalSection (S.L'Access);
1187
1188 SSL.Abort_Undefer.all;
1189 end Set_True;
1190
1191 ------------------------
1192 -- Suspend_Until_True --
1193 ------------------------
1194
1195 procedure Suspend_Until_True (S : in out Suspension_Object) is
1196 Result : DWORD;
1197 Result_Bool : BOOL;
1198
1199 begin
1200 SSL.Abort_Defer.all;
1201
1202 EnterCriticalSection (S.L'Access);
1203
1204 if S.Waiting then
1205
1206 -- Program_Error must be raised upon calling Suspend_Until_True
1207 -- if another task is already waiting on that suspension object
1208 -- (ARM D.10 par. 10).
1209
1210 LeaveCriticalSection (S.L'Access);
1211
1212 SSL.Abort_Undefer.all;
1213
1214 raise Program_Error;
1215
1216 else
1217 -- Suspend the task if the state is False. Otherwise, the task
1218 -- continues its execution, and the state of the suspension object
1219 -- is set to False (ARM D.10 par. 9).
1220
1221 if S.State then
1222 S.State := False;
1223
1224 LeaveCriticalSection (S.L'Access);
1225
1226 SSL.Abort_Undefer.all;
1227
1228 else
1229 S.Waiting := True;
1230
1231 -- Must reset CV BEFORE L is unlocked
1232
1233 Result_Bool := ResetEvent (S.CV);
1234 pragma Assert (Result_Bool = Win32.TRUE);
1235
1236 LeaveCriticalSection (S.L'Access);
1237
1238 SSL.Abort_Undefer.all;
1239
1240 Result := WaitForSingleObject (S.CV, Wait_Infinite);
1241 pragma Assert (Result = 0);
1242 end if;
1243 end if;
1244 end Suspend_Until_True;
1245
1246 ----------------
1247 -- Check_Exit --
1248 ----------------
1249
1250 -- Dummy versions, currently this only works for solaris (native)
1251
1252 function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
1253 pragma Unreferenced (Self_ID);
1254 begin
1255 return True;
1256 end Check_Exit;
1257
1258 --------------------
1259 -- Check_No_Locks --
1260 --------------------
1261
1262 function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
1263 pragma Unreferenced (Self_ID);
1264 begin
1265 return True;
1266 end Check_No_Locks;
1267
1268 ------------------
1269 -- Suspend_Task --
1270 ------------------
1271
1272 function Suspend_Task
1273 (T : ST.Task_Id;
1274 Thread_Self : Thread_Id) return Boolean
1275 is
1276 begin
1277 if T.Common.LL.Thread /= Thread_Self then
1278 return SuspendThread (T.Common.LL.Thread) = NO_ERROR;
1279 else
1280 return True;
1281 end if;
1282 end Suspend_Task;
1283
1284 -----------------
1285 -- Resume_Task --
1286 -----------------
1287
1288 function Resume_Task
1289 (T : ST.Task_Id;
1290 Thread_Self : Thread_Id) return Boolean
1291 is
1292 begin
1293 if T.Common.LL.Thread /= Thread_Self then
1294 return ResumeThread (T.Common.LL.Thread) = NO_ERROR;
1295 else
1296 return True;
1297 end if;
1298 end Resume_Task;
1299
1300 --------------------
1301 -- Stop_All_Tasks --
1302 --------------------
1303
1304 procedure Stop_All_Tasks is
1305 begin
1306 null;
1307 end Stop_All_Tasks;
1308
1309 ---------------
1310 -- Stop_Task --
1311 ---------------
1312
1313 function Stop_Task (T : ST.Task_Id) return Boolean is
1314 pragma Unreferenced (T);
1315 begin
1316 return False;
1317 end Stop_Task;
1318
1319 -------------------
1320 -- Continue_Task --
1321 -------------------
1322
1323 function Continue_Task (T : ST.Task_Id) return Boolean is
1324 pragma Unreferenced (T);
1325 begin
1326 return False;
1327 end Continue_Task;
1328
1329 -----------------------
1330 -- Set_Task_Affinity --
1331 -----------------------
1332
1333 procedure Set_Task_Affinity (T : ST.Task_Id) is
1334 Result : DWORD;
1335
1336 use type System.Multiprocessors.CPU_Range;
1337
1338 begin
1339 -- Do nothing if the underlying thread has not yet been created. If the
1340 -- thread has not yet been created then the proper affinity will be set
1341 -- during its creation.
1342
1343 if T.Common.LL.Thread = Null_Thread_Id then
1344 null;
1345
1346 -- pragma CPU
1347
1348 elsif T.Common.Base_CPU /= Multiprocessors.Not_A_Specific_CPU then
1349
1350 -- The CPU numbering in pragma CPU starts at 1 while the subprogram
1351 -- to set the affinity starts at 0, therefore we must substract 1.
1352
1353 Result :=
1354 SetThreadIdealProcessor
1355 (T.Common.LL.Thread, ProcessorId (T.Common.Base_CPU) - 1);
1356 pragma Assert (Result = 1);
1357
1358 -- Task_Info
1359
1360 elsif T.Common.Task_Info /= null then
1361 if T.Common.Task_Info.CPU /= Task_Info.Any_CPU then
1362 Result :=
1363 SetThreadIdealProcessor
1364 (T.Common.LL.Thread, T.Common.Task_Info.CPU);
1365 pragma Assert (Result = 1);
1366 end if;
1367
1368 -- Dispatching domains
1369
1370 elsif T.Common.Domain /= null
1371 and then (T.Common.Domain /= ST.System_Domain
1372 or else
1373 T.Common.Domain.all /=
1374 (Multiprocessors.CPU'First ..
1375 Multiprocessors.Number_Of_CPUs => True))
1376 then
1377 declare
1378 CPU_Set : DWORD := 0;
1379
1380 begin
1381 for Proc in T.Common.Domain'Range loop
1382 if T.Common.Domain (Proc) then
1383
1384 -- The thread affinity mask is a bit vector in which each
1385 -- bit represents a logical processor.
1386
1387 CPU_Set := CPU_Set + 2 ** (Integer (Proc) - 1);
1388 end if;
1389 end loop;
1390
1391 Result := SetThreadAffinityMask (T.Common.LL.Thread, CPU_Set);
1392 pragma Assert (Result = 1);
1393 end;
1394 end if;
1395 end Set_Task_Affinity;
1396
1397 end System.Task_Primitives.Operations;