diff options
Diffstat (limited to 'gcc/ada/5wtaprop.adb')
| -rw-r--r-- | gcc/ada/5wtaprop.adb | 1113 |
1 files changed, 1113 insertions, 0 deletions
diff --git a/gcc/ada/5wtaprop.adb b/gcc/ada/5wtaprop.adb new file mode 100644 index 00000000000..850ddb696b8 --- /dev/null +++ b/gcc/ada/5wtaprop.adb @@ -0,0 +1,1113 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- 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 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.66 $ +-- -- +-- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. It is -- +-- now maintained by Ada Core Technologies Inc. in cooperation with Florida -- +-- State University (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This is a NT (native) version of this package. + +-- This package contains all the GNULL primitives that interface directly +-- with the underlying OS. + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during +-- tasking operations. It causes infinite loops and other problems. + +with System.Tasking.Debug; +-- used for Known_Tasks + +with Interfaces.C; +-- used for int +-- size_t + +with Interfaces.C.Strings; +-- used for Null_Ptr + +with System.OS_Interface; +-- used for various type, constant, and operations + +with System.Parameters; +-- used for Size_Type + +with System.Tasking; +-- used for Ada_Task_Control_Block +-- Task_ID + +with System.Soft_Links; +-- used for Defer/Undefer_Abort +-- to initialize TSD for a C thread, in function Self + +-- Note that we do not use System.Tasking.Initialization directly since +-- this is a higher level package that we shouldn't depend on. For example +-- when using the restricted run time, it is replaced by +-- System.Tasking.Restricted.Initialization + +with System.OS_Primitives; +-- used for Delay_Modes + +with System.Task_Info; +-- used for Unspecified_Task_Info + +with Unchecked_Conversion; +with Unchecked_Deallocation; + +package body System.Task_Primitives.Operations is + + use System.Tasking.Debug; + use System.Tasking; + use Interfaces.C; + use Interfaces.C.Strings; + use System.OS_Interface; + use System.Parameters; + use System.OS_Primitives; + + pragma Linker_Options ("-Xlinker --stack=0x800000,0x1000"); + + package SSL renames System.Soft_Links; + + ------------------ + -- Local Data -- + ------------------ + + Environment_Task_ID : Task_ID; + -- A variable to hold Task_ID for the environment task. + + All_Tasks_L : aliased System.Task_Primitives.RTS_Lock; + -- See comments on locking rules in System.Tasking (spec). + + Time_Slice_Val : Integer; + pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); + + Dispatching_Policy : Character; + pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); + + FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F'; + -- Indicates whether FIFO_Within_Priorities is set. + + --------------------------------- + -- Foreign Threads Detection -- + --------------------------------- + + -- The following are used to allow the Self function to + -- automatically generate ATCB's for C threads that happen to call + -- Ada procedure, which in turn happen to call the Ada run-time system. + + type Fake_ATCB; + type Fake_ATCB_Ptr is access Fake_ATCB; + type Fake_ATCB is record + Stack_Base : Interfaces.C.unsigned := 0; + -- A value of zero indicates the node is not in use. + Next : Fake_ATCB_Ptr; + Real_ATCB : aliased Ada_Task_Control_Block (0); + end record; + + Fake_ATCB_List : Fake_ATCB_Ptr; + -- A linear linked list. + -- The list is protected by All_Tasks_L; + -- Nodes are added to this list from the front. + -- Once a node is added to this list, it is never removed. + + Fake_Task_Elaborated : aliased Boolean := True; + -- Used to identified fake tasks (i.e., non-Ada Threads). + + Next_Fake_ATCB : Fake_ATCB_Ptr; + -- Used to allocate one Fake_ATCB in advance. See comment in New_Fake_ATCB + + --------------------------------- + -- Support for New_Fake_ATCB -- + --------------------------------- + + function New_Fake_ATCB return Task_ID; + -- Allocate and Initialize a new ATCB. This code can safely be called from + -- a foreign thread, as it doesn't access implicitely or explicitely + -- "self" before having initialized the new ATCB. + + ------------------------------------ + -- The thread local storage index -- + ------------------------------------ + + TlsIndex : DWORD; + pragma Export (Ada, TlsIndex); + -- To ensure that this variable won't be local to this package, since + -- in some cases, inlining forces this variable to be global anyway. + + ---------------------------------- + -- Utility Conversion Functions -- + ---------------------------------- + + function To_Task_Id is new Unchecked_Conversion (System.Address, Task_ID); + + function To_Address is new Unchecked_Conversion (Task_ID, System.Address); + + ------------------- + -- New_Fake_ATCB -- + ------------------- + + function New_Fake_ATCB return Task_ID is + Self_ID : Task_ID; + P, Q : Fake_ATCB_Ptr; + Succeeded : Boolean; + Res : BOOL; + + begin + -- This section is ticklish. + -- We dare not call anything that might require an ATCB, until + -- we have the new ATCB in place. + + Write_Lock (All_Tasks_L'Access); + Q := null; + P := Fake_ATCB_List; + + while P /= null loop + if P.Stack_Base = 0 then + Q := P; + end if; + + P := P.Next; + end loop; + + if Q = null then + + -- Create a new ATCB with zero entries. + + Self_ID := Next_Fake_ATCB.Real_ATCB'Access; + Next_Fake_ATCB.Stack_Base := 1; + Next_Fake_ATCB.Next := Fake_ATCB_List; + Fake_ATCB_List := Next_Fake_ATCB; + Next_Fake_ATCB := null; + + else + -- Reuse an existing fake ATCB. + + Self_ID := Q.Real_ATCB'Access; + Q.Stack_Base := 1; + end if; + + -- Record this as the Task_ID for the current thread. + + Self_ID.Common.LL.Thread := GetCurrentThread; + + Res := TlsSetValue (TlsIndex, To_Address (Self_ID)); + pragma Assert (Res = True); + + -- Do the standard initializations + + System.Tasking.Initialize_ATCB + (Self_ID, null, Null_Address, Null_Task, Fake_Task_Elaborated'Access, + System.Priority'First, Task_Info.Unspecified_Task_Info, 0, Self_ID, + Succeeded); + pragma Assert (Succeeded); + + -- Finally, it is safe to use an allocator in this thread. + + if Next_Fake_ATCB = null then + Next_Fake_ATCB := new Fake_ATCB; + end if; + + Self_ID.Master_of_Task := 0; + Self_ID.Master_Within := Self_ID.Master_of_Task + 1; + + for L in Self_ID.Entry_Calls'Range loop + Self_ID.Entry_Calls (L).Self := Self_ID; + Self_ID.Entry_Calls (L).Level := L; + end loop; + + Self_ID.Common.State := Runnable; + Self_ID.Awake_Count := 1; + + -- Since this is not an ordinary Ada task, we will start out undeferred + + Self_ID.Deferral_Level := 0; + + System.Soft_Links.Create_TSD (Self_ID.Common.Compiler_Data); + + -- ???? + -- The following call is commented out to avoid dependence on + -- the System.Tasking.Initialization package. + -- It seems that if we want Ada.Task_Attributes to work correctly + -- for C threads we will need to raise the visibility of this soft + -- link to System.Soft_Links. + -- We are putting that off until this new functionality is otherwise + -- stable. + -- System.Tasking.Initialization.Initialize_Attributes_Link.all (T); + + -- Must not unlock until Next_ATCB is again allocated. + + Unlock (All_Tasks_L'Access); + return Self_ID; + end New_Fake_ATCB; + + ---------------------------------- + -- Condition Variable Functions -- + ---------------------------------- + + procedure Initialize_Cond (Cond : access Condition_Variable); + -- Initialize given condition variable Cond + + procedure Finalize_Cond (Cond : access Condition_Variable); + -- Finalize given condition variable Cond. + + procedure Cond_Signal (Cond : access Condition_Variable); + -- Signal condition variable Cond + + procedure Cond_Wait + (Cond : access Condition_Variable; + L : access RTS_Lock); + -- Wait on conditional variable Cond, using lock L + + procedure Cond_Timed_Wait + (Cond : access Condition_Variable; + L : access RTS_Lock; + Rel_Time : Duration; + Timed_Out : out Boolean; + Status : out Integer); + -- Do timed wait on condition variable Cond using lock L. The duration + -- of the timed wait is given by Rel_Time. When the condition is + -- signalled, Timed_Out shows whether or not a time out occurred. + -- Status shows whether Cond_Timed_Wait completed successfully. + + --------------------- + -- Initialize_Cond -- + --------------------- + + procedure Initialize_Cond (Cond : access Condition_Variable) is + hEvent : HANDLE; + + begin + hEvent := CreateEvent (null, True, False, Null_Ptr); + pragma Assert (hEvent /= 0); + Cond.all := Condition_Variable (hEvent); + end Initialize_Cond; + + ------------------- + -- Finalize_Cond -- + ------------------- + + -- No such problem here, DosCloseEventSem has been derived. + -- What does such refer to in above comment??? + + procedure Finalize_Cond (Cond : access Condition_Variable) is + Result : BOOL; + + begin + Result := CloseHandle (HANDLE (Cond.all)); + pragma Assert (Result = True); + end Finalize_Cond; + + ----------------- + -- Cond_Signal -- + ----------------- + + procedure Cond_Signal (Cond : access Condition_Variable) is + Result : BOOL; + + begin + Result := SetEvent (HANDLE (Cond.all)); + pragma Assert (Result = True); + end Cond_Signal; + + --------------- + -- Cond_Wait -- + --------------- + + -- Pre-assertion: Cond is posted + -- L is locked. + + -- Post-assertion: Cond is posted + -- L is locked. + + procedure Cond_Wait + (Cond : access Condition_Variable; + L : access RTS_Lock) + is + Result : DWORD; + Result_Bool : BOOL; + + begin + -- Must reset Cond BEFORE L is unlocked. + + Result_Bool := ResetEvent (HANDLE (Cond.all)); + pragma Assert (Result_Bool = True); + Unlock (L); + + -- No problem if we are interrupted here: if the condition is signaled, + -- WaitForSingleObject will simply not block + + Result := WaitForSingleObject (HANDLE (Cond.all), Wait_Infinite); + pragma Assert (Result = 0); + + Write_Lock (L); + end Cond_Wait; + + --------------------- + -- Cond_Timed_Wait -- + --------------------- + + -- Pre-assertion: Cond is posted + -- L is locked. + + -- Post-assertion: Cond is posted + -- L is locked. + + procedure Cond_Timed_Wait + (Cond : access Condition_Variable; + L : access RTS_Lock; + Rel_Time : Duration; + Timed_Out : out Boolean; + Status : out Integer) + is + Time_Out : DWORD; + Result : BOOL; + + Int_Rel_Time : DWORD; + Wait_Result : DWORD; + + begin + -- Must reset Cond BEFORE L is unlocked. + + Result := ResetEvent (HANDLE (Cond.all)); + pragma Assert (Result = True); + Unlock (L); + + -- No problem if we are interrupted here: if the condition is signaled, + -- WaitForSingleObject will simply not block + + if Rel_Time <= 0.0 then + Timed_Out := True; + else + Int_Rel_Time := DWORD (Rel_Time); + Time_Out := Int_Rel_Time * 1000 + + DWORD ((Rel_Time - Duration (Int_Rel_Time)) * 1000.0); + Wait_Result := WaitForSingleObject (HANDLE (Cond.all), Time_Out); + + if Wait_Result = WAIT_TIMEOUT then + Timed_Out := True; + Wait_Result := 0; + else + Timed_Out := False; + end if; + end if; + + Write_Lock (L); + + -- Ensure post-condition + + if Timed_Out then + Result := SetEvent (HANDLE (Cond.all)); + pragma Assert (Result = True); + end if; + + Status := Integer (Wait_Result); + end Cond_Timed_Wait; + + ------------------ + -- Stack_Guard -- + ------------------ + + -- The underlying thread system sets a guard page at the + -- bottom of a thread stack, so nothing is needed. + -- ??? Check the comment above + + procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is + begin + null; + end Stack_Guard; + + -------------------- + -- Get_Thread_Id -- + -------------------- + + function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is + begin + return T.Common.LL.Thread; + end Get_Thread_Id; + + ---------- + -- Self -- + ---------- + + function Self return Task_ID is + Self_Id : Task_ID; + + begin + Self_Id := To_Task_Id (TlsGetValue (TlsIndex)); + + if Self_Id = null then + return New_Fake_ATCB; + end if; + + return Self_Id; + end Self; + + --------------------- + -- Initialize_Lock -- + --------------------- + + -- Note: mutexes and cond_variables needed per-task basis are + -- initialized in Intialize_TCB and the Storage_Error is handled. + -- Other mutexes (such as All_Tasks_Lock, Memory_Lock...) used in + -- the RTS is initialized before any status change of RTS. + -- Therefore raising Storage_Error in the following routines + -- should be able to be handled safely. + + procedure Initialize_Lock + (Prio : System.Any_Priority; + L : access Lock) is + begin + InitializeCriticalSection (L.Mutex'Access); + L.Owner_Priority := 0; + L.Priority := Prio; + end Initialize_Lock; + + procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is + begin + InitializeCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access); + end Initialize_Lock; + + ------------------- + -- Finalize_Lock -- + ------------------- + + procedure Finalize_Lock (L : access Lock) is + begin + DeleteCriticalSection (L.Mutex'Access); + end Finalize_Lock; + + procedure Finalize_Lock (L : access RTS_Lock) is + begin + DeleteCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access); + end Finalize_Lock; + + ---------------- + -- Write_Lock -- + ---------------- + + procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is + begin + L.Owner_Priority := Get_Priority (Self); + + if L.Priority < L.Owner_Priority then + Ceiling_Violation := True; + return; + end if; + + EnterCriticalSection (L.Mutex'Access); + + Ceiling_Violation := False; + end Write_Lock; + + procedure Write_Lock (L : access RTS_Lock) is + begin + EnterCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access); + end Write_Lock; + + procedure Write_Lock (T : Task_ID) is + begin + EnterCriticalSection + (CRITICAL_SECTION (T.Common.LL.L)'Unrestricted_Access); + end Write_Lock; + + --------------- + -- Read_Lock -- + --------------- + + procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is + begin + Write_Lock (L, Ceiling_Violation); + end Read_Lock; + + ------------ + -- Unlock -- + ------------ + + procedure Unlock (L : access Lock) is + begin + LeaveCriticalSection (L.Mutex'Access); + end Unlock; + + procedure Unlock (L : access RTS_Lock) is + begin + LeaveCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access); + end Unlock; + + procedure Unlock (T : Task_ID) is + begin + LeaveCriticalSection + (CRITICAL_SECTION (T.Common.LL.L)'Unrestricted_Access); + end Unlock; + + ----------- + -- Sleep -- + ----------- + + procedure Sleep + (Self_ID : Task_ID; + Reason : System.Tasking.Task_States) is + begin + pragma Assert (Self_ID = Self); + + Cond_Wait (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); + + if Self_ID.Deferral_Level = 0 + and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level + then + Unlock (Self_ID); + raise Standard'Abort_Signal; + end if; + end Sleep; + + ----------------- + -- Timed_Sleep -- + ----------------- + + -- This is for use within the run-time system, so abort is + -- assumed to be already deferred, and the caller should be + -- holding its own ATCB lock. + + 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 := Monotonic_Clock; + Rel_Time : Duration; + Abs_Time : Duration; + Result : Integer; + + Local_Timedout : Boolean; + + begin + 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; + + Cond_Timed_Wait (Self_ID.Common.LL.CV'Access, + Self_ID.Common.LL.L'Access, Rel_Time, Local_Timedout, Result); + + exit when Abs_Time <= Monotonic_Clock; + + if not Local_Timedout then + -- somebody may have called Wakeup for us + Timedout := False; + exit; + end if; + + Rel_Time := Abs_Time - Monotonic_Clock; + end loop; + end if; + end Timed_Sleep; + + ----------------- + -- Timed_Delay -- + ----------------- + + procedure Timed_Delay + (Self_ID : Task_ID; + Time : Duration; + Mode : ST.Delay_Modes) + is + Check_Time : constant Duration := Monotonic_Clock; + Rel_Time : Duration; + Abs_Time : Duration; + Result : Integer; + Timedout : Boolean; + + begin + -- Only the little window between deferring abort and + -- locking Self_ID is the reason we need to + -- check for pending abort and priority change below! :( + + SSL.Abort_Defer.all; + Write_Lock (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; + + Cond_Timed_Wait (Self_ID.Common.LL.CV'Access, + Self_ID.Common.LL.L'Access, Rel_Time, Timedout, Result); + + exit when Abs_Time <= Monotonic_Clock; + + Rel_Time := Abs_Time - Monotonic_Clock; + end loop; + + Self_ID.Common.State := Runnable; + end if; + + Unlock (Self_ID); + Yield; + SSL.Abort_Undefer.all; + end Timed_Delay; + + ------------ + -- Wakeup -- + ------------ + + procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is + begin + Cond_Signal (T.Common.LL.CV'Access); + end Wakeup; + + ----------- + -- Yield -- + ----------- + + procedure Yield (Do_Yield : Boolean := True) is + begin + if Do_Yield then + Sleep (0); + end if; + end Yield; + + ------------------ + -- Set_Priority -- + ------------------ + + type Prio_Array_Type is array (System.Any_Priority) of Integer; + pragma Atomic_Components (Prio_Array_Type); + + Prio_Array : Prio_Array_Type; + -- Global array containing the id of the currently running task for + -- each priority. + -- + -- Note: we assume that we are on a single processor with run-til-blocked + -- scheduling. + + procedure Set_Priority + (T : Task_ID; + Prio : System.Any_Priority; + Loss_Of_Inheritance : Boolean := False) + is + Res : BOOL; + Array_Item : Integer; + + begin + Res := SetThreadPriority + (T.Common.LL.Thread, Interfaces.C.int (Underlying_Priorities (Prio))); + pragma Assert (Res = True); + + -- ??? Work around a bug in NT 4.0 SP3 scheduler + -- It looks like when a task with Thread_Priority_Idle (using RT class) + -- never reaches its time slice (e.g by doing multiple and simple RV, + -- see CXD8002), the scheduler never gives higher priority task a + -- chance to run. + -- Note that this works fine on NT 4.0 SP1 + + if Time_Slice_Val = 0 + and then Underlying_Priorities (Prio) = Thread_Priority_Idle + and then Loss_Of_Inheritance + then + Sleep (20); + end if; + + if FIFO_Within_Priorities then + + -- Annex D requirement [RM D.2.2 par. 9]: + -- If the task drops its priority due to the loss of inherited + -- priority, it is added at the head of the ready queue for its + -- new active priority. + + if Loss_Of_Inheritance + and then Prio < T.Common.Current_Priority + then + Array_Item := Prio_Array (T.Common.Base_Priority) + 1; + Prio_Array (T.Common.Base_Priority) := Array_Item; + + loop + -- Let some processes a chance to arrive + + Yield; + + -- Then wait for our turn to proceed + + exit when Array_Item = Prio_Array (T.Common.Base_Priority) + or else Prio_Array (T.Common.Base_Priority) = 1; + end loop; + + Prio_Array (T.Common.Base_Priority) := + Prio_Array (T.Common.Base_Priority) - 1; + end if; + end if; + + T.Common.Current_Priority := Prio; + end Set_Priority; + + ------------------ + -- Get_Priority -- + ------------------ + + function Get_Priority (T : Task_ID) return System.Any_Priority is + begin + return T.Common.Current_Priority; + end Get_Priority; + + ---------------- + -- Enter_Task -- + ---------------- + + -- There were two paths were we needed to call Enter_Task : + -- 1) from System.Task_Primitives.Operations.Initialize + -- 2) from System.Tasking.Stages.Task_Wrapper + -- + -- The thread initialisation has to be done only for the first case. + -- + -- This is because the GetCurrentThread NT call does not return the + -- real thread handler but only a "pseudo" one. It is not possible to + -- release the thread handle and free the system ressources from this + -- "pseudo" handle. So we really want to keep the real thread handle + -- set in System.Task_Primitives.Operations.Create_Task during the + -- thread creation. + + procedure Enter_Task (Self_ID : Task_ID) is + procedure Init_Float; + pragma Import (C, Init_Float, "__gnat_init_float"); + -- Properly initializes the FPU for x86 systems. + + Succeeded : BOOL; + + begin + Succeeded := TlsSetValue (TlsIndex, To_Address (Self_ID)); + pragma Assert (Succeeded = True); + Init_Float; + + Self_ID.Common.LL.Thread_Id := GetCurrentThreadId; + + Lock_All_Tasks_List; + + 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_All_Tasks_List; + end Enter_Task; + + -------------- + -- New_ATCB -- + -------------- + + function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is + begin + return new Ada_Task_Control_Block (Entry_Num); + end New_ATCB; + + ---------------------- + -- Initialize_TCB -- + ---------------------- + + procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is + begin + Initialize_Cond (Self_ID.Common.LL.CV'Access); + Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level); + Succeeded := True; + end Initialize_TCB; + + ----------------- + -- Create_Task -- + ----------------- + + procedure Create_Task + (T : Task_ID; + Wrapper : System.Address; + Stack_Size : System.Parameters.Size_Type; + Priority : System.Any_Priority; + Succeeded : out Boolean) + is + hTask : HANDLE; + TaskId : aliased DWORD; + + -- ??? The fact that we can't use PVOID because the compiler + -- gives a "PVOID is not visible" error is a GNAT bug. + -- The strange thing is that the file compiles fine during a regular + -- build. + + pTaskParameter : System.OS_Interface.PVOID; + dwStackSize : DWORD; + Result : DWORD; + Entry_Point : PTHREAD_START_ROUTINE; + + function To_PTHREAD_START_ROUTINE is new + Unchecked_Conversion (System.Address, PTHREAD_START_ROUTINE); + + begin + pTaskParameter := To_Address (T); + + if Stack_Size = Unspecified_Size then + dwStackSize := DWORD (Default_Stack_Size); + + elsif Stack_Size < Minimum_Stack_Size then + dwStackSize := DWORD (Minimum_Stack_Size); + + else + dwStackSize := DWORD (Stack_Size); + end if; + + Entry_Point := To_PTHREAD_START_ROUTINE (Wrapper); + + hTask := CreateThread + (null, + dwStackSize, + Entry_Point, + pTaskParameter, + DWORD (Create_Suspended), + TaskId'Unchecked_Access); + + -- Step 1: Create the thread in blocked mode + + if hTask = 0 then + raise Storage_Error; + end if; + + -- Step 2: set its TCB + + T.Common.LL.Thread := hTask; + + -- Step 3: set its priority (child has inherited priority from parent) + + Set_Priority (T, Priority); + + -- Step 4: Now, start it for good: + + Result := ResumeThread (hTask); + pragma Assert (Result = 1); + + Succeeded := Result = 1; + end Create_Task; + + ------------------ + -- Finalize_TCB -- + ------------------ + + procedure Finalize_TCB (T : Task_ID) is + Self_ID : Task_ID := T; + Result : DWORD; + Succeeded : BOOL; + + procedure Free is new + Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID); + + begin + Finalize_Lock (T.Common.LL.L'Access); + Finalize_Cond (T.Common.LL.CV'Access); + + if T.Known_Tasks_Index /= -1 then + Known_Tasks (T.Known_Tasks_Index) := null; + end if; + + -- Wait for the thread to terminate then close it. this is needed + -- to release system ressources. + + Result := WaitForSingleObject (T.Common.LL.Thread, Wait_Infinite); + pragma Assert (Result /= WAIT_FAILED); + Succeeded := CloseHandle (T.Common.LL.Thread); + pragma Assert (Succeeded = True); + + Free (Self_ID); + end Finalize_TCB; + + --------------- + -- Exit_Task -- + --------------- + + procedure Exit_Task is + begin + ExitThread (0); + end Exit_Task; + + ---------------- + -- Abort_Task -- + ---------------- + + procedure Abort_Task (T : Task_ID) is + begin + null; + end Abort_Task; + + ---------------------- + -- Environment_Task -- + ---------------------- + + function Environment_Task return Task_ID is + begin + return Environment_Task_ID; + end Environment_Task; + + ------------------------- + -- Lock_All_Tasks_List -- + ------------------------- + + procedure Lock_All_Tasks_List is + begin + Write_Lock (All_Tasks_L'Access); + end Lock_All_Tasks_List; + + --------------------------- + -- Unlock_All_Tasks_List -- + --------------------------- + + procedure Unlock_All_Tasks_List is + begin + Unlock (All_Tasks_L'Access); + end Unlock_All_Tasks_List; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Environment_Task : Task_ID) is + Res : BOOL; + begin + Environment_Task_ID := Environment_Task; + + if Time_Slice_Val = 0 or else FIFO_Within_Priorities then + Res := OS_Interface.SetPriorityClass + (GetCurrentProcess, Realtime_Priority_Class); + end if; + + TlsIndex := TlsAlloc; + + -- Initialize the lock used to synchronize chain of all ATCBs. + + Initialize_Lock (All_Tasks_L'Access, All_Tasks_Level); + + Environment_Task.Common.LL.Thread := GetCurrentThread; + Enter_Task (Environment_Task); + + -- Create a free ATCB for use on the Fake_ATCB_List + + Next_Fake_ATCB := new Fake_ATCB; + end Initialize; + + --------------------- + -- Monotonic_Clock -- + --------------------- + + function Monotonic_Clock return Duration + renames System.OS_Primitives.Monotonic_Clock; + + ------------------- + -- RT_Resolution -- + ------------------- + + function RT_Resolution return Duration is + begin + return 0.000_001; -- 1 micro-second + end RT_Resolution; + + ---------------- + -- Check_Exit -- + ---------------- + + -- Dummy versions. The only currently working versions is for solaris + -- (native). + + function Check_Exit (Self_ID : ST.Task_ID) return Boolean is + begin + return True; + end Check_Exit; + + -------------------- + -- Check_No_Locks -- + -------------------- + + function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is + begin + return True; + end Check_No_Locks; + + ------------------ + -- Suspend_Task -- + ------------------ + + function Suspend_Task + (T : ST.Task_ID; + Thread_Self : Thread_Id) return Boolean is + begin + if T.Common.LL.Thread /= Thread_Self then + return SuspendThread (T.Common.LL.Thread) = NO_ERROR; + else + return True; + end if; + end Suspend_Task; + + ----------------- + -- Resume_Task -- + ----------------- + + function Resume_Task + (T : ST.Task_ID; + Thread_Self : Thread_Id) return Boolean is + begin + if T.Common.LL.Thread /= Thread_Self then + return ResumeThread (T.Common.LL.Thread) = NO_ERROR; + else + return True; + end if; + end Resume_Task; + +end System.Task_Primitives.Operations; |