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-2003, 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.Initialization
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
);
214 function Get_Thread_Id
(T
: ST
.Task_ID
) return OSI
.Thread_Id
is
216 return OSI
.Thread_Id
(T
.Common
.LL
.Thread
);
223 function Self
return Task_ID
is
224 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
);
686 Sem_Must_Not_Fail
(DosPostEventSem
(T
.Common
.LL
.CV
));
693 procedure Yield
(Do_Yield
: Boolean := True) is
696 System
.OS_Interface
.Yield
;
700 ----------------------------
701 -- Set_Temporary_Priority --
702 ----------------------------
704 procedure Set_Temporary_Priority
706 New_Priority
: System
.Any_Priority
)
709 Delta_Priority
: Integer;
712 -- When Lock_Prio_Level = 0, we always need to set the
713 -- Active_Priority. In this way we can make priority changes
714 -- due to locking independent of those caused by calling
717 if Thread_Local_Data_Ptr
.Lock_Prio_Level
= 0
718 or else New_Priority
< T
.Common
.Current_Priority
720 Delta_Priority
:= T
.Common
.Current_Priority
-
721 T
.Common
.LL
.Current_Priority
;
723 Delta_Priority
:= New_Priority
- T
.Common
.LL
.Current_Priority
;
726 if Delta_Priority
/= 0 then
727 -- ??? There is a race-condition here
728 -- The TCB is updated before the system call to make
729 -- pre-emption in the critical section less likely.
731 T
.Common
.LL
.Current_Priority
:=
732 T
.Common
.LL
.Current_Priority
+ Delta_Priority
;
734 (DosSetPriority
(Scope
=> PRTYS_THREAD
,
735 Class
=> PRTYC_NOCHANGE
,
736 Delta_P
=> IC
.long
(Delta_Priority
),
737 PorTid
=> T
.Common
.LL
.Thread
));
739 end Set_Temporary_Priority
;
745 procedure Set_Priority
747 Prio
: System
.Any_Priority
;
748 Loss_Of_Inheritance
: Boolean := False)
750 pragma Unreferenced
(Loss_Of_Inheritance
);
753 T
.Common
.Current_Priority
:= Prio
;
754 Set_Temporary_Priority
(T
, Prio
);
761 function Get_Priority
(T
: Task_ID
) return System
.Any_Priority
is
763 return T
.Common
.Current_Priority
;
770 procedure Enter_Task
(Self_ID
: Task_ID
) is
772 -- Initialize thread local data. Must be done first.
774 Thread_Local_Data_Ptr
.Self_ID
:= Self_ID
;
775 Thread_Local_Data_Ptr
.Lock_Prio_Level
:= 0;
779 for J
in Known_Tasks
'Range loop
780 if Known_Tasks
(J
) = null then
781 Known_Tasks
(J
) := Self_ID
;
782 Self_ID
.Known_Tasks_Index
:= J
;
789 -- For OS/2, we can set Self_ID.Common.LL.Thread in
790 -- Create_Task, since the thread is created suspended.
791 -- That is, there is no danger of the thread racing ahead
792 -- and trying to reference Self_ID.Common.LL.Thread before it
793 -- has been initialized.
795 -- .... Do we need to do anything with signals for OS/2 ???
802 function New_ATCB
(Entry_Num
: Task_Entry_Index
) return Task_ID
is
804 return new Ada_Task_Control_Block
(Entry_Num
);
811 function Is_Valid_Task
return Boolean is
816 -----------------------------
817 -- Register_Foreign_Thread --
818 -----------------------------
820 function Register_Foreign_Thread
return Task_ID
is
823 end Register_Foreign_Thread
;
829 procedure Initialize_TCB
(Self_ID
: Task_ID
; Succeeded
: out Boolean) is
831 if DosCreateEventSem
(ICS
.Null_Ptr
,
832 Self_ID
.Common
.LL
.CV
'Unchecked_Access, 0, True32
) = NO_ERROR
835 and then DosCreateMutexSem
837 Self_ID
.Common
.LL
.L
.Mutex
'Unchecked_Access,
842 Must_Not_Fail
(DosCloseEventSem
(Self_ID
.Common
.LL
.CV
));
847 -- We now want to do the equivalent of:
850 -- (Self_ID.Common.LL.L'Unchecked_Access, ATCB_Level);
852 -- But we avoid that because the Initialize_TCB routine has an
853 -- exception handler, and it is too early for us to deal with
854 -- installing handlers (see comment below), so we do our own
855 -- Initialize_Lock operation manually.
857 Self_ID
.Common
.LL
.L
.Priority
:= System
.Any_Priority
'Last;
858 Self_ID
.Common
.LL
.L
.Owner_ID
:= Null_Address
;
864 -- Note: at one time we had an exception handler here, whose code
869 -- Assumes any failure must be due to insufficient resources
871 -- when Storage_Error =>
872 -- Must_Not_Fail (DosCloseEventSem (Self_ID.Common.LL.CV));
873 -- Succeeded := False;
875 -- but that won't work with the old exception scheme, since it would
876 -- result in messing with Jmpbuf values too early. If and when we get
877 -- switched entirely to the new zero-cost exception scheme, we could
878 -- put this handler back in!
885 procedure Create_Task
887 Wrapper
: System
.Address
;
888 Stack_Size
: System
.Parameters
.Size_Type
;
889 Priority
: System
.Any_Priority
;
890 Succeeded
: out Boolean)
892 Result
: aliased APIRET
;
893 Adjusted_Stack_Size
: System
.Parameters
.Size_Type
;
894 use System
.Parameters
;
897 -- In OS/2 the allocated stack size should be based on the
898 -- amount of address space that should be reserved for the stack.
899 -- Actual memory will only be used when the stack is touched anyway.
901 -- The new minimum size is 12 kB, although the EMX docs
902 -- recommend a minimum size of 32 kB. (The original was 4 kB)
903 -- Systems that use many tasks (say > 30) and require much
904 -- memory may run out of virtual address space, since OS/2
905 -- has a per-proces limit of 512 MB, of which max. 300 MB is
906 -- usable in practise.
908 if Stack_Size
= Unspecified_Size
then
909 Adjusted_Stack_Size
:= Default_Stack_Size
;
911 elsif Stack_Size
< Minimum_Stack_Size
then
912 Adjusted_Stack_Size
:= Minimum_Stack_Size
;
915 Adjusted_Stack_Size
:= Stack_Size
;
919 -- Because DosCreateThread is called directly here, the
920 -- C RTL doesn't get initialized for the new thead. EMX by
921 -- default uses per-thread local heaps in addition to the
922 -- global heap. There might be other effects of by-passing the
925 -- When using _beginthread the newly created thread is not
926 -- blocked initially. Does this matter or can I create the
927 -- thread running anyway? The LL.Thread variable will be set
928 -- anyway because the variable is passed by reference to OS/2.
930 T
.Common
.LL
.Wrapper
:= To_PFNTHREAD
(Wrapper
);
932 -- The OS implicitly gives the new task the priority of this task.
934 T
.Common
.LL
.Current_Priority
:= Self
.Common
.LL
.Current_Priority
;
936 -- If task was locked before activator task was
937 -- initialized, assume it has OS standard priority
939 if T
.Common
.LL
.L
.Owner_Priority
not in Any_Priority
'Range then
940 T
.Common
.LL
.L
.Owner_Priority
:= 1;
943 -- Create the thread, in blocked mode
945 Result
:= DosCreateThread
946 (F_ptid
=> T
.Common
.LL
.Thread
'Unchecked_Access,
947 pfn
=> T
.Common
.LL
.Wrapper
,
948 param
=> To_Address
(T
),
949 flag
=> Block_Child
+ Commit_Stack
,
950 cbStack
=> ULONG
(Adjusted_Stack_Size
));
952 Succeeded
:= (Result
= NO_ERROR
);
954 if not Succeeded
then
958 -- Set the new thread's priority
959 -- (child has inherited priority from parent)
961 Set_Priority
(T
, Priority
);
963 -- Start the thread executing
965 Must_Not_Fail
(DosResumeThread
(T
.Common
.LL
.Thread
));
973 procedure Finalize_TCB
(T
: Task_ID
) is
976 procedure Free
is new
977 Unchecked_Deallocation
(Ada_Task_Control_Block
, Task_ID
);
980 Must_Not_Fail
(DosCloseEventSem
(T
.Common
.LL
.CV
));
982 if not Single_Lock
then
983 Finalize_Lock
(T
.Common
.LL
.L
'Unchecked_Access);
986 if T
.Known_Tasks_Index
/= -1 then
987 Known_Tasks
(T
.Known_Tasks_Index
) := null;
997 procedure Exit_Task
is
999 Thread_Local_Data_Ptr
:= null;
1006 procedure Abort_Task
(T
: Task_ID
) is
1007 pragma Unreferenced
(T
);
1012 -- Task abortion not implemented yet.
1013 -- Should perform other action ???
1023 function Check_Exit
(Self_ID
: ST
.Task_ID
) return Boolean is
1025 return Check_No_Locks
(Self_ID
);
1028 --------------------
1029 -- Check_No_Locks --
1030 --------------------
1032 function Check_No_Locks
(Self_ID
: ST
.Task_ID
) return Boolean is
1033 TLD
: constant Access_Thread_Local_Data
:= Thread_Local_Data_Ptr
;
1036 return Self_ID
= TLD
.Self_ID
1037 and then TLD
.Lock_Prio_Level
= 0;
1040 ----------------------
1041 -- Environment_Task --
1042 ----------------------
1044 function Environment_Task
return Task_ID
is
1046 return Environment_Task_ID
;
1047 end Environment_Task
;
1053 procedure Lock_RTS
is
1055 Write_Lock
(Single_RTS_Lock
'Access, Global_Lock
=> True);
1062 procedure Unlock_RTS
is
1064 Unlock
(Single_RTS_Lock
'Access, Global_Lock
=> True);
1071 function Suspend_Task
1073 Thread_Self
: Thread_Id
)
1077 if Thread_Id
(T
.Common
.LL
.Thread
) /= Thread_Self
then
1078 return DosSuspendThread
(T
.Common
.LL
.Thread
) = NO_ERROR
;
1088 function Resume_Task
1090 Thread_Self
: Thread_Id
)
1094 if Thread_Id
(T
.Common
.LL
.Thread
) /= Thread_Self
then
1095 return DosResumeThread
(T
.Common
.LL
.Thread
) = NO_ERROR
;
1105 procedure Initialize
(Environment_Task
: Task_ID
) is
1106 Succeeded
: Boolean;
1108 Environment_Task_ID
:= Environment_Task
;
1110 Initialize_Lock
(Single_RTS_Lock
'Access, RTS_Lock_Level
);
1111 -- Initialize the lock used to synchronize chain of all ATCBs.
1113 -- Set ID of environment task.
1115 Thread_Local_Data_Ptr
.Self_ID
:= Environment_Task
;
1116 Environment_Task
.Common
.LL
.Thread
:= 1; -- By definition
1118 -- This priority is unknown in fact.
1119 -- If actual current priority is different,
1120 -- it will get synchronized later on anyway.
1122 Environment_Task
.Common
.LL
.Current_Priority
:=
1123 Environment_Task
.Common
.Current_Priority
;
1125 -- Initialize TCB for this task.
1126 -- This includes all the normal task-external initialization.
1127 -- This is also done by Initialize_ATCB, why ???
1129 Initialize_TCB
(Environment_Task
, Succeeded
);
1131 -- Consider raising Storage_Error,
1132 -- if propagation can be tolerated ???
1134 pragma Assert
(Succeeded
);
1136 -- Do normal task-internal initialization,
1137 -- which depends on an initialized TCB.
1139 Enter_Task
(Environment_Task
);
1141 -- Insert here any other special
1142 -- initialization needed for the environment task.
1146 -- Initialize pointer to task local data.
1147 -- This is done once, for all tasks.
1149 Must_Not_Fail
(DosAllocThreadLocalMemory
1150 ((Thread_Local_Data
'Size + 31) / 32, -- nr of 32-bit words
1151 To_PPVOID
(Thread_Local_Data_Ptr
'Access)));
1153 -- Initialize thread local data for main thread
1155 Thread_Local_Data_Ptr
.Self_ID
:= null;
1156 Thread_Local_Data_Ptr
.Lock_Prio_Level
:= 0;
1157 end System
.Task_Primitives
.Operations
;