1 ------------------------------------------------------------------------------
3 -- GNU ADA 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-2004, 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, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, 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;
201 type PCRITICAL_SECTION
is access all CRITICAL_SECTION
;
203 procedure InitializeCriticalSection
(pCriticalSection
: PCRITICAL_SECTION
);
205 (Stdcall
, InitializeCriticalSection
, "InitializeCriticalSection");
207 procedure EnterCriticalSection
(pCriticalSection
: PCRITICAL_SECTION
);
208 pragma Import
(Stdcall
, EnterCriticalSection
, "EnterCriticalSection");
210 procedure LeaveCriticalSection
(pCriticalSection
: PCRITICAL_SECTION
);
211 pragma Import
(Stdcall
, LeaveCriticalSection
, "LeaveCriticalSection");
213 procedure DeleteCriticalSection
(pCriticalSection
: PCRITICAL_SECTION
);
214 pragma Import
(Stdcall
, DeleteCriticalSection
, "DeleteCriticalSection");
216 -------------------------------------------------------------
217 -- Thread Creation, Activation, Suspension And Termination --
218 -------------------------------------------------------------
220 type PTHREAD_START_ROUTINE
is access function
221 (pThreadParameter
: PVOID
) return DWORD
;
222 pragma Convention
(Stdcall
, PTHREAD_START_ROUTINE
);
224 function To_PTHREAD_START_ROUTINE
is new
225 Unchecked_Conversion
(System
.Address
, PTHREAD_START_ROUTINE
);
227 type SECURITY_ATTRIBUTES
is record
229 pSecurityDescriptor
: PVOID
;
230 bInheritHandle
: BOOL
;
233 type PSECURITY_ATTRIBUTES
is access all SECURITY_ATTRIBUTES
;
235 function CreateThread
236 (pThreadAttributes
: PSECURITY_ATTRIBUTES
;
238 pStartAddress
: PTHREAD_START_ROUTINE
;
240 dwCreationFlags
: DWORD
;
241 pThreadId
: PDWORD
) return HANDLE
;
242 pragma Import
(Stdcall
, CreateThread
, "CreateThread");
244 function BeginThreadEx
245 (pThreadAttributes
: PSECURITY_ATTRIBUTES
;
247 pStartAddress
: PTHREAD_START_ROUTINE
;
249 dwCreationFlags
: DWORD
;
250 pThreadId
: PDWORD
) return HANDLE
;
251 pragma Import
(C
, BeginThreadEx
, "_beginthreadex");
253 Debug_Process
: constant := 16#
00000001#
;
254 Debug_Only_This_Process
: constant := 16#
00000002#
;
255 Create_Suspended
: constant := 16#
00000004#
;
256 Detached_Process
: constant := 16#
00000008#
;
257 Create_New_Console
: constant := 16#
00000010#
;
259 Create_New_Process_Group
: constant := 16#
00000200#
;
261 Create_No_window
: constant := 16#
08000000#
;
263 Profile_User
: constant := 16#
10000000#
;
264 Profile_Kernel
: constant := 16#
20000000#
;
265 Profile_Server
: constant := 16#
40000000#
;
267 function GetExitCodeThread
269 pExitCode
: PDWORD
) return BOOL
;
270 pragma Import
(Stdcall
, GetExitCodeThread
, "GetExitCodeThread");
272 function ResumeThread
(hThread
: HANDLE
) return DWORD
;
273 pragma Import
(Stdcall
, ResumeThread
, "ResumeThread");
275 function SuspendThread
(hThread
: HANDLE
) return DWORD
;
276 pragma Import
(Stdcall
, SuspendThread
, "SuspendThread");
278 procedure ExitThread
(dwExitCode
: DWORD
);
279 pragma Import
(Stdcall
, ExitThread
, "ExitThread");
281 procedure EndThreadEx
(dwExitCode
: DWORD
);
282 pragma Import
(C
, EndThreadEx
, "_endthreadex");
284 function TerminateThread
286 dwExitCode
: DWORD
) return BOOL
;
287 pragma Import
(Stdcall
, TerminateThread
, "TerminateThread");
289 function GetCurrentThread
return HANDLE
;
290 pragma Import
(Stdcall
, GetCurrentThread
, "GetCurrentThread");
292 function GetCurrentProcess
return HANDLE
;
293 pragma Import
(Stdcall
, GetCurrentProcess
, "GetCurrentProcess");
295 function GetCurrentThreadId
return DWORD
;
296 pragma Import
(Stdcall
, GetCurrentThreadId
, "GetCurrentThreadId");
298 function TlsAlloc
return DWORD
;
299 pragma Import
(Stdcall
, TlsAlloc
, "TlsAlloc");
301 function TlsGetValue
(dwTlsIndex
: DWORD
) return PVOID
;
302 pragma Import
(Stdcall
, TlsGetValue
, "TlsGetValue");
304 function TlsSetValue
(dwTlsIndex
: DWORD
; pTlsValue
: PVOID
) return BOOL
;
305 pragma Import
(Stdcall
, TlsSetValue
, "TlsSetValue");
307 function TlsFree
(dwTlsIndex
: DWORD
) return BOOL
;
308 pragma Import
(Stdcall
, TlsFree
, "TlsFree");
310 TLS_Nothing
: constant := DWORD
'Last;
312 procedure ExitProcess
(uExitCode
: Interfaces
.C
.unsigned
);
313 pragma Import
(Stdcall
, ExitProcess
, "ExitProcess");
315 function WaitForSingleObject
317 dwMilliseconds
: DWORD
) return DWORD
;
318 pragma Import
(Stdcall
, WaitForSingleObject
, "WaitForSingleObject");
320 function WaitForSingleObjectEx
322 dwMilliseconds
: DWORD
;
323 fAlertable
: BOOL
) return DWORD
;
324 pragma Import
(Stdcall
, WaitForSingleObjectEx
, "WaitForSingleObjectEx");
326 Wait_Infinite
: constant := DWORD
'Last;
327 WAIT_TIMEOUT
: constant := 16#
0000_0102#
;
328 WAIT_FAILED
: constant := 16#FFFF_FFFF#
;
330 ------------------------------------
331 -- Semaphores, Events and Mutexes --
332 ------------------------------------
334 function CloseHandle
(hObject
: HANDLE
) return BOOL
;
335 pragma Import
(Stdcall
, CloseHandle
, "CloseHandle");
337 function CreateSemaphore
338 (pSemaphoreAttributes
: PSECURITY_ATTRIBUTES
;
339 lInitialCount
: Interfaces
.C
.long
;
340 lMaximumCount
: Interfaces
.C
.long
;
341 pName
: PSZ
) return HANDLE
;
342 pragma Import
(Stdcall
, CreateSemaphore
, "CreateSemaphoreA");
344 function OpenSemaphore
345 (dwDesiredAccess
: DWORD
;
346 bInheritHandle
: BOOL
;
347 pName
: PSZ
) return HANDLE
;
348 pragma Import
(Stdcall
, OpenSemaphore
, "OpenSemaphoreA");
350 function ReleaseSemaphore
351 (hSemaphore
: HANDLE
;
352 lReleaseCount
: Interfaces
.C
.long
;
353 pPreviousCount
: PLONG
) return BOOL
;
354 pragma Import
(Stdcall
, ReleaseSemaphore
, "ReleaseSemaphore");
357 (pEventAttributes
: PSECURITY_ATTRIBUTES
;
359 bInitialState
: BOOL
;
360 pName
: PSZ
) return HANDLE
;
361 pragma Import
(Stdcall
, CreateEvent
, "CreateEventA");
364 (dwDesiredAccess
: DWORD
;
365 bInheritHandle
: BOOL
;
366 pName
: PSZ
) return HANDLE
;
367 pragma Import
(Stdcall
, OpenEvent
, "OpenEventA");
369 function SetEvent
(hEvent
: HANDLE
) return BOOL
;
370 pragma Import
(Stdcall
, SetEvent
, "SetEvent");
372 function ResetEvent
(hEvent
: HANDLE
) return BOOL
;
373 pragma Import
(Stdcall
, ResetEvent
, "ResetEvent");
375 function PulseEvent
(hEvent
: HANDLE
) return BOOL
;
376 pragma Import
(Stdcall
, PulseEvent
, "PulseEvent");
379 (pMutexAttributes
: PSECURITY_ATTRIBUTES
;
380 bInitialOwner
: BOOL
;
381 pName
: PSZ
) return HANDLE
;
382 pragma Import
(Stdcall
, CreateMutex
, "CreateMutexA");
385 (dwDesiredAccess
: DWORD
;
386 bInheritHandle
: BOOL
;
387 pName
: PSZ
) return HANDLE
;
388 pragma Import
(Stdcall
, OpenMutex
, "OpenMutexA");
390 function ReleaseMutex
(hMutex
: HANDLE
) return BOOL
;
391 pragma Import
(Stdcall
, ReleaseMutex
, "ReleaseMutex");
393 ---------------------------------------------------
394 -- Accessing properties of Threads and Processes --
395 ---------------------------------------------------
401 function SetThreadPriority
403 nPriority
: Interfaces
.C
.int
) return BOOL
;
404 pragma Import
(Stdcall
, SetThreadPriority
, "SetThreadPriority");
406 function GetThreadPriority
(hThread
: HANDLE
) return Interfaces
.C
.int
;
407 pragma Import
(Stdcall
, GetThreadPriority
, "GetThreadPriority");
409 function SetPriorityClass
411 dwPriorityClass
: DWORD
) return BOOL
;
412 pragma Import
(Stdcall
, SetPriorityClass
, "SetPriorityClass");
414 procedure SetThreadPriorityBoost
416 DisablePriorityBoost
: BOOL
);
417 pragma Import
(Stdcall
, SetThreadPriorityBoost
, "SetThreadPriorityBoost");
419 Normal_Priority_Class
: constant := 16#
00000020#
;
420 Idle_Priority_Class
: constant := 16#
00000040#
;
421 High_Priority_Class
: constant := 16#
00000080#
;
422 Realtime_Priority_Class
: constant := 16#
00000100#
;
424 Thread_Priority_Idle
: constant := -15;
425 Thread_Priority_Lowest
: constant := -2;
426 Thread_Priority_Below_Normal
: constant := -1;
427 Thread_Priority_Normal
: constant := 0;
428 Thread_Priority_Above_Normal
: constant := 1;
429 Thread_Priority_Highest
: constant := 2;
430 Thread_Priority_Time_Critical
: constant := 15;
431 Thread_Priority_Error_Return
: constant := Interfaces
.C
.long
'Last;
433 function GetLastError
return DWORD
;
434 pragma Import
(Stdcall
, GetLastError
, "GetLastError");
438 type sigset_t
is new Interfaces
.C
.unsigned_long
;
440 type CRITICAL_SECTION
is record
441 DebugInfo
: System
.Address
;
442 -- The following three fields control entering and
443 -- exiting the critical section for the resource
444 LockCount
: Long_Integer;
445 RecursionCount
: Long_Integer;
446 OwningThread
: HANDLE
;
447 LockSemaphore
: HANDLE
;
451 end System
.OS_Interface
;