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, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- GNARL was developed by the GNARL team at Florida State University. --
30 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
32 ------------------------------------------------------------------------------
34 -- This is 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
46 with System
.OS_Primitives
;
47 -- used for Delay_Modes
50 with Interfaces
.OS2Lib
.Errors
;
51 with Interfaces
.OS2Lib
.Threads
;
52 with Interfaces
.OS2Lib
.Synchronization
;
57 with Interfaces
.C
.Strings
;
60 with System
.Parameters
;
63 with Unchecked_Conversion
;
64 with Unchecked_Deallocation
;
66 package body System
.Task_Primitives
.Operations
is
68 package IC
renames Interfaces
.C
;
69 package ICS
renames Interfaces
.C
.Strings
;
70 package OSP
renames System
.OS_Primitives
;
72 use Interfaces
.OS2Lib
;
73 use Interfaces
.OS2Lib
.Errors
;
74 use Interfaces
.OS2Lib
.Threads
;
75 use Interfaces
.OS2Lib
.Synchronization
;
76 use System
.Parameters
;
77 use System
.Tasking
.Debug
;
79 use System
.OS_Interface
;
81 use System
.OS_Primitives
;
87 Max_Locks_Per_Task
: constant := 100;
88 Suppress_Owner_Check
: constant Boolean := False;
94 subtype Lock_Range
is Integer range 0 .. Max_Locks_Per_Task
;
100 -- The OS/2 DosAllocThreadLocalMemory API is used to allocate our TCB_Ptr
102 -- This API reserves a small range of virtual addresses that is backed
103 -- by different physical memory for each running thread. In this case we
104 -- create a pointer at a fixed address that points to the TCB_Ptr for the
105 -- running thread. So all threads will be able to query and update their
106 -- own TCB_Ptr without destroying the TCB_Ptr of other threads.
108 type Thread_Local_Data
is record
109 Self_ID
: Task_Id
; -- ID of the current thread
110 Lock_Prio_Level
: Lock_Range
; -- Nr of priority changes due to locks
112 -- ... room for expansion here, if we decide to make access to
113 -- jump-buffer and exception stack more efficient in future
116 type Access_Thread_Local_Data
is access all Thread_Local_Data
;
118 -- Pointer to Thread Local Data
119 Thread_Local_Data_Ptr
: aliased Access_Thread_Local_Data
;
121 type PPTLD
is access all Access_Thread_Local_Data
;
123 Single_RTS_Lock
: aliased RTS_Lock
;
124 -- This is a lock to allow only one thread of control in the RTS at
125 -- a time; it is used to execute in mutual exclusion from all other tasks.
126 -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
128 Environment_Task_Id
: Task_Id
;
129 -- A variable to hold Task_Id for the environment task
131 -----------------------
132 -- Local Subprograms --
133 -----------------------
135 function To_PPVOID
is new Unchecked_Conversion
(PPTLD
, PPVOID
);
136 function To_Address
is new Unchecked_Conversion
(Task_Id
, System
.Address
);
137 function To_PFNTHREAD
is
138 new Unchecked_Conversion
(System
.Address
, PFNTHREAD
);
140 function To_MS
(D
: Duration) return ULONG
;
142 procedure Set_Temporary_Priority
144 New_Priority
: in System
.Any_Priority
);
150 function To_MS
(D
: Duration) return ULONG
is
152 return ULONG
(D
* 1_000
);
159 function Monotonic_Clock
return Duration renames OSP
.Monotonic_Clock
;
165 function RT_Resolution
return Duration is
174 -- OS/2 only has limited support for asynchronous signals.
175 -- It seems not to be possible to jump out of an exception
176 -- handler or to change the execution context of the thread.
177 -- So asynchonous transfer of control is not supported.
183 -- The underlying thread system sets a guard page at the
184 -- bottom of a thread stack, so nothing is needed.
185 -- ??? Check the comment above
187 procedure Stack_Guard
(T
: ST
.Task_Id
; On
: Boolean) is
188 pragma Unreferenced
(T
);
189 pragma Unreferenced
(On
);
198 function Get_Thread_Id
(T
: ST
.Task_Id
) return OSI
.Thread_Id
is
200 return OSI
.Thread_Id
(T
.Common
.LL
.Thread
);
207 function Self
return Task_Id
is
208 Self_ID
: Task_Id
renames Thread_Local_Data_Ptr
.Self_ID
;
211 -- Check that the thread local data has been initialized
214 ((Thread_Local_Data_Ptr
/= null
215 and then Thread_Local_Data_Ptr
.Self_ID
/= null));
220 ---------------------
221 -- Initialize_Lock --
222 ---------------------
224 procedure Initialize_Lock
225 (Prio
: System
.Any_Priority
;
230 (ICS
.Null_Ptr
, L
.Mutex
'Unchecked_Access, 0, False32
) /= NO_ERROR
235 pragma Assert
(L
.Mutex
/= 0, "Error creating Mutex");
237 L
.Owner_ID
:= Null_Address
;
240 procedure Initialize_Lock
(L
: access RTS_Lock
; Level
: Lock_Level
) is
241 pragma Unreferenced
(Level
);
245 (ICS
.Null_Ptr
, L
.Mutex
'Unchecked_Access, 0, False32
) /= NO_ERROR
250 pragma Assert
(L
.Mutex
/= 0, "Error creating Mutex");
252 L
.Priority
:= System
.Any_Priority
'Last;
253 L
.Owner_ID
:= Null_Address
;
260 procedure Finalize_Lock
(L
: access Lock
) is
262 Must_Not_Fail
(DosCloseMutexSem
(L
.Mutex
));
265 procedure Finalize_Lock
(L
: access RTS_Lock
) is
267 Must_Not_Fail
(DosCloseMutexSem
(L
.Mutex
));
274 procedure Write_Lock
(L
: access Lock
; Ceiling_Violation
: out Boolean) is
275 Self_ID
: constant Task_Id
:= Thread_Local_Data_Ptr
.Self_ID
;
276 Old_Priority
: constant Any_Priority
:=
277 Self_ID
.Common
.LL
.Current_Priority
;
280 if L
.Priority
< Old_Priority
then
281 Ceiling_Violation
:= True;
285 Ceiling_Violation
:= False;
287 -- Increase priority before getting the lock
288 -- to prevent priority inversion
290 Thread_Local_Data_Ptr
.Lock_Prio_Level
:=
291 Thread_Local_Data_Ptr
.Lock_Prio_Level
+ 1;
292 if L
.Priority
> Old_Priority
then
293 Set_Temporary_Priority
(Self_ID
, L
.Priority
);
296 -- Request the lock and then update the lock owner data
298 Must_Not_Fail
(DosRequestMutexSem
(L
.Mutex
, SEM_INDEFINITE_WAIT
));
299 L
.Owner_Priority
:= Old_Priority
;
300 L
.Owner_ID
:= Self_ID
.all'Address;
304 (L
: access RTS_Lock
;
305 Global_Lock
: Boolean := False)
308 Old_Priority
: Any_Priority
;
311 if not Single_Lock
or else Global_Lock
then
312 Self_ID
:= Thread_Local_Data_Ptr
.Self_ID
;
313 Old_Priority
:= Self_ID
.Common
.LL
.Current_Priority
;
315 -- Increase priority before getting the lock
316 -- to prevent priority inversion
318 Thread_Local_Data_Ptr
.Lock_Prio_Level
:=
319 Thread_Local_Data_Ptr
.Lock_Prio_Level
+ 1;
321 if L
.Priority
> Old_Priority
then
322 Set_Temporary_Priority
(Self_ID
, L
.Priority
);
325 -- Request the lock and then update the lock owner data
327 Must_Not_Fail
(DosRequestMutexSem
(L
.Mutex
, SEM_INDEFINITE_WAIT
));
328 L
.Owner_Priority
:= Old_Priority
;
329 L
.Owner_ID
:= Self_ID
.all'Address;
333 procedure Write_Lock
(T
: Task_Id
) is
335 if not Single_Lock
then
337 -- Request the lock and then update the lock owner data
340 (DosRequestMutexSem
(T
.Common
.LL
.L
.Mutex
, SEM_INDEFINITE_WAIT
));
341 T
.Common
.LL
.L
.Owner_ID
:= Null_Address
;
350 (L
: access Lock
; Ceiling_Violation
: out Boolean) renames Write_Lock
;
356 procedure Unlock
(L
: access Lock
) is
357 Self_ID
: constant Task_Id
:= Thread_Local_Data_Ptr
.Self_ID
;
358 Old_Priority
: constant Any_Priority
:= L
.Owner_Priority
;
361 -- Check that this task holds the lock
363 pragma Assert
(Suppress_Owner_Check
364 or else L
.Owner_ID
= Self_ID
.all'Address);
366 -- Upate the owner data
368 L
.Owner_ID
:= Null_Address
;
370 -- Do the actual unlocking. No more references
371 -- to owner data of L after this point.
373 Must_Not_Fail
(DosReleaseMutexSem
(L
.Mutex
));
375 -- Reset priority after unlocking to avoid priority inversion
377 Thread_Local_Data_Ptr
.Lock_Prio_Level
:=
378 Thread_Local_Data_Ptr
.Lock_Prio_Level
- 1;
379 if L
.Priority
/= Old_Priority
then
380 Set_Temporary_Priority
(Self_ID
, Old_Priority
);
384 procedure Unlock
(L
: access RTS_Lock
; Global_Lock
: Boolean := False) is
386 Old_Priority
: Any_Priority
;
389 if not Single_Lock
or else Global_Lock
then
390 Self_ID
:= Thread_Local_Data_Ptr
.Self_ID
;
391 Old_Priority
:= L
.Owner_Priority
;
392 -- Check that this task holds the lock
394 pragma Assert
(Suppress_Owner_Check
395 or else L
.Owner_ID
= Self_ID
.all'Address);
397 -- Upate the owner data
399 L
.Owner_ID
:= Null_Address
;
401 -- Do the actual unlocking. No more references
402 -- to owner data of L after this point.
404 Must_Not_Fail
(DosReleaseMutexSem
(L
.Mutex
));
406 -- Reset priority after unlocking to avoid priority inversion
408 Thread_Local_Data_Ptr
.Lock_Prio_Level
:=
409 Thread_Local_Data_Ptr
.Lock_Prio_Level
- 1;
411 if L
.Priority
/= Old_Priority
then
412 Set_Temporary_Priority
(Self_ID
, Old_Priority
);
417 procedure Unlock
(T
: Task_Id
) is
419 if not Single_Lock
then
421 -- Check the owner data
423 pragma Assert
(Suppress_Owner_Check
424 or else T
.Common
.LL
.L
.Owner_ID
= Null_Address
);
426 -- Do the actual unlocking. No more references
427 -- to owner data of T.Common.LL.L after this point.
429 Must_Not_Fail
(DosReleaseMutexSem
(T
.Common
.LL
.L
.Mutex
));
439 Reason
: System
.Tasking
.Task_States
)
441 pragma Unreferenced
(Reason
);
443 Count
: aliased ULONG
; -- Used to store dummy result
446 -- Must reset Cond BEFORE L is unlocked
449 (DosResetEventSem
(Self_ID
.Common
.LL
.CV
, Count
'Unchecked_Access));
457 -- No problem if we are interrupted here.
458 -- If the condition is signaled, DosWaitEventSem will simply not block.
461 (DosWaitEventSem
(Self_ID
.Common
.LL
.CV
, SEM_INDEFINITE_WAIT
));
463 -- Since L was previously accquired, lock operation should not fail
468 Write_Lock
(Self_ID
);
476 -- This is for use within the run-time system, so abort is
477 -- assumed to be already deferred, and the caller should be
478 -- holding its own ATCB lock.
480 -- Pre-assertion: Cond is posted
483 -- Post-assertion: Cond is posted
486 procedure Timed_Sleep
489 Mode
: ST
.Delay_Modes
;
490 Reason
: System
.Tasking
.Task_States
;
491 Timedout
: out Boolean;
492 Yielded
: out Boolean)
494 pragma Unreferenced
(Reason
);
496 Check_Time
: constant Duration := OSP
.Monotonic_Clock
;
501 Count
: aliased ULONG
; -- Used to store dummy result
504 -- Must reset Cond BEFORE Self_ID is unlocked
507 (DosResetEventSem
(Self_ID
.Common
.LL
.CV
,
508 Count
'Unchecked_Access));
519 if Mode
= Relative
then
521 Abs_Time
:= Duration'Min (Time
, Max_Sensible_Delay
) + Check_Time
;
523 Rel_Time
:= Time
- Check_Time
;
527 if Rel_Time
> 0.0 then
529 exit when Self_ID
.Pending_ATC_Level
< Self_ID
.ATC_Nesting_Level
530 or else Self_ID
.Pending_Priority_Change
;
532 Time_Out
:= To_MS
(Rel_Time
);
533 Result
:= DosWaitEventSem
(Self_ID
.Common
.LL
.CV
, Time_Out
);
535 ((Result
= NO_ERROR
or Result
= ERROR_TIMEOUT
536 or Result
= ERROR_INTERRUPT
));
539 -- What to do with error condition ERROR_NOT_ENOUGH_MEMORY? Can
540 -- we raise an exception here? And what about ERROR_INTERRUPT?
541 -- Should that be treated as a simple timeout?
542 -- For now, consider only ERROR_TIMEOUT to be a timeout.
544 exit when Abs_Time
<= OSP
.Monotonic_Clock
;
546 if Result
/= ERROR_TIMEOUT
then
547 -- somebody may have called Wakeup for us
552 Rel_Time
:= Abs_Time
- OSP
.Monotonic_Clock
;
556 -- Ensure post-condition
561 Write_Lock
(Self_ID
);
565 Sem_Must_Not_Fail
(DosPostEventSem
(Self_ID
.Common
.LL
.CV
));
573 procedure Timed_Delay
576 Mode
: ST
.Delay_Modes
)
578 Check_Time
: constant Duration := OSP
.Monotonic_Clock
;
581 Timedout
: Boolean := True;
584 Count
: aliased ULONG
; -- Used to store dummy result
590 Write_Lock
(Self_ID
);
593 -- Must reset Cond BEFORE Self_ID is unlocked
596 (DosResetEventSem
(Self_ID
.Common
.LL
.CV
,
597 Count
'Unchecked_Access));
605 if Mode
= Relative
then
607 Abs_Time
:= Time
+ Check_Time
;
609 Rel_Time
:= Time
- Check_Time
;
613 if Rel_Time
> 0.0 then
614 Self_ID
.Common
.State
:= Delay_Sleep
;
617 if Self_ID
.Pending_Priority_Change
then
618 Self_ID
.Pending_Priority_Change
:= False;
619 Self_ID
.Common
.Base_Priority
:= Self_ID
.New_Base_Priority
;
620 Set_Priority
(Self_ID
, Self_ID
.Common
.Base_Priority
);
623 exit when Self_ID
.Pending_ATC_Level
< Self_ID
.ATC_Nesting_Level
;
625 Time_Out
:= To_MS
(Rel_Time
);
626 Result
:= DosWaitEventSem
(Self_ID
.Common
.LL
.CV
, Time_Out
);
628 exit when Abs_Time
<= OSP
.Monotonic_Clock
;
630 Rel_Time
:= Abs_Time
- OSP
.Monotonic_Clock
;
633 Self_ID
.Common
.State
:= Runnable
;
634 Timedout
:= Result
= ERROR_TIMEOUT
;
640 Write_Lock
(Self_ID
);
644 Sem_Must_Not_Fail
(DosPostEventSem
(Self_ID
.Common
.LL
.CV
));
653 System
.OS_Interface
.Yield
;
660 procedure Wakeup
(T
: Task_Id
; Reason
: System
.Tasking
.Task_States
) is
661 pragma Unreferenced
(Reason
);
663 Sem_Must_Not_Fail
(DosPostEventSem
(T
.Common
.LL
.CV
));
670 procedure Yield
(Do_Yield
: Boolean := True) is
673 System
.OS_Interface
.Yield
;
677 ----------------------------
678 -- Set_Temporary_Priority --
679 ----------------------------
681 procedure Set_Temporary_Priority
683 New_Priority
: System
.Any_Priority
)
686 Delta_Priority
: Integer;
689 -- When Lock_Prio_Level = 0, we always need to set the
690 -- Active_Priority. In this way we can make priority changes
691 -- due to locking independent of those caused by calling
694 if Thread_Local_Data_Ptr
.Lock_Prio_Level
= 0
695 or else New_Priority
< T
.Common
.Current_Priority
697 Delta_Priority
:= T
.Common
.Current_Priority
-
698 T
.Common
.LL
.Current_Priority
;
700 Delta_Priority
:= New_Priority
- T
.Common
.LL
.Current_Priority
;
703 if Delta_Priority
/= 0 then
704 -- ??? There is a race-condition here
705 -- The TCB is updated before the system call to make
706 -- pre-emption in the critical section less likely.
708 T
.Common
.LL
.Current_Priority
:=
709 T
.Common
.LL
.Current_Priority
+ Delta_Priority
;
711 (DosSetPriority
(Scope
=> PRTYS_THREAD
,
712 Class
=> PRTYC_NOCHANGE
,
713 Delta_P
=> IC
.long
(Delta_Priority
),
714 PorTid
=> T
.Common
.LL
.Thread
));
716 end Set_Temporary_Priority
;
722 procedure Set_Priority
724 Prio
: System
.Any_Priority
;
725 Loss_Of_Inheritance
: Boolean := False)
727 pragma Unreferenced
(Loss_Of_Inheritance
);
729 T
.Common
.Current_Priority
:= Prio
;
730 Set_Temporary_Priority
(T
, Prio
);
737 function Get_Priority
(T
: Task_Id
) return System
.Any_Priority
is
739 return T
.Common
.Current_Priority
;
746 procedure Enter_Task
(Self_ID
: Task_Id
) is
748 -- Initialize thread local data. Must be done first
750 Thread_Local_Data_Ptr
.Self_ID
:= Self_ID
;
751 Thread_Local_Data_Ptr
.Lock_Prio_Level
:= 0;
755 for J
in Known_Tasks
'Range loop
756 if Known_Tasks
(J
) = null then
757 Known_Tasks
(J
) := Self_ID
;
758 Self_ID
.Known_Tasks_Index
:= J
;
765 -- For OS/2, we can set Self_ID.Common.LL.Thread in
766 -- Create_Task, since the thread is created suspended.
767 -- That is, there is no danger of the thread racing ahead
768 -- and trying to reference Self_ID.Common.LL.Thread before it
769 -- has been initialized.
771 -- .... Do we need to do anything with signals for OS/2 ???
778 function New_ATCB
(Entry_Num
: Task_Entry_Index
) return Task_Id
is
780 return new Ada_Task_Control_Block
(Entry_Num
);
787 function Is_Valid_Task
return Boolean is
792 -----------------------------
793 -- Register_Foreign_Thread --
794 -----------------------------
796 function Register_Foreign_Thread
return Task_Id
is
799 end Register_Foreign_Thread
;
805 procedure Initialize_TCB
(Self_ID
: Task_Id
; Succeeded
: out Boolean) is
807 if DosCreateEventSem
(ICS
.Null_Ptr
,
808 Self_ID
.Common
.LL
.CV
'Unchecked_Access, 0, True32
) = NO_ERROR
811 and then DosCreateMutexSem
813 Self_ID
.Common
.LL
.L
.Mutex
'Unchecked_Access,
818 Must_Not_Fail
(DosCloseEventSem
(Self_ID
.Common
.LL
.CV
));
823 -- We now want to do the equivalent of:
826 -- (Self_ID.Common.LL.L'Unchecked_Access, ATCB_Level);
828 -- But we avoid that because the Initialize_TCB routine has an
829 -- exception handler, and it is too early for us to deal with
830 -- installing handlers (see comment below), so we do our own
831 -- Initialize_Lock operation manually.
833 Self_ID
.Common
.LL
.L
.Priority
:= System
.Any_Priority
'Last;
834 Self_ID
.Common
.LL
.L
.Owner_ID
:= Null_Address
;
840 -- Note: at one time we had an exception handler here, whose code
845 -- Assumes any failure must be due to insufficient resources
847 -- when Storage_Error =>
848 -- Must_Not_Fail (DosCloseEventSem (Self_ID.Common.LL.CV));
849 -- Succeeded := False;
851 -- but that won't work with the old exception scheme, since it would
852 -- result in messing with Jmpbuf values too early. If and when we get
853 -- switched entirely to the new zero-cost exception scheme, we could
854 -- put this handler back in!
861 procedure Create_Task
863 Wrapper
: System
.Address
;
864 Stack_Size
: System
.Parameters
.Size_Type
;
865 Priority
: System
.Any_Priority
;
866 Succeeded
: out Boolean)
868 Result
: aliased APIRET
;
869 Adjusted_Stack_Size
: System
.Parameters
.Size_Type
;
870 use System
.Parameters
;
873 -- In OS/2 the allocated stack size should be based on the
874 -- amount of address space that should be reserved for the stack.
875 -- Actual memory will only be used when the stack is touched anyway.
877 -- The new minimum size is 12 kB, although the EMX docs
878 -- recommend a minimum size of 32 kB. (The original was 4 kB)
879 -- Systems that use many tasks (say > 30) and require much
880 -- memory may run out of virtual address space, since OS/2
881 -- has a per-proces limit of 512 MB, of which max. 300 MB is
882 -- usable in practise.
884 if Stack_Size
= Unspecified_Size
then
885 Adjusted_Stack_Size
:= Default_Stack_Size
;
887 elsif Stack_Size
< Minimum_Stack_Size
then
888 Adjusted_Stack_Size
:= Minimum_Stack_Size
;
891 Adjusted_Stack_Size
:= Stack_Size
;
895 -- Because DosCreateThread is called directly here, the
896 -- C RTL doesn't get initialized for the new thead. EMX by
897 -- default uses per-thread local heaps in addition to the
898 -- global heap. There might be other effects of by-passing the
901 -- When using _beginthread the newly created thread is not
902 -- blocked initially. Does this matter or can I create the
903 -- thread running anyway? The LL.Thread variable will be set
904 -- anyway because the variable is passed by reference to OS/2.
906 T
.Common
.LL
.Wrapper
:= To_PFNTHREAD
(Wrapper
);
908 -- The OS implicitly gives the new task the priority of this task
910 T
.Common
.LL
.Current_Priority
:= Self
.Common
.LL
.Current_Priority
;
912 -- If task was locked before activator task was
913 -- initialized, assume it has OS standard priority
915 if T
.Common
.LL
.L
.Owner_Priority
not in Any_Priority
'Range then
916 T
.Common
.LL
.L
.Owner_Priority
:= 1;
919 -- Create the thread, in blocked mode
921 Result
:= DosCreateThread
922 (F_ptid
=> T
.Common
.LL
.Thread
'Unchecked_Access,
923 pfn
=> T
.Common
.LL
.Wrapper
,
924 param
=> To_Address
(T
),
925 flag
=> Block_Child
+ Commit_Stack
,
926 cbStack
=> ULONG
(Adjusted_Stack_Size
));
928 Succeeded
:= (Result
= NO_ERROR
);
930 if not Succeeded
then
934 -- Set the new thread's priority
935 -- (child has inherited priority from parent)
937 Set_Priority
(T
, Priority
);
939 -- Start the thread executing
941 Must_Not_Fail
(DosResumeThread
(T
.Common
.LL
.Thread
));
949 procedure Finalize_TCB
(T
: Task_Id
) is
952 procedure Free
is new
953 Unchecked_Deallocation
(Ada_Task_Control_Block
, Task_Id
);
956 Must_Not_Fail
(DosCloseEventSem
(T
.Common
.LL
.CV
));
958 if not Single_Lock
then
959 Finalize_Lock
(T
.Common
.LL
.L
'Unchecked_Access);
962 if T
.Known_Tasks_Index
/= -1 then
963 Known_Tasks
(T
.Known_Tasks_Index
) := null;
973 procedure Exit_Task
is
975 Thread_Local_Data_Ptr
:= null;
982 procedure Abort_Task
(T
: Task_Id
) is
983 pragma Unreferenced
(T
);
988 -- Task abort not implemented yet.
989 -- Should perform other action ???
997 procedure Initialize
(S
: in out Suspension_Object
) is
998 Result
: Interfaces
.C
.int
;
1000 -- Initialize internal state. It is always initialized to False (ARM
1006 -- Initialize internal mutex
1007 if DosCreateMutexSem
1008 (ICS
.Null_Ptr
, S
.L
'Unchecked_Access, 0, False32
) /= NO_ERROR
1010 raise Storage_Error
;
1013 pragma Assert
(S
.L
/= 0, "Error creating Mutex");
1015 -- Initialize internal condition variable
1017 if DosCreateEventSem
1018 (ICS
.Null_Ptr
, S
.CV
'Unchecked_Access, 0, True32
) /= NO_ERROR
1020 Must_Not_Fail
(DosCloseMutexSem
(S
.L
));
1022 raise Storage_Error
;
1025 pragma Assert
(S
.CV
/= 0, "Error creating Condition Variable");
1032 procedure Finalize
(S
: in out Suspension_Object
) is
1034 -- Destroy internal mutex
1036 Must_Not_Fail
(DosCloseMutexSem
(S
.L
'Access));
1038 -- Destroy internal condition variable
1040 Must_Not_Fail
(DosCloseEventSem
(S
.CV
'Access));
1047 function Current_State
(S
: Suspension_Object
) return Boolean is
1049 -- We do not want to use lock on this read operation. State is marked
1050 -- as Atomic so that we ensure that the value retrieved is correct.
1059 procedure Set_False
(S
: in out Suspension_Object
) is
1061 Must_Not_Fail
(DosRequestMutexSem
(S
.L
, SEM_INDEFINITE_WAIT
));
1065 Must_Not_Fail
(DosReleaseMutexSem
(S
.L
));
1072 procedure Set_True
(S
: in out Suspension_Object
) is
1074 Must_Not_Fail
(DosRequestMutexSem
(S
.L
, SEM_INDEFINITE_WAIT
));
1076 -- If there is already a task waiting on this suspension object then
1077 -- we resume it, leaving the state of the suspension object to False,
1078 -- as it is specified in ARM D.10 par. 9. Otherwise, it just leaves
1079 -- the state to True.
1085 Sem_Must_Not_Fail
(DosPostEventSem
(S
.CV
));
1090 Must_Not_Fail
(DosReleaseMutexSem
(S
.L
));
1093 ------------------------
1094 -- Suspend_Until_True --
1095 ------------------------
1097 procedure Suspend_Until_True
(S
: in out Suspension_Object
) is
1098 Count
: aliased ULONG
; -- Used to store dummy result
1100 Must_Not_Fail
(DosRequestMutexSem
(S
.L
, SEM_INDEFINITE_WAIT
));
1103 -- Program_Error must be raised upon calling Suspend_Until_True
1104 -- if another task is already waiting on that suspension object
1105 -- (ARM D.10 par. 10).
1107 Must_Not_Fail
(DosReleaseMutexSem
(S
.L
));
1109 raise Program_Error
;
1111 -- Suspend the task if the state is False. Otherwise, the task
1112 -- continues its execution, and the state of the suspension object
1113 -- is set to False (ARM D.10 par. 9).
1118 Must_Not_Fail
(DosReleaseMutexSem
(S
.L
));
1122 -- Must reset Cond BEFORE L is unlocked
1125 (DosResetEventSem
(S
.CV
, Count
'Unchecked_Access));
1127 Must_Not_Fail
(DosReleaseMutexSem
(S
.L
));
1130 (DosWaitEventSem
(S
.CV
, SEM_INDEFINITE_WAIT
));
1133 end Suspend_Until_True
;
1141 function Check_Exit
(Self_ID
: ST
.Task_Id
) return Boolean is
1143 return Check_No_Locks
(Self_ID
);
1146 --------------------
1147 -- Check_No_Locks --
1148 --------------------
1150 function Check_No_Locks
(Self_ID
: ST
.Task_Id
) return Boolean is
1151 TLD
: constant Access_Thread_Local_Data
:= Thread_Local_Data_Ptr
;
1153 return Self_ID
= TLD
.Self_ID
1154 and then TLD
.Lock_Prio_Level
= 0;
1157 ----------------------
1158 -- Environment_Task --
1159 ----------------------
1161 function Environment_Task
return Task_Id
is
1163 return Environment_Task_Id
;
1164 end Environment_Task
;
1170 procedure Lock_RTS
is
1172 Write_Lock
(Single_RTS_Lock
'Access, Global_Lock
=> True);
1179 procedure Unlock_RTS
is
1181 Unlock
(Single_RTS_Lock
'Access, Global_Lock
=> True);
1188 function Suspend_Task
1190 Thread_Self
: Thread_Id
) return Boolean
1193 if Thread_Id
(T
.Common
.LL
.Thread
) /= Thread_Self
then
1194 return DosSuspendThread
(T
.Common
.LL
.Thread
) = NO_ERROR
;
1204 function Resume_Task
1206 Thread_Self
: Thread_Id
) return Boolean
1209 if Thread_Id
(T
.Common
.LL
.Thread
) /= Thread_Self
then
1210 return DosResumeThread
(T
.Common
.LL
.Thread
) = NO_ERROR
;
1220 procedure Initialize
(Environment_Task
: Task_Id
) is
1221 Succeeded
: Boolean;
1223 Environment_Task_Id
:= Environment_Task
;
1225 OS_Primitives
.Initialize
;
1227 -- Initialize pointer to task local data.
1228 -- This is done once, for all tasks.
1230 Must_Not_Fail
(DosAllocThreadLocalMemory
1231 ((Thread_Local_Data
'Size + 31) / 32, -- nr of 32-bit words
1232 To_PPVOID
(Thread_Local_Data_Ptr
'Access)));
1234 -- Initialize thread local data for main thread
1236 Thread_Local_Data_Ptr
.Self_ID
:= null;
1237 Thread_Local_Data_Ptr
.Lock_Prio_Level
:= 0;
1239 Initialize_Lock
(Single_RTS_Lock
'Access, RTS_Lock_Level
);
1240 -- Initialize the lock used to synchronize chain of all ATCBs
1242 -- Set ID of environment task
1244 Thread_Local_Data_Ptr
.Self_ID
:= Environment_Task
;
1245 Environment_Task
.Common
.LL
.Thread
:= 1; -- By definition
1247 -- This priority is unknown in fact.
1248 -- If actual current priority is different,
1249 -- it will get synchronized later on anyway.
1251 Environment_Task
.Common
.LL
.Current_Priority
:=
1252 Environment_Task
.Common
.Current_Priority
;
1254 -- Initialize TCB for this task.
1255 -- This includes all the normal task-external initialization.
1256 -- This is also done by Initialize_ATCB, why ???
1258 Initialize_TCB
(Environment_Task
, Succeeded
);
1260 -- Consider raising Storage_Error,
1261 -- if propagation can be tolerated ???
1263 pragma Assert
(Succeeded
);
1265 -- Do normal task-internal initialization,
1266 -- which depends on an initialized TCB.
1268 Enter_Task
(Environment_Task
);
1270 -- Insert here any other special
1271 -- initialization needed for the environment task.
1274 end System
.Task_Primitives
.Operations
;