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 --
10 -- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
12 -- GNARL is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNARL; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
23 -- As a special exception, if other files instantiate generics from this --
24 -- unit, or you link this unit with other files to produce an executable, --
25 -- this unit does not by itself cause the resulting executable to be --
26 -- covered by the GNU General Public License. This exception does not --
27 -- however invalidate any other reasons why the executable file might be --
28 -- covered by the GNU Public License. --
30 -- GNARL was developed by the GNARL team at Florida State University. It is --
31 -- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
33 ------------------------------------------------------------------------------
35 -- This is an OS/2 version of this package
37 -- This package contains all the GNULL primitives that interface directly
38 -- with the underlying OS.
41 -- Turn off polling, we do not want ATC polling to take place during
42 -- tasking operations. It causes infinite loops and other problems.
44 with System
.Tasking
.Debug
;
45 -- used for Known_Tasks
50 with Interfaces
.C
.Strings
;
53 with Interfaces
.OS2Lib
.Errors
;
54 with Interfaces
.OS2Lib
.Threads
;
55 with Interfaces
.OS2Lib
.Synchronization
;
57 with System
.Parameters
;
63 with System
.Parameters
;
66 with System
.Soft_Links
;
67 -- used for Defer/Undefer_Abort
69 -- Note that we do not use System.Tasking.Initialization directly since
70 -- this is a higher level package that we shouldn't depend on. For example
71 -- when using the restricted run time, it is replaced by
72 -- System.Tasking.Restricted.Initialization
74 with System
.OS_Primitives
;
75 -- used for Delay_Modes
78 with Unchecked_Conversion
;
79 with Unchecked_Deallocation
;
81 package body System
.Task_Primitives
.Operations
is
83 package IC
renames Interfaces
.C
;
84 package ICS
renames Interfaces
.C
.Strings
;
85 package OSP
renames System
.OS_Primitives
;
86 package SSL
renames System
.Soft_Links
;
88 use Interfaces
.OS2Lib
;
89 use Interfaces
.OS2Lib
.Errors
;
90 use Interfaces
.OS2Lib
.Threads
;
91 use Interfaces
.OS2Lib
.Synchronization
;
92 use System
.Parameters
;
93 use System
.Tasking
.Debug
;
95 use System
.OS_Interface
;
97 use System
.OS_Primitives
;
100 -- Local Constants --
101 ---------------------
103 Max_Locks_Per_Task
: constant := 100;
104 Suppress_Owner_Check
: constant Boolean := False;
110 subtype Lock_Range
is Integer range 0 .. Max_Locks_Per_Task
;
116 -- The OS/2 DosAllocThreadLocalMemory API is used to allocate our TCB_Ptr.
118 -- This API reserves a small range of virtual addresses that is backed
119 -- by different physical memory for each running thread. In this case we
120 -- create a pointer at a fixed address that points to the TCB_Ptr for the
121 -- running thread. So all threads will be able to query and update their
122 -- own TCB_Ptr without destroying the TCB_Ptr of other threads.
124 type Thread_Local_Data
is record
125 Self_ID
: Task_ID
; -- ID of the current thread
126 Lock_Prio_Level
: Lock_Range
; -- Nr of priority changes due to locks
128 -- ... room for expansion here, if we decide to make access to
129 -- jump-buffer and exception stack more efficient in future
132 type Access_Thread_Local_Data
is access all Thread_Local_Data
;
134 -- Pointer to Thread Local Data
135 Thread_Local_Data_Ptr
: aliased Access_Thread_Local_Data
;
137 type PPTLD
is access all Access_Thread_Local_Data
;
139 Single_RTS_Lock
: aliased RTS_Lock
;
140 -- This is a lock to allow only one thread of control in the RTS at
141 -- a time; it is used to execute in mutual exclusion from all other tasks.
142 -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
144 Environment_Task_ID
: Task_ID
;
145 -- A variable to hold Task_ID for the environment task.
147 -----------------------
148 -- Local Subprograms --
149 -----------------------
151 function To_PPVOID
is new Unchecked_Conversion
(PPTLD
, PPVOID
);
152 function To_Address
is new Unchecked_Conversion
(Task_ID
, System
.Address
);
153 function To_PFNTHREAD
is
154 new Unchecked_Conversion
(System
.Address
, PFNTHREAD
);
156 function To_MS
(D
: Duration) return ULONG
;
158 procedure Set_Temporary_Priority
160 New_Priority
: in System
.Any_Priority
);
166 function To_MS
(D
: Duration) return ULONG
is
168 return ULONG
(D
* 1_000
);
175 function Monotonic_Clock
return Duration renames OSP
.Monotonic_Clock
;
181 function RT_Resolution
return Duration is
190 -- OS/2 only has limited support for asynchronous signals.
191 -- It seems not to be possible to jump out of an exception
192 -- handler or to change the execution context of the thread.
193 -- So asynchonous transfer of control is not supported.
199 -- The underlying thread system sets a guard page at the
200 -- bottom of a thread stack, so nothing is needed.
201 -- ??? Check the comment above
203 procedure Stack_Guard
(T
: ST
.Task_ID
; On
: Boolean) is
204 pragma Warnings
(Off
, T
);
205 pragma Warnings
(Off
, On
);
215 function Get_Thread_Id
(T
: ST
.Task_ID
) return OSI
.Thread_Id
is
217 return OSI
.Thread_Id
(T
.Common
.LL
.Thread
);
224 function Self
return Task_ID
is
225 Self_ID
: Task_ID
renames Thread_Local_Data_Ptr
.Self_ID
;
227 -- Check that the thread local data has been initialized.
230 ((Thread_Local_Data_Ptr
/= null
231 and then Thread_Local_Data_Ptr
.Self_ID
/= null));
236 ---------------------
237 -- Initialize_Lock --
238 ---------------------
240 procedure Initialize_Lock
241 (Prio
: System
.Any_Priority
;
246 (ICS
.Null_Ptr
, L
.Mutex
'Unchecked_Access, 0, False32
) /= NO_ERROR
251 pragma Assert
(L
.Mutex
/= 0, "Error creating Mutex");
253 L
.Owner_ID
:= Null_Address
;
256 procedure Initialize_Lock
(L
: access RTS_Lock
; Level
: Lock_Level
) is
257 pragma Warnings
(Off
, Level
);
261 (ICS
.Null_Ptr
, L
.Mutex
'Unchecked_Access, 0, False32
) /= NO_ERROR
266 pragma Assert
(L
.Mutex
/= 0, "Error creating Mutex");
268 L
.Priority
:= System
.Any_Priority
'Last;
269 L
.Owner_ID
:= Null_Address
;
276 procedure Finalize_Lock
(L
: access Lock
) is
278 Must_Not_Fail
(DosCloseMutexSem
(L
.Mutex
));
281 procedure Finalize_Lock
(L
: access RTS_Lock
) is
283 Must_Not_Fail
(DosCloseMutexSem
(L
.Mutex
));
290 procedure Write_Lock
(L
: access Lock
; Ceiling_Violation
: out Boolean) is
291 Self_ID
: constant Task_ID
:= Thread_Local_Data_Ptr
.Self_ID
;
292 Old_Priority
: constant Any_Priority
:=
293 Self_ID
.Common
.LL
.Current_Priority
;
296 if L
.Priority
< Old_Priority
then
297 Ceiling_Violation
:= True;
301 Ceiling_Violation
:= False;
303 -- Increase priority before getting the lock
304 -- to prevent priority inversion
306 Thread_Local_Data_Ptr
.Lock_Prio_Level
:=
307 Thread_Local_Data_Ptr
.Lock_Prio_Level
+ 1;
308 if L
.Priority
> Old_Priority
then
309 Set_Temporary_Priority
(Self_ID
, L
.Priority
);
312 -- Request the lock and then update the lock owner data
314 Must_Not_Fail
(DosRequestMutexSem
(L
.Mutex
, SEM_INDEFINITE_WAIT
));
315 L
.Owner_Priority
:= Old_Priority
;
316 L
.Owner_ID
:= Self_ID
.all'Address;
320 (L
: access RTS_Lock
; 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
351 -- Request the lock and then update the lock owner data
354 (DosRequestMutexSem
(T
.Common
.LL
.L
.Mutex
, SEM_INDEFINITE_WAIT
));
355 T
.Common
.LL
.L
.Owner_ID
:= Null_Address
;
364 (L
: access Lock
; Ceiling_Violation
: out Boolean) renames Write_Lock
;
370 procedure Unlock
(L
: access Lock
) is
371 Self_ID
: constant Task_ID
:= Thread_Local_Data_Ptr
.Self_ID
;
372 Old_Priority
: constant Any_Priority
:= L
.Owner_Priority
;
375 -- Check that this task holds the lock
377 pragma Assert
(Suppress_Owner_Check
378 or else L
.Owner_ID
= Self_ID
.all'Address);
380 -- Upate the owner data
382 L
.Owner_ID
:= Null_Address
;
384 -- Do the actual unlocking. No more references
385 -- to owner data of L after this point.
387 Must_Not_Fail
(DosReleaseMutexSem
(L
.Mutex
));
389 -- Reset priority after unlocking to avoid priority inversion
391 Thread_Local_Data_Ptr
.Lock_Prio_Level
:=
392 Thread_Local_Data_Ptr
.Lock_Prio_Level
- 1;
393 if L
.Priority
/= Old_Priority
then
394 Set_Temporary_Priority
(Self_ID
, Old_Priority
);
398 procedure Unlock
(L
: access RTS_Lock
; Global_Lock
: Boolean := False) is
400 Old_Priority
: Any_Priority
;
403 if not Single_Lock
or else Global_Lock
then
404 Self_ID
:= Thread_Local_Data_Ptr
.Self_ID
;
405 Old_Priority
:= L
.Owner_Priority
;
406 -- Check that this task holds the lock
408 pragma Assert
(Suppress_Owner_Check
409 or else L
.Owner_ID
= Self_ID
.all'Address);
411 -- Upate the owner data
413 L
.Owner_ID
:= Null_Address
;
415 -- Do the actual unlocking. No more references
416 -- to owner data of L after this point.
418 Must_Not_Fail
(DosReleaseMutexSem
(L
.Mutex
));
420 -- Reset priority after unlocking to avoid priority inversion
421 Thread_Local_Data_Ptr
.Lock_Prio_Level
:=
422 Thread_Local_Data_Ptr
.Lock_Prio_Level
- 1;
424 if L
.Priority
/= Old_Priority
then
425 Set_Temporary_Priority
(Self_ID
, Old_Priority
);
430 procedure Unlock
(T
: Task_ID
) is
432 if not Single_Lock
then
433 -- Check the owner data
435 pragma Assert
(Suppress_Owner_Check
436 or else T
.Common
.LL
.L
.Owner_ID
= Null_Address
);
438 -- Do the actual unlocking. No more references
439 -- to owner data of T.Common.LL.L after this point.
441 Must_Not_Fail
(DosReleaseMutexSem
(T
.Common
.LL
.L
.Mutex
));
451 Reason
: System
.Tasking
.Task_States
)
453 pragma Warnings
(Off
, Reason
);
455 Count
: aliased ULONG
; -- Used to store dummy result
458 -- Must reset Cond BEFORE L is unlocked.
461 (DosResetEventSem
(Self_ID
.Common
.LL
.CV
, Count
'Unchecked_Access));
469 -- No problem if we are interrupted here.
470 -- If the condition is signaled, DosWaitEventSem will simply not block.
473 (DosWaitEventSem
(Self_ID
.Common
.LL
.CV
, SEM_INDEFINITE_WAIT
));
475 -- Since L was previously accquired, lock operation should not fail.
480 Write_Lock
(Self_ID
);
488 -- This is for use within the run-time system, so abort is
489 -- assumed to be already deferred, and the caller should be
490 -- holding its own ATCB lock.
492 -- Pre-assertion: Cond is posted
495 -- Post-assertion: Cond is posted
498 procedure Timed_Sleep
501 Mode
: ST
.Delay_Modes
;
502 Reason
: System
.Tasking
.Task_States
;
503 Timedout
: out Boolean;
504 Yielded
: out Boolean)
506 pragma Warnings
(Off
, Reason
);
508 Check_Time
: constant Duration := OSP
.Monotonic_Clock
;
513 Count
: aliased ULONG
; -- Used to store dummy result
516 -- Must reset Cond BEFORE Self_ID is unlocked.
519 (DosResetEventSem
(Self_ID
.Common
.LL
.CV
,
520 Count
'Unchecked_Access));
531 if Mode
= Relative
then
533 Abs_Time
:= Duration'Min (Time
, Max_Sensible_Delay
) + Check_Time
;
535 Rel_Time
:= Time
- Check_Time
;
539 if Rel_Time
> 0.0 then
541 exit when Self_ID
.Pending_ATC_Level
< Self_ID
.ATC_Nesting_Level
542 or else Self_ID
.Pending_Priority_Change
;
544 Time_Out
:= To_MS
(Rel_Time
);
545 Result
:= DosWaitEventSem
(Self_ID
.Common
.LL
.CV
, Time_Out
);
547 ((Result
= NO_ERROR
or Result
= ERROR_TIMEOUT
548 or Result
= ERROR_INTERRUPT
));
551 -- What to do with error condition ERROR_NOT_ENOUGH_MEMORY? Can
552 -- we raise an exception here? And what about ERROR_INTERRUPT?
553 -- Should that be treated as a simple timeout?
554 -- For now, consider only ERROR_TIMEOUT to be a timeout.
556 exit when Abs_Time
<= OSP
.Monotonic_Clock
;
558 if Result
/= ERROR_TIMEOUT
then
559 -- somebody may have called Wakeup for us
564 Rel_Time
:= Abs_Time
- OSP
.Monotonic_Clock
;
568 -- Ensure post-condition
573 Write_Lock
(Self_ID
);
577 Sem_Must_Not_Fail
(DosPostEventSem
(Self_ID
.Common
.LL
.CV
));
585 procedure Timed_Delay
588 Mode
: ST
.Delay_Modes
)
590 Check_Time
: constant Duration := OSP
.Monotonic_Clock
;
593 Timedout
: Boolean := True;
596 Count
: aliased ULONG
; -- Used to store dummy result
599 -- Only the little window between deferring abort and
600 -- locking Self_ID is the reason we need to
601 -- check for pending abort and priority change below! :(
608 Write_Lock
(Self_ID
);
611 -- Must reset Cond BEFORE Self_ID is unlocked.
614 (DosResetEventSem
(Self_ID
.Common
.LL
.CV
,
615 Count
'Unchecked_Access));
623 if Mode
= Relative
then
625 Abs_Time
:= Time
+ Check_Time
;
627 Rel_Time
:= Time
- Check_Time
;
631 if Rel_Time
> 0.0 then
632 Self_ID
.Common
.State
:= Delay_Sleep
;
635 if Self_ID
.Pending_Priority_Change
then
636 Self_ID
.Pending_Priority_Change
:= False;
637 Self_ID
.Common
.Base_Priority
:= Self_ID
.New_Base_Priority
;
638 Set_Priority
(Self_ID
, Self_ID
.Common
.Base_Priority
);
641 exit when Self_ID
.Pending_ATC_Level
< Self_ID
.ATC_Nesting_Level
;
643 Time_Out
:= To_MS
(Rel_Time
);
644 Result
:= DosWaitEventSem
(Self_ID
.Common
.LL
.CV
, Time_Out
);
646 exit when Abs_Time
<= OSP
.Monotonic_Clock
;
648 Rel_Time
:= Abs_Time
- OSP
.Monotonic_Clock
;
651 Self_ID
.Common
.State
:= Runnable
;
652 Timedout
:= Result
= ERROR_TIMEOUT
;
658 Write_Lock
(Self_ID
);
662 Sem_Must_Not_Fail
(DosPostEventSem
(Self_ID
.Common
.LL
.CV
));
671 System
.OS_Interface
.Yield
;
672 SSL
.Abort_Undefer
.all;
679 procedure Wakeup
(T
: Task_ID
; Reason
: System
.Tasking
.Task_States
) is
680 pragma Warnings
(Off
, Reason
);
682 Sem_Must_Not_Fail
(DosPostEventSem
(T
.Common
.LL
.CV
));
689 procedure Yield
(Do_Yield
: Boolean := True) is
692 System
.OS_Interface
.Yield
;
696 ----------------------------
697 -- Set_Temporary_Priority --
698 ----------------------------
700 procedure Set_Temporary_Priority
702 New_Priority
: System
.Any_Priority
)
705 Delta_Priority
: Integer;
708 -- When Lock_Prio_Level = 0, we always need to set the
709 -- Active_Priority. In this way we can make priority changes
710 -- due to locking independent of those caused by calling
713 if Thread_Local_Data_Ptr
.Lock_Prio_Level
= 0
714 or else New_Priority
< T
.Common
.Current_Priority
716 Delta_Priority
:= T
.Common
.Current_Priority
-
717 T
.Common
.LL
.Current_Priority
;
719 Delta_Priority
:= New_Priority
- T
.Common
.LL
.Current_Priority
;
722 if Delta_Priority
/= 0 then
723 -- ??? There is a race-condition here
724 -- The TCB is updated before the system call to make
725 -- pre-emption in the critical section less likely.
727 T
.Common
.LL
.Current_Priority
:=
728 T
.Common
.LL
.Current_Priority
+ Delta_Priority
;
730 (DosSetPriority
(Scope
=> PRTYS_THREAD
,
731 Class
=> PRTYC_NOCHANGE
,
732 Delta_P
=> IC
.long
(Delta_Priority
),
733 PorTid
=> T
.Common
.LL
.Thread
));
735 end Set_Temporary_Priority
;
741 procedure Set_Priority
743 Prio
: System
.Any_Priority
;
744 Loss_Of_Inheritance
: Boolean := False)
746 pragma Warnings
(Off
, Loss_Of_Inheritance
);
749 T
.Common
.Current_Priority
:= Prio
;
750 Set_Temporary_Priority
(T
, Prio
);
757 function Get_Priority
(T
: Task_ID
) return System
.Any_Priority
is
759 return T
.Common
.Current_Priority
;
766 procedure Enter_Task
(Self_ID
: Task_ID
) is
768 -- Initialize thread local data. Must be done first.
770 Thread_Local_Data_Ptr
.Self_ID
:= Self_ID
;
771 Thread_Local_Data_Ptr
.Lock_Prio_Level
:= 0;
775 for J
in Known_Tasks
'Range loop
776 if Known_Tasks
(J
) = null then
777 Known_Tasks
(J
) := Self_ID
;
778 Self_ID
.Known_Tasks_Index
:= J
;
785 -- For OS/2, we can set Self_ID.Common.LL.Thread in
786 -- Create_Task, since the thread is created suspended.
787 -- That is, there is no danger of the thread racing ahead
788 -- and trying to reference Self_ID.Common.LL.Thread before it
789 -- has been initialized.
791 -- .... Do we need to do anything with signals for OS/2 ???
798 function New_ATCB
(Entry_Num
: Task_Entry_Index
) return Task_ID
is
800 return new Ada_Task_Control_Block
(Entry_Num
);
803 ----------------------
805 ----------------------
807 procedure Initialize_TCB
(Self_ID
: Task_ID
; Succeeded
: out Boolean) is
809 if DosCreateEventSem
(ICS
.Null_Ptr
,
810 Self_ID
.Common
.LL
.CV
'Unchecked_Access, 0, True32
) = NO_ERROR
813 and then DosCreateMutexSem
815 Self_ID
.Common
.LL
.L
.Mutex
'Unchecked_Access,
820 Must_Not_Fail
(DosCloseEventSem
(Self_ID
.Common
.LL
.CV
));
825 -- We now want to do the equivalent of:
828 -- (Self_ID.Common.LL.L'Unchecked_Access, ATCB_Level);
830 -- But we avoid that because the Initialize_TCB routine has an
831 -- exception handler, and it is too early for us to deal with
832 -- installing handlers (see comment below), so we do our own
833 -- Initialize_Lock operation manually.
835 Self_ID
.Common
.LL
.L
.Priority
:= System
.Any_Priority
'Last;
836 Self_ID
.Common
.LL
.L
.Owner_ID
:= Null_Address
;
842 -- Note: at one time we had an exception handler here, whose code
847 -- Assumes any failure must be due to insufficient resources
849 -- when Storage_Error =>
850 -- Must_Not_Fail (DosCloseEventSem (Self_ID.Common.LL.CV));
851 -- Succeeded := False;
853 -- but that won't work with the old exception scheme, since it would
854 -- result in messing with Jmpbuf values too early. If and when we get
855 -- switched entirely to the new zero-cost exception scheme, we could
856 -- put this handler back in!
863 procedure Create_Task
865 Wrapper
: System
.Address
;
866 Stack_Size
: System
.Parameters
.Size_Type
;
867 Priority
: System
.Any_Priority
;
868 Succeeded
: out Boolean)
870 Result
: aliased APIRET
;
871 Adjusted_Stack_Size
: System
.Parameters
.Size_Type
;
872 use System
.Parameters
;
875 -- In OS/2 the allocated stack size should be based on the
876 -- amount of address space that should be reserved for the stack.
877 -- Actual memory will only be used when the stack is touched anyway.
879 -- The new minimum size is 12 kB, although the EMX docs
880 -- recommend a minimum size of 32 kB. (The original was 4 kB)
881 -- Systems that use many tasks (say > 30) and require much
882 -- memory may run out of virtual address space, since OS/2
883 -- has a per-process limit of 512 MB, of which max. 300 MB is
884 -- usable in practise.
886 if Stack_Size
= Unspecified_Size
then
887 Adjusted_Stack_Size
:= Default_Stack_Size
;
889 elsif Stack_Size
< Minimum_Stack_Size
then
890 Adjusted_Stack_Size
:= Minimum_Stack_Size
;
893 Adjusted_Stack_Size
:= Stack_Size
;
897 -- Because DosCreateThread is called directly here, the
898 -- C RTL doesn't get initialized for the new thead. EMX by
899 -- default uses per-thread local heaps in addition to the
900 -- global heap. There might be other effects of by-passing the
903 -- When using _beginthread the newly created thread is not
904 -- blocked initially. Does this matter or can I create the
905 -- thread running anyway? The LL.Thread variable will be set
906 -- anyway because the variable is passed by reference to OS/2.
908 T
.Common
.LL
.Wrapper
:= To_PFNTHREAD
(Wrapper
);
910 -- The OS implicitly gives the new task the priority of this task.
912 T
.Common
.LL
.Current_Priority
:= Self
.Common
.LL
.Current_Priority
;
914 -- If task was locked before activator task was
915 -- initialized, assume it has OS standard priority
917 if T
.Common
.LL
.L
.Owner_Priority
not in Any_Priority
'Range then
918 T
.Common
.LL
.L
.Owner_Priority
:= 1;
921 -- Create the thread, in blocked mode
923 Result
:= DosCreateThread
924 (F_ptid
=> T
.Common
.LL
.Thread
'Unchecked_Access,
925 pfn
=> T
.Common
.LL
.Wrapper
,
926 param
=> To_Address
(T
),
927 flag
=> Block_Child
+ Commit_Stack
,
928 cbStack
=> ULONG
(Adjusted_Stack_Size
));
930 Succeeded
:= (Result
= NO_ERROR
);
932 if not Succeeded
then
936 -- Set the new thread's priority
937 -- (child has inherited priority from parent)
939 Set_Priority
(T
, Priority
);
941 -- Start the thread executing
943 Must_Not_Fail
(DosResumeThread
(T
.Common
.LL
.Thread
));
951 procedure Finalize_TCB
(T
: Task_ID
) is
954 procedure Free
is new
955 Unchecked_Deallocation
(Ada_Task_Control_Block
, Task_ID
);
958 Must_Not_Fail
(DosCloseEventSem
(T
.Common
.LL
.CV
));
960 if not Single_Lock
then
961 Finalize_Lock
(T
.Common
.LL
.L
'Unchecked_Access);
964 if T
.Known_Tasks_Index
/= -1 then
965 Known_Tasks
(T
.Known_Tasks_Index
) := null;
975 procedure Exit_Task
is
977 DosExit
(EXIT_THREAD
, 0);
979 -- Do not finalize TCB here.
980 -- GNARL layer is responsible for that.
988 procedure Abort_Task
(T
: Task_ID
) is
989 pragma Warnings
(Off
, T
);
994 -- Task abortion not implemented yet.
995 -- Should perform other action ???
1003 -- Dummy versions. The only currently working versions is for solaris
1006 function Check_Exit
(Self_ID
: ST
.Task_ID
) return Boolean is
1008 return Check_No_Locks
(Self_ID
);
1011 --------------------
1012 -- Check_No_Locks --
1013 --------------------
1015 function Check_No_Locks
(Self_ID
: ST
.Task_ID
) return Boolean is
1016 TLD
: constant Access_Thread_Local_Data
:= Thread_Local_Data_Ptr
;
1018 return Self_ID
= TLD
.Self_ID
1019 and then TLD
.Lock_Prio_Level
= 0;
1022 ----------------------
1023 -- Environment_Task --
1024 ----------------------
1026 function Environment_Task
return Task_ID
is
1028 return Environment_Task_ID
;
1029 end Environment_Task
;
1035 procedure Lock_RTS
is
1037 Write_Lock
(Single_RTS_Lock
'Access, Global_Lock
=> True);
1044 procedure Unlock_RTS
is
1046 Unlock
(Single_RTS_Lock
'Access, Global_Lock
=> True);
1053 function Suspend_Task
1055 Thread_Self
: Thread_Id
) return Boolean is
1057 if Thread_Id
(T
.Common
.LL
.Thread
) /= Thread_Self
then
1058 return DosSuspendThread
(T
.Common
.LL
.Thread
) = NO_ERROR
;
1068 function Resume_Task
1070 Thread_Self
: Thread_Id
) return Boolean is
1072 if Thread_Id
(T
.Common
.LL
.Thread
) /= Thread_Self
then
1073 return DosResumeThread
(T
.Common
.LL
.Thread
) = NO_ERROR
;
1083 procedure Initialize
(Environment_Task
: Task_ID
) is
1084 Succeeded
: Boolean;
1086 Environment_Task_ID
:= Environment_Task
;
1088 Initialize_Lock
(Single_RTS_Lock
'Access, RTS_Lock_Level
);
1089 -- Initialize the lock used to synchronize chain of all ATCBs.
1091 -- Set ID of environment task.
1093 Thread_Local_Data_Ptr
.Self_ID
:= Environment_Task
;
1094 Environment_Task
.Common
.LL
.Thread
:= 1; -- By definition
1096 -- This priority is unknown in fact.
1097 -- If actual current priority is different,
1098 -- it will get synchronized later on anyway.
1100 Environment_Task
.Common
.LL
.Current_Priority
:=
1101 Environment_Task
.Common
.Current_Priority
;
1103 -- Initialize TCB for this task.
1104 -- This includes all the normal task-external initialization.
1105 -- This is also done by Initialize_ATCB, why ???
1107 Initialize_TCB
(Environment_Task
, Succeeded
);
1109 -- Consider raising Storage_Error,
1110 -- if propagation can be tolerated ???
1112 pragma Assert
(Succeeded
);
1114 -- Do normal task-internal initialization,
1115 -- which depends on an initialized TCB.
1117 Enter_Task
(Environment_Task
);
1119 -- Insert here any other special
1120 -- initialization needed for the environment task.
1124 -- Initialize pointer to task local data.
1125 -- This is done once, for all tasks.
1127 Must_Not_Fail
(DosAllocThreadLocalMemory
1128 ((Thread_Local_Data
'Size + 31) / 32, -- nr of 32-bit words
1129 To_PPVOID
(Thread_Local_Data_Ptr
'Access)));
1131 -- Initialize thread local data for main thread
1133 Thread_Local_Data_Ptr
.Self_ID
:= null;
1134 Thread_Local_Data_Ptr
.Lock_Prio_Level
:= 0;
1135 end System
.Task_Primitives
.Operations
;