?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Merge from mainline
[official-gcc.git] / gcc / ada / s-taprop-mingw.adb
blob7280f646dd26c4f183432eab2b178ce7f629dfc6
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-2006, 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 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. --
21 -- --
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. --
28 -- --
29 -- GNARL was developed by the GNARL team at Florida State University. --
30 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
31 -- --
32 ------------------------------------------------------------------------------
33
34 -- This is a NT (native) version of this package
35
36 -- This package contains all the GNULL primitives that interface directly
37 -- with the underlying OS.
38
39 pragma Polling (Off);
40 -- Turn off polling, we do not want ATC polling to take place during
41 -- tasking operations. It causes infinite loops and other problems.
42
43 with System.Tasking.Debug;
44 -- used for Known_Tasks
45
46 with System.OS_Primitives;
47 -- used for Delay_Modes
48
49 with Interfaces.C;
50 -- used for int
51 -- size_t
52
53 with Interfaces.C.Strings;
54 -- used for Null_Ptr
55
56 with System.Task_Info;
57 -- used for Unspecified_Task_Info
58
59 with Unchecked_Deallocation;
60
61 package body System.Task_Primitives.Operations is
62
63 use System.Tasking.Debug;
64 use System.Tasking;
65 use Interfaces.C;
66 use Interfaces.C.Strings;
67 use System.OS_Interface;
68 use System.Parameters;
69 use System.OS_Primitives;
70
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.
77
78 ----------------
79 -- Local Data --
80 ----------------
81
82 Environment_Task_Id : Task_Id;
83 -- A variable to hold Task_Id for the environment task
84
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
89
90 Time_Slice_Val : Integer;
91 pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
92
93 Dispatching_Policy : Character;
94 pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
95
96 Foreign_Task_Elaborated : aliased Boolean := True;
97 -- Used to identified fake tasks (i.e., non-Ada Threads)
98
99 ------------------------------------
100 -- The thread local storage index --
101 ------------------------------------
102
103 TlsIndex : DWORD;
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.
107
108 --------------------
109 -- Local Packages --
110 --------------------
111
112 package Specific is
113
114 function Is_Valid_Task return Boolean;
115 pragma Inline (Is_Valid_Task);
116 -- Does executing thread have a TCB?
117
118 procedure Set (Self_Id : Task_Id);
119 pragma Inline (Set);
120 -- Set the self id for the current task.
121
122 end Specific;
123
124 package body Specific is
125
126 function Is_Valid_Task return Boolean is
127 begin
128 return TlsGetValue (TlsIndex) /= System.Null_Address;
129 end Is_Valid_Task;
130
131 procedure Set (Self_Id : Task_Id) is
132 Succeeded : BOOL;
133 begin
134 Succeeded := TlsSetValue (TlsIndex, To_Address (Self_Id));
135 pragma Assert (Succeeded = True);
136 end Set;
137
138 end Specific;
139
140 ---------------------------------
141 -- Support for foreign threads --
142 ---------------------------------
143
144 function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id;
145 -- Allocate and Initialize a new ATCB for the current Thread.
146
147 function Register_Foreign_Thread
148 (Thread : Thread_Id) return Task_Id is separate;
149
150 ----------------------------------
151 -- Condition Variable Functions --
152 ----------------------------------
153
154 procedure Initialize_Cond (Cond : access Condition_Variable);
155 -- Initialize given condition variable Cond
156
157 procedure Finalize_Cond (Cond : access Condition_Variable);
158 -- Finalize given condition variable Cond.
159
160 procedure Cond_Signal (Cond : access Condition_Variable);
161 -- Signal condition variable Cond
162
163 procedure Cond_Wait
164 (Cond : access Condition_Variable;
165 L : access RTS_Lock);
166 -- Wait on conditional variable Cond, using lock L
167
168 procedure Cond_Timed_Wait
169 (Cond : access Condition_Variable;
170 L : access RTS_Lock;
171 Rel_Time : Duration;
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.
179
180 ---------------------
181 -- Initialize_Cond --
182 ---------------------
183
184 procedure Initialize_Cond (Cond : access Condition_Variable) is
185 hEvent : HANDLE;
186
187 begin
188 hEvent := CreateEvent (null, True, False, Null_Ptr);
189 pragma Assert (hEvent /= 0);
190 Cond.all := Condition_Variable (hEvent);
191 end Initialize_Cond;
192
193 -------------------
194 -- Finalize_Cond --
195 -------------------
196
197 -- No such problem here, DosCloseEventSem has been derived.
198 -- What does such refer to in above comment???
199
200 procedure Finalize_Cond (Cond : access Condition_Variable) is
201 Result : BOOL;
202 begin
203 Result := CloseHandle (HANDLE (Cond.all));
204 pragma Assert (Result = True);
205 end Finalize_Cond;
206
207 -----------------
208 -- Cond_Signal --
209 -----------------
210
211 procedure Cond_Signal (Cond : access Condition_Variable) is
212 Result : BOOL;
213 begin
214 Result := SetEvent (HANDLE (Cond.all));
215 pragma Assert (Result = True);
216 end Cond_Signal;
217
218 ---------------
219 -- Cond_Wait --
220 ---------------
221
222 -- Pre-assertion: Cond is posted
223 -- L is locked.
224
225 -- Post-assertion: Cond is posted
226 -- L is locked.
227
228 procedure Cond_Wait
229 (Cond : access Condition_Variable;
230 L : access RTS_Lock)
231 is
232 Result : DWORD;
233 Result_Bool : BOOL;
234
235 begin
236 -- Must reset Cond BEFORE L is unlocked.
237
238 Result_Bool := ResetEvent (HANDLE (Cond.all));
239 pragma Assert (Result_Bool = True);
240 Unlock (L);
241
242 -- No problem if we are interrupted here: if the condition is signaled,
243 -- WaitForSingleObject will simply not block
244
245 Result := WaitForSingleObject (HANDLE (Cond.all), Wait_Infinite);
246 pragma Assert (Result = 0);
247
248 Write_Lock (L);
249 end Cond_Wait;
250
251 ---------------------
252 -- Cond_Timed_Wait --
253 ---------------------
254
255 -- Pre-assertion: Cond is posted
256 -- L is locked.
257
258 -- Post-assertion: Cond is posted
259 -- L is locked.
260
261 procedure Cond_Timed_Wait
262 (Cond : access Condition_Variable;
263 L : access RTS_Lock;
264 Rel_Time : Duration;
265 Timed_Out : out Boolean;
266 Status : out Integer)
267 is
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
271
272 Time_Out : DWORD;
273 Result : BOOL;
274 Wait_Result : DWORD;
275
276 begin
277 -- Must reset Cond BEFORE L is unlocked.
278
279 Result := ResetEvent (HANDLE (Cond.all));
280 pragma Assert (Result = True);
281 Unlock (L);
282
283 -- No problem if we are interrupted here: if the condition is signaled,
284 -- WaitForSingleObject will simply not block
285
286 if Rel_Time <= 0.0 then
287 Timed_Out := True;
288 Wait_Result := 0;
289
290 else
291 if Rel_Time >= Duration (Time_Out_Max) / 1000 then
292 Time_Out := Time_Out_Max;
293 else
294 Time_Out := DWORD (Rel_Time * 1000);
295 end if;
296
297 Wait_Result := WaitForSingleObject (HANDLE (Cond.all), Time_Out);
298
299 if Wait_Result = WAIT_TIMEOUT then
300 Timed_Out := True;
301 Wait_Result := 0;
302 else
303 Timed_Out := False;
304 end if;
305 end if;
306
307 Write_Lock (L);
308
309 -- Ensure post-condition
310
311 if Timed_Out then
312 Result := SetEvent (HANDLE (Cond.all));
313 pragma Assert (Result = True);
314 end if;
315
316 Status := Integer (Wait_Result);
317 end Cond_Timed_Wait;
318
319 ------------------
320 -- Stack_Guard --
321 ------------------
322
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
326
327 procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
328 pragma Warnings (Off, T);
329 pragma Warnings (Off, On);
330
331 begin
332 null;
333 end Stack_Guard;
334
335 --------------------
336 -- Get_Thread_Id --
337 --------------------
338
339 function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
340 begin
341 return T.Common.LL.Thread;
342 end Get_Thread_Id;
343
344 ----------
345 -- Self --
346 ----------
347
348 function Self return Task_Id is
349 Self_Id : constant Task_Id := To_Task_Id (TlsGetValue (TlsIndex));
350 begin
351 if Self_Id = null then
352 return Register_Foreign_Thread (GetCurrentThread);
353 else
354 return Self_Id;
355 end if;
356 end Self;
357
358 ---------------------
359 -- Initialize_Lock --
360 ---------------------
361
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.
368
369 procedure Initialize_Lock
370 (Prio : System.Any_Priority;
371 L : access Lock)
372 is
373 begin
374 InitializeCriticalSection (L.Mutex'Access);
375 L.Owner_Priority := 0;
376 L.Priority := Prio;
377 end Initialize_Lock;
378
379 procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is
380 pragma Unreferenced (Level);
381 begin
382 InitializeCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access);
383 end Initialize_Lock;
384
385 -------------------
386 -- Finalize_Lock --
387 -------------------
388
389 procedure Finalize_Lock (L : access Lock) is
390 begin
391 DeleteCriticalSection (L.Mutex'Access);
392 end Finalize_Lock;
393
394 procedure Finalize_Lock (L : access RTS_Lock) is
395 begin
396 DeleteCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access);
397 end Finalize_Lock;
398
399 ----------------
400 -- Write_Lock --
401 ----------------
402
403 procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
404 begin
405 L.Owner_Priority := Get_Priority (Self);
406
407 if L.Priority < L.Owner_Priority then
408 Ceiling_Violation := True;
409 return;
410 end if;
411
412 EnterCriticalSection (L.Mutex'Access);
413
414 Ceiling_Violation := False;
415 end Write_Lock;
416
417 procedure Write_Lock
418 (L : access RTS_Lock;
419 Global_Lock : Boolean := False)
420 is
421 begin
422 if not Single_Lock or else Global_Lock then
423 EnterCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access);
424 end if;
425 end Write_Lock;
426
427 procedure Write_Lock (T : Task_Id) is
428 begin
429 if not Single_Lock then
430 EnterCriticalSection
431 (CRITICAL_SECTION (T.Common.LL.L)'Unrestricted_Access);
432 end if;
433 end Write_Lock;
434
435 ---------------
436 -- Read_Lock --
437 ---------------
438
439 procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
440 begin
441 Write_Lock (L, Ceiling_Violation);
442 end Read_Lock;
443
444 ------------
445 -- Unlock --
446 ------------
447
448 procedure Unlock (L : access Lock) is
449 begin
450 LeaveCriticalSection (L.Mutex'Access);
451 end Unlock;
452
453 procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
454 begin
455 if not Single_Lock or else Global_Lock then
456 LeaveCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access);
457 end if;
458 end Unlock;
459
460 procedure Unlock (T : Task_Id) is
461 begin
462 if not Single_Lock then
463 LeaveCriticalSection
464 (CRITICAL_SECTION (T.Common.LL.L)'Unrestricted_Access);
465 end if;
466 end Unlock;
467
468 -----------
469 -- Sleep --
470 -----------
471
472 procedure Sleep
473 (Self_ID : Task_Id;
474 Reason : System.Tasking.Task_States)
475 is
476 pragma Unreferenced (Reason);
477
478 begin
479 pragma Assert (Self_ID = Self);
480
481 if Single_Lock then
482 Cond_Wait (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
483 else
484 Cond_Wait (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
485 end if;
486
487 if Self_ID.Deferral_Level = 0
488 and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
489 then
490 Unlock (Self_ID);
491 raise Standard'Abort_Signal;
492 end if;
493 end Sleep;
494
495 -----------------
496 -- Timed_Sleep --
497 -----------------
498
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.
502
503 procedure Timed_Sleep
504 (Self_ID : Task_Id;
505 Time : Duration;
506 Mode : ST.Delay_Modes;
507 Reason : System.Tasking.Task_States;
508 Timedout : out Boolean;
509 Yielded : out Boolean)
510 is
511 pragma Unreferenced (Reason);
512 Check_Time : Duration := Monotonic_Clock;
513 Rel_Time : Duration;
514 Abs_Time : Duration;
515 Result : Integer;
516
517 Local_Timedout : Boolean;
518
519 begin
520 Timedout := True;
521 Yielded := False;
522
523 if Mode = Relative then
524 Rel_Time := Time;
525 Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time;
526 else
527 Rel_Time := Time - Check_Time;
528 Abs_Time := Time;
529 end if;
530
531 if Rel_Time > 0.0 then
532 loop
533 exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
534 or else Self_ID.Pending_Priority_Change;
535
536 if Single_Lock then
537 Cond_Timed_Wait (Self_ID.Common.LL.CV'Access,
538 Single_RTS_Lock'Access, Rel_Time, Local_Timedout, Result);
539 else
540 Cond_Timed_Wait (Self_ID.Common.LL.CV'Access,
541 Self_ID.Common.LL.L'Access, Rel_Time, Local_Timedout, Result);
542 end if;
543
544 Check_Time := Monotonic_Clock;
545 exit when Abs_Time <= Check_Time;
546
547 if not Local_Timedout then
548
549 -- Somebody may have called Wakeup for us
550
551 Timedout := False;
552 exit;
553 end if;
554
555 Rel_Time := Abs_Time - Check_Time;
556 end loop;
557 end if;
558 end Timed_Sleep;
559
560 -----------------
561 -- Timed_Delay --
562 -----------------
563
564 procedure Timed_Delay
565 (Self_ID : Task_Id;
566 Time : Duration;
567 Mode : ST.Delay_Modes)
568 is
569 Check_Time : Duration := Monotonic_Clock;
570 Rel_Time : Duration;
571 Abs_Time : Duration;
572 Result : Integer;
573 Timedout : Boolean;
574
575 begin
576 if Single_Lock then
577 Lock_RTS;
578 end if;
579
580 Write_Lock (Self_ID);
581
582 if Mode = Relative then
583 Rel_Time := Time;
584 Abs_Time := Time + Check_Time;
585 else
586 Rel_Time := Time - Check_Time;
587 Abs_Time := Time;
588 end if;
589
590 if Rel_Time > 0.0 then
591 Self_ID.Common.State := Delay_Sleep;
592
593 loop
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);
598 end if;
599
600 exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
601
602 if Single_Lock then
603 Cond_Timed_Wait (Self_ID.Common.LL.CV'Access,
604 Single_RTS_Lock'Access, Rel_Time, Timedout, Result);
605 else
606 Cond_Timed_Wait (Self_ID.Common.LL.CV'Access,
607 Self_ID.Common.LL.L'Access, Rel_Time, Timedout, Result);
608 end if;
609
610 Check_Time := Monotonic_Clock;
611 exit when Abs_Time <= Check_Time;
612
613 Rel_Time := Abs_Time - Check_Time;
614 end loop;
615
616 Self_ID.Common.State := Runnable;
617 end if;
618
619 Unlock (Self_ID);
620
621 if Single_Lock then
622 Unlock_RTS;
623 end if;
624
625 Yield;
626 end Timed_Delay;
627
628 ------------
629 -- Wakeup --
630 ------------
631
632 procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
633 pragma Unreferenced (Reason);
634 begin
635 Cond_Signal (T.Common.LL.CV'Access);
636 end Wakeup;
637
638 -----------
639 -- Yield --
640 -----------
641
642 procedure Yield (Do_Yield : Boolean := True) is
643 begin
644 if Do_Yield then
645 Sleep (0);
646 end if;
647 end Yield;
648
649 ------------------
650 -- Set_Priority --
651 ------------------
652
653 type Prio_Array_Type is array (System.Any_Priority) of Integer;
654 pragma Atomic_Components (Prio_Array_Type);
655
656 Prio_Array : Prio_Array_Type;
657 -- Global array containing the id of the currently running task for
658 -- each priority.
659 --
660 -- Note: we assume that we are on a single processor with run-til-blocked
661 -- scheduling.
662
663 procedure Set_Priority
664 (T : Task_Id;
665 Prio : System.Any_Priority;
666 Loss_Of_Inheritance : Boolean := False)
667 is
668 Res : BOOL;
669 Array_Item : Integer;
670
671 begin
672 Res := SetThreadPriority
673 (T.Common.LL.Thread, Interfaces.C.int (Underlying_Priorities (Prio)));
674 pragma Assert (Res = True);
675
676 if Dispatching_Policy = 'F' then
677
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.
682
683 if Loss_Of_Inheritance
684 and then Prio < T.Common.Current_Priority
685 then
686 Array_Item := Prio_Array (T.Common.Base_Priority) + 1;
687 Prio_Array (T.Common.Base_Priority) := Array_Item;
688
689 loop
690 -- Let some processes a chance to arrive
691
692 Yield;
693
694 -- Then wait for our turn to proceed
695
696 exit when Array_Item = Prio_Array (T.Common.Base_Priority)
697 or else Prio_Array (T.Common.Base_Priority) = 1;
698 end loop;
699
700 Prio_Array (T.Common.Base_Priority) :=
701 Prio_Array (T.Common.Base_Priority) - 1;
702 end if;
703 end if;
704
705 T.Common.Current_Priority := Prio;
706 end Set_Priority;
707
708 ------------------
709 -- Get_Priority --
710 ------------------
711
712 function Get_Priority (T : Task_Id) return System.Any_Priority is
713 begin
714 return T.Common.Current_Priority;
715 end Get_Priority;
716
717 ----------------
718 -- Enter_Task --
719 ----------------
720
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
724 --
725 -- The thread initialisation has to be done only for the first case.
726 --
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
732 -- thread creation.
733
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.
738
739 begin
740 Specific.Set (Self_ID);
741 Init_Float;
742
743 Self_ID.Common.LL.Thread_Id := GetCurrentThreadId;
744
745 Lock_RTS;
746
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;
751 exit;
752 end if;
753 end loop;
754
755 Unlock_RTS;
756 end Enter_Task;
757
758 --------------
759 -- New_ATCB --
760 --------------
761
762 function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is
763 begin
764 return new Ada_Task_Control_Block (Entry_Num);
765 end New_ATCB;
766
767 -------------------
768 -- Is_Valid_Task --
769 -------------------
770
771 function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task;
772
773 -----------------------------
774 -- Register_Foreign_Thread --
775 -----------------------------
776
777 function Register_Foreign_Thread return Task_Id is
778 begin
779 if Is_Valid_Task then
780 return Self;
781 else
782 return Register_Foreign_Thread (GetCurrentThread);
783 end if;
784 end Register_Foreign_Thread;
785
786 --------------------
787 -- Initialize_TCB --
788 --------------------
789
790 procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
791 begin
792 -- Initialize thread ID to 0, this is needed to detect threads that
793 -- are not yet activated.
794
795 Self_ID.Common.LL.Thread := 0;
796
797 Initialize_Cond (Self_ID.Common.LL.CV'Access);
798
799 if not Single_Lock then
800 Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level);
801 end if;
802
803 Succeeded := True;
804 end Initialize_TCB;
805
806 -----------------
807 -- Create_Task --
808 -----------------
809
810 procedure Create_Task
811 (T : Task_Id;
812 Wrapper : System.Address;
813 Stack_Size : System.Parameters.Size_Type;
814 Priority : System.Any_Priority;
815 Succeeded : out Boolean)
816 is
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
821 -- needed.
822
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
826
827 hTask : HANDLE;
828 TaskId : aliased DWORD;
829 pTaskParameter : System.OS_Interface.PVOID;
830 Result : DWORD;
831 Entry_Point : PTHREAD_START_ROUTINE;
832
833 begin
834 pTaskParameter := To_Address (T);
835
836 Entry_Point := To_PTHREAD_START_ROUTINE (Wrapper);
837
838 if Is_Windows_XP = 1 then
839 hTask := CreateThread
840 (null,
841 DWORD (Stack_Size),
842 Entry_Point,
843 pTaskParameter,
844 DWORD (Create_Suspended) or
845 DWORD (Stack_Size_Param_Is_A_Reservation),
846 TaskId'Unchecked_Access);
847 else
848 hTask := CreateThread
849 (null,
850 Initial_Stack_Size,
851 Entry_Point,
852 pTaskParameter,
853 DWORD (Create_Suspended),
854 TaskId'Unchecked_Access);
855 end if;
856
857 -- Step 1: Create the thread in blocked mode
858
859 if hTask = 0 then
860 raise Storage_Error;
861 end if;
862
863 -- Step 2: set its TCB
864
865 T.Common.LL.Thread := hTask;
866
867 -- Step 3: set its priority (child has inherited priority from parent)
868
869 Set_Priority (T, Priority);
870
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.
875
876 SetThreadPriorityBoost (hTask, DisablePriorityBoost => True);
877 end if;
878
879 -- Step 4: Now, start it for good:
880
881 Result := ResumeThread (hTask);
882 pragma Assert (Result = 1);
883
884 Succeeded := Result = 1;
885 end Create_Task;
886
887 ------------------
888 -- Finalize_TCB --
889 ------------------
890
891 procedure Finalize_TCB (T : Task_Id) is
892 Self_ID : Task_Id := T;
893 Result : DWORD;
894 Succeeded : BOOL;
895 Is_Self : constant Boolean := T = Self;
896
897 procedure Free is new
898 Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
899
900 begin
901 if not Single_Lock then
902 Finalize_Lock (T.Common.LL.L'Access);
903 end if;
904
905 Finalize_Cond (T.Common.LL.CV'Access);
906
907 if T.Known_Tasks_Index /= -1 then
908 Known_Tasks (T.Known_Tasks_Index) := null;
909 end if;
910
911 if Self_ID.Common.LL.Thread /= 0 then
912
913 -- This task has been activated. Wait for the thread to terminate
914 -- then close it. this is needed to release system ressources.
915
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);
920 end if;
921
922 Free (Self_ID);
923
924 if Is_Self then
925 Specific.Set (null);
926 end if;
927 end Finalize_TCB;
928
929 ---------------
930 -- Exit_Task --
931 ---------------
932
933 procedure Exit_Task is
934 begin
935 Specific.Set (null);
936 end Exit_Task;
937
938 ----------------
939 -- Abort_Task --
940 ----------------
941
942 procedure Abort_Task (T : Task_Id) is
943 pragma Unreferenced (T);
944 begin
945 null;
946 end Abort_Task;
947
948 ----------------------
949 -- Environment_Task --
950 ----------------------
951
952 function Environment_Task return Task_Id is
953 begin
954 return Environment_Task_Id;
955 end Environment_Task;
956
957 --------------
958 -- Lock_RTS --
959 --------------
960
961 procedure Lock_RTS is
962 begin
963 Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
964 end Lock_RTS;
965
966 ----------------
967 -- Unlock_RTS --
968 ----------------
969
970 procedure Unlock_RTS is
971 begin
972 Unlock (Single_RTS_Lock'Access, Global_Lock => True);
973 end Unlock_RTS;
974
975 ----------------
976 -- Initialize --
977 ----------------
978
979 procedure Initialize (Environment_Task : Task_Id) is
980 Discard : BOOL;
981 pragma Unreferenced (Discard);
982
983 begin
984 Environment_Task_Id := Environment_Task;
985 OS_Primitives.Initialize;
986
987 if Time_Slice_Val = 0 or else Dispatching_Policy = 'F' then
988
989 -- Here we need Annex D semantics, switch the current process to the
990 -- High_Priority_Class.
991
992 Discard :=
993 OS_Interface.SetPriorityClass
994 (GetCurrentProcess, High_Priority_Class);
995
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.
1001 end if;
1002
1003 TlsIndex := TlsAlloc;
1004
1005 -- Initialize the lock used to synchronize chain of all ATCBs.
1006
1007 Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
1008
1009 Environment_Task.Common.LL.Thread := GetCurrentThread;
1010 Enter_Task (Environment_Task);
1011 end Initialize;
1012
1013 ---------------------
1014 -- Monotonic_Clock --
1015 ---------------------
1016
1017 function Monotonic_Clock return Duration
1018 renames System.OS_Primitives.Monotonic_Clock;
1019
1020 -------------------
1021 -- RT_Resolution --
1022 -------------------
1023
1024 function RT_Resolution return Duration is
1025 begin
1026 return 0.000_001; -- 1 micro-second
1027 end RT_Resolution;
1028
1029 ----------------
1030 -- Initialize --
1031 ----------------
1032
1033 procedure Initialize (S : in out Suspension_Object) is
1034 begin
1035 -- Initialize internal state. It is always initialized to False (ARM
1036 -- D.10 par. 6).
1037
1038 S.State := False;
1039 S.Waiting := False;
1040
1041 -- Initialize internal mutex
1042
1043 InitializeCriticalSection (S.L'Access);
1044
1045 -- Initialize internal condition variable
1046
1047 S.CV := CreateEvent (null, True, False, Null_Ptr);
1048 pragma Assert (S.CV /= 0);
1049 end Initialize;
1050
1051 --------------
1052 -- Finalize --
1053 --------------
1054
1055 procedure Finalize (S : in out Suspension_Object) is
1056 Result : BOOL;
1057 begin
1058 -- Destroy internal mutex
1059
1060 DeleteCriticalSection (S.L'Access);
1061
1062 -- Destroy internal condition variable
1063
1064 Result := CloseHandle (S.CV);
1065 pragma Assert (Result = True);
1066 end Finalize;
1067
1068 -------------------
1069 -- Current_State --
1070 -------------------
1071
1072 function Current_State (S : Suspension_Object) return Boolean is
1073 begin
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.
1076
1077 return S.State;
1078 end Current_State;
1079
1080 ---------------
1081 -- Set_False --
1082 ---------------
1083
1084 procedure Set_False (S : in out Suspension_Object) is
1085 begin
1086 EnterCriticalSection (S.L'Access);
1087
1088 S.State := False;
1089
1090 LeaveCriticalSection (S.L'Access);
1091 end Set_False;
1092
1093 --------------
1094 -- Set_True --
1095 --------------
1096
1097 procedure Set_True (S : in out Suspension_Object) is
1098 Result : BOOL;
1099 begin
1100 EnterCriticalSection (S.L'Access);
1101
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.
1106
1107 if S.Waiting then
1108 S.Waiting := False;
1109 S.State := False;
1110
1111 Result := SetEvent (S.CV);
1112 pragma Assert (Result = True);
1113 else
1114 S.State := True;
1115 end if;
1116
1117 LeaveCriticalSection (S.L'Access);
1118 end Set_True;
1119
1120 ------------------------
1121 -- Suspend_Until_True --
1122 ------------------------
1123
1124 procedure Suspend_Until_True (S : in out Suspension_Object) is
1125 Result : DWORD;
1126 Result_Bool : BOOL;
1127 begin
1128 EnterCriticalSection (S.L'Access);
1129
1130 if S.Waiting then
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).
1134
1135 LeaveCriticalSection (S.L'Access);
1136
1137 raise Program_Error;
1138 else
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).
1142
1143 if S.State then
1144 S.State := False;
1145
1146 LeaveCriticalSection (S.L'Access);
1147 else
1148 S.Waiting := True;
1149
1150 -- Must reset CV BEFORE L is unlocked.
1151
1152 Result_Bool := ResetEvent (S.CV);
1153 pragma Assert (Result_Bool = True);
1154
1155 LeaveCriticalSection (S.L'Access);
1156
1157 Result := WaitForSingleObject (S.CV, Wait_Infinite);
1158 pragma Assert (Result = 0);
1159 end if;
1160 end if;
1161 end Suspend_Until_True;
1162
1163 ----------------
1164 -- Check_Exit --
1165 ----------------
1166
1167 -- Dummy versions. The only currently working versions is for solaris
1168 -- (native).
1169
1170 function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
1171 pragma Unreferenced (Self_ID);
1172 begin
1173 return True;
1174 end Check_Exit;
1175
1176 --------------------
1177 -- Check_No_Locks --
1178 --------------------
1179
1180 function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
1181 pragma Unreferenced (Self_ID);
1182 begin
1183 return True;
1184 end Check_No_Locks;
1185
1186 ------------------
1187 -- Suspend_Task --
1188 ------------------
1189
1190 function Suspend_Task
1191 (T : ST.Task_Id;
1192 Thread_Self : Thread_Id) return Boolean
1193 is
1194 begin
1195 if T.Common.LL.Thread /= Thread_Self then
1196 return SuspendThread (T.Common.LL.Thread) = NO_ERROR;
1197 else
1198 return True;
1199 end if;
1200 end Suspend_Task;
1201
1202 -----------------
1203 -- Resume_Task --
1204 -----------------
1205
1206 function Resume_Task
1207 (T : ST.Task_Id;
1208 Thread_Self : Thread_Id) return Boolean
1209 is
1210 begin
1211 if T.Common.LL.Thread /= Thread_Self then
1212 return ResumeThread (T.Common.LL.Thread) = NO_ERROR;
1213 else
1214 return True;
1215 end if;
1216 end Resume_Task;
1217
1218 end System.Task_Primitives.Operations;
Mirror of the offical gcc git repository hosted at gcc.gnu.org