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-2006, 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
;
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;
102 Max_Interrupt
: constant := 31;
103 type Signal
is new int
range 0 .. Max_Interrupt
;
104 for Signal
'Size use int
'Size;
106 SIGINT
: constant := 2; -- interrupt (Ctrl-C)
107 SIGILL
: constant := 4; -- illegal instruction (not reset)
108 SIGFPE
: constant := 8; -- floating point exception
109 SIGSEGV
: constant := 11; -- segmentation violation
110 SIGTERM
: constant := 15; -- software termination signal from kill
111 SIGBREAK
: constant := 21; -- break (Ctrl-Break)
112 SIGABRT
: constant := 22; -- used by abort, replace SIGIOT in the future
114 type sigset_t
is private;
116 type isr_address
is access procedure (sig
: int
);
118 function intr_attach
(sig
: int
; handler
: isr_address
) return long
;
119 pragma Import
(C
, intr_attach
, "signal");
121 Intr_Attach_Reset
: constant Boolean := True;
122 -- True if intr_attach is reset after an interrupt handler is called
124 procedure kill
(sig
: Signal
);
125 pragma Import
(C
, kill
, "raise");
127 ---------------------
128 -- Time Management --
129 ---------------------
131 procedure Sleep
(dwMilliseconds
: DWORD
);
132 pragma Import
(Stdcall
, Sleep
, External_Name
=> "Sleep");
134 type SYSTEMTIME
is record
142 wMilliseconds
: WORD
;
145 procedure GetSystemTime
(pSystemTime
: access SYSTEMTIME
);
146 pragma Import
(Stdcall
, GetSystemTime
, "GetSystemTime");
148 procedure GetSystemTimeAsFileTime
(lpFileTime
: access Long_Long_Integer);
149 pragma Import
(Stdcall
, GetSystemTimeAsFileTime
, "GetSystemTimeAsFileTime");
151 function SetSystemTime
(pSystemTime
: access SYSTEMTIME
) return BOOL
;
152 pragma Import
(Stdcall
, SetSystemTime
, "SetSystemTime");
154 function FileTimeToSystemTime
155 (lpFileTime
: access Long_Long_Integer;
156 lpSystemTime
: access SYSTEMTIME
) return BOOL
;
157 pragma Import
(Stdcall
, FileTimeToSystemTime
, "FileTimeToSystemTime");
159 function SystemTimeToFileTime
160 (lpSystemTime
: access SYSTEMTIME
;
161 lpFileTime
: access Long_Long_Integer) return BOOL
;
162 pragma Import
(Stdcall
, SystemTimeToFileTime
, "SystemTimeToFileTime");
164 function FileTimeToLocalFileTime
165 (lpFileTime
: access Long_Long_Integer;
166 lpLocalFileTime
: access Long_Long_Integer) return BOOL
;
167 pragma Import
(Stdcall
, FileTimeToLocalFileTime
, "FileTimeToLocalFileTime");
169 function LocalFileTimeToFileTime
170 (lpFileTime
: access Long_Long_Integer;
171 lpLocalFileTime
: access Long_Long_Integer) return BOOL
;
172 pragma Import
(Stdcall
, LocalFileTimeToFileTime
, "LocalFileTimeToFileTime");
174 function QueryPerformanceCounter
175 (lpPerformanceCount
: access LARGE_INTEGER
) return BOOL
;
177 (Stdcall
, QueryPerformanceCounter
, "QueryPerformanceCounter");
179 function QueryPerformanceFrequency
180 (lpFrequency
: access LARGE_INTEGER
) return BOOL
;
182 (Stdcall
, QueryPerformanceFrequency
, "QueryPerformanceFrequency");
188 type Thread_Body
is access
189 function (arg
: System
.Address
) return System
.Address
;
191 function Thread_Body_Access
is new
192 Unchecked_Conversion
(System
.Address
, Thread_Body
);
194 procedure SwitchToThread
;
195 pragma Import
(Stdcall
, SwitchToThread
, "SwitchToThread");
197 -----------------------
198 -- Critical sections --
199 -----------------------
201 type CRITICAL_SECTION
is private;
203 procedure InitializeCriticalSection
204 (pCriticalSection
: access CRITICAL_SECTION
);
206 (Stdcall
, InitializeCriticalSection
, "InitializeCriticalSection");
208 procedure EnterCriticalSection
209 (pCriticalSection
: access CRITICAL_SECTION
);
210 pragma Import
(Stdcall
, EnterCriticalSection
, "EnterCriticalSection");
212 procedure LeaveCriticalSection
213 (pCriticalSection
: access CRITICAL_SECTION
);
214 pragma Import
(Stdcall
, LeaveCriticalSection
, "LeaveCriticalSection");
216 procedure DeleteCriticalSection
217 (pCriticalSection
: access CRITICAL_SECTION
);
218 pragma Import
(Stdcall
, DeleteCriticalSection
, "DeleteCriticalSection");
220 -------------------------------------------------------------
221 -- Thread Creation, Activation, Suspension And Termination --
222 -------------------------------------------------------------
224 type PTHREAD_START_ROUTINE
is access function
225 (pThreadParameter
: PVOID
) return DWORD
;
226 pragma Convention
(Stdcall
, PTHREAD_START_ROUTINE
);
228 function To_PTHREAD_START_ROUTINE
is new
229 Unchecked_Conversion
(System
.Address
, PTHREAD_START_ROUTINE
);
231 type SECURITY_ATTRIBUTES
is record
233 pSecurityDescriptor
: PVOID
;
234 bInheritHandle
: BOOL
;
237 type PSECURITY_ATTRIBUTES
is access all SECURITY_ATTRIBUTES
;
239 function CreateThread
240 (pThreadAttributes
: PSECURITY_ATTRIBUTES
;
242 pStartAddress
: PTHREAD_START_ROUTINE
;
244 dwCreationFlags
: DWORD
;
245 pThreadId
: PDWORD
) return HANDLE
;
246 pragma Import
(Stdcall
, CreateThread
, "CreateThread");
248 function BeginThreadEx
249 (pThreadAttributes
: PSECURITY_ATTRIBUTES
;
251 pStartAddress
: PTHREAD_START_ROUTINE
;
253 dwCreationFlags
: DWORD
;
254 pThreadId
: PDWORD
) return HANDLE
;
255 pragma Import
(C
, BeginThreadEx
, "_beginthreadex");
257 Debug_Process
: constant := 16#
00000001#
;
258 Debug_Only_This_Process
: constant := 16#
00000002#
;
259 Create_Suspended
: constant := 16#
00000004#
;
260 Detached_Process
: constant := 16#
00000008#
;
261 Create_New_Console
: constant := 16#
00000010#
;
263 Create_New_Process_Group
: constant := 16#
00000200#
;
265 Create_No_window
: constant := 16#
08000000#
;
267 Profile_User
: constant := 16#
10000000#
;
268 Profile_Kernel
: constant := 16#
20000000#
;
269 Profile_Server
: constant := 16#
40000000#
;
271 Stack_Size_Param_Is_A_Reservation
: constant := 16#
00010000#
;
273 function GetExitCodeThread
275 pExitCode
: PDWORD
) return BOOL
;
276 pragma Import
(Stdcall
, GetExitCodeThread
, "GetExitCodeThread");
278 function ResumeThread
(hThread
: HANDLE
) return DWORD
;
279 pragma Import
(Stdcall
, ResumeThread
, "ResumeThread");
281 function SuspendThread
(hThread
: HANDLE
) return DWORD
;
282 pragma Import
(Stdcall
, SuspendThread
, "SuspendThread");
284 procedure ExitThread
(dwExitCode
: DWORD
);
285 pragma Import
(Stdcall
, ExitThread
, "ExitThread");
287 procedure EndThreadEx
(dwExitCode
: DWORD
);
288 pragma Import
(C
, EndThreadEx
, "_endthreadex");
290 function TerminateThread
292 dwExitCode
: DWORD
) return BOOL
;
293 pragma Import
(Stdcall
, TerminateThread
, "TerminateThread");
295 function GetCurrentThread
return HANDLE
;
296 pragma Import
(Stdcall
, GetCurrentThread
, "GetCurrentThread");
298 function GetCurrentProcess
return HANDLE
;
299 pragma Import
(Stdcall
, GetCurrentProcess
, "GetCurrentProcess");
301 function GetCurrentThreadId
return DWORD
;
302 pragma Import
(Stdcall
, GetCurrentThreadId
, "GetCurrentThreadId");
304 function TlsAlloc
return DWORD
;
305 pragma Import
(Stdcall
, TlsAlloc
, "TlsAlloc");
307 function TlsGetValue
(dwTlsIndex
: DWORD
) return PVOID
;
308 pragma Import
(Stdcall
, TlsGetValue
, "TlsGetValue");
310 function TlsSetValue
(dwTlsIndex
: DWORD
; pTlsValue
: PVOID
) return BOOL
;
311 pragma Import
(Stdcall
, TlsSetValue
, "TlsSetValue");
313 function TlsFree
(dwTlsIndex
: DWORD
) return BOOL
;
314 pragma Import
(Stdcall
, TlsFree
, "TlsFree");
316 TLS_Nothing
: constant := DWORD
'Last;
318 procedure ExitProcess
(uExitCode
: Interfaces
.C
.unsigned
);
319 pragma Import
(Stdcall
, ExitProcess
, "ExitProcess");
321 function WaitForSingleObject
323 dwMilliseconds
: DWORD
) return DWORD
;
324 pragma Import
(Stdcall
, WaitForSingleObject
, "WaitForSingleObject");
326 function WaitForSingleObjectEx
328 dwMilliseconds
: DWORD
;
329 fAlertable
: BOOL
) return DWORD
;
330 pragma Import
(Stdcall
, WaitForSingleObjectEx
, "WaitForSingleObjectEx");
332 Wait_Infinite
: constant := DWORD
'Last;
333 WAIT_TIMEOUT
: constant := 16#
0000_0102#
;
334 WAIT_FAILED
: constant := 16#FFFF_FFFF#
;
336 ------------------------------------
337 -- Semaphores, Events and Mutexes --
338 ------------------------------------
340 function CloseHandle
(hObject
: HANDLE
) return BOOL
;
341 pragma Import
(Stdcall
, CloseHandle
, "CloseHandle");
343 function CreateSemaphore
344 (pSemaphoreAttributes
: PSECURITY_ATTRIBUTES
;
345 lInitialCount
: Interfaces
.C
.long
;
346 lMaximumCount
: Interfaces
.C
.long
;
347 pName
: PSZ
) return HANDLE
;
348 pragma Import
(Stdcall
, CreateSemaphore
, "CreateSemaphoreA");
350 function OpenSemaphore
351 (dwDesiredAccess
: DWORD
;
352 bInheritHandle
: BOOL
;
353 pName
: PSZ
) return HANDLE
;
354 pragma Import
(Stdcall
, OpenSemaphore
, "OpenSemaphoreA");
356 function ReleaseSemaphore
357 (hSemaphore
: HANDLE
;
358 lReleaseCount
: Interfaces
.C
.long
;
359 pPreviousCount
: PLONG
) return BOOL
;
360 pragma Import
(Stdcall
, ReleaseSemaphore
, "ReleaseSemaphore");
363 (pEventAttributes
: PSECURITY_ATTRIBUTES
;
365 bInitialState
: BOOL
;
366 pName
: PSZ
) return HANDLE
;
367 pragma Import
(Stdcall
, CreateEvent
, "CreateEventA");
370 (dwDesiredAccess
: DWORD
;
371 bInheritHandle
: BOOL
;
372 pName
: PSZ
) return HANDLE
;
373 pragma Import
(Stdcall
, OpenEvent
, "OpenEventA");
375 function SetEvent
(hEvent
: HANDLE
) return BOOL
;
376 pragma Import
(Stdcall
, SetEvent
, "SetEvent");
378 function ResetEvent
(hEvent
: HANDLE
) return BOOL
;
379 pragma Import
(Stdcall
, ResetEvent
, "ResetEvent");
381 function PulseEvent
(hEvent
: HANDLE
) return BOOL
;
382 pragma Import
(Stdcall
, PulseEvent
, "PulseEvent");
385 (pMutexAttributes
: PSECURITY_ATTRIBUTES
;
386 bInitialOwner
: BOOL
;
387 pName
: PSZ
) return HANDLE
;
388 pragma Import
(Stdcall
, CreateMutex
, "CreateMutexA");
391 (dwDesiredAccess
: DWORD
;
392 bInheritHandle
: BOOL
;
393 pName
: PSZ
) return HANDLE
;
394 pragma Import
(Stdcall
, OpenMutex
, "OpenMutexA");
396 function ReleaseMutex
(hMutex
: HANDLE
) return BOOL
;
397 pragma Import
(Stdcall
, ReleaseMutex
, "ReleaseMutex");
399 ---------------------------------------------------
400 -- Accessing properties of Threads and Processes --
401 ---------------------------------------------------
407 function SetThreadPriority
409 nPriority
: Interfaces
.C
.int
) return BOOL
;
410 pragma Import
(Stdcall
, SetThreadPriority
, "SetThreadPriority");
412 function GetThreadPriority
(hThread
: HANDLE
) return Interfaces
.C
.int
;
413 pragma Import
(Stdcall
, GetThreadPriority
, "GetThreadPriority");
415 function SetPriorityClass
417 dwPriorityClass
: DWORD
) return BOOL
;
418 pragma Import
(Stdcall
, SetPriorityClass
, "SetPriorityClass");
420 procedure SetThreadPriorityBoost
422 DisablePriorityBoost
: BOOL
);
423 pragma Import
(Stdcall
, SetThreadPriorityBoost
, "SetThreadPriorityBoost");
425 Normal_Priority_Class
: constant := 16#
00000020#
;
426 Idle_Priority_Class
: constant := 16#
00000040#
;
427 High_Priority_Class
: constant := 16#
00000080#
;
428 Realtime_Priority_Class
: constant := 16#
00000100#
;
430 Thread_Priority_Idle
: constant := -15;
431 Thread_Priority_Lowest
: constant := -2;
432 Thread_Priority_Below_Normal
: constant := -1;
433 Thread_Priority_Normal
: constant := 0;
434 Thread_Priority_Above_Normal
: constant := 1;
435 Thread_Priority_Highest
: constant := 2;
436 Thread_Priority_Time_Critical
: constant := 15;
437 Thread_Priority_Error_Return
: constant := Interfaces
.C
.long
'Last;
439 function GetLastError
return DWORD
;
440 pragma Import
(Stdcall
, GetLastError
, "GetLastError");
444 type sigset_t
is new Interfaces
.C
.unsigned_long
;
446 type CRITICAL_SECTION
is record
447 DebugInfo
: System
.Address
;
448 -- The following three fields control entering and
449 -- exiting the critical section for the resource
450 LockCount
: Long_Integer;
451 RecursionCount
: Long_Integer;
452 OwningThread
: HANDLE
;
453 LockSemaphore
: HANDLE
;
457 end System
.OS_Interface
;