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 function GetExitCodeThread
272 pExitCode
: PDWORD
) return BOOL
;
273 pragma Import
(Stdcall
, GetExitCodeThread
, "GetExitCodeThread");
275 function ResumeThread
(hThread
: HANDLE
) return DWORD
;
276 pragma Import
(Stdcall
, ResumeThread
, "ResumeThread");
278 function SuspendThread
(hThread
: HANDLE
) return DWORD
;
279 pragma Import
(Stdcall
, SuspendThread
, "SuspendThread");
281 procedure ExitThread
(dwExitCode
: DWORD
);
282 pragma Import
(Stdcall
, ExitThread
, "ExitThread");
284 procedure EndThreadEx
(dwExitCode
: DWORD
);
285 pragma Import
(C
, EndThreadEx
, "_endthreadex");
287 function TerminateThread
289 dwExitCode
: DWORD
) return BOOL
;
290 pragma Import
(Stdcall
, TerminateThread
, "TerminateThread");
292 function GetCurrentThread
return HANDLE
;
293 pragma Import
(Stdcall
, GetCurrentThread
, "GetCurrentThread");
295 function GetCurrentProcess
return HANDLE
;
296 pragma Import
(Stdcall
, GetCurrentProcess
, "GetCurrentProcess");
298 function GetCurrentThreadId
return DWORD
;
299 pragma Import
(Stdcall
, GetCurrentThreadId
, "GetCurrentThreadId");
301 function TlsAlloc
return DWORD
;
302 pragma Import
(Stdcall
, TlsAlloc
, "TlsAlloc");
304 function TlsGetValue
(dwTlsIndex
: DWORD
) return PVOID
;
305 pragma Import
(Stdcall
, TlsGetValue
, "TlsGetValue");
307 function TlsSetValue
(dwTlsIndex
: DWORD
; pTlsValue
: PVOID
) return BOOL
;
308 pragma Import
(Stdcall
, TlsSetValue
, "TlsSetValue");
310 function TlsFree
(dwTlsIndex
: DWORD
) return BOOL
;
311 pragma Import
(Stdcall
, TlsFree
, "TlsFree");
313 TLS_Nothing
: constant := DWORD
'Last;
315 procedure ExitProcess
(uExitCode
: Interfaces
.C
.unsigned
);
316 pragma Import
(Stdcall
, ExitProcess
, "ExitProcess");
318 function WaitForSingleObject
320 dwMilliseconds
: DWORD
) return DWORD
;
321 pragma Import
(Stdcall
, WaitForSingleObject
, "WaitForSingleObject");
323 function WaitForSingleObjectEx
325 dwMilliseconds
: DWORD
;
326 fAlertable
: BOOL
) return DWORD
;
327 pragma Import
(Stdcall
, WaitForSingleObjectEx
, "WaitForSingleObjectEx");
329 Wait_Infinite
: constant := DWORD
'Last;
330 WAIT_TIMEOUT
: constant := 16#
0000_0102#
;
331 WAIT_FAILED
: constant := 16#FFFF_FFFF#
;
333 ------------------------------------
334 -- Semaphores, Events and Mutexes --
335 ------------------------------------
337 function CloseHandle
(hObject
: HANDLE
) return BOOL
;
338 pragma Import
(Stdcall
, CloseHandle
, "CloseHandle");
340 function CreateSemaphore
341 (pSemaphoreAttributes
: PSECURITY_ATTRIBUTES
;
342 lInitialCount
: Interfaces
.C
.long
;
343 lMaximumCount
: Interfaces
.C
.long
;
344 pName
: PSZ
) return HANDLE
;
345 pragma Import
(Stdcall
, CreateSemaphore
, "CreateSemaphoreA");
347 function OpenSemaphore
348 (dwDesiredAccess
: DWORD
;
349 bInheritHandle
: BOOL
;
350 pName
: PSZ
) return HANDLE
;
351 pragma Import
(Stdcall
, OpenSemaphore
, "OpenSemaphoreA");
353 function ReleaseSemaphore
354 (hSemaphore
: HANDLE
;
355 lReleaseCount
: Interfaces
.C
.long
;
356 pPreviousCount
: PLONG
) return BOOL
;
357 pragma Import
(Stdcall
, ReleaseSemaphore
, "ReleaseSemaphore");
360 (pEventAttributes
: PSECURITY_ATTRIBUTES
;
362 bInitialState
: BOOL
;
363 pName
: PSZ
) return HANDLE
;
364 pragma Import
(Stdcall
, CreateEvent
, "CreateEventA");
367 (dwDesiredAccess
: DWORD
;
368 bInheritHandle
: BOOL
;
369 pName
: PSZ
) return HANDLE
;
370 pragma Import
(Stdcall
, OpenEvent
, "OpenEventA");
372 function SetEvent
(hEvent
: HANDLE
) return BOOL
;
373 pragma Import
(Stdcall
, SetEvent
, "SetEvent");
375 function ResetEvent
(hEvent
: HANDLE
) return BOOL
;
376 pragma Import
(Stdcall
, ResetEvent
, "ResetEvent");
378 function PulseEvent
(hEvent
: HANDLE
) return BOOL
;
379 pragma Import
(Stdcall
, PulseEvent
, "PulseEvent");
382 (pMutexAttributes
: PSECURITY_ATTRIBUTES
;
383 bInitialOwner
: BOOL
;
384 pName
: PSZ
) return HANDLE
;
385 pragma Import
(Stdcall
, CreateMutex
, "CreateMutexA");
388 (dwDesiredAccess
: DWORD
;
389 bInheritHandle
: BOOL
;
390 pName
: PSZ
) return HANDLE
;
391 pragma Import
(Stdcall
, OpenMutex
, "OpenMutexA");
393 function ReleaseMutex
(hMutex
: HANDLE
) return BOOL
;
394 pragma Import
(Stdcall
, ReleaseMutex
, "ReleaseMutex");
396 ---------------------------------------------------
397 -- Accessing properties of Threads and Processes --
398 ---------------------------------------------------
404 function SetThreadPriority
406 nPriority
: Interfaces
.C
.int
) return BOOL
;
407 pragma Import
(Stdcall
, SetThreadPriority
, "SetThreadPriority");
409 function GetThreadPriority
(hThread
: HANDLE
) return Interfaces
.C
.int
;
410 pragma Import
(Stdcall
, GetThreadPriority
, "GetThreadPriority");
412 function SetPriorityClass
414 dwPriorityClass
: DWORD
) return BOOL
;
415 pragma Import
(Stdcall
, SetPriorityClass
, "SetPriorityClass");
417 procedure SetThreadPriorityBoost
419 DisablePriorityBoost
: BOOL
);
420 pragma Import
(Stdcall
, SetThreadPriorityBoost
, "SetThreadPriorityBoost");
422 Normal_Priority_Class
: constant := 16#
00000020#
;
423 Idle_Priority_Class
: constant := 16#
00000040#
;
424 High_Priority_Class
: constant := 16#
00000080#
;
425 Realtime_Priority_Class
: constant := 16#
00000100#
;
427 Thread_Priority_Idle
: constant := -15;
428 Thread_Priority_Lowest
: constant := -2;
429 Thread_Priority_Below_Normal
: constant := -1;
430 Thread_Priority_Normal
: constant := 0;
431 Thread_Priority_Above_Normal
: constant := 1;
432 Thread_Priority_Highest
: constant := 2;
433 Thread_Priority_Time_Critical
: constant := 15;
434 Thread_Priority_Error_Return
: constant := Interfaces
.C
.long
'Last;
436 function GetLastError
return DWORD
;
437 pragma Import
(Stdcall
, GetLastError
, "GetLastError");
441 type sigset_t
is new Interfaces
.C
.unsigned_long
;
443 type CRITICAL_SECTION
is record
444 DebugInfo
: System
.Address
;
445 -- The following three fields control entering and
446 -- exiting the critical section for the resource
447 LockCount
: Long_Integer;
448 RecursionCount
: Long_Integer;
449 OwningThread
: HANDLE
;
450 LockSemaphore
: HANDLE
;
454 end System
.OS_Interface
;