2017-09-11 Jerome Lambourg <lambourg@adacore.com>

[thirdparty/gcc.git] / gcc / ada / libgnarl / s-osinte__mingw.ads

------------------------------------------------------------------------------
--                                                                          --
--                 GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS                 --
--                                                                          --
--                   S Y S T E M . O S _ I N T E R F A C E                  --
--                                                                          --
--                                  S p e c                                 --
--                                                                          --
--             Copyright (C) 1991-2017, Florida State University            --
--          Copyright (C) 1995-2017, Free Software Foundation, Inc.         --
--                                                                          --
-- GNAT 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 3,  or (at your option) any later ver- --
-- sion.  GNAT 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.                                     --
--                                                                          --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception,   --
-- version 3.1, as published by the Free Software Foundation.               --
--                                                                          --
-- You should have received a copy of the GNU General Public License and    --
-- a copy of the GCC Runtime Library Exception along with this program;     --
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
-- <http://www.gnu.org/licenses/>.                                          --
--                                                                          --
-- GNARL was developed by the GNARL team at Florida State University.       --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

--  This is a NT (native) version of this package

--  This package encapsulates all direct interfaces to OS services
--  that are needed by the tasking run-time (libgnarl). For non tasking
--  oriented services consider declaring them into system-win32.

--  PLEASE DO NOT add any with-clauses to this package or remove the pragma
--  Preelaborate. This package is designed to be a bottom-level (leaf) package.

with Ada.Unchecked_Conversion;

with Interfaces.C;
with Interfaces.C.Strings;
with System.Win32;

package System.OS_Interface is
   pragma Preelaborate;

   pragma Linker_Options ("-mthreads");

   subtype int  is Interfaces.C.int;
   subtype long is Interfaces.C.long;

   subtype LARGE_INTEGER is System.Win32.LARGE_INTEGER;

   -------------------
   -- General Types --
   -------------------

   subtype PSZ   is Interfaces.C.Strings.chars_ptr;

   Null_Void : constant Win32.PVOID := System.Null_Address;

   -------------------------
   -- Handles for objects --
   -------------------------

   subtype Thread_Id is Win32.HANDLE;

   -----------
   -- Errno --
   -----------

   NO_ERROR : constant := 0;
   FUNC_ERR : constant := -1;

   -------------
   -- Signals --
   -------------

   Max_Interrupt : constant := 31;
   type Signal is new int range 0 .. Max_Interrupt;
   for Signal'Size use int'Size;

   SIGINT     : constant := 2; --  interrupt (Ctrl-C)
   SIGILL     : constant := 4; --  illegal instruction (not reset)
   SIGFPE     : constant := 8; --  floating point exception
   SIGSEGV    : constant := 11; -- segmentation violation
   SIGTERM    : constant := 15; -- software termination signal from kill
   SIGBREAK   : constant := 21; -- break (Ctrl-Break)
   SIGABRT    : constant := 22; -- used by abort, replace SIGIOT in the future

   type sigset_t is private;

   type isr_address is access procedure (sig : int);
   pragma Convention (C, isr_address);

   function intr_attach (sig : int; handler : isr_address) return long;
   pragma Import (C, intr_attach, "signal");

   Intr_Attach_Reset : constant Boolean := True;
   --  True if intr_attach is reset after an interrupt handler is called

   procedure kill (sig : Signal);
   pragma Import (C, kill, "raise");

   ------------
   -- Clock  --
   ------------

   procedure QueryPerformanceFrequency
     (lpPerformanceFreq : access LARGE_INTEGER);
   pragma Import
     (Stdcall, QueryPerformanceFrequency, "QueryPerformanceFrequency");

   --  According to the spec, on XP and later than function cannot fail,
   --  so we ignore the return value and import it as a procedure.

   -------------
   -- Threads --
   -------------

   type Thread_Body is access
     function (arg : System.Address) return System.Address;
   pragma Convention (C, Thread_Body);

   function Thread_Body_Access is new
     Ada.Unchecked_Conversion (System.Address, Thread_Body);

   procedure SwitchToThread;
   pragma Import (Stdcall, SwitchToThread, "SwitchToThread");

   function GetThreadTimes
     (hThread        : Win32.HANDLE;
      lpCreationTime : access Long_Long_Integer;
      lpExitTime     : access Long_Long_Integer;
      lpKernelTime   : access Long_Long_Integer;
      lpUserTime     : access Long_Long_Integer) return Win32.BOOL;
   pragma Import (Stdcall, GetThreadTimes, "GetThreadTimes");

   -----------------------
   -- Critical sections --
   -----------------------

   type CRITICAL_SECTION is private;

   -------------------------------------------------------------
   -- Thread Creation, Activation, Suspension And Termination --
   -------------------------------------------------------------

   type PTHREAD_START_ROUTINE is access function
     (pThreadParameter : Win32.PVOID) return Win32.DWORD;
   pragma Convention (Stdcall, PTHREAD_START_ROUTINE);

   function To_PTHREAD_START_ROUTINE is new
     Ada.Unchecked_Conversion (System.Address, PTHREAD_START_ROUTINE);

   function CreateThread
     (pThreadAttributes : access Win32.SECURITY_ATTRIBUTES;
      dwStackSize       : Win32.DWORD;
      pStartAddress     : PTHREAD_START_ROUTINE;
      pParameter        : Win32.PVOID;
      dwCreationFlags   : Win32.DWORD;
      pThreadId         : access Win32.DWORD) return Win32.HANDLE;
   pragma Import (Stdcall, CreateThread, "CreateThread");

   function BeginThreadEx
     (pThreadAttributes : access Win32.SECURITY_ATTRIBUTES;
      dwStackSize       : Win32.DWORD;
      pStartAddress     : PTHREAD_START_ROUTINE;
      pParameter        : Win32.PVOID;
      dwCreationFlags   : Win32.DWORD;
      pThreadId         : not null access Win32.DWORD) return Win32.HANDLE;
   pragma Import (C, BeginThreadEx, "_beginthreadex");

   Debug_Process                     : constant := 16#00000001#;
   Debug_Only_This_Process           : constant := 16#00000002#;
   Create_Suspended                  : constant := 16#00000004#;
   Detached_Process                  : constant := 16#00000008#;
   Create_New_Console                : constant := 16#00000010#;

   Create_New_Process_Group          : constant := 16#00000200#;

   Create_No_window                  : constant := 16#08000000#;

   Profile_User                      : constant := 16#10000000#;
   Profile_Kernel                    : constant := 16#20000000#;
   Profile_Server                    : constant := 16#40000000#;

   Stack_Size_Param_Is_A_Reservation : constant := 16#00010000#;

   function GetExitCodeThread
     (hThread   : Win32.HANDLE;
      pExitCode : not null access Win32.DWORD) return Win32.BOOL;
   pragma Import (Stdcall, GetExitCodeThread, "GetExitCodeThread");

   function ResumeThread (hThread : Win32.HANDLE) return Win32.DWORD;
   pragma Import (Stdcall, ResumeThread, "ResumeThread");

   function SuspendThread (hThread : Win32.HANDLE) return Win32.DWORD;
   pragma Import (Stdcall, SuspendThread, "SuspendThread");

   procedure ExitThread (dwExitCode : Win32.DWORD);
   pragma Import (Stdcall, ExitThread, "ExitThread");

   procedure EndThreadEx (dwExitCode : Win32.DWORD);
   pragma Import (C, EndThreadEx, "_endthreadex");

   function TerminateThread
     (hThread    : Win32.HANDLE;
      dwExitCode : Win32.DWORD) return Win32.BOOL;
   pragma Import (Stdcall, TerminateThread, "TerminateThread");

   function GetCurrentThread return Win32.HANDLE;
   pragma Import (Stdcall, GetCurrentThread, "GetCurrentThread");

   function GetCurrentProcess return Win32.HANDLE;
   pragma Import (Stdcall, GetCurrentProcess, "GetCurrentProcess");

   function GetCurrentThreadId return Win32.DWORD;
   pragma Import (Stdcall, GetCurrentThreadId, "GetCurrentThreadId");

   function TlsAlloc return Win32.DWORD;
   pragma Import (Stdcall, TlsAlloc, "TlsAlloc");

   function TlsGetValue (dwTlsIndex : Win32.DWORD) return Win32.PVOID;
   pragma Import (Stdcall, TlsGetValue, "TlsGetValue");

   function TlsSetValue
     (dwTlsIndex : Win32.DWORD; pTlsValue : Win32.PVOID) return Win32.BOOL;
   pragma Import (Stdcall, TlsSetValue, "TlsSetValue");

   function TlsFree (dwTlsIndex : Win32.DWORD) return Win32.BOOL;
   pragma Import (Stdcall, TlsFree, "TlsFree");

   TLS_Nothing : constant := Win32.DWORD'Last;

   procedure ExitProcess (uExitCode : Interfaces.C.unsigned);
   pragma Import (Stdcall, ExitProcess, "ExitProcess");

   function WaitForSingleObject
     (hHandle        : Win32.HANDLE;
      dwMilliseconds : Win32.DWORD) return Win32.DWORD;
   pragma Import (Stdcall, WaitForSingleObject, "WaitForSingleObject");

   function WaitForSingleObjectEx
     (hHandle        : Win32.HANDLE;
      dwMilliseconds : Win32.DWORD;
      fAlertable     : Win32.BOOL) return Win32.DWORD;
   pragma Import (Stdcall, WaitForSingleObjectEx, "WaitForSingleObjectEx");

   Wait_Infinite : constant := Win32.DWORD'Last;
   WAIT_TIMEOUT  : constant := 16#0000_0102#;
   WAIT_FAILED   : constant := 16#FFFF_FFFF#;

   ------------------------------------
   -- Semaphores, Events and Mutexes --
   ------------------------------------

   function CreateSemaphore
     (pSemaphoreAttributes : access Win32.SECURITY_ATTRIBUTES;
      lInitialCount        : Interfaces.C.long;
      lMaximumCount        : Interfaces.C.long;
      pName                : PSZ) return Win32.HANDLE;
   pragma Import (Stdcall, CreateSemaphore, "CreateSemaphoreA");

   function OpenSemaphore
     (dwDesiredAccess : Win32.DWORD;
      bInheritHandle  : Win32.BOOL;
      pName           : PSZ) return Win32.HANDLE;
   pragma Import (Stdcall, OpenSemaphore, "OpenSemaphoreA");

   function ReleaseSemaphore
     (hSemaphore     : Win32.HANDLE;
      lReleaseCount  : Interfaces.C.long;
      pPreviousCount : access Win32.LONG) return Win32.BOOL;
   pragma Import (Stdcall, ReleaseSemaphore, "ReleaseSemaphore");

   function CreateEvent
     (pEventAttributes : access Win32.SECURITY_ATTRIBUTES;
      bManualReset     : Win32.BOOL;
      bInitialState    : Win32.BOOL;
      pName            : PSZ) return Win32.HANDLE;
   pragma Import (Stdcall, CreateEvent, "CreateEventA");

   function OpenEvent
     (dwDesiredAccess : Win32.DWORD;
      bInheritHandle  : Win32.BOOL;
      pName           : PSZ) return Win32.HANDLE;
   pragma Import (Stdcall, OpenEvent, "OpenEventA");

   function SetEvent (hEvent : Win32.HANDLE) return Win32.BOOL;
   pragma Import (Stdcall, SetEvent, "SetEvent");

   function ResetEvent (hEvent : Win32.HANDLE) return Win32.BOOL;
   pragma Import (Stdcall, ResetEvent, "ResetEvent");

   function PulseEvent (hEvent : Win32.HANDLE) return Win32.BOOL;
   pragma Import (Stdcall, PulseEvent, "PulseEvent");

   function CreateMutex
     (pMutexAttributes : access Win32.SECURITY_ATTRIBUTES;
      bInitialOwner    : Win32.BOOL;
      pName            : PSZ) return Win32.HANDLE;
   pragma Import (Stdcall, CreateMutex, "CreateMutexA");

   function OpenMutex
     (dwDesiredAccess : Win32.DWORD;
      bInheritHandle  : Win32.BOOL;
      pName           : PSZ) return Win32.HANDLE;
   pragma Import (Stdcall, OpenMutex, "OpenMutexA");

   function ReleaseMutex (hMutex : Win32.HANDLE) return Win32.BOOL;
   pragma Import (Stdcall, ReleaseMutex, "ReleaseMutex");

   ---------------------------------------------------
   -- Accessing properties of Threads and Processes --
   ---------------------------------------------------

   -----------------
   --  Priorities --
   -----------------

   function SetThreadPriority
     (hThread   : Win32.HANDLE;
      nPriority : Interfaces.C.int) return Win32.BOOL;
   pragma Import (Stdcall, SetThreadPriority, "SetThreadPriority");

   function GetThreadPriority (hThread : Win32.HANDLE) return Interfaces.C.int;
   pragma Import (Stdcall, GetThreadPriority, "GetThreadPriority");

   function SetPriorityClass
     (hProcess        : Win32.HANDLE;
      dwPriorityClass : Win32.DWORD) return Win32.BOOL;
   pragma Import (Stdcall, SetPriorityClass, "SetPriorityClass");

   procedure SetThreadPriorityBoost
     (hThread              : Win32.HANDLE;
      DisablePriorityBoost : Win32.BOOL);
   pragma Import (Stdcall, SetThreadPriorityBoost, "SetThreadPriorityBoost");

   Normal_Priority_Class   : constant := 16#00000020#;
   Idle_Priority_Class     : constant := 16#00000040#;
   High_Priority_Class     : constant := 16#00000080#;
   Realtime_Priority_Class : constant := 16#00000100#;

   Thread_Priority_Idle          : constant := -15;
   Thread_Priority_Lowest        : constant := -2;
   Thread_Priority_Below_Normal  : constant := -1;
   Thread_Priority_Normal        : constant := 0;
   Thread_Priority_Above_Normal  : constant := 1;
   Thread_Priority_Highest       : constant := 2;
   Thread_Priority_Time_Critical : constant := 15;
   Thread_Priority_Error_Return  : constant := Interfaces.C.long'Last;

private

   type sigset_t is new Interfaces.C.unsigned_long;

   type CRITICAL_SECTION is record
      DebugInfo : System.Address;

      LockCount      : Long_Integer;
      RecursionCount : Long_Integer;
      OwningThread   : Win32.HANDLE;
      --  The above three fields control entering and exiting the critical
      --  section for the resource.

      LockSemaphore : Win32.HANDLE;
      SpinCount     : Win32.DWORD;
   end record;

end System.OS_Interface;