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-2005, Free Software Foundation, Inc. --
11 -- GNARL is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNARL; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- GNARL was developed by the GNARL team at Florida State University. --
30 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
32 ------------------------------------------------------------------------------
34 -- This is an OS/2 version of this package
36 -- This package contains all the GNULL primitives that interface directly
37 -- with the underlying OS.
40 -- Turn off polling, we do not want ATC polling to take place during
41 -- tasking operations. It causes infinite loops and other problems.
43 with System.Tasking.Debug;
44 -- used for Known_Tasks
49 with Interfaces.C.Strings;
52 with Interfaces.OS2Lib.Errors;
53 with Interfaces.OS2Lib.Threads;
54 with Interfaces.OS2Lib.Synchronization;
56 with System.Parameters;
62 with System.Parameters;
65 with System.Soft_Links;
66 -- used for Defer/Undefer_Abort
68 -- Note that we do not use System.Tasking.Initialization directly since
69 -- this is a higher level package that we shouldn't depend on. For example
70 -- when using the restricted run time, it is replaced by
71 -- System.Tasking.Restricted.Stages.
73 with System.OS_Primitives;
74 -- used for Delay_Modes
77 with Unchecked_Conversion;
78 with Unchecked_Deallocation;
80 package body System.Task_Primitives.Operations is
82 package IC renames Interfaces.C;
83 package ICS renames Interfaces.C.Strings;
84 package OSP renames System.OS_Primitives;
85 package SSL renames System.Soft_Links;
87 use Interfaces.OS2Lib;
88 use Interfaces.OS2Lib.Errors;
89 use Interfaces.OS2Lib.Threads;
90 use Interfaces.OS2Lib.Synchronization;
91 use System.Parameters;
92 use System.Tasking.Debug;
94 use System.OS_Interface;
96 use System.OS_Primitives;
100 ---------------------
102 Max_Locks_Per_Task : constant := 100;
103 Suppress_Owner_Check : constant Boolean := False;
109 subtype Lock_Range is Integer range 0 .. Max_Locks_Per_Task;
115 -- The OS/2 DosAllocThreadLocalMemory API is used to allocate our TCB_Ptr
117 -- This API reserves a small range of virtual addresses that is backed
118 -- by different physical memory for each running thread. In this case we
119 -- create a pointer at a fixed address that points to the TCB_Ptr for the
120 -- running thread. So all threads will be able to query and update their
121 -- own TCB_Ptr without destroying the TCB_Ptr of other threads.
123 type Thread_Local_Data is record
124 Self_ID : Task_Id; -- ID of the current thread
125 Lock_Prio_Level : Lock_Range; -- Nr of priority changes due to locks
127 -- ... room for expansion here, if we decide to make access to
128 -- jump-buffer and exception stack more efficient in future
131 type Access_Thread_Local_Data is access all Thread_Local_Data;
133 -- Pointer to Thread Local Data
134 Thread_Local_Data_Ptr : aliased Access_Thread_Local_Data;
136 type PPTLD is access all Access_Thread_Local_Data;
138 Single_RTS_Lock : aliased RTS_Lock;
139 -- This is a lock to allow only one thread of control in the RTS at
140 -- a time; it is used to execute in mutual exclusion from all other tasks.
141 -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
143 Environment_Task_Id : Task_Id;
144 -- A variable to hold Task_Id for the environment task
146 -----------------------
147 -- Local Subprograms --
148 -----------------------
150 function To_PPVOID is new Unchecked_Conversion (PPTLD, PPVOID);
151 function To_Address is new Unchecked_Conversion (Task_Id, System.Address);
152 function To_PFNTHREAD is
153 new Unchecked_Conversion (System.Address, PFNTHREAD);
155 function To_MS (D : Duration) return ULONG;
157 procedure Set_Temporary_Priority
159 New_Priority : in System.Any_Priority);
165 function To_MS (D : Duration) return ULONG is
167 return ULONG (D * 1_000);
174 function Monotonic_Clock return Duration renames OSP.Monotonic_Clock;
180 function RT_Resolution return Duration is
189 -- OS/2 only has limited support for asynchronous signals.
190 -- It seems not to be possible to jump out of an exception
191 -- handler or to change the execution context of the thread.
192 -- So asynchonous transfer of control is not supported.
198 -- The underlying thread system sets a guard page at the
199 -- bottom of a thread stack, so nothing is needed.
200 -- ??? Check the comment above
202 procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
203 pragma Unreferenced (T);
204 pragma Unreferenced (On);
213 function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
215 return OSI.Thread_Id (T.Common.LL.Thread);
222 function Self return Task_Id is
223 Self_ID : Task_Id renames Thread_Local_Data_Ptr.Self_ID;
226 -- Check that the thread local data has been initialized
229 ((Thread_Local_Data_Ptr /= null
230 and then Thread_Local_Data_Ptr.Self_ID /= null));
235 ---------------------
236 -- Initialize_Lock --
237 ---------------------
239 procedure Initialize_Lock
240 (Prio : System.Any_Priority;
245 (ICS.Null_Ptr, L.Mutex'Unchecked_Access, 0, False32) /= NO_ERROR
250 pragma Assert (L.Mutex /= 0, "Error creating Mutex");
252 L.Owner_ID := Null_Address;
255 procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is
256 pragma Unreferenced (Level);
260 (ICS.Null_Ptr, L.Mutex'Unchecked_Access, 0, False32) /= NO_ERROR
265 pragma Assert (L.Mutex /= 0, "Error creating Mutex");
267 L.Priority := System.Any_Priority'Last;
268 L.Owner_ID := Null_Address;
275 procedure Finalize_Lock (L : access Lock) is
277 Must_Not_Fail (DosCloseMutexSem (L.Mutex));
280 procedure Finalize_Lock (L : access RTS_Lock) is
282 Must_Not_Fail (DosCloseMutexSem (L.Mutex));
289 procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
290 Self_ID : constant Task_Id := Thread_Local_Data_Ptr.Self_ID;
291 Old_Priority : constant Any_Priority :=
292 Self_ID.Common.LL.Current_Priority;
295 if L.Priority < Old_Priority then
296 Ceiling_Violation := True;
300 Ceiling_Violation := False;
302 -- Increase priority before getting the lock
303 -- to prevent priority inversion
305 Thread_Local_Data_Ptr.Lock_Prio_Level :=
306 Thread_Local_Data_Ptr.Lock_Prio_Level + 1;
307 if L.Priority > Old_Priority then
308 Set_Temporary_Priority (Self_ID, L.Priority);
311 -- Request the lock and then update the lock owner data
313 Must_Not_Fail (DosRequestMutexSem (L.Mutex, SEM_INDEFINITE_WAIT));
314 L.Owner_Priority := Old_Priority;
315 L.Owner_ID := Self_ID.all'Address;
319 (L : access RTS_Lock;
320 Global_Lock : Boolean := False)
323 Old_Priority : Any_Priority;
326 if not Single_Lock or else Global_Lock then
327 Self_ID := Thread_Local_Data_Ptr.Self_ID;
328 Old_Priority := Self_ID.Common.LL.Current_Priority;
330 -- Increase priority before getting the lock
331 -- to prevent priority inversion
333 Thread_Local_Data_Ptr.Lock_Prio_Level :=
334 Thread_Local_Data_Ptr.Lock_Prio_Level + 1;
336 if L.Priority > Old_Priority then
337 Set_Temporary_Priority (Self_ID, L.Priority);
340 -- Request the lock and then update the lock owner data
342 Must_Not_Fail (DosRequestMutexSem (L.Mutex, SEM_INDEFINITE_WAIT));
343 L.Owner_Priority := Old_Priority;
344 L.Owner_ID := Self_ID.all'Address;
348 procedure Write_Lock (T : Task_Id) is
350 if not Single_Lock then
352 -- Request the lock and then update the lock owner data
355 (DosRequestMutexSem (T.Common.LL.L.Mutex, SEM_INDEFINITE_WAIT));
356 T.Common.LL.L.Owner_ID := Null_Address;
365 (L : access Lock; Ceiling_Violation : out Boolean) renames Write_Lock;
371 procedure Unlock (L : access Lock) is
372 Self_ID : constant Task_Id := Thread_Local_Data_Ptr.Self_ID;
373 Old_Priority : constant Any_Priority := L.Owner_Priority;
376 -- Check that this task holds the lock
378 pragma Assert (Suppress_Owner_Check
379 or else L.Owner_ID = Self_ID.all'Address);
381 -- Upate the owner data
383 L.Owner_ID := Null_Address;
385 -- Do the actual unlocking. No more references
386 -- to owner data of L after this point.
388 Must_Not_Fail (DosReleaseMutexSem (L.Mutex));
390 -- Reset priority after unlocking to avoid priority inversion
392 Thread_Local_Data_Ptr.Lock_Prio_Level :=
393 Thread_Local_Data_Ptr.Lock_Prio_Level - 1;
394 if L.Priority /= Old_Priority then
395 Set_Temporary_Priority (Self_ID, Old_Priority);
399 procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
401 Old_Priority : Any_Priority;
404 if not Single_Lock or else Global_Lock then
405 Self_ID := Thread_Local_Data_Ptr.Self_ID;
406 Old_Priority := L.Owner_Priority;
407 -- Check that this task holds the lock
409 pragma Assert (Suppress_Owner_Check
410 or else L.Owner_ID = Self_ID.all'Address);
412 -- Upate the owner data
414 L.Owner_ID := Null_Address;
416 -- Do the actual unlocking. No more references
417 -- to owner data of L after this point.
419 Must_Not_Fail (DosReleaseMutexSem (L.Mutex));
421 -- Reset priority after unlocking to avoid priority inversion
423 Thread_Local_Data_Ptr.Lock_Prio_Level :=
424 Thread_Local_Data_Ptr.Lock_Prio_Level - 1;
426 if L.Priority /= Old_Priority then
427 Set_Temporary_Priority (Self_ID, Old_Priority);
432 procedure Unlock (T : Task_Id) is
434 if not Single_Lock then
436 -- Check the owner data
438 pragma Assert (Suppress_Owner_Check
439 or else T.Common.LL.L.Owner_ID = Null_Address);
441 -- Do the actual unlocking. No more references
442 -- to owner data of T.Common.LL.L after this point.
444 Must_Not_Fail (DosReleaseMutexSem (T.Common.LL.L.Mutex));
454 Reason : System.Tasking.Task_States)
456 pragma Unreferenced (Reason);
458 Count : aliased ULONG; -- Used to store dummy result
461 -- Must reset Cond BEFORE L is unlocked
464 (DosResetEventSem (Self_ID.Common.LL.CV, Count'Unchecked_Access));
472 -- No problem if we are interrupted here.
473 -- If the condition is signaled, DosWaitEventSem will simply not block.
476 (DosWaitEventSem (Self_ID.Common.LL.CV, SEM_INDEFINITE_WAIT));
478 -- Since L was previously accquired, lock operation should not fail
483 Write_Lock (Self_ID);
491 -- This is for use within the run-time system, so abort is
492 -- assumed to be already deferred, and the caller should be
493 -- holding its own ATCB lock.
495 -- Pre-assertion: Cond is posted
498 -- Post-assertion: Cond is posted
501 procedure Timed_Sleep
504 Mode : ST.Delay_Modes;
505 Reason : System.Tasking.Task_States;
506 Timedout : out Boolean;
507 Yielded : out Boolean)
509 pragma Unreferenced (Reason);
511 Check_Time : constant Duration := OSP.Monotonic_Clock;
516 Count : aliased ULONG; -- Used to store dummy result
519 -- Must reset Cond BEFORE Self_ID is unlocked
522 (DosResetEventSem (Self_ID.Common.LL.CV,
523 Count'Unchecked_Access));
534 if Mode = Relative then
536 Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time;
538 Rel_Time := Time - Check_Time;
542 if Rel_Time > 0.0 then
544 exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
545 or else Self_ID.Pending_Priority_Change;
547 Time_Out := To_MS (Rel_Time);
548 Result := DosWaitEventSem (Self_ID.Common.LL.CV, Time_Out);
550 ((Result = NO_ERROR or Result = ERROR_TIMEOUT
551 or Result = ERROR_INTERRUPT));
554 -- What to do with error condition ERROR_NOT_ENOUGH_MEMORY? Can
555 -- we raise an exception here? And what about ERROR_INTERRUPT?
556 -- Should that be treated as a simple timeout?
557 -- For now, consider only ERROR_TIMEOUT to be a timeout.
559 exit when Abs_Time <= OSP.Monotonic_Clock;
561 if Result /= ERROR_TIMEOUT then
562 -- somebody may have called Wakeup for us
567 Rel_Time := Abs_Time - OSP.Monotonic_Clock;
571 -- Ensure post-condition
576 Write_Lock (Self_ID);
580 Sem_Must_Not_Fail (DosPostEventSem (Self_ID.Common.LL.CV));
588 procedure Timed_Delay
591 Mode : ST.Delay_Modes)
593 Check_Time : constant Duration := OSP.Monotonic_Clock;
596 Timedout : Boolean := True;
599 Count : aliased ULONG; -- Used to store dummy result
602 -- Only the little window between deferring abort and
603 -- locking Self_ID is the reason we need to
604 -- check for pending abort and priority change below! :(
611 Write_Lock (Self_ID);
614 -- Must reset Cond BEFORE Self_ID is unlocked
617 (DosResetEventSem (Self_ID.Common.LL.CV,
618 Count'Unchecked_Access));
626 if Mode = Relative then
628 Abs_Time := Time + Check_Time;
630 Rel_Time := Time - Check_Time;
634 if Rel_Time > 0.0 then
635 Self_ID.Common.State := Delay_Sleep;
638 if Self_ID.Pending_Priority_Change then
639 Self_ID.Pending_Priority_Change := False;
640 Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
641 Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
644 exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
646 Time_Out := To_MS (Rel_Time);
647 Result := DosWaitEventSem (Self_ID.Common.LL.CV, Time_Out);
649 exit when Abs_Time <= OSP.Monotonic_Clock;
651 Rel_Time := Abs_Time - OSP.Monotonic_Clock;
654 Self_ID.Common.State := Runnable;
655 Timedout := Result = ERROR_TIMEOUT;
661 Write_Lock (Self_ID);
665 Sem_Must_Not_Fail (DosPostEventSem (Self_ID.Common.LL.CV));
674 System.OS_Interface.Yield;
675 SSL.Abort_Undefer.all;
682 procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
683 pragma Unreferenced (Reason);
685 Sem_Must_Not_Fail (DosPostEventSem (T.Common.LL.CV));
692 procedure Yield (Do_Yield : Boolean := True) is
695 System.OS_Interface.Yield;
699 ----------------------------
700 -- Set_Temporary_Priority --
701 ----------------------------
703 procedure Set_Temporary_Priority
705 New_Priority : System.Any_Priority)
708 Delta_Priority : Integer;
711 -- When Lock_Prio_Level = 0, we always need to set the
712 -- Active_Priority. In this way we can make priority changes
713 -- due to locking independent of those caused by calling
716 if Thread_Local_Data_Ptr.Lock_Prio_Level = 0
717 or else New_Priority < T.Common.Current_Priority
719 Delta_Priority := T.Common.Current_Priority -
720 T.Common.LL.Current_Priority;
722 Delta_Priority := New_Priority - T.Common.LL.Current_Priority;
725 if Delta_Priority /= 0 then
726 -- ??? There is a race-condition here
727 -- The TCB is updated before the system call to make
728 -- pre-emption in the critical section less likely.
730 T.Common.LL.Current_Priority :=
731 T.Common.LL.Current_Priority + Delta_Priority;
733 (DosSetPriority (Scope => PRTYS_THREAD,
734 Class => PRTYC_NOCHANGE,
735 Delta_P => IC.long (Delta_Priority),
736 PorTid => T.Common.LL.Thread));
738 end Set_Temporary_Priority;
744 procedure Set_Priority
746 Prio : System.Any_Priority;
747 Loss_Of_Inheritance : Boolean := False)
749 pragma Unreferenced (Loss_Of_Inheritance);
751 T.Common.Current_Priority := Prio;
752 Set_Temporary_Priority (T, Prio);
759 function Get_Priority (T : Task_Id) return System.Any_Priority is
761 return T.Common.Current_Priority;
768 procedure Enter_Task (Self_ID : Task_Id) is
770 -- Initialize thread local data. Must be done first
772 Thread_Local_Data_Ptr.Self_ID := Self_ID;
773 Thread_Local_Data_Ptr.Lock_Prio_Level := 0;
777 for J in Known_Tasks'Range loop
778 if Known_Tasks (J) = null then
779 Known_Tasks (J) := Self_ID;
780 Self_ID.Known_Tasks_Index := J;
787 -- For OS/2, we can set Self_ID.Common.LL.Thread in
788 -- Create_Task, since the thread is created suspended.
789 -- That is, there is no danger of the thread racing ahead
790 -- and trying to reference Self_ID.Common.LL.Thread before it
791 -- has been initialized.
793 -- .... Do we need to do anything with signals for OS/2 ???
800 function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is
802 return new Ada_Task_Control_Block (Entry_Num);
809 function Is_Valid_Task return Boolean is
814 -----------------------------
815 -- Register_Foreign_Thread --
816 -----------------------------
818 function Register_Foreign_Thread return Task_Id is
821 end Register_Foreign_Thread;
827 procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
829 if DosCreateEventSem (ICS.Null_Ptr,
830 Self_ID.Common.LL.CV'Unchecked_Access, 0, True32) = NO_ERROR
833 and then DosCreateMutexSem
835 Self_ID.Common.LL.L.Mutex'Unchecked_Access,
840 Must_Not_Fail (DosCloseEventSem (Self_ID.Common.LL.CV));
845 -- We now want to do the equivalent of:
848 -- (Self_ID.Common.LL.L'Unchecked_Access, ATCB_Level);
850 -- But we avoid that because the Initialize_TCB routine has an
851 -- exception handler, and it is too early for us to deal with
852 -- installing handlers (see comment below), so we do our own
853 -- Initialize_Lock operation manually.
855 Self_ID.Common.LL.L.Priority := System.Any_Priority'Last;
856 Self_ID.Common.LL.L.Owner_ID := Null_Address;
862 -- Note: at one time we had an exception handler here, whose code
867 -- Assumes any failure must be due to insufficient resources
869 -- when Storage_Error =>
870 -- Must_Not_Fail (DosCloseEventSem (Self_ID.Common.LL.CV));
871 -- Succeeded := False;
873 -- but that won't work with the old exception scheme, since it would
874 -- result in messing with Jmpbuf values too early. If and when we get
875 -- switched entirely to the new zero-cost exception scheme, we could
876 -- put this handler back in!
883 procedure Create_Task
885 Wrapper : System.Address;
886 Stack_Size : System.Parameters.Size_Type;
887 Priority : System.Any_Priority;
888 Succeeded : out Boolean)
890 Result : aliased APIRET;
891 Adjusted_Stack_Size : System.Parameters.Size_Type;
892 use System.Parameters;
895 -- In OS/2 the allocated stack size should be based on the
896 -- amount of address space that should be reserved for the stack.
897 -- Actual memory will only be used when the stack is touched anyway.
899 -- The new minimum size is 12 kB, although the EMX docs
900 -- recommend a minimum size of 32 kB. (The original was 4 kB)
901 -- Systems that use many tasks (say > 30) and require much
902 -- memory may run out of virtual address space, since OS/2
903 -- has a per-proces limit of 512 MB, of which max. 300 MB is
904 -- usable in practise.
906 if Stack_Size = Unspecified_Size then
907 Adjusted_Stack_Size := Default_Stack_Size;
909 elsif Stack_Size < Minimum_Stack_Size then
910 Adjusted_Stack_Size := Minimum_Stack_Size;
913 Adjusted_Stack_Size := Stack_Size;
917 -- Because DosCreateThread is called directly here, the
918 -- C RTL doesn't get initialized for the new thead. EMX by
919 -- default uses per-thread local heaps in addition to the
920 -- global heap. There might be other effects of by-passing the
923 -- When using _beginthread the newly created thread is not
924 -- blocked initially. Does this matter or can I create the
925 -- thread running anyway? The LL.Thread variable will be set
926 -- anyway because the variable is passed by reference to OS/2.
928 T.Common.LL.Wrapper := To_PFNTHREAD (Wrapper);
930 -- The OS implicitly gives the new task the priority of this task
932 T.Common.LL.Current_Priority := Self.Common.LL.Current_Priority;
934 -- If task was locked before activator task was
935 -- initialized, assume it has OS standard priority
937 if T.Common.LL.L.Owner_Priority not in Any_Priority'Range then
938 T.Common.LL.L.Owner_Priority := 1;
941 -- Create the thread, in blocked mode
943 Result := DosCreateThread
944 (F_ptid => T.Common.LL.Thread'Unchecked_Access,
945 pfn => T.Common.LL.Wrapper,
946 param => To_Address (T),
947 flag => Block_Child + Commit_Stack,
948 cbStack => ULONG (Adjusted_Stack_Size));
950 Succeeded := (Result = NO_ERROR);
952 if not Succeeded then
956 -- Set the new thread's priority
957 -- (child has inherited priority from parent)
959 Set_Priority (T, Priority);
961 -- Start the thread executing
963 Must_Not_Fail (DosResumeThread (T.Common.LL.Thread));
971 procedure Finalize_TCB (T : Task_Id) is
974 procedure Free is new
975 Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
978 Must_Not_Fail (DosCloseEventSem (T.Common.LL.CV));
980 if not Single_Lock then
981 Finalize_Lock (T.Common.LL.L'Unchecked_Access);
984 if T.Known_Tasks_Index /= -1 then
985 Known_Tasks (T.Known_Tasks_Index) := null;
995 procedure Exit_Task is
997 Thread_Local_Data_Ptr := null;
1004 procedure Abort_Task (T : Task_Id) is
1005 pragma Unreferenced (T);
1010 -- Task abort not implemented yet.
1011 -- Should perform other action ???
1019 procedure Initialize (S : in out Suspension_Object) is
1020 Result : Interfaces.C.int;
1022 -- Initialize internal state. It is always initialized to False (ARM
1028 -- Initialize internal mutex
1029 if DosCreateMutexSem
1030 (ICS.Null_Ptr, S.L'Unchecked_Access, 0, False32) /= NO_ERROR
1032 raise Storage_Error;
1035 pragma Assert (S.L /= 0, "Error creating Mutex");
1037 -- Initialize internal condition variable
1039 if DosCreateEventSem
1040 (ICS.Null_Ptr, S.CV'Unchecked_Access, 0, True32) /= NO_ERROR
1042 Must_Not_Fail (DosCloseMutexSem (S.L));
1044 raise Storage_Error;
1047 pragma Assert (S.CV /= 0, "Error creating Condition Variable");
1054 procedure Finalize (S : in out Suspension_Object) is
1056 -- Destroy internal mutex
1058 Must_Not_Fail (DosCloseMutexSem (S.L'Access));
1060 -- Destroy internal condition variable
1062 Must_Not_Fail (DosCloseEventSem (S.CV'Access));
1069 function Current_State (S : Suspension_Object) return Boolean is
1071 -- We do not want to use lock on this read operation. State is marked
1072 -- as Atomic so that we ensure that the value retrieved is correct.
1081 procedure Set_False (S : in out Suspension_Object) is
1083 Must_Not_Fail (DosRequestMutexSem (S.L, SEM_INDEFINITE_WAIT));
1087 Must_Not_Fail (DosReleaseMutexSem (S.L));
1094 procedure Set_True (S : in out Suspension_Object) is
1096 Must_Not_Fail (DosRequestMutexSem (S.L, SEM_INDEFINITE_WAIT));
1098 -- If there is already a task waiting on this suspension object then
1099 -- we resume it, leaving the state of the suspension object to False,
1100 -- as it is specified in ARM D.10 par. 9. Otherwise, it just leaves
1101 -- the state to True.
1107 Sem_Must_Not_Fail (DosPostEventSem (S.CV));
1112 Must_Not_Fail (DosReleaseMutexSem (S.L));
1115 ------------------------
1116 -- Suspend_Until_True --
1117 ------------------------
1119 procedure Suspend_Until_True (S : in out Suspension_Object) is
1120 Count : aliased ULONG; -- Used to store dummy result
1122 Must_Not_Fail (DosRequestMutexSem (S.L, SEM_INDEFINITE_WAIT));
1125 -- Program_Error must be raised upon calling Suspend_Until_True
1126 -- if another task is already waiting on that suspension object
1127 -- (ARM D.10 par. 10).
1129 Must_Not_Fail (DosReleaseMutexSem (S.L));
1131 raise Program_Error;
1133 -- Suspend the task if the state is False. Otherwise, the task
1134 -- continues its execution, and the state of the suspension object
1135 -- is set to False (ARM D.10 par. 9).
1140 Must_Not_Fail (DosReleaseMutexSem (S.L));
1144 -- Must reset Cond BEFORE L is unlocked
1147 (DosResetEventSem (S.CV, Count'Unchecked_Access));
1149 Must_Not_Fail (DosReleaseMutexSem (S.L));
1152 (DosWaitEventSem (S.CV, SEM_INDEFINITE_WAIT));
1155 end Suspend_Until_True;
1163 function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
1165 return Check_No_Locks (Self_ID);
1168 --------------------
1169 -- Check_No_Locks --
1170 --------------------
1172 function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
1173 TLD : constant Access_Thread_Local_Data := Thread_Local_Data_Ptr;
1175 return Self_ID = TLD.Self_ID
1176 and then TLD.Lock_Prio_Level = 0;
1179 ----------------------
1180 -- Environment_Task --
1181 ----------------------
1183 function Environment_Task return Task_Id is
1185 return Environment_Task_Id;
1186 end Environment_Task;
1192 procedure Lock_RTS is
1194 Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
1201 procedure Unlock_RTS is
1203 Unlock (Single_RTS_Lock'Access, Global_Lock => True);
1210 function Suspend_Task
1212 Thread_Self : Thread_Id) return Boolean
1215 if Thread_Id (T.Common.LL.Thread) /= Thread_Self then
1216 return DosSuspendThread (T.Common.LL.Thread) = NO_ERROR;
1226 function Resume_Task
1228 Thread_Self : Thread_Id) return Boolean
1231 if Thread_Id (T.Common.LL.Thread) /= Thread_Self then
1232 return DosResumeThread (T.Common.LL.Thread) = NO_ERROR;
1242 procedure Initialize (Environment_Task : Task_Id) is
1243 Succeeded : Boolean;
1245 Environment_Task_Id := Environment_Task;
1247 Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
1248 -- Initialize the lock used to synchronize chain of all ATCBs
1250 -- Set ID of environment task
1252 Thread_Local_Data_Ptr.Self_ID := Environment_Task;
1253 Environment_Task.Common.LL.Thread := 1; -- By definition
1255 -- This priority is unknown in fact.
1256 -- If actual current priority is different,
1257 -- it will get synchronized later on anyway.
1259 Environment_Task.Common.LL.Current_Priority :=
1260 Environment_Task.Common.Current_Priority;
1262 -- Initialize TCB for this task.
1263 -- This includes all the normal task-external initialization.
1264 -- This is also done by Initialize_ATCB, why ???
1266 Initialize_TCB (Environment_Task, Succeeded);
1268 -- Consider raising Storage_Error,
1269 -- if propagation can be tolerated ???
1271 pragma Assert (Succeeded);
1273 -- Do normal task-internal initialization,
1274 -- which depends on an initialized TCB.
1276 Enter_Task (Environment_Task);
1278 -- Insert here any other special
1279 -- initialization needed for the environment task.
1283 -- Initialize pointer to task local data.
1284 -- This is done once, for all tasks.
1286 Must_Not_Fail (DosAllocThreadLocalMemory
1287 ((Thread_Local_Data'Size + 31) / 32, -- nr of 32-bit words
1288 To_PPVOID (Thread_Local_Data_Ptr'Access)));
1290 -- Initialize thread local data for main thread
1292 Thread_Local_Data_Ptr.Self_ID := null;
1293 Thread_Local_Data_Ptr.Lock_Prio_Level := 0;
1294 end System.Task_Primitives.Operations;