1 ------------------------------------------------------------------------------
3 -- GNU ADA 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 ???
1021 function Check_Exit
(Self_ID
: ST
.Task_Id
) return Boolean is
1023 return Check_No_Locks
(Self_ID
);
1026 --------------------
1027 -- Check_No_Locks --
1028 --------------------
1030 function Check_No_Locks
(Self_ID
: ST
.Task_Id
) return Boolean is
1031 TLD
: constant Access_Thread_Local_Data
:= Thread_Local_Data_Ptr
;
1033 return Self_ID
= TLD
.Self_ID
1034 and then TLD
.Lock_Prio_Level
= 0;
1037 ----------------------
1038 -- Environment_Task --
1039 ----------------------
1041 function Environment_Task
return Task_Id
is
1043 return Environment_Task_Id
;
1044 end Environment_Task
;
1050 procedure Lock_RTS
is
1052 Write_Lock
(Single_RTS_Lock
'Access, Global_Lock
=> True);
1059 procedure Unlock_RTS
is
1061 Unlock
(Single_RTS_Lock
'Access, Global_Lock
=> True);
1068 function Suspend_Task
1070 Thread_Self
: Thread_Id
) return Boolean
1073 if Thread_Id
(T
.Common
.LL
.Thread
) /= Thread_Self
then
1074 return DosSuspendThread
(T
.Common
.LL
.Thread
) = NO_ERROR
;
1084 function Resume_Task
1086 Thread_Self
: Thread_Id
) return Boolean
1089 if Thread_Id
(T
.Common
.LL
.Thread
) /= Thread_Self
then
1090 return DosResumeThread
(T
.Common
.LL
.Thread
) = NO_ERROR
;
1100 procedure Initialize
(Environment_Task
: Task_Id
) is
1101 Succeeded
: Boolean;
1103 Environment_Task_Id
:= Environment_Task
;
1105 Initialize_Lock
(Single_RTS_Lock
'Access, RTS_Lock_Level
);
1106 -- Initialize the lock used to synchronize chain of all ATCBs
1108 -- Set ID of environment task
1110 Thread_Local_Data_Ptr
.Self_ID
:= Environment_Task
;
1111 Environment_Task
.Common
.LL
.Thread
:= 1; -- By definition
1113 -- This priority is unknown in fact.
1114 -- If actual current priority is different,
1115 -- it will get synchronized later on anyway.
1117 Environment_Task
.Common
.LL
.Current_Priority
:=
1118 Environment_Task
.Common
.Current_Priority
;
1120 -- Initialize TCB for this task.
1121 -- This includes all the normal task-external initialization.
1122 -- This is also done by Initialize_ATCB, why ???
1124 Initialize_TCB
(Environment_Task
, Succeeded
);
1126 -- Consider raising Storage_Error,
1127 -- if propagation can be tolerated ???
1129 pragma Assert
(Succeeded
);
1131 -- Do normal task-internal initialization,
1132 -- which depends on an initialized TCB.
1134 Enter_Task
(Environment_Task
);
1136 -- Insert here any other special
1137 -- initialization needed for the environment task.
1141 -- Initialize pointer to task local data.
1142 -- This is done once, for all tasks.
1144 Must_Not_Fail
(DosAllocThreadLocalMemory
1145 ((Thread_Local_Data
'Size + 31) / 32, -- nr of 32-bit words
1146 To_PPVOID
(Thread_Local_Data_Ptr
'Access)));
1148 -- Initialize thread local data for main thread
1150 Thread_Local_Data_Ptr
.Self_ID
:= null;
1151 Thread_Local_Data_Ptr
.Lock_Prio_Level
:= 0;
1152 end System
.Task_Primitives
.Operations
;