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-2011, 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   -------------------
57   -- General Types --
58   -------------------
59
60   subtype PSZ   is Interfaces.C.Strings.chars_ptr;
61
62   Null_Void : constant Win32.PVOID := System.Null_Address;
63
64   -------------------------
65   -- Handles for objects --
66   -------------------------
67
68   subtype Thread_Id is Win32.HANDLE;
69
70   -----------
71   -- Errno --
72   -----------
73
74   NO_ERROR : constant := 0;
75   FUNC_ERR : constant := -1;
76
77   -------------
78   -- Signals --
79   -------------
80
81   Max_Interrupt : constant := 31;
82   type Signal is new int range 0 .. Max_Interrupt;
83   for Signal'Size use int'Size;
84
85   SIGINT     : constant := 2; --  interrupt (Ctrl-C)
86   SIGILL     : constant := 4; --  illegal instruction (not reset)
87   SIGFPE     : constant := 8; --  floating point exception
88   SIGSEGV    : constant := 11; -- segmentation violation
89   SIGTERM    : constant := 15; -- software termination signal from kill
90   SIGBREAK   : constant := 21; -- break (Ctrl-Break)
91   SIGABRT    : constant := 22; -- used by abort, replace SIGIOT in the future
92
93   type sigset_t is private;
94
95   type isr_address is access procedure (sig : int);
96   pragma Convention (C, isr_address);
97
98   function intr_attach (sig : int; handler : isr_address) return long;
99   pragma Import (C, intr_attach, "signal");
100
101   Intr_Attach_Reset : constant Boolean := True;
102   --  True if intr_attach is reset after an interrupt handler is called
103
104   procedure kill (sig : Signal);
105   pragma Import (C, kill, "raise");
106
107   -------------
108   -- Threads --
109   -------------
110
111   type Thread_Body is access
112     function (arg : System.Address) return System.Address;
113   pragma Convention (C, Thread_Body);
114
115   function Thread_Body_Access is new
116     Ada.Unchecked_Conversion (System.Address, Thread_Body);
117
118   procedure SwitchToThread;
119   pragma Import (Stdcall, SwitchToThread, "SwitchToThread");
120
121   function GetThreadTimes
122     (hThread        : Win32.HANDLE;
123      lpCreationTime : access Long_Long_Integer;
124      lpExitTime     : access Long_Long_Integer;
125      lpKernelTime   : access Long_Long_Integer;
126      lpUserTime     : access Long_Long_Integer) return Win32.BOOL;
127   pragma Import (Stdcall, GetThreadTimes, "GetThreadTimes");
128
129   -----------------------
130   -- Critical sections --
131   -----------------------
132
133   type CRITICAL_SECTION is private;
134
135   -------------------------------------------------------------
136   -- Thread Creation, Activation, Suspension And Termination --
137   -------------------------------------------------------------
138
139   type PTHREAD_START_ROUTINE is access function
140     (pThreadParameter : Win32.PVOID) return Win32.DWORD;
141   pragma Convention (Stdcall, PTHREAD_START_ROUTINE);
142
143   function To_PTHREAD_START_ROUTINE is new
144     Ada.Unchecked_Conversion (System.Address, PTHREAD_START_ROUTINE);
145
146   function CreateThread
147     (pThreadAttributes : access Win32.SECURITY_ATTRIBUTES;
148      dwStackSize       : Win32.DWORD;
149      pStartAddress     : PTHREAD_START_ROUTINE;
150      pParameter        : Win32.PVOID;
151      dwCreationFlags   : Win32.DWORD;
152      pThreadId         : access Win32.DWORD) return Win32.HANDLE;
153   pragma Import (Stdcall, CreateThread, "CreateThread");
154
155   function BeginThreadEx
156     (pThreadAttributes : access Win32.SECURITY_ATTRIBUTES;
157      dwStackSize       : Win32.DWORD;
158      pStartAddress     : PTHREAD_START_ROUTINE;
159      pParameter        : Win32.PVOID;
160      dwCreationFlags   : Win32.DWORD;
161      pThreadId         : not null access Win32.DWORD) return Win32.HANDLE;
162   pragma Import (C, BeginThreadEx, "_beginthreadex");
163
164   Debug_Process                     : constant := 16#00000001#;
165   Debug_Only_This_Process           : constant := 16#00000002#;
166   Create_Suspended                  : constant := 16#00000004#;
167   Detached_Process                  : constant := 16#00000008#;
168   Create_New_Console                : constant := 16#00000010#;
169
170   Create_New_Process_Group          : constant := 16#00000200#;
171
172   Create_No_window                  : constant := 16#08000000#;
173
174   Profile_User                      : constant := 16#10000000#;
175   Profile_Kernel                    : constant := 16#20000000#;
176   Profile_Server                    : constant := 16#40000000#;
177
178   Stack_Size_Param_Is_A_Reservation : constant := 16#00010000#;
179
180   function GetExitCodeThread
181     (hThread   : Win32.HANDLE;
182      pExitCode : not null access Win32.DWORD) return Win32.BOOL;
183   pragma Import (Stdcall, GetExitCodeThread, "GetExitCodeThread");
184
185   function ResumeThread (hThread : Win32.HANDLE) return Win32.DWORD;
186   pragma Import (Stdcall, ResumeThread, "ResumeThread");
187
188   function SuspendThread (hThread : Win32.HANDLE) return Win32.DWORD;
189   pragma Import (Stdcall, SuspendThread, "SuspendThread");
190
191   procedure ExitThread (dwExitCode : Win32.DWORD);
192   pragma Import (Stdcall, ExitThread, "ExitThread");
193
194   procedure EndThreadEx (dwExitCode : Win32.DWORD);
195   pragma Import (C, EndThreadEx, "_endthreadex");
196
197   function TerminateThread
198     (hThread    : Win32.HANDLE;
199      dwExitCode : Win32.DWORD) return Win32.BOOL;
200   pragma Import (Stdcall, TerminateThread, "TerminateThread");
201
202   function GetCurrentThread return Win32.HANDLE;
203   pragma Import (Stdcall, GetCurrentThread, "GetCurrentThread");
204
205   function GetCurrentProcess return Win32.HANDLE;
206   pragma Import (Stdcall, GetCurrentProcess, "GetCurrentProcess");
207
208   function GetCurrentThreadId return Win32.DWORD;
209   pragma Import (Stdcall, GetCurrentThreadId, "GetCurrentThreadId");
210
211   function TlsAlloc return Win32.DWORD;
212   pragma Import (Stdcall, TlsAlloc, "TlsAlloc");
213
214   function TlsGetValue (dwTlsIndex : Win32.DWORD) return Win32.PVOID;
215   pragma Import (Stdcall, TlsGetValue, "TlsGetValue");
216
217   function TlsSetValue
218     (dwTlsIndex : Win32.DWORD; pTlsValue : Win32.PVOID) return Win32.BOOL;
219   pragma Import (Stdcall, TlsSetValue, "TlsSetValue");
220
221   function TlsFree (dwTlsIndex : Win32.DWORD) return Win32.BOOL;
222   pragma Import (Stdcall, TlsFree, "TlsFree");
223
224   TLS_Nothing : constant := Win32.DWORD'Last;
225
226   procedure ExitProcess (uExitCode : Interfaces.C.unsigned);
227   pragma Import (Stdcall, ExitProcess, "ExitProcess");
228
229   function WaitForSingleObject
230     (hHandle        : Win32.HANDLE;
231      dwMilliseconds : Win32.DWORD) return Win32.DWORD;
232   pragma Import (Stdcall, WaitForSingleObject, "WaitForSingleObject");
233
234   function WaitForSingleObjectEx
235     (hHandle        : Win32.HANDLE;
236      dwMilliseconds : Win32.DWORD;
237      fAlertable     : Win32.BOOL) return Win32.DWORD;
238   pragma Import (Stdcall, WaitForSingleObjectEx, "WaitForSingleObjectEx");
239
240   Wait_Infinite : constant := Win32.DWORD'Last;
241   WAIT_TIMEOUT  : constant := 16#0000_0102#;
242   WAIT_FAILED   : constant := 16#FFFF_FFFF#;
243
244   ------------------------------------
245   -- Semaphores, Events and Mutexes --
246   ------------------------------------
247
248   function CreateSemaphore
249     (pSemaphoreAttributes : access Win32.SECURITY_ATTRIBUTES;
250      lInitialCount        : Interfaces.C.long;
251      lMaximumCount        : Interfaces.C.long;
252      pName                : PSZ) return Win32.HANDLE;
253   pragma Import (Stdcall, CreateSemaphore, "CreateSemaphoreA");
254
255   function OpenSemaphore
256     (dwDesiredAccess : Win32.DWORD;
257      bInheritHandle  : Win32.BOOL;
258      pName           : PSZ) return Win32.HANDLE;
259   pragma Import (Stdcall, OpenSemaphore, "OpenSemaphoreA");
260
261   function ReleaseSemaphore
262     (hSemaphore     : Win32.HANDLE;
263      lReleaseCount  : Interfaces.C.long;
264      pPreviousCount : access Win32.LONG) return Win32.BOOL;
265   pragma Import (Stdcall, ReleaseSemaphore, "ReleaseSemaphore");
266
267   function CreateEvent
268     (pEventAttributes : access Win32.SECURITY_ATTRIBUTES;
269      bManualReset     : Win32.BOOL;
270      bInitialState    : Win32.BOOL;
271      pName            : PSZ) return Win32.HANDLE;
272   pragma Import (Stdcall, CreateEvent, "CreateEventA");
273
274   function OpenEvent
275     (dwDesiredAccess : Win32.DWORD;
276      bInheritHandle  : Win32.BOOL;
277      pName           : PSZ) return Win32.HANDLE;
278   pragma Import (Stdcall, OpenEvent, "OpenEventA");
279
280   function SetEvent (hEvent : Win32.HANDLE) return Win32.BOOL;
281   pragma Import (Stdcall, SetEvent, "SetEvent");
282
283   function ResetEvent (hEvent : Win32.HANDLE) return Win32.BOOL;
284   pragma Import (Stdcall, ResetEvent, "ResetEvent");
285
286   function PulseEvent (hEvent : Win32.HANDLE) return Win32.BOOL;
287   pragma Import (Stdcall, PulseEvent, "PulseEvent");
288
289   function CreateMutex
290     (pMutexAttributes : access Win32.SECURITY_ATTRIBUTES;
291      bInitialOwner    : Win32.BOOL;
292      pName            : PSZ) return Win32.HANDLE;
293   pragma Import (Stdcall, CreateMutex, "CreateMutexA");
294
295   function OpenMutex
296     (dwDesiredAccess : Win32.DWORD;
297      bInheritHandle  : Win32.BOOL;
298      pName           : PSZ) return Win32.HANDLE;
299   pragma Import (Stdcall, OpenMutex, "OpenMutexA");
300
301   function ReleaseMutex (hMutex : Win32.HANDLE) return Win32.BOOL;
302   pragma Import (Stdcall, ReleaseMutex, "ReleaseMutex");
303
304   ---------------------------------------------------
305   -- Accessing properties of Threads and Processes --
306   ---------------------------------------------------
307
308   -----------------
309   --  Priorities --
310   -----------------
311
312   function SetThreadPriority
313     (hThread   : Win32.HANDLE;
314      nPriority : Interfaces.C.int) return Win32.BOOL;
315   pragma Import (Stdcall, SetThreadPriority, "SetThreadPriority");
316
317   function GetThreadPriority (hThread : Win32.HANDLE) return Interfaces.C.int;
318   pragma Import (Stdcall, GetThreadPriority, "GetThreadPriority");
319
320   function SetPriorityClass
321     (hProcess        : Win32.HANDLE;
322      dwPriorityClass : Win32.DWORD) return Win32.BOOL;
323   pragma Import (Stdcall, SetPriorityClass, "SetPriorityClass");
324
325   procedure SetThreadPriorityBoost
326     (hThread              : Win32.HANDLE;
327      DisablePriorityBoost : Win32.BOOL);
328   pragma Import (Stdcall, SetThreadPriorityBoost, "SetThreadPriorityBoost");
329
330   Normal_Priority_Class   : constant := 16#00000020#;
331   Idle_Priority_Class     : constant := 16#00000040#;
332   High_Priority_Class     : constant := 16#00000080#;
333   Realtime_Priority_Class : constant := 16#00000100#;
334
335   Thread_Priority_Idle          : constant := -15;
336   Thread_Priority_Lowest        : constant := -2;
337   Thread_Priority_Below_Normal  : constant := -1;
338   Thread_Priority_Normal        : constant := 0;
339   Thread_Priority_Above_Normal  : constant := 1;
340   Thread_Priority_Highest       : constant := 2;
341   Thread_Priority_Time_Critical : constant := 15;
342   Thread_Priority_Error_Return  : constant := Interfaces.C.long'Last;
343
344private
345
346   type sigset_t is new Interfaces.C.unsigned_long;
347
348   type CRITICAL_SECTION is record
349      DebugInfo : System.Address;
350
351      LockCount      : Long_Integer;
352      RecursionCount : Long_Integer;
353      OwningThread   : Win32.HANDLE;
354      --  The above three fields control entering and exiting the critical
355      --  section for the resource.
356
357      LockSemaphore : Win32.HANDLE;
358      SpinCount     : Win32.DWORD;
359   end record;
360
361end System.OS_Interface;
362