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.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;
type Microseconds is new IC.long;
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;
All_Tasks_L : aliased System.Task_Primitives.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
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
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) is
Self_ID : constant Task_ID := Thread_Local_Data_Ptr.Self_ID;
Old_Priority : constant Any_Priority :=
Self_ID.Common.LL.Current_Priority;
begin
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 (T : Task_ID) is
begin
Must_Not_Fail
(DosRequestMutexSem (T.Common.LL.L.Mutex, SEM_INDEFINITE_WAIT));
T.Common.LL.L.Owner_ID := Null_Address;
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) 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 (T : Task_ID) is
begin
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 Unlock;
procedure Sleep (Self_ID : Task_ID;
Reason : System.Tasking.Task_States) is
Count : aliased ULONG;
begin
Sem_Must_Not_Fail
(DosResetEventSem (Self_ID.Common.LL.CV, Count'Unchecked_Access));
Unlock (Self_ID);
Sem_Must_Not_Fail
(DosWaitEventSem (Self_ID.Common.LL.CV, SEM_INDEFINITE_WAIT));
Write_Lock (Self_ID);
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
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));
Unlock (Self_ID);
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;
Write_Lock (Self_ID);
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;
Write_Lock (Self_ID);
Sem_Must_Not_Fail
(DosResetEventSem (Self_ID.Common.LL.CV,
Count'Unchecked_Access));
Unlock (Self_ID);
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;
Write_Lock (Self_ID);
if Timedout then
Sem_Must_Not_Fail (DosPostEventSem (Self_ID.Common.LL.CV));
end if;
Unlock (Self_ID);
System.OS_Interface.Yield;
SSL.Abort_Undefer.all;
end Timed_Delay;
procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is
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
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_All_Tasks_List;
for I in Known_Tasks'Range loop
if Known_Tasks (I) = null then
Known_Tasks (I) := Self_ID;
Self_ID.Known_Tasks_Index := I;
exit;
end if;
end loop;
Unlock_All_Tasks_List;
null;
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;
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 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;
pragma Assert (Self_ID.Common.LL.L.Mutex /= 0);
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));
Finalize_Lock (T.Common.LL.L'Unchecked_Access);
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
DosExit (EXIT_THREAD, 0);
end Exit_Task;
procedure Abort_Task (T : Task_ID) is
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_All_Tasks_List is
begin
Write_Lock (All_Tasks_L'Access);
end Lock_All_Tasks_List;
procedure Unlock_All_Tasks_List is
begin
Unlock (All_Tasks_L'Access);
end Unlock_All_Tasks_List;
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 (All_Tasks_L'Access, All_Tasks_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;