1------------------------------------------------------------------------------
2--                                                                          --
3--                 GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS                 --
4--                                                                          --
5--                   S Y S T E M . O S _ I N T E R F A C E                  --
6--                                                                          --
7--                                  S p e c                                 --
8--                                                                          --
9--             Copyright (C) 1991-1994, Florida State University            --
10--          Copyright (C) 1995-2014, Free Software Foundation, Inc.         --
11--                                                                          --
12-- GNAT is free software;  you can  redistribute it  and/or modify it under --
13-- terms of the  GNU General Public License as published  by the Free Soft- --
14-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
15-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
16-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
17-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
18--                                                                          --
19-- As a special exception under Section 7 of GPL version 3, you are granted --
20-- additional permissions described in the GCC Runtime Library Exception,   --
21-- version 3.1, as published by the Free Software Foundation.               --
22--                                                                          --
23-- You should have received a copy of the GNU General Public License and    --
24-- a copy of the GCC Runtime Library Exception along with this program;     --
25-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
26-- <http://www.gnu.org/licenses/>.                                          --
27--                                                                          --
28-- GNARL was developed by the GNARL team at Florida State University.       --
29-- Extensive contributions were provided by Ada Core Technologies Inc.      --
30--                                                                          --
31------------------------------------------------------------------------------
32
33--  This is a NT (native) version of this package
34
35--  This package encapsulates all direct interfaces to OS services
36--  that are needed by the tasking run-time (libgnarl). For non tasking
37--  oriented services consider declaring them into system-win32.
38
39--  PLEASE DO NOT add any with-clauses to this package or remove the pragma
40--  Preelaborate. This package is designed to be a bottom-level (leaf) package.
41
42with Ada.Unchecked_Conversion;
43
44with Interfaces.C;
45with Interfaces.C.Strings;
46with System.Win32;
47
48package System.OS_Interface is
49   pragma Preelaborate;
50
51   pragma Linker_Options ("-mthreads");
52
53   subtype int  is Interfaces.C.int;
54   subtype long is Interfaces.C.long;
55
56   subtype LARGE_INTEGER is System.Win32.LARGE_INTEGER;
57
58   -------------------
59   -- General Types --
60   -------------------
61
62   subtype PSZ   is Interfaces.C.Strings.chars_ptr;
63
64   Null_Void : constant Win32.PVOID := System.Null_Address;
65
66   -------------------------
67   -- Handles for objects --
68   -------------------------
69
70   subtype Thread_Id is Win32.HANDLE;
71
72   -----------
73   -- Errno --
74   -----------
75
76   NO_ERROR : constant := 0;
77   FUNC_ERR : constant := -1;
78
79   -------------
80   -- Signals --
81   -------------
82
83   Max_Interrupt : constant := 31;
84   type Signal is new int range 0 .. Max_Interrupt;
85   for Signal'Size use int'Size;
86
87   SIGINT     : constant := 2; --  interrupt (Ctrl-C)
88   SIGILL     : constant := 4; --  illegal instruction (not reset)
89   SIGFPE     : constant := 8; --  floating point exception
90   SIGSEGV    : constant := 11; -- segmentation violation
91   SIGTERM    : constant := 15; -- software termination signal from kill
92   SIGBREAK   : constant := 21; -- break (Ctrl-Break)
93   SIGABRT    : constant := 22; -- used by abort, replace SIGIOT in the future
94
95   type sigset_t is private;
96
97   type isr_address is access procedure (sig : int);
98   pragma Convention (C, isr_address);
99
100   function intr_attach (sig : int; handler : isr_address) return long;
101   pragma Import (C, intr_attach, "signal");
102
103   Intr_Attach_Reset : constant Boolean := True;
104   --  True if intr_attach is reset after an interrupt handler is called
105
106   procedure kill (sig : Signal);
107   pragma Import (C, kill, "raise");
108
109   ------------
110   -- Clock  --
111   ------------
112
113   procedure QueryPerformanceFrequency
114     (lpPerformanceFreq : access LARGE_INTEGER);
115   pragma Import
116     (Stdcall, QueryPerformanceFrequency, "QueryPerformanceFrequency");
117
118   --  According to the spec, on XP and later than function cannot fail,
119   --  so we ignore the return value and import it as a procedure.
120
121   -------------
122   -- Threads --
123   -------------
124
125   type Thread_Body is access
126     function (arg : System.Address) return System.Address;
127   pragma Convention (C, Thread_Body);
128
129   function Thread_Body_Access is new
130     Ada.Unchecked_Conversion (System.Address, Thread_Body);
131
132   procedure SwitchToThread;
133   pragma Import (Stdcall, SwitchToThread, "SwitchToThread");
134
135   function GetThreadTimes
136     (hThread        : Win32.HANDLE;
137      lpCreationTime : access Long_Long_Integer;
138      lpExitTime     : access Long_Long_Integer;
139      lpKernelTime   : access Long_Long_Integer;
140      lpUserTime     : access Long_Long_Integer) return Win32.BOOL;
141   pragma Import (Stdcall, GetThreadTimes, "GetThreadTimes");
142
143   -----------------------
144   -- Critical sections --
145   -----------------------
146
147   type CRITICAL_SECTION is private;
148
149   -------------------------------------------------------------
150   -- Thread Creation, Activation, Suspension And Termination --
151   -------------------------------------------------------------
152
153   type PTHREAD_START_ROUTINE is access function
154     (pThreadParameter : Win32.PVOID) return Win32.DWORD;
155   pragma Convention (Stdcall, PTHREAD_START_ROUTINE);
156
157   function To_PTHREAD_START_ROUTINE is new
158     Ada.Unchecked_Conversion (System.Address, PTHREAD_START_ROUTINE);
159
160   function CreateThread
161     (pThreadAttributes : access Win32.SECURITY_ATTRIBUTES;
162      dwStackSize       : Win32.DWORD;
163      pStartAddress     : PTHREAD_START_ROUTINE;
164      pParameter        : Win32.PVOID;
165      dwCreationFlags   : Win32.DWORD;
166      pThreadId         : access Win32.DWORD) return Win32.HANDLE;
167   pragma Import (Stdcall, CreateThread, "CreateThread");
168
169   function BeginThreadEx
170     (pThreadAttributes : access Win32.SECURITY_ATTRIBUTES;
171      dwStackSize       : Win32.DWORD;
172      pStartAddress     : PTHREAD_START_ROUTINE;
173      pParameter        : Win32.PVOID;
174      dwCreationFlags   : Win32.DWORD;
175      pThreadId         : not null access Win32.DWORD) return Win32.HANDLE;
176   pragma Import (C, BeginThreadEx, "_beginthreadex");
177
178   Debug_Process                     : constant := 16#00000001#;
179   Debug_Only_This_Process           : constant := 16#00000002#;
180   Create_Suspended                  : constant := 16#00000004#;
181   Detached_Process                  : constant := 16#00000008#;
182   Create_New_Console                : constant := 16#00000010#;
183
184   Create_New_Process_Group          : constant := 16#00000200#;
185
186   Create_No_window                  : constant := 16#08000000#;
187
188   Profile_User                      : constant := 16#10000000#;
189   Profile_Kernel                    : constant := 16#20000000#;
190   Profile_Server                    : constant := 16#40000000#;
191
192   Stack_Size_Param_Is_A_Reservation : constant := 16#00010000#;
193
194   function GetExitCodeThread
195     (hThread   : Win32.HANDLE;
196      pExitCode : not null access Win32.DWORD) return Win32.BOOL;
197   pragma Import (Stdcall, GetExitCodeThread, "GetExitCodeThread");
198
199   function ResumeThread (hThread : Win32.HANDLE) return Win32.DWORD;
200   pragma Import (Stdcall, ResumeThread, "ResumeThread");
201
202   function SuspendThread (hThread : Win32.HANDLE) return Win32.DWORD;
203   pragma Import (Stdcall, SuspendThread, "SuspendThread");
204
205   procedure ExitThread (dwExitCode : Win32.DWORD);
206   pragma Import (Stdcall, ExitThread, "ExitThread");
207
208   procedure EndThreadEx (dwExitCode : Win32.DWORD);
209   pragma Import (C, EndThreadEx, "_endthreadex");
210
211   function TerminateThread
212     (hThread    : Win32.HANDLE;
213      dwExitCode : Win32.DWORD) return Win32.BOOL;
214   pragma Import (Stdcall, TerminateThread, "TerminateThread");
215
216   function GetCurrentThread return Win32.HANDLE;
217   pragma Import (Stdcall, GetCurrentThread, "GetCurrentThread");
218
219   function GetCurrentProcess return Win32.HANDLE;
220   pragma Import (Stdcall, GetCurrentProcess, "GetCurrentProcess");
221
222   function GetCurrentThreadId return Win32.DWORD;
223   pragma Import (Stdcall, GetCurrentThreadId, "GetCurrentThreadId");
224
225   function TlsAlloc return Win32.DWORD;
226   pragma Import (Stdcall, TlsAlloc, "TlsAlloc");
227
228   function TlsGetValue (dwTlsIndex : Win32.DWORD) return Win32.PVOID;
229   pragma Import (Stdcall, TlsGetValue, "TlsGetValue");
230
231   function TlsSetValue
232     (dwTlsIndex : Win32.DWORD; pTlsValue : Win32.PVOID) return Win32.BOOL;
233   pragma Import (Stdcall, TlsSetValue, "TlsSetValue");
234
235   function TlsFree (dwTlsIndex : Win32.DWORD) return Win32.BOOL;
236   pragma Import (Stdcall, TlsFree, "TlsFree");
237
238   TLS_Nothing : constant := Win32.DWORD'Last;
239
240   procedure ExitProcess (uExitCode : Interfaces.C.unsigned);
241   pragma Import (Stdcall, ExitProcess, "ExitProcess");
242
243   function WaitForSingleObject
244     (hHandle        : Win32.HANDLE;
245      dwMilliseconds : Win32.DWORD) return Win32.DWORD;
246   pragma Import (Stdcall, WaitForSingleObject, "WaitForSingleObject");
247
248   function WaitForSingleObjectEx
249     (hHandle        : Win32.HANDLE;
250      dwMilliseconds : Win32.DWORD;
251      fAlertable     : Win32.BOOL) return Win32.DWORD;
252   pragma Import (Stdcall, WaitForSingleObjectEx, "WaitForSingleObjectEx");
253
254   Wait_Infinite : constant := Win32.DWORD'Last;
255   WAIT_TIMEOUT  : constant := 16#0000_0102#;
256   WAIT_FAILED   : constant := 16#FFFF_FFFF#;
257
258   ------------------------------------
259   -- Semaphores, Events and Mutexes --
260   ------------------------------------
261
262   function CreateSemaphore
263     (pSemaphoreAttributes : access Win32.SECURITY_ATTRIBUTES;
264      lInitialCount        : Interfaces.C.long;
265      lMaximumCount        : Interfaces.C.long;
266      pName                : PSZ) return Win32.HANDLE;
267   pragma Import (Stdcall, CreateSemaphore, "CreateSemaphoreA");
268
269   function OpenSemaphore
270     (dwDesiredAccess : Win32.DWORD;
271      bInheritHandle  : Win32.BOOL;
272      pName           : PSZ) return Win32.HANDLE;
273   pragma Import (Stdcall, OpenSemaphore, "OpenSemaphoreA");
274
275   function ReleaseSemaphore
276     (hSemaphore     : Win32.HANDLE;
277      lReleaseCount  : Interfaces.C.long;
278      pPreviousCount : access Win32.LONG) return Win32.BOOL;
279   pragma Import (Stdcall, ReleaseSemaphore, "ReleaseSemaphore");
280
281   function CreateEvent
282     (pEventAttributes : access Win32.SECURITY_ATTRIBUTES;
283      bManualReset     : Win32.BOOL;
284      bInitialState    : Win32.BOOL;
285      pName            : PSZ) return Win32.HANDLE;
286   pragma Import (Stdcall, CreateEvent, "CreateEventA");
287
288   function OpenEvent
289     (dwDesiredAccess : Win32.DWORD;
290      bInheritHandle  : Win32.BOOL;
291      pName           : PSZ) return Win32.HANDLE;
292   pragma Import (Stdcall, OpenEvent, "OpenEventA");
293
294   function SetEvent (hEvent : Win32.HANDLE) return Win32.BOOL;
295   pragma Import (Stdcall, SetEvent, "SetEvent");
296
297   function ResetEvent (hEvent : Win32.HANDLE) return Win32.BOOL;
298   pragma Import (Stdcall, ResetEvent, "ResetEvent");
299
300   function PulseEvent (hEvent : Win32.HANDLE) return Win32.BOOL;
301   pragma Import (Stdcall, PulseEvent, "PulseEvent");
302
303   function CreateMutex
304     (pMutexAttributes : access Win32.SECURITY_ATTRIBUTES;
305      bInitialOwner    : Win32.BOOL;
306      pName            : PSZ) return Win32.HANDLE;
307   pragma Import (Stdcall, CreateMutex, "CreateMutexA");
308
309   function OpenMutex
310     (dwDesiredAccess : Win32.DWORD;
311      bInheritHandle  : Win32.BOOL;
312      pName           : PSZ) return Win32.HANDLE;
313   pragma Import (Stdcall, OpenMutex, "OpenMutexA");
314
315   function ReleaseMutex (hMutex : Win32.HANDLE) return Win32.BOOL;
316   pragma Import (Stdcall, ReleaseMutex, "ReleaseMutex");
317
318   ---------------------------------------------------
319   -- Accessing properties of Threads and Processes --
320   ---------------------------------------------------
321
322   -----------------
323   --  Priorities --
324   -----------------
325
326   function SetThreadPriority
327     (hThread   : Win32.HANDLE;
328      nPriority : Interfaces.C.int) return Win32.BOOL;
329   pragma Import (Stdcall, SetThreadPriority, "SetThreadPriority");
330
331   function GetThreadPriority (hThread : Win32.HANDLE) return Interfaces.C.int;
332   pragma Import (Stdcall, GetThreadPriority, "GetThreadPriority");
333
334   function SetPriorityClass
335     (hProcess        : Win32.HANDLE;
336      dwPriorityClass : Win32.DWORD) return Win32.BOOL;
337   pragma Import (Stdcall, SetPriorityClass, "SetPriorityClass");
338
339   procedure SetThreadPriorityBoost
340     (hThread              : Win32.HANDLE;
341      DisablePriorityBoost : Win32.BOOL);
342   pragma Import (Stdcall, SetThreadPriorityBoost, "SetThreadPriorityBoost");
343
344   Normal_Priority_Class   : constant := 16#00000020#;
345   Idle_Priority_Class     : constant := 16#00000040#;
346   High_Priority_Class     : constant := 16#00000080#;
347   Realtime_Priority_Class : constant := 16#00000100#;
348
349   Thread_Priority_Idle          : constant := -15;
350   Thread_Priority_Lowest        : constant := -2;
351   Thread_Priority_Below_Normal  : constant := -1;
352   Thread_Priority_Normal        : constant := 0;
353   Thread_Priority_Above_Normal  : constant := 1;
354   Thread_Priority_Highest       : constant := 2;
355   Thread_Priority_Time_Critical : constant := 15;
356   Thread_Priority_Error_Return  : constant := Interfaces.C.long'Last;
357
358private
359
360   type sigset_t is new Interfaces.C.unsigned_long;
361
362   type CRITICAL_SECTION is record
363      DebugInfo : System.Address;
364
365      LockCount      : Long_Integer;
366      RecursionCount : Long_Integer;
367      OwningThread   : Win32.HANDLE;
368      --  The above three fields control entering and exiting the critical
369      --  section for the resource.
370
371      LockSemaphore : Win32.HANDLE;
372      SpinCount     : Win32.DWORD;
373   end record;
374
375end System.OS_Interface;
376