1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
5 -- S Y S T E M . O S _ I N T E R F A C E --
9 -- Copyright (C) 1991-1994, Florida State University --
10 -- Copyright (C) 1995-2008, Free Software Foundation, Inc. --
12 -- GNARL 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 2, or (at your option) any later ver- --
15 -- sion. GNARL 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. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNARL; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
21 -- Boston, MA 02110-1301, USA. --
23 -- As a special exception, if other files instantiate generics from this --
24 -- unit, or you link this unit with other files to produce an executable, --
25 -- this unit does not by itself cause the resulting executable to be --
26 -- covered by the GNU General Public License. This exception does not --
27 -- however invalidate any other reasons why the executable file might be --
28 -- covered by the GNU Public License. --
30 -- GNARL was developed by the GNARL team at Florida State University. --
31 -- Extensive contributions were provided by Ada Core Technologies Inc. --
33 ------------------------------------------------------------------------------
35 -- This is a NT (native) version of this package
37 -- This package encapsulates all direct interfaces to OS services
38 -- that are needed by the tasking run-time (libgnarl).
40 -- PLEASE DO NOT add any with-clauses to this package or remove the pragma
41 -- Preelaborate. This package is designed to be a bottom-level (leaf) package.
45 with Interfaces.C.Strings;
47 with Ada.Unchecked_Conversion;
49 package System.OS_Interface is
52 pragma Linker_Options ("-mthreads");
54 subtype int is Interfaces.C.int;
55 subtype long is Interfaces.C.long;
61 type DWORD is new Interfaces.C.unsigned_long;
62 type WORD is new Interfaces.C.unsigned_short;
64 -- The LARGE_INTEGER type is actually a fixed point type
65 -- that only can represent integers. The reason for this is
66 -- easier conversion to Duration or other fixed point types.
67 -- (See Operations.Clock)
69 type LARGE_INTEGER is delta 1.0 range -2.0**63 .. 2.0**63 - 1.0;
71 subtype PSZ is Interfaces.C.Strings.chars_ptr;
72 subtype PCHAR is Interfaces.C.Strings.chars_ptr;
74 subtype PVOID is System.Address;
76 Null_Void : constant PVOID := System.Null_Address;
78 type PLONG is access all Interfaces.C.long;
79 type PDWORD is access all DWORD;
80 type BYTE is new Interfaces.C.unsigned_char;
81 subtype CHAR is Interfaces.C.char;
83 type BOOL is new Boolean;
84 for BOOL'Size use Interfaces.C.unsigned_long'Size;
86 -------------------------
87 -- Handles for objects --
88 -------------------------
90 type HANDLE is new Interfaces.C.long;
91 type PHANDLE is access all HANDLE;
93 subtype Thread_Id is HANDLE;
99 NO_ERROR : constant := 0;
100 FUNC_ERR : constant := -1;
106 type SECURITY_ATTRIBUTES is record
108 pSecurityDescriptor : PVOID;
109 bInheritHandle : BOOL;
112 function CloseHandle (hObject : HANDLE) return BOOL;
113 pragma Import (Stdcall, CloseHandle, "CloseHandle");
115 ------------------------
116 -- System Information --
117 ------------------------
119 type SYSTEM_INFO is record
122 lpMinimumApplicationAddress : PVOID;
123 lpMaximumApplicationAddress : PVOID;
124 dwActiveProcessorMask : DWORD;
125 dwNumberOfProcessors : DWORD;
126 dwProcessorType : DWORD;
127 dwAllocationGranularity : DWORD;
131 procedure GetSystemInfo (SI : access SYSTEM_INFO);
132 pragma Import (Stdcall, GetSystemInfo, "GetSystemInfo");
138 Max_Interrupt : constant := 31;
139 type Signal is new int range 0 .. Max_Interrupt;
140 for Signal'Size use int'Size;
142 SIGINT : constant := 2; -- interrupt (Ctrl-C)
143 SIGILL : constant := 4; -- illegal instruction (not reset)
144 SIGFPE : constant := 8; -- floating point exception
145 SIGSEGV : constant := 11; -- segmentation violation
146 SIGTERM : constant := 15; -- software termination signal from kill
147 SIGBREAK : constant := 21; -- break (Ctrl-Break)
148 SIGABRT : constant := 22; -- used by abort, replace SIGIOT in the future
150 type sigset_t is private;
152 type isr_address is access procedure (sig : int);
153 pragma Convention (C, isr_address);
155 function intr_attach (sig : int; handler : isr_address) return long;
156 pragma Import (C, intr_attach, "signal");
158 Intr_Attach_Reset : constant Boolean := True;
159 -- True if intr_attach is reset after an interrupt handler is called
161 procedure kill (sig : Signal);
162 pragma Import (C, kill, "raise");
164 ---------------------
165 -- Time Management --
166 ---------------------
168 procedure Sleep (dwMilliseconds : DWORD);
169 pragma Import (Stdcall, Sleep, External_Name => "Sleep");
171 type SYSTEMTIME is record
179 wMilliseconds : WORD;
182 procedure GetSystemTime (pSystemTime : access SYSTEMTIME);
183 pragma Import (Stdcall, GetSystemTime, "GetSystemTime");
185 procedure GetSystemTimeAsFileTime (lpFileTime : access Long_Long_Integer);
186 pragma Import (Stdcall, GetSystemTimeAsFileTime, "GetSystemTimeAsFileTime");
188 function SetSystemTime (pSystemTime : access SYSTEMTIME) return BOOL;
189 pragma Import (Stdcall, SetSystemTime, "SetSystemTime");
191 function FileTimeToSystemTime
192 (lpFileTime : access Long_Long_Integer;
193 lpSystemTime : access SYSTEMTIME) return BOOL;
194 pragma Import (Stdcall, FileTimeToSystemTime, "FileTimeToSystemTime");
196 function SystemTimeToFileTime
197 (lpSystemTime : access SYSTEMTIME;
198 lpFileTime : access Long_Long_Integer) return BOOL;
199 pragma Import (Stdcall, SystemTimeToFileTime, "SystemTimeToFileTime");
201 function FileTimeToLocalFileTime
202 (lpFileTime : access Long_Long_Integer;
203 lpLocalFileTime : access Long_Long_Integer) return BOOL;
204 pragma Import (Stdcall, FileTimeToLocalFileTime, "FileTimeToLocalFileTime");
206 function LocalFileTimeToFileTime
207 (lpFileTime : access Long_Long_Integer;
208 lpLocalFileTime : access Long_Long_Integer) return BOOL;
209 pragma Import (Stdcall, LocalFileTimeToFileTime, "LocalFileTimeToFileTime");
211 function QueryPerformanceCounter
212 (lpPerformanceCount : access LARGE_INTEGER) return BOOL;
214 (Stdcall, QueryPerformanceCounter, "QueryPerformanceCounter");
216 function QueryPerformanceFrequency
217 (lpFrequency : access LARGE_INTEGER) return BOOL;
219 (Stdcall, QueryPerformanceFrequency, "QueryPerformanceFrequency");
225 type Thread_Body is access
226 function (arg : System.Address) return System.Address;
227 pragma Convention (C, Thread_Body);
229 function Thread_Body_Access is new
230 Ada.Unchecked_Conversion (System.Address, Thread_Body);
232 procedure SwitchToThread;
233 pragma Import (Stdcall, SwitchToThread, "SwitchToThread");
235 function GetThreadTimes
237 lpCreationTime : access Long_Long_Integer;
238 lpExitTime : access Long_Long_Integer;
239 lpKernelTime : access Long_Long_Integer;
240 lpUserTime : access Long_Long_Integer) return BOOL;
241 pragma Import (Stdcall, GetThreadTimes, "GetThreadTimes");
243 -----------------------
244 -- Critical sections --
245 -----------------------
247 type CRITICAL_SECTION is private;
249 procedure InitializeCriticalSection
250 (pCriticalSection : access CRITICAL_SECTION);
252 (Stdcall, InitializeCriticalSection, "InitializeCriticalSection");
254 procedure EnterCriticalSection
255 (pCriticalSection : access CRITICAL_SECTION);
256 pragma Import (Stdcall, EnterCriticalSection, "EnterCriticalSection");
258 procedure LeaveCriticalSection
259 (pCriticalSection : access CRITICAL_SECTION);
260 pragma Import (Stdcall, LeaveCriticalSection, "LeaveCriticalSection");
262 procedure DeleteCriticalSection
263 (pCriticalSection : access CRITICAL_SECTION);
264 pragma Import (Stdcall, DeleteCriticalSection, "DeleteCriticalSection");
266 -------------------------------------------------------------
267 -- Thread Creation, Activation, Suspension And Termination --
268 -------------------------------------------------------------
270 subtype ProcessorId is DWORD;
272 type PTHREAD_START_ROUTINE is access function
273 (pThreadParameter : PVOID) return DWORD;
274 pragma Convention (Stdcall, PTHREAD_START_ROUTINE);
276 function To_PTHREAD_START_ROUTINE is new
277 Ada.Unchecked_Conversion (System.Address, PTHREAD_START_ROUTINE);
279 function CreateThread
280 (pThreadAttributes : access SECURITY_ATTRIBUTES;
282 pStartAddress : PTHREAD_START_ROUTINE;
284 dwCreationFlags : DWORD;
285 pThreadId : PDWORD) return HANDLE;
286 pragma Import (Stdcall, CreateThread, "CreateThread");
288 function BeginThreadEx
289 (pThreadAttributes : access SECURITY_ATTRIBUTES;
291 pStartAddress : PTHREAD_START_ROUTINE;
293 dwCreationFlags : DWORD;
294 pThreadId : PDWORD) return HANDLE;
295 pragma Import (C, BeginThreadEx, "_beginthreadex");
297 Debug_Process : constant := 16#00000001#;
298 Debug_Only_This_Process : constant := 16#00000002#;
299 Create_Suspended : constant := 16#00000004#;
300 Detached_Process : constant := 16#00000008#;
301 Create_New_Console : constant := 16#00000010#;
303 Create_New_Process_Group : constant := 16#00000200#;
305 Create_No_window : constant := 16#08000000#;
307 Profile_User : constant := 16#10000000#;
308 Profile_Kernel : constant := 16#20000000#;
309 Profile_Server : constant := 16#40000000#;
311 Stack_Size_Param_Is_A_Reservation : constant := 16#00010000#;
313 function GetExitCodeThread
315 pExitCode : PDWORD) return BOOL;
316 pragma Import (Stdcall, GetExitCodeThread, "GetExitCodeThread");
318 function ResumeThread (hThread : HANDLE) return DWORD;
319 pragma Import (Stdcall, ResumeThread, "ResumeThread");
321 function SuspendThread (hThread : HANDLE) return DWORD;
322 pragma Import (Stdcall, SuspendThread, "SuspendThread");
324 procedure ExitThread (dwExitCode : DWORD);
325 pragma Import (Stdcall, ExitThread, "ExitThread");
327 procedure EndThreadEx (dwExitCode : DWORD);
328 pragma Import (C, EndThreadEx, "_endthreadex");
330 function TerminateThread
332 dwExitCode : DWORD) return BOOL;
333 pragma Import (Stdcall, TerminateThread, "TerminateThread");
335 function GetCurrentThread return HANDLE;
336 pragma Import (Stdcall, GetCurrentThread, "GetCurrentThread");
338 function GetCurrentProcess return HANDLE;
339 pragma Import (Stdcall, GetCurrentProcess, "GetCurrentProcess");
341 function GetCurrentThreadId return DWORD;
342 pragma Import (Stdcall, GetCurrentThreadId, "GetCurrentThreadId");
344 function TlsAlloc return DWORD;
345 pragma Import (Stdcall, TlsAlloc, "TlsAlloc");
347 function TlsGetValue (dwTlsIndex : DWORD) return PVOID;
348 pragma Import (Stdcall, TlsGetValue, "TlsGetValue");
350 function TlsSetValue (dwTlsIndex : DWORD; pTlsValue : PVOID) return BOOL;
351 pragma Import (Stdcall, TlsSetValue, "TlsSetValue");
353 function TlsFree (dwTlsIndex : DWORD) return BOOL;
354 pragma Import (Stdcall, TlsFree, "TlsFree");
356 TLS_Nothing : constant := DWORD'Last;
358 procedure ExitProcess (uExitCode : Interfaces.C.unsigned);
359 pragma Import (Stdcall, ExitProcess, "ExitProcess");
361 function WaitForSingleObject
363 dwMilliseconds : DWORD) return DWORD;
364 pragma Import (Stdcall, WaitForSingleObject, "WaitForSingleObject");
366 function WaitForSingleObjectEx
368 dwMilliseconds : DWORD;
369 fAlertable : BOOL) return DWORD;
370 pragma Import (Stdcall, WaitForSingleObjectEx, "WaitForSingleObjectEx");
372 function SetThreadIdealProcessor
374 dwIdealProcessor : ProcessorId) return DWORD;
375 pragma Import (Stdcall, SetThreadIdealProcessor, "SetThreadIdealProcessor");
377 Wait_Infinite : constant := DWORD'Last;
378 WAIT_TIMEOUT : constant := 16#0000_0102#;
379 WAIT_FAILED : constant := 16#FFFF_FFFF#;
381 ------------------------------------
382 -- Semaphores, Events and Mutexes --
383 ------------------------------------
385 function CreateSemaphore
386 (pSemaphoreAttributes : access SECURITY_ATTRIBUTES;
387 lInitialCount : Interfaces.C.long;
388 lMaximumCount : Interfaces.C.long;
389 pName : PSZ) return HANDLE;
390 pragma Import (Stdcall, CreateSemaphore, "CreateSemaphoreA");
392 function OpenSemaphore
393 (dwDesiredAccess : DWORD;
394 bInheritHandle : BOOL;
395 pName : PSZ) return HANDLE;
396 pragma Import (Stdcall, OpenSemaphore, "OpenSemaphoreA");
398 function ReleaseSemaphore
399 (hSemaphore : HANDLE;
400 lReleaseCount : Interfaces.C.long;
401 pPreviousCount : PLONG) return BOOL;
402 pragma Import (Stdcall, ReleaseSemaphore, "ReleaseSemaphore");
405 (pEventAttributes : access SECURITY_ATTRIBUTES;
407 bInitialState : BOOL;
408 pName : PSZ) return HANDLE;
409 pragma Import (Stdcall, CreateEvent, "CreateEventA");
412 (dwDesiredAccess : DWORD;
413 bInheritHandle : BOOL;
414 pName : PSZ) return HANDLE;
415 pragma Import (Stdcall, OpenEvent, "OpenEventA");
417 function SetEvent (hEvent : HANDLE) return BOOL;
418 pragma Import (Stdcall, SetEvent, "SetEvent");
420 function ResetEvent (hEvent : HANDLE) return BOOL;
421 pragma Import (Stdcall, ResetEvent, "ResetEvent");
423 function PulseEvent (hEvent : HANDLE) return BOOL;
424 pragma Import (Stdcall, PulseEvent, "PulseEvent");
427 (pMutexAttributes : access SECURITY_ATTRIBUTES;
428 bInitialOwner : BOOL;
429 pName : PSZ) return HANDLE;
430 pragma Import (Stdcall, CreateMutex, "CreateMutexA");
433 (dwDesiredAccess : DWORD;
434 bInheritHandle : BOOL;
435 pName : PSZ) return HANDLE;
436 pragma Import (Stdcall, OpenMutex, "OpenMutexA");
438 function ReleaseMutex (hMutex : HANDLE) return BOOL;
439 pragma Import (Stdcall, ReleaseMutex, "ReleaseMutex");
441 ---------------------------------------------------
442 -- Accessing properties of Threads and Processes --
443 ---------------------------------------------------
449 function SetThreadPriority
451 nPriority : Interfaces.C.int) return BOOL;
452 pragma Import (Stdcall, SetThreadPriority, "SetThreadPriority");
454 function GetThreadPriority (hThread : HANDLE) return Interfaces.C.int;
455 pragma Import (Stdcall, GetThreadPriority, "GetThreadPriority");
457 function SetPriorityClass
459 dwPriorityClass : DWORD) return BOOL;
460 pragma Import (Stdcall, SetPriorityClass, "SetPriorityClass");
462 procedure SetThreadPriorityBoost
464 DisablePriorityBoost : BOOL);
465 pragma Import (Stdcall, SetThreadPriorityBoost, "SetThreadPriorityBoost");
467 Normal_Priority_Class : constant := 16#00000020#;
468 Idle_Priority_Class : constant := 16#00000040#;
469 High_Priority_Class : constant := 16#00000080#;
470 Realtime_Priority_Class : constant := 16#00000100#;
472 Thread_Priority_Idle : constant := -15;
473 Thread_Priority_Lowest : constant := -2;
474 Thread_Priority_Below_Normal : constant := -1;
475 Thread_Priority_Normal : constant := 0;
476 Thread_Priority_Above_Normal : constant := 1;
477 Thread_Priority_Highest : constant := 2;
478 Thread_Priority_Time_Critical : constant := 15;
479 Thread_Priority_Error_Return : constant := Interfaces.C.long'Last;
481 function GetLastError return DWORD;
482 pragma Import (Stdcall, GetLastError, "GetLastError");
486 type sigset_t is new Interfaces.C.unsigned_long;
488 type CRITICAL_SECTION is record
489 DebugInfo : System.Address;
490 -- The following three fields control entering and
491 -- exiting the critical section for the resource
492 LockCount : Long_Integer;
493 RecursionCount : Long_Integer;
494 OwningThread : HANDLE;
495 LockSemaphore : HANDLE;
499 end System.OS_Interface;