pragma Polling (Off);
with System.Tasking.Debug;
with Interfaces.C;
with Interfaces.C.Strings;
with Interfaces.OS2Lib.Errors;
with Interfaces.OS2Lib.Threads;
with Interfaces.OS2Lib.Synchronization;
with System.Parameters;
with System.Tasking;
with System.Parameters;
with System.Soft_Links;
with System.OS_Primitives;
with Unchecked_Conversion;
with Unchecked_Deallocation;
package body System.Task_Primitives.Operations is
package IC renames Interfaces.C;
package ICS renames Interfaces.C.Strings;
package OSP renames System.OS_Primitives;
package SSL renames System.Soft_Links;
use Interfaces.OS2Lib;
use Interfaces.OS2Lib.Errors;
use Interfaces.OS2Lib.Threads;
use Interfaces.OS2Lib.Synchronization;
use System.Parameters;
use System.Tasking.Debug;
use System.Tasking;
use System.OS_Interface;
use Interfaces.C;
use System.OS_Primitives;
Max_Locks_Per_Task : constant := 100;
Suppress_Owner_Check : constant Boolean := False;
subtype Lock_Range is Integer range 0 .. Max_Locks_Per_Task;
type Thread_Local_Data is record
Self_ID : Task_Id; Lock_Prio_Level : Lock_Range;
end record;
type Access_Thread_Local_Data is access all Thread_Local_Data;
Thread_Local_Data_Ptr : aliased Access_Thread_Local_Data;
type PPTLD is access all Access_Thread_Local_Data;
Single_RTS_Lock : aliased RTS_Lock;
Environment_Task_Id : Task_Id;
function To_PPVOID is new Unchecked_Conversion (PPTLD, PPVOID);
function To_Address is new Unchecked_Conversion (Task_Id, System.Address);
function To_PFNTHREAD is
new Unchecked_Conversion (System.Address, PFNTHREAD);
function To_MS (D : Duration) return ULONG;
procedure Set_Temporary_Priority
(T : in Task_Id;
New_Priority : in System.Any_Priority);
function To_MS (D : Duration) return ULONG is
begin
return ULONG (D * 1_000);
end To_MS;
function Monotonic_Clock return Duration renames OSP.Monotonic_Clock;
function RT_Resolution return Duration is
begin
return 10#1.0#E-6;
end RT_Resolution;
procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
pragma Unreferenced (T);
pragma Unreferenced (On);
begin
null;
end Stack_Guard;
function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
begin
return OSI.Thread_Id (T.Common.LL.Thread);
end Get_Thread_Id;
function Self return Task_Id is
Self_ID : Task_Id renames Thread_Local_Data_Ptr.Self_ID;
begin
pragma Assert
((Thread_Local_Data_Ptr /= null
and then Thread_Local_Data_Ptr.Self_ID /= null));
return Self_ID;
end Self;
procedure Initialize_Lock
(Prio : System.Any_Priority;
L : access Lock)
is
begin
if DosCreateMutexSem
(ICS.Null_Ptr, L.Mutex'Unchecked_Access, 0, False32) /= NO_ERROR
then
raise Storage_Error;
end if;
pragma Assert (L.Mutex /= 0, "Error creating Mutex");
L.Priority := Prio;
L.Owner_ID := Null_Address;
end Initialize_Lock;
procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is
pragma Unreferenced (Level);
begin
if DosCreateMutexSem
(ICS.Null_Ptr, L.Mutex'Unchecked_Access, 0, False32) /= NO_ERROR
then
raise Storage_Error;
end if;
pragma Assert (L.Mutex /= 0, "Error creating Mutex");
L.Priority := System.Any_Priority'Last;
L.Owner_ID := Null_Address;
end Initialize_Lock;
procedure Finalize_Lock (L : access Lock) is
begin
Must_Not_Fail (DosCloseMutexSem (L.Mutex));
end Finalize_Lock;
procedure Finalize_Lock (L : access RTS_Lock) is
begin
Must_Not_Fail (DosCloseMutexSem (L.Mutex));
end Finalize_Lock;
procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
Self_ID : constant Task_Id := Thread_Local_Data_Ptr.Self_ID;
Old_Priority : constant Any_Priority :=
Self_ID.Common.LL.Current_Priority;
begin
if L.Priority < Old_Priority then
Ceiling_Violation := True;
return;
end if;
Ceiling_Violation := False;
Thread_Local_Data_Ptr.Lock_Prio_Level :=
Thread_Local_Data_Ptr.Lock_Prio_Level + 1;
if L.Priority > Old_Priority then
Set_Temporary_Priority (Self_ID, L.Priority);
end if;
Must_Not_Fail (DosRequestMutexSem (L.Mutex, SEM_INDEFINITE_WAIT));
L.Owner_Priority := Old_Priority;
L.Owner_ID := Self_ID.all'Address;
end Write_Lock;
procedure Write_Lock
(L : access RTS_Lock;
Global_Lock : Boolean := False)
is
Self_ID : Task_Id;
Old_Priority : Any_Priority;
begin
if not Single_Lock or else Global_Lock then
Self_ID := Thread_Local_Data_Ptr.Self_ID;
Old_Priority := Self_ID.Common.LL.Current_Priority;
Thread_Local_Data_Ptr.Lock_Prio_Level :=
Thread_Local_Data_Ptr.Lock_Prio_Level + 1;
if L.Priority > Old_Priority then
Set_Temporary_Priority (Self_ID, L.Priority);
end if;
Must_Not_Fail (DosRequestMutexSem (L.Mutex, SEM_INDEFINITE_WAIT));
L.Owner_Priority := Old_Priority;
L.Owner_ID := Self_ID.all'Address;
end if;
end Write_Lock;
procedure Write_Lock (T : Task_Id) is
begin
if not Single_Lock then
Must_Not_Fail
(DosRequestMutexSem (T.Common.LL.L.Mutex, SEM_INDEFINITE_WAIT));
T.Common.LL.L.Owner_ID := Null_Address;
end if;
end Write_Lock;
procedure Read_Lock
(L : access Lock; Ceiling_Violation : out Boolean) renames Write_Lock;
procedure Unlock (L : access Lock) is
Self_ID : constant Task_Id := Thread_Local_Data_Ptr.Self_ID;
Old_Priority : constant Any_Priority := L.Owner_Priority;
begin
pragma Assert (Suppress_Owner_Check
or else L.Owner_ID = Self_ID.all'Address);
L.Owner_ID := Null_Address;
Must_Not_Fail (DosReleaseMutexSem (L.Mutex));
Thread_Local_Data_Ptr.Lock_Prio_Level :=
Thread_Local_Data_Ptr.Lock_Prio_Level - 1;
if L.Priority /= Old_Priority then
Set_Temporary_Priority (Self_ID, Old_Priority);
end if;
end Unlock;
procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
Self_ID : Task_Id;
Old_Priority : Any_Priority;
begin
if not Single_Lock or else Global_Lock then
Self_ID := Thread_Local_Data_Ptr.Self_ID;
Old_Priority := L.Owner_Priority;
pragma Assert (Suppress_Owner_Check
or else L.Owner_ID = Self_ID.all'Address);
L.Owner_ID := Null_Address;
Must_Not_Fail (DosReleaseMutexSem (L.Mutex));
Thread_Local_Data_Ptr.Lock_Prio_Level :=
Thread_Local_Data_Ptr.Lock_Prio_Level - 1;
if L.Priority /= Old_Priority then
Set_Temporary_Priority (Self_ID, Old_Priority);
end if;
end if;
end Unlock;
procedure Unlock (T : Task_Id) is
begin
if not Single_Lock then
pragma Assert (Suppress_Owner_Check
or else T.Common.LL.L.Owner_ID = Null_Address);
Must_Not_Fail (DosReleaseMutexSem (T.Common.LL.L.Mutex));
end if;
end Unlock;
procedure Sleep
(Self_ID : Task_Id;
Reason : System.Tasking.Task_States)
is
pragma Unreferenced (Reason);
Count : aliased ULONG;
begin
Sem_Must_Not_Fail
(DosResetEventSem (Self_ID.Common.LL.CV, Count'Unchecked_Access));
if Single_Lock then
Unlock_RTS;
else
Unlock (Self_ID);
end if;
Sem_Must_Not_Fail
(DosWaitEventSem (Self_ID.Common.LL.CV, SEM_INDEFINITE_WAIT));
if Single_Lock then
Lock_RTS;
else
Write_Lock (Self_ID);
end if;
end Sleep;
procedure Timed_Sleep
(Self_ID : Task_Id;
Time : Duration;
Mode : ST.Delay_Modes;
Reason : System.Tasking.Task_States;
Timedout : out Boolean;
Yielded : out Boolean)
is
pragma Unreferenced (Reason);
Check_Time : constant Duration := OSP.Monotonic_Clock;
Rel_Time : Duration;
Abs_Time : Duration;
Time_Out : ULONG;
Result : APIRET;
Count : aliased ULONG;
begin
Sem_Must_Not_Fail
(DosResetEventSem (Self_ID.Common.LL.CV,
Count'Unchecked_Access));
if Single_Lock then
Unlock_RTS;
else
Unlock (Self_ID);
end if;
Timedout := True;
Yielded := False;
if Mode = Relative then
Rel_Time := Time;
Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time;
else
Rel_Time := Time - Check_Time;
Abs_Time := Time;
end if;
if Rel_Time > 0.0 then
loop
exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
or else Self_ID.Pending_Priority_Change;
Time_Out := To_MS (Rel_Time);
Result := DosWaitEventSem (Self_ID.Common.LL.CV, Time_Out);
pragma Assert
((Result = NO_ERROR or Result = ERROR_TIMEOUT
or Result = ERROR_INTERRUPT));
exit when Abs_Time <= OSP.Monotonic_Clock;
if Result /= ERROR_TIMEOUT then
Timedout := False;
exit;
end if;
Rel_Time := Abs_Time - OSP.Monotonic_Clock;
end loop;
end if;
if Single_Lock then
Lock_RTS;
else
Write_Lock (Self_ID);
end if;
if Timedout then
Sem_Must_Not_Fail (DosPostEventSem (Self_ID.Common.LL.CV));
end if;
end Timed_Sleep;
procedure Timed_Delay
(Self_ID : Task_Id;
Time : Duration;
Mode : ST.Delay_Modes)
is
Check_Time : constant Duration := OSP.Monotonic_Clock;
Rel_Time : Duration;
Abs_Time : Duration;
Timedout : Boolean := True;
Time_Out : ULONG;
Result : APIRET;
Count : aliased ULONG;
begin
SSL.Abort_Defer.all;
if Single_Lock then
Lock_RTS;
else
Write_Lock (Self_ID);
end if;
Sem_Must_Not_Fail
(DosResetEventSem (Self_ID.Common.LL.CV,
Count'Unchecked_Access));
if Single_Lock then
Unlock_RTS;
else
Unlock (Self_ID);
end if;
if Mode = Relative then
Rel_Time := Time;
Abs_Time := Time + Check_Time;
else
Rel_Time := Time - Check_Time;
Abs_Time := Time;
end if;
if Rel_Time > 0.0 then
Self_ID.Common.State := Delay_Sleep;
loop
if Self_ID.Pending_Priority_Change then
Self_ID.Pending_Priority_Change := False;
Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
end if;
exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
Time_Out := To_MS (Rel_Time);
Result := DosWaitEventSem (Self_ID.Common.LL.CV, Time_Out);
exit when Abs_Time <= OSP.Monotonic_Clock;
Rel_Time := Abs_Time - OSP.Monotonic_Clock;
end loop;
Self_ID.Common.State := Runnable;
Timedout := Result = ERROR_TIMEOUT;
end if;
if Single_Lock then
Lock_RTS;
else
Write_Lock (Self_ID);
end if;
if Timedout then
Sem_Must_Not_Fail (DosPostEventSem (Self_ID.Common.LL.CV));
end if;
if Single_Lock then
Unlock_RTS;
else
Unlock (Self_ID);
end if;
System.OS_Interface.Yield;
SSL.Abort_Undefer.all;
end Timed_Delay;
procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
pragma Unreferenced (Reason);
begin
Sem_Must_Not_Fail (DosPostEventSem (T.Common.LL.CV));
end Wakeup;
procedure Yield (Do_Yield : Boolean := True) is
begin
if Do_Yield then
System.OS_Interface.Yield;
end if;
end Yield;
procedure Set_Temporary_Priority
(T : Task_Id;
New_Priority : System.Any_Priority)
is
use Interfaces.C;
Delta_Priority : Integer;
begin
if Thread_Local_Data_Ptr.Lock_Prio_Level = 0
or else New_Priority < T.Common.Current_Priority
then
Delta_Priority := T.Common.Current_Priority -
T.Common.LL.Current_Priority;
else
Delta_Priority := New_Priority - T.Common.LL.Current_Priority;
end if;
if Delta_Priority /= 0 then
T.Common.LL.Current_Priority :=
T.Common.LL.Current_Priority + Delta_Priority;
Must_Not_Fail
(DosSetPriority (Scope => PRTYS_THREAD,
Class => PRTYC_NOCHANGE,
Delta_P => IC.long (Delta_Priority),
PorTid => T.Common.LL.Thread));
end if;
end Set_Temporary_Priority;
procedure Set_Priority
(T : Task_Id;
Prio : System.Any_Priority;
Loss_Of_Inheritance : Boolean := False)
is
pragma Unreferenced (Loss_Of_Inheritance);
begin
T.Common.Current_Priority := Prio;
Set_Temporary_Priority (T, Prio);
end Set_Priority;
function Get_Priority (T : Task_Id) return System.Any_Priority is
begin
return T.Common.Current_Priority;
end Get_Priority;
procedure Enter_Task (Self_ID : Task_Id) is
begin
Thread_Local_Data_Ptr.Self_ID := Self_ID;
Thread_Local_Data_Ptr.Lock_Prio_Level := 0;
Lock_RTS;
for J in Known_Tasks'Range loop
if Known_Tasks (J) = null then
Known_Tasks (J) := Self_ID;
Self_ID.Known_Tasks_Index := J;
exit;
end if;
end loop;
Unlock_RTS;
end Enter_Task;
function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is
begin
return new Ada_Task_Control_Block (Entry_Num);
end New_ATCB;
function Is_Valid_Task return Boolean is
begin
return False;
end Is_Valid_Task;
function Register_Foreign_Thread return Task_Id is
begin
return null;
end Register_Foreign_Thread;
procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
begin
if DosCreateEventSem (ICS.Null_Ptr,
Self_ID.Common.LL.CV'Unchecked_Access, 0, True32) = NO_ERROR
then
if not Single_Lock
and then DosCreateMutexSem
(ICS.Null_Ptr,
Self_ID.Common.LL.L.Mutex'Unchecked_Access,
0,
False32) /= NO_ERROR
then
Succeeded := False;
Must_Not_Fail (DosCloseEventSem (Self_ID.Common.LL.CV));
else
Succeeded := True;
end if;
Self_ID.Common.LL.L.Priority := System.Any_Priority'Last;
Self_ID.Common.LL.L.Owner_ID := Null_Address;
else
Succeeded := False;
end if;
end Initialize_TCB;
procedure Create_Task
(T : Task_Id;
Wrapper : System.Address;
Stack_Size : System.Parameters.Size_Type;
Priority : System.Any_Priority;
Succeeded : out Boolean)
is
Result : aliased APIRET;
Adjusted_Stack_Size : System.Parameters.Size_Type;
use System.Parameters;
begin
if Stack_Size = Unspecified_Size then
Adjusted_Stack_Size := Default_Stack_Size;
elsif Stack_Size < Minimum_Stack_Size then
Adjusted_Stack_Size := Minimum_Stack_Size;
else
Adjusted_Stack_Size := Stack_Size;
end if;
T.Common.LL.Wrapper := To_PFNTHREAD (Wrapper);
T.Common.LL.Current_Priority := Self.Common.LL.Current_Priority;
if T.Common.LL.L.Owner_Priority not in Any_Priority'Range then
T.Common.LL.L.Owner_Priority := 1;
end if;
Result := DosCreateThread
(F_ptid => T.Common.LL.Thread'Unchecked_Access,
pfn => T.Common.LL.Wrapper,
param => To_Address (T),
flag => Block_Child + Commit_Stack,
cbStack => ULONG (Adjusted_Stack_Size));
Succeeded := (Result = NO_ERROR);
if not Succeeded then
return;
end if;
Set_Priority (T, Priority);
Must_Not_Fail (DosResumeThread (T.Common.LL.Thread));
end Create_Task;
procedure Finalize_TCB (T : Task_Id) is
Tmp : Task_Id := T;
procedure Free is new
Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
begin
Must_Not_Fail (DosCloseEventSem (T.Common.LL.CV));
if not Single_Lock then
Finalize_Lock (T.Common.LL.L'Unchecked_Access);
end if;
if T.Known_Tasks_Index /= -1 then
Known_Tasks (T.Known_Tasks_Index) := null;
end if;
Free (Tmp);
end Finalize_TCB;
procedure Exit_Task is
begin
Thread_Local_Data_Ptr := null;
end Exit_Task;
procedure Abort_Task (T : Task_Id) is
pragma Unreferenced (T);
begin
null;
end Abort_Task;
function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
begin
return Check_No_Locks (Self_ID);
end Check_Exit;
function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
TLD : constant Access_Thread_Local_Data := Thread_Local_Data_Ptr;
begin
return Self_ID = TLD.Self_ID
and then TLD.Lock_Prio_Level = 0;
end Check_No_Locks;
function Environment_Task return Task_Id is
begin
return Environment_Task_Id;
end Environment_Task;
procedure Lock_RTS is
begin
Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
end Lock_RTS;
procedure Unlock_RTS is
begin
Unlock (Single_RTS_Lock'Access, Global_Lock => True);
end Unlock_RTS;
function Suspend_Task
(T : ST.Task_Id;
Thread_Self : Thread_Id) return Boolean
is
begin
if Thread_Id (T.Common.LL.Thread) /= Thread_Self then
return DosSuspendThread (T.Common.LL.Thread) = NO_ERROR;
else
return True;
end if;
end Suspend_Task;
function Resume_Task
(T : ST.Task_Id;
Thread_Self : Thread_Id) return Boolean
is
begin
if Thread_Id (T.Common.LL.Thread) /= Thread_Self then
return DosResumeThread (T.Common.LL.Thread) = NO_ERROR;
else
return True;
end if;
end Resume_Task;
procedure Initialize (Environment_Task : Task_Id) is
Succeeded : Boolean;
begin
Environment_Task_Id := Environment_Task;
Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
Thread_Local_Data_Ptr.Self_ID := Environment_Task;
Environment_Task.Common.LL.Thread := 1;
Environment_Task.Common.LL.Current_Priority :=
Environment_Task.Common.Current_Priority;
Initialize_TCB (Environment_Task, Succeeded);
pragma Assert (Succeeded);
Enter_Task (Environment_Task);
end Initialize;
begin
Must_Not_Fail (DosAllocThreadLocalMemory
((Thread_Local_Data'Size + 31) / 32, To_PPVOID (Thread_Local_Data_Ptr'Access)));
Thread_Local_Data_Ptr.Self_ID := null;
Thread_Local_Data_Ptr.Lock_Prio_Level := 0;
end System.Task_Primitives.Operations;