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-2005, 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 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
;
71 subtype PVOID
is System
.Address
;
73 Null_Void
: constant PVOID
:= System
.Null_Address
;
75 type PLONG
is access all Interfaces
.C
.long
;
76 type PDWORD
is access all DWORD
;
78 type BOOL
is new Boolean;
79 for BOOL
'Size use Interfaces
.C
.unsigned_long
'Size;
81 -------------------------
82 -- Handles for objects --
83 -------------------------
85 type HANDLE
is new Interfaces
.C
.long
;
86 type PHANDLE
is access all HANDLE
;
88 subtype Thread_Id
is HANDLE
;
94 NO_ERROR
: constant := 0;
95 FUNC_ERR
: constant := -1;
101 Max_Interrupt
: constant := 31;
102 type Signal
is new int
range 0 .. Max_Interrupt
;
103 for Signal
'Size use int
'Size;
105 SIGINT
: constant := 2; -- interrupt (Ctrl-C)
106 SIGILL
: constant := 4; -- illegal instruction (not reset)
107 SIGFPE
: constant := 8; -- floating point exception
108 SIGSEGV
: constant := 11; -- segmentation violation
109 SIGTERM
: constant := 15; -- software termination signal from kill
110 SIGBREAK
: constant := 21; -- break (Ctrl-Break)
111 SIGABRT
: constant := 22; -- used by abort, replace SIGIOT in the future
113 type sigset_t
is private;
115 type isr_address
is access procedure (sig
: int
);
117 function intr_attach
(sig
: int
; handler
: isr_address
) return long
;
118 pragma Import
(C
, intr_attach
, "signal");
120 Intr_Attach_Reset
: constant Boolean := True;
121 -- True if intr_attach is reset after an interrupt handler is called
123 procedure kill
(sig
: Signal
);
124 pragma Import
(C
, kill
, "raise");
126 ---------------------
127 -- Time Management --
128 ---------------------
130 procedure Sleep
(dwMilliseconds
: DWORD
);
131 pragma Import
(Stdcall
, Sleep
, External_Name
=> "Sleep");
133 type SYSTEMTIME
is record
141 wMilliseconds
: WORD
;
144 procedure GetSystemTime
(pSystemTime
: access SYSTEMTIME
);
145 pragma Import
(Stdcall
, GetSystemTime
, "GetSystemTime");
147 procedure GetSystemTimeAsFileTime
(lpFileTime
: access Long_Long_Integer);
148 pragma Import
(Stdcall
, GetSystemTimeAsFileTime
, "GetSystemTimeAsFileTime");
150 function SetSystemTime
(pSystemTime
: access SYSTEMTIME
) return BOOL
;
151 pragma Import
(Stdcall
, SetSystemTime
, "SetSystemTime");
153 function FileTimeToSystemTime
154 (lpFileTime
: access Long_Long_Integer;
155 lpSystemTime
: access SYSTEMTIME
) return BOOL
;
156 pragma Import
(Stdcall
, FileTimeToSystemTime
, "FileTimeToSystemTime");
158 function SystemTimeToFileTime
159 (lpSystemTime
: access SYSTEMTIME
;
160 lpFileTime
: access Long_Long_Integer) return BOOL
;
161 pragma Import
(Stdcall
, SystemTimeToFileTime
, "SystemTimeToFileTime");
163 function FileTimeToLocalFileTime
164 (lpFileTime
: access Long_Long_Integer;
165 lpLocalFileTime
: access Long_Long_Integer) return BOOL
;
166 pragma Import
(Stdcall
, FileTimeToLocalFileTime
, "FileTimeToLocalFileTime");
168 function LocalFileTimeToFileTime
169 (lpFileTime
: access Long_Long_Integer;
170 lpLocalFileTime
: access Long_Long_Integer) return BOOL
;
171 pragma Import
(Stdcall
, LocalFileTimeToFileTime
, "LocalFileTimeToFileTime");
173 function QueryPerformanceCounter
174 (lpPerformanceCount
: access LARGE_INTEGER
) return BOOL
;
176 (Stdcall
, QueryPerformanceCounter
, "QueryPerformanceCounter");
178 function QueryPerformanceFrequency
179 (lpFrequency
: access LARGE_INTEGER
) return BOOL
;
181 (Stdcall
, QueryPerformanceFrequency
, "QueryPerformanceFrequency");
187 type Thread_Body
is access
188 function (arg
: System
.Address
) return System
.Address
;
190 function Thread_Body_Access
is new
191 Unchecked_Conversion
(System
.Address
, Thread_Body
);
193 procedure SwitchToThread
;
194 pragma Import
(Stdcall
, SwitchToThread
, "SwitchToThread");
196 -----------------------
197 -- Critical sections --
198 -----------------------
200 type CRITICAL_SECTION
is private;
202 procedure InitializeCriticalSection
203 (pCriticalSection
: access CRITICAL_SECTION
);
205 (Stdcall
, InitializeCriticalSection
, "InitializeCriticalSection");
207 procedure EnterCriticalSection
208 (pCriticalSection
: access CRITICAL_SECTION
);
209 pragma Import
(Stdcall
, EnterCriticalSection
, "EnterCriticalSection");
211 procedure LeaveCriticalSection
212 (pCriticalSection
: access CRITICAL_SECTION
);
213 pragma Import
(Stdcall
, LeaveCriticalSection
, "LeaveCriticalSection");
215 procedure DeleteCriticalSection
216 (pCriticalSection
: access CRITICAL_SECTION
);
217 pragma Import
(Stdcall
, DeleteCriticalSection
, "DeleteCriticalSection");
219 -------------------------------------------------------------
220 -- Thread Creation, Activation, Suspension And Termination --
221 -------------------------------------------------------------
223 type PTHREAD_START_ROUTINE
is access function
224 (pThreadParameter
: PVOID
) return DWORD
;
225 pragma Convention
(Stdcall
, PTHREAD_START_ROUTINE
);
227 function To_PTHREAD_START_ROUTINE
is new
228 Unchecked_Conversion
(System
.Address
, PTHREAD_START_ROUTINE
);
230 type SECURITY_ATTRIBUTES
is record
232 pSecurityDescriptor
: PVOID
;
233 bInheritHandle
: BOOL
;
236 type PSECURITY_ATTRIBUTES
is access all SECURITY_ATTRIBUTES
;
238 function CreateThread
239 (pThreadAttributes
: PSECURITY_ATTRIBUTES
;
241 pStartAddress
: PTHREAD_START_ROUTINE
;
243 dwCreationFlags
: DWORD
;
244 pThreadId
: PDWORD
) return HANDLE
;
245 pragma Import
(Stdcall
, CreateThread
, "CreateThread");
247 function BeginThreadEx
248 (pThreadAttributes
: PSECURITY_ATTRIBUTES
;
250 pStartAddress
: PTHREAD_START_ROUTINE
;
252 dwCreationFlags
: DWORD
;
253 pThreadId
: PDWORD
) return HANDLE
;
254 pragma Import
(C
, BeginThreadEx
, "_beginthreadex");
256 Debug_Process
: constant := 16#
00000001#
;
257 Debug_Only_This_Process
: constant := 16#
00000002#
;
258 Create_Suspended
: constant := 16#
00000004#
;
259 Detached_Process
: constant := 16#
00000008#
;
260 Create_New_Console
: constant := 16#
00000010#
;
262 Create_New_Process_Group
: constant := 16#
00000200#
;
264 Create_No_window
: constant := 16#
08000000#
;
266 Profile_User
: constant := 16#
10000000#
;
267 Profile_Kernel
: constant := 16#
20000000#
;
268 Profile_Server
: constant := 16#
40000000#
;
270 Stack_Size_Param_Is_A_Reservation
: constant := 16#
00010000#
;
272 function GetExitCodeThread
274 pExitCode
: PDWORD
) return BOOL
;
275 pragma Import
(Stdcall
, GetExitCodeThread
, "GetExitCodeThread");
277 function ResumeThread
(hThread
: HANDLE
) return DWORD
;
278 pragma Import
(Stdcall
, ResumeThread
, "ResumeThread");
280 function SuspendThread
(hThread
: HANDLE
) return DWORD
;
281 pragma Import
(Stdcall
, SuspendThread
, "SuspendThread");
283 procedure ExitThread
(dwExitCode
: DWORD
);
284 pragma Import
(Stdcall
, ExitThread
, "ExitThread");
286 procedure EndThreadEx
(dwExitCode
: DWORD
);
287 pragma Import
(C
, EndThreadEx
, "_endthreadex");
289 function TerminateThread
291 dwExitCode
: DWORD
) return BOOL
;
292 pragma Import
(Stdcall
, TerminateThread
, "TerminateThread");
294 function GetCurrentThread
return HANDLE
;
295 pragma Import
(Stdcall
, GetCurrentThread
, "GetCurrentThread");
297 function GetCurrentProcess
return HANDLE
;
298 pragma Import
(Stdcall
, GetCurrentProcess
, "GetCurrentProcess");
300 function GetCurrentThreadId
return DWORD
;
301 pragma Import
(Stdcall
, GetCurrentThreadId
, "GetCurrentThreadId");
303 function TlsAlloc
return DWORD
;
304 pragma Import
(Stdcall
, TlsAlloc
, "TlsAlloc");
306 function TlsGetValue
(dwTlsIndex
: DWORD
) return PVOID
;
307 pragma Import
(Stdcall
, TlsGetValue
, "TlsGetValue");
309 function TlsSetValue
(dwTlsIndex
: DWORD
; pTlsValue
: PVOID
) return BOOL
;
310 pragma Import
(Stdcall
, TlsSetValue
, "TlsSetValue");
312 function TlsFree
(dwTlsIndex
: DWORD
) return BOOL
;
313 pragma Import
(Stdcall
, TlsFree
, "TlsFree");
315 TLS_Nothing
: constant := DWORD
'Last;
317 procedure ExitProcess
(uExitCode
: Interfaces
.C
.unsigned
);
318 pragma Import
(Stdcall
, ExitProcess
, "ExitProcess");
320 function WaitForSingleObject
322 dwMilliseconds
: DWORD
) return DWORD
;
323 pragma Import
(Stdcall
, WaitForSingleObject
, "WaitForSingleObject");
325 function WaitForSingleObjectEx
327 dwMilliseconds
: DWORD
;
328 fAlertable
: BOOL
) return DWORD
;
329 pragma Import
(Stdcall
, WaitForSingleObjectEx
, "WaitForSingleObjectEx");
331 Wait_Infinite
: constant := DWORD
'Last;
332 WAIT_TIMEOUT
: constant := 16#
0000_0102#
;
333 WAIT_FAILED
: constant := 16#FFFF_FFFF#
;
335 ------------------------------------
336 -- Semaphores, Events and Mutexes --
337 ------------------------------------
339 function CloseHandle
(hObject
: HANDLE
) return BOOL
;
340 pragma Import
(Stdcall
, CloseHandle
, "CloseHandle");
342 function CreateSemaphore
343 (pSemaphoreAttributes
: PSECURITY_ATTRIBUTES
;
344 lInitialCount
: Interfaces
.C
.long
;
345 lMaximumCount
: Interfaces
.C
.long
;
346 pName
: PSZ
) return HANDLE
;
347 pragma Import
(Stdcall
, CreateSemaphore
, "CreateSemaphoreA");
349 function OpenSemaphore
350 (dwDesiredAccess
: DWORD
;
351 bInheritHandle
: BOOL
;
352 pName
: PSZ
) return HANDLE
;
353 pragma Import
(Stdcall
, OpenSemaphore
, "OpenSemaphoreA");
355 function ReleaseSemaphore
356 (hSemaphore
: HANDLE
;
357 lReleaseCount
: Interfaces
.C
.long
;
358 pPreviousCount
: PLONG
) return BOOL
;
359 pragma Import
(Stdcall
, ReleaseSemaphore
, "ReleaseSemaphore");
362 (pEventAttributes
: PSECURITY_ATTRIBUTES
;
364 bInitialState
: BOOL
;
365 pName
: PSZ
) return HANDLE
;
366 pragma Import
(Stdcall
, CreateEvent
, "CreateEventA");
369 (dwDesiredAccess
: DWORD
;
370 bInheritHandle
: BOOL
;
371 pName
: PSZ
) return HANDLE
;
372 pragma Import
(Stdcall
, OpenEvent
, "OpenEventA");
374 function SetEvent
(hEvent
: HANDLE
) return BOOL
;
375 pragma Import
(Stdcall
, SetEvent
, "SetEvent");
377 function ResetEvent
(hEvent
: HANDLE
) return BOOL
;
378 pragma Import
(Stdcall
, ResetEvent
, "ResetEvent");
380 function PulseEvent
(hEvent
: HANDLE
) return BOOL
;
381 pragma Import
(Stdcall
, PulseEvent
, "PulseEvent");
384 (pMutexAttributes
: PSECURITY_ATTRIBUTES
;
385 bInitialOwner
: BOOL
;
386 pName
: PSZ
) return HANDLE
;
387 pragma Import
(Stdcall
, CreateMutex
, "CreateMutexA");
390 (dwDesiredAccess
: DWORD
;
391 bInheritHandle
: BOOL
;
392 pName
: PSZ
) return HANDLE
;
393 pragma Import
(Stdcall
, OpenMutex
, "OpenMutexA");
395 function ReleaseMutex
(hMutex
: HANDLE
) return BOOL
;
396 pragma Import
(Stdcall
, ReleaseMutex
, "ReleaseMutex");
398 ---------------------------------------------------
399 -- Accessing properties of Threads and Processes --
400 ---------------------------------------------------
406 function SetThreadPriority
408 nPriority
: Interfaces
.C
.int
) return BOOL
;
409 pragma Import
(Stdcall
, SetThreadPriority
, "SetThreadPriority");
411 function GetThreadPriority
(hThread
: HANDLE
) return Interfaces
.C
.int
;
412 pragma Import
(Stdcall
, GetThreadPriority
, "GetThreadPriority");
414 function SetPriorityClass
416 dwPriorityClass
: DWORD
) return BOOL
;
417 pragma Import
(Stdcall
, SetPriorityClass
, "SetPriorityClass");
419 procedure SetThreadPriorityBoost
421 DisablePriorityBoost
: BOOL
);
422 pragma Import
(Stdcall
, SetThreadPriorityBoost
, "SetThreadPriorityBoost");
424 Normal_Priority_Class
: constant := 16#
00000020#
;
425 Idle_Priority_Class
: constant := 16#
00000040#
;
426 High_Priority_Class
: constant := 16#
00000080#
;
427 Realtime_Priority_Class
: constant := 16#
00000100#
;
429 Thread_Priority_Idle
: constant := -15;
430 Thread_Priority_Lowest
: constant := -2;
431 Thread_Priority_Below_Normal
: constant := -1;
432 Thread_Priority_Normal
: constant := 0;
433 Thread_Priority_Above_Normal
: constant := 1;
434 Thread_Priority_Highest
: constant := 2;
435 Thread_Priority_Time_Critical
: constant := 15;
436 Thread_Priority_Error_Return
: constant := Interfaces
.C
.long
'Last;
438 function GetLastError
return DWORD
;
439 pragma Import
(Stdcall
, GetLastError
, "GetLastError");
443 type sigset_t
is new Interfaces
.C
.unsigned_long
;
445 type CRITICAL_SECTION
is record
446 DebugInfo
: System
.Address
;
447 -- The following three fields control entering and
448 -- exiting the critical section for the resource
449 LockCount
: Long_Integer;
450 RecursionCount
: Long_Integer;
451 OwningThread
: HANDLE
;
452 LockSemaphore
: HANDLE
;
456 end System
.OS_Interface
;