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-2007, 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 children of System.
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.
44 with Interfaces
.C
.Strings
;
45 with Ada
.Unchecked_Conversion
;
47 package System
.OS_Interface
is
50 pragma Linker_Options
("-mthreads");
52 subtype int
is Interfaces
.C
.int
;
53 subtype long
is Interfaces
.C
.long
;
59 type DWORD
is new Interfaces
.C
.unsigned_long
;
60 type WORD
is new Interfaces
.C
.unsigned_short
;
62 -- The LARGE_INTEGER type is actually a fixed point type
63 -- that only can represent integers. The reason for this is
64 -- easier conversion to Duration or other fixed point types.
65 -- (See Operations.Clock)
67 type LARGE_INTEGER
is delta 1.0 range -2.0**63 .. 2.0**63 - 1.0;
69 subtype PSZ
is Interfaces
.C
.Strings
.chars_ptr
;
70 subtype PCHAR
is Interfaces
.C
.Strings
.chars_ptr
;
72 subtype PVOID
is System
.Address
;
74 Null_Void
: constant PVOID
:= System
.Null_Address
;
76 type PLONG
is access all Interfaces
.C
.long
;
77 type PDWORD
is access all DWORD
;
79 type BOOL
is new Boolean;
80 for BOOL
'Size use Interfaces
.C
.unsigned_long
'Size;
82 -------------------------
83 -- Handles for objects --
84 -------------------------
86 type HANDLE
is new Interfaces
.C
.long
;
87 type PHANDLE
is access all HANDLE
;
89 subtype Thread_Id
is HANDLE
;
95 NO_ERROR
: constant := 0;
96 FUNC_ERR
: constant := -1;
98 ------------------------
99 -- System Information --
100 ------------------------
102 type SYSTEM_INFO
is record
105 lpMinimumApplicationAddress
: PVOID
;
106 lpMaximumApplicationAddress
: PVOID
;
107 dwActiveProcessorMask
: DWORD
;
108 dwNumberOfProcessors
: DWORD
;
109 dwProcessorType
: DWORD
;
110 dwAllocationGranularity
: DWORD
;
114 procedure GetSystemInfo
(SI
: access SYSTEM_INFO
);
115 pragma Import
(Stdcall
, GetSystemInfo
, "GetSystemInfo");
121 Max_Interrupt
: constant := 31;
122 type Signal
is new int
range 0 .. Max_Interrupt
;
123 for Signal
'Size use int
'Size;
125 SIGINT
: constant := 2; -- interrupt (Ctrl-C)
126 SIGILL
: constant := 4; -- illegal instruction (not reset)
127 SIGFPE
: constant := 8; -- floating point exception
128 SIGSEGV
: constant := 11; -- segmentation violation
129 SIGTERM
: constant := 15; -- software termination signal from kill
130 SIGBREAK
: constant := 21; -- break (Ctrl-Break)
131 SIGABRT
: constant := 22; -- used by abort, replace SIGIOT in the future
133 type sigset_t
is private;
135 type isr_address
is access procedure (sig
: int
);
136 pragma Convention
(C
, isr_address
);
138 function intr_attach
(sig
: int
; handler
: isr_address
) return long
;
139 pragma Import
(C
, intr_attach
, "signal");
141 Intr_Attach_Reset
: constant Boolean := True;
142 -- True if intr_attach is reset after an interrupt handler is called
144 procedure kill
(sig
: Signal
);
145 pragma Import
(C
, kill
, "raise");
147 ---------------------
148 -- Time Management --
149 ---------------------
151 procedure Sleep
(dwMilliseconds
: DWORD
);
152 pragma Import
(Stdcall
, Sleep
, External_Name
=> "Sleep");
154 type SYSTEMTIME
is record
162 wMilliseconds
: WORD
;
165 procedure GetSystemTime
(pSystemTime
: access SYSTEMTIME
);
166 pragma Import
(Stdcall
, GetSystemTime
, "GetSystemTime");
168 procedure GetSystemTimeAsFileTime
(lpFileTime
: access Long_Long_Integer);
169 pragma Import
(Stdcall
, GetSystemTimeAsFileTime
, "GetSystemTimeAsFileTime");
171 function SetSystemTime
(pSystemTime
: access SYSTEMTIME
) return BOOL
;
172 pragma Import
(Stdcall
, SetSystemTime
, "SetSystemTime");
174 function FileTimeToSystemTime
175 (lpFileTime
: access Long_Long_Integer;
176 lpSystemTime
: access SYSTEMTIME
) return BOOL
;
177 pragma Import
(Stdcall
, FileTimeToSystemTime
, "FileTimeToSystemTime");
179 function SystemTimeToFileTime
180 (lpSystemTime
: access SYSTEMTIME
;
181 lpFileTime
: access Long_Long_Integer) return BOOL
;
182 pragma Import
(Stdcall
, SystemTimeToFileTime
, "SystemTimeToFileTime");
184 function FileTimeToLocalFileTime
185 (lpFileTime
: access Long_Long_Integer;
186 lpLocalFileTime
: access Long_Long_Integer) return BOOL
;
187 pragma Import
(Stdcall
, FileTimeToLocalFileTime
, "FileTimeToLocalFileTime");
189 function LocalFileTimeToFileTime
190 (lpFileTime
: access Long_Long_Integer;
191 lpLocalFileTime
: access Long_Long_Integer) return BOOL
;
192 pragma Import
(Stdcall
, LocalFileTimeToFileTime
, "LocalFileTimeToFileTime");
194 function QueryPerformanceCounter
195 (lpPerformanceCount
: access LARGE_INTEGER
) return BOOL
;
197 (Stdcall
, QueryPerformanceCounter
, "QueryPerformanceCounter");
199 function QueryPerformanceFrequency
200 (lpFrequency
: access LARGE_INTEGER
) return BOOL
;
202 (Stdcall
, QueryPerformanceFrequency
, "QueryPerformanceFrequency");
208 type Thread_Body
is access
209 function (arg
: System
.Address
) return System
.Address
;
210 pragma Convention
(C
, Thread_Body
);
212 function Thread_Body_Access
is new
213 Ada
.Unchecked_Conversion
(System
.Address
, Thread_Body
);
215 procedure SwitchToThread
;
216 pragma Import
(Stdcall
, SwitchToThread
, "SwitchToThread");
218 function GetThreadTimes
220 lpCreationTime
: access Long_Long_Integer;
221 lpExitTime
: access Long_Long_Integer;
222 lpKernelTime
: access Long_Long_Integer;
223 lpUserTime
: access Long_Long_Integer) return BOOL
;
224 pragma Import
(Stdcall
, GetThreadTimes
, "GetThreadTimes");
226 -----------------------
227 -- Critical sections --
228 -----------------------
230 type CRITICAL_SECTION
is private;
232 procedure InitializeCriticalSection
233 (pCriticalSection
: access CRITICAL_SECTION
);
235 (Stdcall
, InitializeCriticalSection
, "InitializeCriticalSection");
237 procedure EnterCriticalSection
238 (pCriticalSection
: access CRITICAL_SECTION
);
239 pragma Import
(Stdcall
, EnterCriticalSection
, "EnterCriticalSection");
241 procedure LeaveCriticalSection
242 (pCriticalSection
: access CRITICAL_SECTION
);
243 pragma Import
(Stdcall
, LeaveCriticalSection
, "LeaveCriticalSection");
245 procedure DeleteCriticalSection
246 (pCriticalSection
: access CRITICAL_SECTION
);
247 pragma Import
(Stdcall
, DeleteCriticalSection
, "DeleteCriticalSection");
249 -------------------------------------------------------------
250 -- Thread Creation, Activation, Suspension And Termination --
251 -------------------------------------------------------------
253 subtype ProcessorId
is DWORD
;
255 type PTHREAD_START_ROUTINE
is access function
256 (pThreadParameter
: PVOID
) return DWORD
;
257 pragma Convention
(Stdcall
, PTHREAD_START_ROUTINE
);
259 function To_PTHREAD_START_ROUTINE
is new
260 Ada
.Unchecked_Conversion
(System
.Address
, PTHREAD_START_ROUTINE
);
262 type SECURITY_ATTRIBUTES
is record
264 pSecurityDescriptor
: PVOID
;
265 bInheritHandle
: BOOL
;
268 type PSECURITY_ATTRIBUTES
is access all SECURITY_ATTRIBUTES
;
270 function CreateThread
271 (pThreadAttributes
: PSECURITY_ATTRIBUTES
;
273 pStartAddress
: PTHREAD_START_ROUTINE
;
275 dwCreationFlags
: DWORD
;
276 pThreadId
: PDWORD
) return HANDLE
;
277 pragma Import
(Stdcall
, CreateThread
, "CreateThread");
279 function BeginThreadEx
280 (pThreadAttributes
: PSECURITY_ATTRIBUTES
;
282 pStartAddress
: PTHREAD_START_ROUTINE
;
284 dwCreationFlags
: DWORD
;
285 pThreadId
: PDWORD
) return HANDLE
;
286 pragma Import
(C
, BeginThreadEx
, "_beginthreadex");
288 Debug_Process
: constant := 16#
00000001#
;
289 Debug_Only_This_Process
: constant := 16#
00000002#
;
290 Create_Suspended
: constant := 16#
00000004#
;
291 Detached_Process
: constant := 16#
00000008#
;
292 Create_New_Console
: constant := 16#
00000010#
;
294 Create_New_Process_Group
: constant := 16#
00000200#
;
296 Create_No_window
: constant := 16#
08000000#
;
298 Profile_User
: constant := 16#
10000000#
;
299 Profile_Kernel
: constant := 16#
20000000#
;
300 Profile_Server
: constant := 16#
40000000#
;
302 Stack_Size_Param_Is_A_Reservation
: constant := 16#
00010000#
;
304 function GetExitCodeThread
306 pExitCode
: PDWORD
) return BOOL
;
307 pragma Import
(Stdcall
, GetExitCodeThread
, "GetExitCodeThread");
309 function ResumeThread
(hThread
: HANDLE
) return DWORD
;
310 pragma Import
(Stdcall
, ResumeThread
, "ResumeThread");
312 function SuspendThread
(hThread
: HANDLE
) return DWORD
;
313 pragma Import
(Stdcall
, SuspendThread
, "SuspendThread");
315 procedure ExitThread
(dwExitCode
: DWORD
);
316 pragma Import
(Stdcall
, ExitThread
, "ExitThread");
318 procedure EndThreadEx
(dwExitCode
: DWORD
);
319 pragma Import
(C
, EndThreadEx
, "_endthreadex");
321 function TerminateThread
323 dwExitCode
: DWORD
) return BOOL
;
324 pragma Import
(Stdcall
, TerminateThread
, "TerminateThread");
326 function GetCurrentThread
return HANDLE
;
327 pragma Import
(Stdcall
, GetCurrentThread
, "GetCurrentThread");
329 function GetCurrentProcess
return HANDLE
;
330 pragma Import
(Stdcall
, GetCurrentProcess
, "GetCurrentProcess");
332 function GetCurrentThreadId
return DWORD
;
333 pragma Import
(Stdcall
, GetCurrentThreadId
, "GetCurrentThreadId");
335 function TlsAlloc
return DWORD
;
336 pragma Import
(Stdcall
, TlsAlloc
, "TlsAlloc");
338 function TlsGetValue
(dwTlsIndex
: DWORD
) return PVOID
;
339 pragma Import
(Stdcall
, TlsGetValue
, "TlsGetValue");
341 function TlsSetValue
(dwTlsIndex
: DWORD
; pTlsValue
: PVOID
) return BOOL
;
342 pragma Import
(Stdcall
, TlsSetValue
, "TlsSetValue");
344 function TlsFree
(dwTlsIndex
: DWORD
) return BOOL
;
345 pragma Import
(Stdcall
, TlsFree
, "TlsFree");
347 TLS_Nothing
: constant := DWORD
'Last;
349 procedure ExitProcess
(uExitCode
: Interfaces
.C
.unsigned
);
350 pragma Import
(Stdcall
, ExitProcess
, "ExitProcess");
352 function WaitForSingleObject
354 dwMilliseconds
: DWORD
) return DWORD
;
355 pragma Import
(Stdcall
, WaitForSingleObject
, "WaitForSingleObject");
357 function WaitForSingleObjectEx
359 dwMilliseconds
: DWORD
;
360 fAlertable
: BOOL
) return DWORD
;
361 pragma Import
(Stdcall
, WaitForSingleObjectEx
, "WaitForSingleObjectEx");
363 function SetThreadIdealProcessor
365 dwIdealProcessor
: ProcessorId
) return DWORD
;
366 pragma Import
(Stdcall
, SetThreadIdealProcessor
, "SetThreadIdealProcessor");
368 Wait_Infinite
: constant := DWORD
'Last;
369 WAIT_TIMEOUT
: constant := 16#
0000_0102#
;
370 WAIT_FAILED
: constant := 16#FFFF_FFFF#
;
372 ------------------------------------
373 -- Semaphores, Events and Mutexes --
374 ------------------------------------
376 function CloseHandle
(hObject
: HANDLE
) return BOOL
;
377 pragma Import
(Stdcall
, CloseHandle
, "CloseHandle");
379 function CreateSemaphore
380 (pSemaphoreAttributes
: PSECURITY_ATTRIBUTES
;
381 lInitialCount
: Interfaces
.C
.long
;
382 lMaximumCount
: Interfaces
.C
.long
;
383 pName
: PSZ
) return HANDLE
;
384 pragma Import
(Stdcall
, CreateSemaphore
, "CreateSemaphoreA");
386 function OpenSemaphore
387 (dwDesiredAccess
: DWORD
;
388 bInheritHandle
: BOOL
;
389 pName
: PSZ
) return HANDLE
;
390 pragma Import
(Stdcall
, OpenSemaphore
, "OpenSemaphoreA");
392 function ReleaseSemaphore
393 (hSemaphore
: HANDLE
;
394 lReleaseCount
: Interfaces
.C
.long
;
395 pPreviousCount
: PLONG
) return BOOL
;
396 pragma Import
(Stdcall
, ReleaseSemaphore
, "ReleaseSemaphore");
399 (pEventAttributes
: PSECURITY_ATTRIBUTES
;
401 bInitialState
: BOOL
;
402 pName
: PSZ
) return HANDLE
;
403 pragma Import
(Stdcall
, CreateEvent
, "CreateEventA");
406 (dwDesiredAccess
: DWORD
;
407 bInheritHandle
: BOOL
;
408 pName
: PSZ
) return HANDLE
;
409 pragma Import
(Stdcall
, OpenEvent
, "OpenEventA");
411 function SetEvent
(hEvent
: HANDLE
) return BOOL
;
412 pragma Import
(Stdcall
, SetEvent
, "SetEvent");
414 function ResetEvent
(hEvent
: HANDLE
) return BOOL
;
415 pragma Import
(Stdcall
, ResetEvent
, "ResetEvent");
417 function PulseEvent
(hEvent
: HANDLE
) return BOOL
;
418 pragma Import
(Stdcall
, PulseEvent
, "PulseEvent");
421 (pMutexAttributes
: PSECURITY_ATTRIBUTES
;
422 bInitialOwner
: BOOL
;
423 pName
: PSZ
) return HANDLE
;
424 pragma Import
(Stdcall
, CreateMutex
, "CreateMutexA");
427 (dwDesiredAccess
: DWORD
;
428 bInheritHandle
: BOOL
;
429 pName
: PSZ
) return HANDLE
;
430 pragma Import
(Stdcall
, OpenMutex
, "OpenMutexA");
432 function ReleaseMutex
(hMutex
: HANDLE
) return BOOL
;
433 pragma Import
(Stdcall
, ReleaseMutex
, "ReleaseMutex");
435 ---------------------------------------------------
436 -- Accessing properties of Threads and Processes --
437 ---------------------------------------------------
443 function SetThreadPriority
445 nPriority
: Interfaces
.C
.int
) return BOOL
;
446 pragma Import
(Stdcall
, SetThreadPriority
, "SetThreadPriority");
448 function GetThreadPriority
(hThread
: HANDLE
) return Interfaces
.C
.int
;
449 pragma Import
(Stdcall
, GetThreadPriority
, "GetThreadPriority");
451 function SetPriorityClass
453 dwPriorityClass
: DWORD
) return BOOL
;
454 pragma Import
(Stdcall
, SetPriorityClass
, "SetPriorityClass");
456 procedure SetThreadPriorityBoost
458 DisablePriorityBoost
: BOOL
);
459 pragma Import
(Stdcall
, SetThreadPriorityBoost
, "SetThreadPriorityBoost");
461 Normal_Priority_Class
: constant := 16#
00000020#
;
462 Idle_Priority_Class
: constant := 16#
00000040#
;
463 High_Priority_Class
: constant := 16#
00000080#
;
464 Realtime_Priority_Class
: constant := 16#
00000100#
;
466 Thread_Priority_Idle
: constant := -15;
467 Thread_Priority_Lowest
: constant := -2;
468 Thread_Priority_Below_Normal
: constant := -1;
469 Thread_Priority_Normal
: constant := 0;
470 Thread_Priority_Above_Normal
: constant := 1;
471 Thread_Priority_Highest
: constant := 2;
472 Thread_Priority_Time_Critical
: constant := 15;
473 Thread_Priority_Error_Return
: constant := Interfaces
.C
.long
'Last;
475 function GetLastError
return DWORD
;
476 pragma Import
(Stdcall
, GetLastError
, "GetLastError");
480 type sigset_t
is new Interfaces
.C
.unsigned_long
;
482 type CRITICAL_SECTION
is record
483 DebugInfo
: System
.Address
;
484 -- The following three fields control entering and
485 -- exiting the critical section for the resource
486 LockCount
: Long_Integer;
487 RecursionCount
: Long_Integer;
488 OwningThread
: HANDLE
;
489 LockSemaphore
: HANDLE
;
493 end System
.OS_Interface
;