* *
* C Implementation File *
* *
- * Copyright (C) 1992-2007, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2008, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
* *
****************************************************************************/
-/* This unit contains initialization circuits that are system dependent. A
- major part of the functionality involved involves stack overflow checking.
+/* This unit contains initialization circuits that are system dependent.
+ A major part of the functionality involves stack overflow checking.
The GCC backend generates probe instructions to test for stack overflow.
For details on the exact approach used to generate these probes, see the
"Using and Porting GCC" manual, in particular the "Stack Checking" section
- and the subsection "Specifying How Stack Checking is Done". The handlers
- installed by this file are used to handle resulting signals that come
- from these probes failing (i.e. touching protected pages) */
+ and the subsection "Specifying How Stack Checking is Done". The handlers
+ installed by this file are used to catch the resulting signals that come
+ from these probes failing (i.e. touching protected pages). */
/* This file should be kept synchronized with 2sinit.ads, 2sinit.adb,
- s-init-ae653-cert.adb and s-init-xi-sparc.adb. All these files implement
- the required functionality for different targets. */
+ s-init-ae653-cert.adb and s-init-xi-sparc.adb. All these files implement
+ the required functionality for different targets. */
/* The following include is here to meet the published VxWorks requirement
- that the __vxworks header appear before any other include. */
+ that the __vxworks header appear before any other include. */
#ifdef __vxworks
#include "vxWorks.h"
#endif
extern void __gnat_raise_program_error (const char *, int);
-/* Addresses of exception data blocks for predefined exceptions. Tasking_Error
- is not used in this unit, and the abort signal is only used on IRIX. */
+/* Addresses of exception data blocks for predefined exceptions. Tasking_Error
+ is not used in this unit, and the abort signal is only used on IRIX. */
extern struct Exception_Data constraint_error;
extern struct Exception_Data numeric_error;
extern struct Exception_Data program_error;
extern struct Exception_Data storage_error;
/* For the Cert run time we use the regular raise exception routine because
- Raise_From_Signal_Handler is not available. */
+ Raise_From_Signal_Handler is not available. */
#ifdef CERT
#define Raise_From_Signal_Handler \
__gnat_raise_exception
extern void Raise_From_Signal_Handler (struct Exception_Data *, const char *);
#endif
-/* Global values computed by the binder */
+/* Global values computed by the binder. */
int __gl_main_priority = -1;
int __gl_time_slice_val = -1;
char __gl_wc_encoding = 'n';
int __gl_leap_seconds_support = 0;
/* Indication of whether synchronous signal handler has already been
- installed by a previous call to adainit */
+ installed by a previous call to adainit. */
int __gnat_handler_installed = 0;
#ifndef IN_RTS
int __gnat_inside_elab_final_code = 0;
/* ??? This variable is obsolete since 2001-08-29 but is kept to allow
- bootstrap from old GNAT versions (< 3.15). */
+ bootstrap from old GNAT versions (< 3.15). */
#endif
/* HAVE_GNAT_INIT_FLOAT must be set on every targets where a __gnat_init_float
- is defined. If this is not set them a void implementation will be defined
- at the end of this unit. */
+ is defined. If this is not set then a void implementation will be defined
+ at the end of this unit. */
#undef HAVE_GNAT_INIT_FLOAT
/******************************/
/* This routine is called from the runtime as needed to determine the state
of an interrupt, as set by an Interrupt_State pragma appearing anywhere
- in the current partition. The input argument is the interrupt number,
+ in the current partition. The input argument is the interrupt number,
and the result is one of the following:
'n' this interrupt not set by any Interrupt_State pragma
'u' Interrupt_State pragma set state to User
'r' Interrupt_State pragma set state to Runtime
- 's' Interrupt_State pragma set state to System */
+ 's' Interrupt_State pragma set state to System */
char
__gnat_get_interrupt_state (int intrup)
char __gnat_get_specific_dispatching (int);
-/* This routine is called from the run time as needed to determine the
+/* This routine is called from the runtime as needed to determine the
priority specific dispatching policy, as set by a
Priority_Specific_Dispatching pragma appearing anywhere in the current
- partition. The input argument is the priority number, and the result is
- the upper case first character of the policy name, e.g. 'F' for
+ partition. The input argument is the priority number, and the result
+ is the upper case first character of the policy name, e.g. 'F' for
FIFO_Within_Priorities. A space ' ' is returned if no
- Priority_Specific_Dispatching pragma is used in the partition. */
+ Priority_Specific_Dispatching pragma is used in the partition. */
char
__gnat_get_specific_dispatching (int priority)
/**********************/
/* This routine is kept for bootstrapping purposes, since the binder generated
- file now sets the __gl_* variables directly. */
+ file now sets the __gl_* variables directly. */
void
__gnat_set_globals ()
#include <signal.h>
#include <sys/time.h>
-/* Some versions of AIX don't define SA_NODEFER. */
+/* Some versions of AIX don't define SA_NODEFER. */
#ifndef SA_NODEFER
#define SA_NODEFER 0
#endif /* SA_NODEFER */
/* Versions of AIX before 4.3 don't have nanosleep but provide
- nsleep instead. */
+ nsleep instead. */
#ifndef _AIXVERSION_430
switch (sig)
{
case SIGSEGV:
- /* FIXME: we need to detect the case of a *real* SIGSEGV */
+ /* FIXME: we need to detect the case of a *real* SIGSEGV. */
exception = &storage_error;
msg = "stack overflow or erroneous memory access";
break;
/* Set up signal handler to map synchronous signals to appropriate
exceptions. Make sure that the handler isn't interrupted by another
- signal that might cause a scheduling event! */
+ signal that might cause a scheduling event! */
act.sa_flags = SA_NODEFER | SA_RESTART | SA_SIGINFO;
act.sa_sigaction = __gnat_error_handler;
sigemptyset (&act.sa_mask);
- /* Do not install handlers if interrupt state is "System" */
+ /* Do not install handlers if interrupt state is "System". */
if (__gnat_get_interrupt_state (SIGABRT) != 's')
sigaction (SIGABRT, &act, NULL);
if (__gnat_get_interrupt_state (SIGFPE) != 's')
/* Setup signal handler to map synchronous signals to appropriate
exceptions. Make sure that the handler isn't interrupted by another
- signal that might cause a scheduling event! */
+ signal that might cause a scheduling event! */
act.sa_handler = (void (*) (int)) __gnat_error_handler;
act.sa_flags = SA_RESTART | SA_NODEFER | SA_SIGINFO;
sigemptyset (&act.sa_mask);
- /* Do not install handlers if interrupt state is "System" */
+ /* Do not install handlers if interrupt state is "System". */
if (__gnat_get_interrupt_state (SIGABRT) != 's')
sigaction (SIGABRT, &act, NULL);
if (__gnat_get_interrupt_state (SIGFPE) != 's')
switch (sig)
{
case SIGSEGV:
- /* FIXME: we need to detect the case of a *real* SIGSEGV */
+ /* FIXME: we need to detect the case of a *real* SIGSEGV. */
exception = &storage_error;
msg = "stack overflow or erroneous memory access";
break;
Raise_From_Signal_Handler (exception, msg);
}
+/* This must be in keeping with System.OS_Interface.Alternate_Stack_Size. */
+#if defined (__hppa__)
+char __gnat_alternate_stack[16 * 1024]; /* 2 * SIGSTKSZ */
+#else
+char __gnat_alternate_stack[128 * 1024]; /* MINSIGSTKSZ */
+#endif
+
void
__gnat_install_handler (void)
{
/* Set up signal handler to map synchronous signals to appropriate
exceptions. Make sure that the handler isn't interrupted by another
- signal that might cause a scheduling event! Also setup an alternate
+ signal that might cause a scheduling event! Also setup an alternate
stack region for the handler execution so that stack overflows can be
handled properly, avoiding a SEGV generation from stack usage by the
- handler itself. */
-
- static char handler_stack[SIGSTKSZ*2];
- /* SIGSTKSZ appeared to be "short" for the needs in some contexts
- (e.g. experiments with GCC ZCX exceptions). */
+ handler itself. */
stack_t stack;
-
- stack.ss_sp = handler_stack;
- stack.ss_size = sizeof (handler_stack);
+ stack.ss_sp = __gnat_alternate_stack;
+ stack.ss_size = sizeof (__gnat_alternate_stack);
stack.ss_flags = 0;
-
sigaltstack (&stack, NULL);
act.sa_sigaction = __gnat_error_handler;
- act.sa_flags = SA_NODEFER | SA_RESTART | SA_ONSTACK | SA_SIGINFO;
+ act.sa_flags = SA_NODEFER | SA_RESTART | SA_SIGINFO;
sigemptyset (&act.sa_mask);
- /* Do not install handlers if interrupt state is "System" */
+ /* Do not install handlers if interrupt state is "System". */
if (__gnat_get_interrupt_state (SIGABRT) != 's')
sigaction (SIGABRT, &act, NULL);
if (__gnat_get_interrupt_state (SIGFPE) != 's')
sigaction (SIGFPE, &act, NULL);
if (__gnat_get_interrupt_state (SIGILL) != 's')
sigaction (SIGILL, &act, NULL);
- if (__gnat_get_interrupt_state (SIGSEGV) != 's')
- sigaction (SIGSEGV, &act, NULL);
if (__gnat_get_interrupt_state (SIGBUS) != 's')
sigaction (SIGBUS, &act, NULL);
+ act.sa_flags |= SA_ONSTACK;
+ if (__gnat_get_interrupt_state (SIGSEGV) != 's')
+ sigaction (SIGSEGV, &act, NULL);
__gnat_handler_installed = 1;
}
#include <sys/ucontext.h>
/* GNU/Linux, which uses glibc, does not define NULL in included
- header files */
+ header files. */
#if !defined (NULL)
#define NULL ((void *) 0)
#if defined (MaRTE)
/* MaRTE OS provides its own version of sigaction, sigfillset, and
- sigemptyset (overriding these symbol names). We want to make sure that
+ sigemptyset (overriding these symbol names). We want to make sure that
the versions provided by the underlying C library are used here (these
versions are renamed by MaRTE to linux_sigaction, fake_linux_sigfillset,
- and fake_linux_sigemptyset, respectively). The MaRTE library will not
+ and fake_linux_sigemptyset, respectively). The MaRTE library will not
always be present (it will not be linked if no tasking constructs are
used), so we use the weak symbol mechanism to point always to the symbols
- defined within the C library. */
+ defined within the C library. */
#pragma weak linux_sigaction
int linux_sigaction (int signum, const struct sigaction *act,
{
mcontext_t *mcontext = &((ucontext_t *) ucontext)->uc_mcontext;
+ /* On the i386 and x86-64 architectures, stack checking is performed by
+ means of probes with moving stack pointer, that is to say the probed
+ address is always the value of the stack pointer. Upon hitting the
+ guard page, the stack pointer therefore points to an inaccessible
+ address and an alternate signal stack is needed to run the handler.
+ But there is an additional twist: on these architectures, the EH
+ return code writes the address of the handler at the target CFA's
+ value on the stack before doing the jump. As a consequence, if
+ there is an active handler in the frame whose stack has overflowed,
+ the stack pointer must nevertheless point to an accessible address
+ by the time the EH return is executed.
+
+ We therefore adjust the saved value of the stack pointer by the size
+ of one page, in order to make sure that it points to an accessible
+ address in case it's used as the target CFA. The stack checking code
+ guarantees that this page is unused by the time this happens. */
+
#if defined (i386)
+ unsigned long pattern = *(unsigned long *)mcontext->gregs[REG_EIP];
+ /* The pattern is "orl $0x0,(%esp)" for a probe in 32-bit mode. */
+ if (signo == SIGSEGV && pattern == 0x00240c83)
+ mcontext->gregs[REG_ESP] += 4096;
mcontext->gregs[REG_EIP]++;
#elif defined (__x86_64__)
+ unsigned long pattern = *(unsigned long *)mcontext->gregs[REG_RIP];
+ /* The pattern is "orq $0x0,(%rsp)" for a probe in 64-bit mode. */
+ if (signo == SIGSEGV && (pattern & 0xffffffffff) == 0x00240c8348)
+ mcontext->gregs[REG_RSP] += 4096;
mcontext->gregs[REG_RIP]++;
#elif defined (__ia64__)
mcontext->sc_ip++;
For now we simply do not attempt any discrimination at all. Note
that this is quite acceptable, since a "real" SIGSEGV can only
- occur as the result of an erroneous program */
+ occur as the result of an erroneous program. */
msg = "stack overflow (or erroneous memory access)";
exception = &storage_error;
/* We adjust the interrupted context here (and not in the
MD_FALLBACK_FRAME_STATE_FOR macro) because recent versions of the Native
- POSIX Thread Library (NPTL) are compiled with DWARF 2 unwind information,
- and hence the later macro is never executed for signal frames. */
+ POSIX Thread Library (NPTL) are compiled with DWARF-2 unwind information,
+ and hence the later macro is never executed for signal frames. */
__gnat_adjust_context_for_raise (sig, ucontext);
Raise_From_Signal_Handler (exception, msg);
}
+#if defined (i386) || defined (__x86_64__)
+/* This must be in keeping with System.OS_Interface.Alternate_Stack_Size. */
+char __gnat_alternate_stack[16 * 1024]; /* 2 * SIGSTKSZ */
+#endif
+
void
__gnat_install_handler (void)
{
/* Set up signal handler to map synchronous signals to appropriate
exceptions. Make sure that the handler isn't interrupted by another
- signal that might cause a scheduling event! */
+ signal that might cause a scheduling event! Also setup an alternate
+ stack region for the handler execution so that stack overflows can be
+ handled properly, avoiding a SEGV generation from stack usage by the
+ handler itself. */
+
+#if defined (i386) || defined (__x86_64__)
+ stack_t stack;
+ stack.ss_sp = __gnat_alternate_stack;
+ stack.ss_size = sizeof (__gnat_alternate_stack);
+ stack.ss_flags = 0;
+ sigaltstack (&stack, NULL);
+#endif
act.sa_sigaction = __gnat_error_handler;
act.sa_flags = SA_NODEFER | SA_RESTART | SA_SIGINFO;
sigemptyset (&act.sa_mask);
- /* Do not install handlers if interrupt state is "System" */
+ /* Do not install handlers if interrupt state is "System". */
if (__gnat_get_interrupt_state (SIGABRT) != 's')
sigaction (SIGABRT, &act, NULL);
if (__gnat_get_interrupt_state (SIGFPE) != 's')
sigaction (SIGFPE, &act, NULL);
if (__gnat_get_interrupt_state (SIGILL) != 's')
sigaction (SIGILL, &act, NULL);
- if (__gnat_get_interrupt_state (SIGSEGV) != 's')
- sigaction (SIGSEGV, &act, NULL);
if (__gnat_get_interrupt_state (SIGBUS) != 's')
sigaction (SIGBUS, &act, NULL);
+#if defined (i386) || defined (__x86_64__)
+ act.sa_flags |= SA_ONSTACK;
+#endif
+ if (__gnat_get_interrupt_state (SIGSEGV) != 's')
+ sigaction (SIGSEGV, &act, NULL);
__gnat_handler_installed = 1;
}
also the signal number but the second argument is the signal
code identifying the cause of the signal. The third argument
points to a sigcontext_t structure containing the receiving
- process's context when the signal was delivered.
-*/
+ process's context when the signal was delivered. */
static void
__gnat_error_handler (int sig, int code, sigcontext_t *sc ATTRIBUTE_UNUSED)
/* ??? Re-add smarts to further verify that we launched
the stack into a guard page, not an attempt to
- write to .text or something */
+ write to .text or something. */
exception = &storage_error;
msg = "SIGSEGV: (stack overflow or erroneous memory access)";
}
/* Just in case the OS guys did it to us again. Sometimes
they fail to document all of the valid codes that are
passed to signal handlers, just in case someone depends
- on knowing all the codes */
+ on knowing all the codes. */
exception = &program_error;
msg = "SIGSEGV: (Undocumented reason)";
}
break;
default:
- /* Everything else is a Program_Error. */
+ /* Everything else is a Program_Error. */
exception = &program_error;
msg = "unhandled signal";
}
/* Setup signal handler to map synchronous signals to appropriate
exceptions. Make sure that the handler isn't interrupted by another
- signal that might cause a scheduling event! */
+ signal that might cause a scheduling event! */
act.sa_handler = __gnat_error_handler;
act.sa_flags = SA_NODEFER + SA_RESTART;
sigfillset (&act.sa_mask);
sigemptyset (&act.sa_mask);
- /* Do not install handlers if interrupt state is "System" */
+ /* Do not install handlers if interrupt state is "System". */
if (__gnat_get_interrupt_state (SIGABRT) != 's')
sigaction (SIGABRT, &act, NULL);
if (__gnat_get_interrupt_state (SIGFPE) != 's')
__gnat_handler_installed = 1;
}
+/*******************/
+/* LynxOS Section */
+/*******************/
+
+#elif defined (__Lynx__)
+
+#include <signal.h>
+#include <unistd.h>
+
+static void
+__gnat_error_handler (int sig)
+{
+ struct Exception_Data *exception;
+ const char *msg;
+
+ switch(sig)
+ {
+ case SIGFPE:
+ exception = &constraint_error;
+ msg = "SIGFPE";
+ break;
+ case SIGILL:
+ exception = &constraint_error;
+ msg = "SIGILL";
+ break;
+ case SIGSEGV:
+ exception = &storage_error;
+ msg = "stack overflow or erroneous memory access";
+ break;
+ case SIGBUS:
+ exception = &constraint_error;
+ msg = "SIGBUS";
+ break;
+ default:
+ exception = &program_error;
+ msg = "unhandled signal";
+ }
+
+ Raise_From_Signal_Handler(exception, msg);
+}
+
+void
+__gnat_install_handler(void)
+{
+ struct sigaction act;
+
+ act.sa_handler = __gnat_error_handler;
+ act.sa_flags = 0x0;
+ sigemptyset (&act.sa_mask);
+
+ /* Do not install handlers if interrupt state is "System". */
+ if (__gnat_get_interrupt_state (SIGFPE) != 's')
+ sigaction (SIGFPE, &act, NULL);
+ if (__gnat_get_interrupt_state (SIGILL) != 's')
+ sigaction (SIGILL, &act, NULL);
+ if (__gnat_get_interrupt_state (SIGSEGV) != 's')
+ sigaction (SIGSEGV, &act, NULL);
+ if (__gnat_get_interrupt_state (SIGBUS) != 's')
+ sigaction (SIGBUS, &act, NULL);
+
+ __gnat_handler_installed = 1;
+}
+
/*******************/
/* Solaris Section */
/*******************/
#include <sys/ucontext.h>
#include <sys/regset.h>
-/* The code below is common to sparc and x86. Beware of the delay slot
+/* The code below is common to SPARC and x86. Beware of the delay slot
differences for signal context adjustments. */
#if defined (__sparc)
/* Likewise regarding how the "instruction pointer" register slot can
be identified in signal machine contexts. We have either "REG_PC"
- or "PC" at hand, depending on the target CPU and solaris version. */
+ or "PC" at hand, depending on the target CPU and Solaris version. */
#if !defined (REG_PC)
#define REG_PC PC
/* Set up signal handler to map synchronous signals to appropriate
exceptions. Make sure that the handler isn't interrupted by another
- signal that might cause a scheduling event! */
+ signal that might cause a scheduling event! */
act.sa_handler = __gnat_error_handler;
act.sa_flags = SA_NODEFER | SA_RESTART | SA_SIGINFO;
sigemptyset (&act.sa_mask);
- /* Do not install handlers if interrupt state is "System" */
+ /* Do not install handlers if interrupt state is "System". */
if (__gnat_get_interrupt_state (SIGABRT) != 's')
sigaction (SIGABRT, &act, NULL);
if (__gnat_get_interrupt_state (SIGFPE) != 's')
#if defined (IN_RTS) && !defined (__IA64)
-/* The prehandler actually gets control first on a condition. It swaps the
- stack pointer and calls the handler (__gnat_error_handler). */
+/* The prehandler actually gets control first on a condition. It swaps the
+ stack pointer and calls the handler (__gnat_error_handler). */
extern long __gnat_error_prehandler (void);
extern char *__gnat_error_prehandler_stack; /* Alternate signal stack */
/* Define macro symbols for the VMS conditions that become Ada exceptions.
Most of these are also defined in the header file ssdef.h which has not
- yet been converted to be recognized by Gnu C. */
+ yet been converted to be recognized by GNU C. */
/* Defining these as macros, as opposed to external addresses, allows
- them to be used in a case statement (below */
+ them to be used in a case statement below. */
#define SS$_ACCVIO 12
#define SS$_HPARITH 1284
#define SS$_STKOVF 1364
#define SS$_RESIGNAL 2328
-/* These codes are in standard message libraries */
+/* These codes are in standard message libraries. */
extern int CMA$_EXIT_THREAD;
extern int SS$_DEBUG;
extern int SS$_INTDIV;
/* These codes are non standard, which is to say the author is
not sure if they are defined in the standard message libraries
- so keep them as macros for now. */
+ so keep them as macros for now. */
#define RDB$_STREAM_EOF 20480426
#define FDL$_UNPRIKW 11829410
/* Conditions that don't have an Ada exception counterpart must raise
Non_Ada_Error. Since this is defined in s-auxdec, it should only be
- referenced by user programs, not the compiler or tools. Hence the
- #ifdef IN_RTS. */
+ referenced by user programs, not the compiler or tools. Hence the
+ #ifdef IN_RTS. */
#ifdef IN_RTS
extern Exception_Code Base_Code_In (Exception_Code);
/* DEC Ada exceptions are not defined in a header file, so they
- must be declared as external addresses */
+ must be declared as external addresses. */
extern int ADA$_PROGRAM_ERROR;
extern int ADA$_LOCK_ERROR;
extern int ADA$_MAXLINEXC;
extern int ADA$_LINEXCMRS;
-/* DEC Ada specific conditions */
+/* DEC Ada specific conditions. */
static const struct cond_except dec_ada_cond_except_table [] = {
{&ADA$_PROGRAM_ERROR, &program_error},
{&ADA$_USE_ERROR, &Use_Error},
#endif /* IN_RTS */
-/* Non DEC Ada specific conditions. We could probably also put
- SS$_HPARITH here and possibly SS$_ACCVIO, SS$_STKOVF. */
+/* Non-DEC Ada specific conditions. We could probably also put
+ SS$_HPARITH here and possibly SS$_ACCVIO, SS$_STKOVF. */
static const struct cond_except cond_except_table [] = {
{&MTH$_FLOOVEMAT, &constraint_error},
{&SS$_INTDIV, &constraint_error},
still need to be handled by such handlers, however, in which case
__gnat_error_handler needs to return SS$_RESIGNAL. Consider for
instance the use of a third party library compiled with DECAda and
- performing it's own exception handling internally.
+ performing its own exception handling internally.
To allow some user-level flexibility, which conditions should be
resignaled is controlled by a predicate function, provided with the
__gnat_resignal_p = predicate;
}
-/* Should match System.Parameters.Default_Exception_Msg_Max_Length */
+/* Should match System.Parameters.Default_Exception_Msg_Max_Length. */
#define Default_Exception_Msg_Max_Length 512
-/* Action routine for SYS$PUTMSG. There may be
- multiple conditions, each with text to be appended to
- MESSAGE and separated by line termination. */
+/* Action routine for SYS$PUTMSG. There may be multiple
+ conditions, each with text to be appended to MESSAGE
+ and separated by line termination. */
static int
copy_msg (msgdesc, message)
int len = strlen (message);
int copy_len;
- /* Check for buffer overflow and skip */
+ /* Check for buffer overflow and skip. */
if (len > 0 && len <= Default_Exception_Msg_Max_Length - 3)
{
strcat (message, "\r\n");
len += 2;
}
- /* Check for buffer overflow and truncate if necessary */
+ /* Check for buffer overflow and truncate if necessary. */
copy_len = (len + msgdesc->len <= Default_Exception_Msg_Max_Length - 1 ?
msgdesc->len :
Default_Exception_Msg_Max_Length - 1 - len);
return SS$_RESIGNAL;
#ifdef IN_RTS
- /* See if it's an imported exception. Beware that registered exceptions
+ /* See if it's an imported exception. Beware that registered exceptions
are bound to their base code, with the severity bits masked off. */
base_code = Base_Code_In ((Exception_Code) sigargs [1]);
exception = Coded_Exception (base_code);
{
message [0] = 0;
- /* Subtract PC & PSL fields which messes with PUTMSG */
+ /* Subtract PC & PSL fields which messes with PUTMSG. */
sigargs [0] -= 2;
SYS$PUTMSG (sigargs, copy_msg, &gnat_facility, message);
sigargs [0] += 2;
msg = message;
exception->Name_Length = 19;
- /* The full name really should be get sys$getmsg returns. ??? */
+ /* ??? The full name really should be get sys$getmsg returns. */
exception->Full_Name = "IMPORTED_EXCEPTION";
exception->Import_Code = base_code;
exception = &constraint_error;
msg = "arithmetic error";
#ifndef __alpha__
- /* No need to adjust pc on alpha: the pc is already on the instruction
+ /* No need to adjust pc on Alpha: the pc is already on the instruction
after the trapping one. */
__gnat_adjust_context_for_raise (0, (void *)mechargs);
#endif
int i;
/* Scan the DEC Ada exception condition table for a match and fetch
- the associated GNAT exception pointer */
+ the associated GNAT exception pointer. */
for (i = 0;
dec_ada_cond_except_table [i].cond &&
!LIB$MATCH_COND (&sigargs [1],
if (!exception)
{
/* Scan the VMS standard condition table for a match and fetch
- the associated GNAT exception pointer */
+ the associated GNAT exception pointer. */
for (i = 0;
cond_except_table [i].cond &&
!LIB$MATCH_COND (&sigargs [1], &cond_except_table [i].cond);
if (!exception)
/* User programs expect Non_Ada_Error to be raised, reference
- DEC Ada test CXCONDHAN. */
+ DEC Ada test CXCONDHAN. */
exception = &Non_Ada_Error;
}
}
exception = &program_error;
#endif
message [0] = 0;
- /* Subtract PC & PSL fields which messes with PUTMSG */
+ /* Subtract PC & PSL fields which messes with PUTMSG. */
sigargs [0] -= 2;
SYS$PUTMSG (sigargs, copy_msg, &gnat_facility, message);
sigargs [0] += 2;
__gnat_handler_installed = 1;
}
-/* __gnat_adjust_context_for_raise for alpha - see comments along with the
+/* __gnat_adjust_context_for_raise for Alpha - see comments along with the
default version later in this file. */
#if defined (IN_RTS) && defined (__alpha__)
/* Set up signal handler to map synchronous signals to appropriate
exceptions. Make sure that the handler isn't interrupted by another
- signal that might cause a scheduling event! */
+ signal that might cause a scheduling event! */
act.sa_sigaction
= (void (*)(int, struct __siginfo *, void*)) __gnat_error_handler;
#include "private/vThreadsP.h"
#endif
-static void __gnat_error_handler (int, int, struct sigcontext *);
-void __gnat_map_signal (int);
+void __gnat_error_handler (int, void *, struct sigcontext *);
#ifndef __RTP__
-/* Directly vectored Interrupt routines are not supported when using RTPs */
+/* Directly vectored Interrupt routines are not supported when using RTPs. */
extern int __gnat_inum_to_ivec (int);
-/* This is needed by the GNAT run time to handle Vxworks interrupts */
+/* This is needed by the GNAT run time to handle Vxworks interrupts. */
int
__gnat_inum_to_ivec (int num)
{
#if !defined(__alpha_vxworks) && (_WRS_VXWORKS_MAJOR != 6) && !defined(__RTP__)
/* getpid is used by s-parint.adb, but is not defined by VxWorks, except
- on Alpha VxWorks and VxWorks 6.x (including RTPs). */
+ on Alpha VxWorks and VxWorks 6.x (including RTPs). */
extern long getpid (void);
#endif
/* VxWorks expects the field excCnt to be zeroed when a signal is handled.
- The VxWorks version of longjmp does this; gcc's builtin_longjmp does not */
+ The VxWorks version of longjmp does this; GCC's builtin_longjmp doesn't. */
void
__gnat_clear_exception_count (void)
{
#endif
}
-/* Exported to s-intman-vxworks.adb in order to handle different signal
- to exception mappings in different VxWorks versions */
+
+/* VxWorks context adjustment for targets that need/support it. */
+
+void __gnat_adjust_context_for_raise (int, void*);
+
+#if defined (_ARCH_PPC) && !defined (VTHREADS) && !defined (__RTP__)
+
+#define HAVE_GNAT_ADJUST_CONTEXT_FOR_RAISE
+
+/* We need the constant and structure definitions describing the machine
+ state. Part of this is normally retrieved from the VxWorks "regs.h" but
+ #including it here gets the GCC internals instance of this file instead.
+ We need to #include the version we need directly here, and prevent the
+ possibly indirect inclusion of the GCC one, as its contents is useless to
+ us and it depends on several other headers that we don't have at hand. */
+#include <arch/ppc/regsPpc.h>
+#define GCC_REGS_H
+#include <sigLib.h>
+
void
+__gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, void *sigcontext)
+{
+ REG_SET * mcontext = ((struct sigcontext *) sigcontext)->sc_pregs;
+ mcontext->pc++;
+}
+
+#endif
+
+/* Handle different SIGnal to exception mappings in different VxWorks
+ versions. */
+static void
__gnat_map_signal (int sig)
{
struct Exception_Data *exception;
Raise_From_Signal_Handler (exception, msg);
}
-static void
-__gnat_error_handler (int sig, int code, struct sigcontext *sc)
+/* Tasking and Non-tasking signal handler. Map SIGnal to Ada exception
+ propagation after the required low level adjustments. */
+
+void
+__gnat_error_handler (int sig, void * si ATTRIBUTE_UNUSED,
+ struct sigcontext * sc)
{
sigset_t mask;
- int result;
/* VxWorks will always mask out the signal during the signal handler and
will reenable it on a longjmp. GNAT does not generate a longjmp to
return from a signal handler so the signal will still be masked unless
- we unmask it. */
+ we unmask it. */
sigprocmask (SIG_SETMASK, NULL, &mask);
sigdelset (&mask, sig);
sigprocmask (SIG_SETMASK, &mask, NULL);
+ __gnat_adjust_context_for_raise (sig, (void *)sc);
__gnat_map_signal (sig);
-
}
void
/* Setup signal handler to map synchronous signals to appropriate
exceptions. Make sure that the handler isn't interrupted by another
- signal that might cause a scheduling event! */
+ signal that might cause a scheduling event! */
act.sa_handler = __gnat_error_handler;
act.sa_flags = SA_SIGINFO | SA_ONSTACK;
sigemptyset (&act.sa_mask);
/* For VxWorks, install all signal handlers, since pragma Interrupt_State
- applies to vectored hardware interrupts, not signals */
+ applies to vectored hardware interrupts, not signals. */
sigaction (SIGFPE, &act, NULL);
sigaction (SIGILL, &act, NULL);
sigaction (SIGSEGV, &act, NULL);
void
__gnat_init_float (void)
{
- /* Disable overflow/underflow exceptions on the PPC processor, this is needed
+ /* Disable overflow/underflow exceptions on the PPC processor, needed
to get correct Ada semantics. Note that for AE653 vThreads, the HW
overflow settings are an OS configuration issue. The instructions
- below have no effect */
+ below have no effect. */
#if defined (_ARCH_PPC) && !defined (_SOFT_FLOAT) && !defined (VTHREADS)
asm ("mtfsb0 25");
asm ("mtfsb0 26");
#if (defined (__i386__) || defined (i386)) && !defined (VTHREADS)
/* This is used to properly initialize the FPU on an x86 for each
- process thread. */
+ process thread. */
asm ("finit");
#endif
- /* Similarly for sparc64. Achieved by masking bits in the Trap Enable Mask
+ /* Similarly for SPARC64. Achieved by masking bits in the Trap Enable Mask
field of the Floating-point Status Register (see the SPARC Architecture
Manual Version 9, p 48). */
#if defined (sparc64)
act.sa_flags = SA_NODEFER | SA_RESTART;
sigemptyset (&act.sa_mask);
- /* Do not install handlers if interrupt state is "System" */
+ /* Do not install handlers if interrupt state is "System". */
if (__gnat_get_interrupt_state (SIGFPE) != 's')
sigaction (SIGFPE, &act, NULL);
if (__gnat_get_interrupt_state (SIGILL) != 's')
#else
-/* For all other versions of GNAT, the handler does nothing */
+/* For all other versions of GNAT, the handler does nothing. */
/*******************/
/* Default Section */
/*********************/
/* This routine is called as each process thread is created, for possible
- initialization of the FP processor. This version is used under INTERIX,
- WIN32 and could be used under OS/2 */
+ initialization of the FP processor. This version is used under INTERIX,
+ WIN32 and could be used under OS/2. */
#if defined (_WIN32) || defined (__INTERIX) || defined (__EMX__) \
|| defined (__Lynx__) || defined(__NetBSD__) || defined(__FreeBSD__) \
#if defined (__i386__) || defined (i386)
/* This is used to properly initialize the FPU on an x86 for each
- process thread. */
+ process thread. */
asm ("finit");
#ifndef HAVE_GNAT_INIT_FLOAT
-/* All targets without a specific __gnat_init_float will use an empty one */
+/* All targets without a specific __gnat_init_float will use an empty one. */
void
__gnat_init_float (void)
{
#ifndef HAVE_GNAT_ADJUST_CONTEXT_FOR_RAISE
-/* All targets without a specific version will use an empty one */
+/* All targets without a specific version will use an empty one. */
/* Given UCONTEXT a pointer to a context structure received by a signal
handler for SIGNO, perform the necessary adjustments to let the handler
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- default
-- Reserved: the OS specific set of signals that are reserved.
+with System.Task_Primitives;
+
package body System.Interrupt_Management is
use Interfaces.C;
begin
-- With the __builtin_longjmp, the signal mask is not restored, so we
- -- need to restore it explicitely.
+ -- need to restore it explicitly.
Result := pthread_sigmask (SIG_UNBLOCK, Signal_Mask'Access, null);
pragma Assert (Result = 0);
old_act : aliased struct_sigaction;
Result : System.OS_Interface.int;
+ Use_Alternate_Stack : constant Boolean :=
+ System.Task_Primitives.Alternate_Stack_Size /= 0;
+ -- Whether to use an alternate signal stack for stack overflows
+
begin
if Initialized then
return;
act.sa_handler := Notify_Exception'Address;
- act.sa_flags := SA_SIGINFO;
-
-- Setting SA_SIGINFO asks the kernel to pass more than just the signal
-- number argument to the handler when it is called. The set of extra
-- parameters includes a pointer to the interrupted context, which the
-- fix should be made in sigsetjmp so that we save the Signal_Set and
-- restore it after a longjmp.
- -- Since SA_NODEFER is obsolete, instead we reset explicitely the mask
+ -- Since SA_NODEFER is obsolete, instead we reset explicitly the mask
-- in the exception handler.
Result := sigemptyset (Signal_Mask'Access);
Reserve (Exception_Interrupts (J)) := True;
if State (Exception_Interrupts (J)) /= Default then
+ act.sa_flags := SA_SIGINFO;
+
+ if Use_Alternate_Stack
+ and then Exception_Interrupts (J) = SIGSEGV
+ then
+ act.sa_flags := act.sa_flags + SA_ONSTACK;
+ end if;
+
Result :=
sigaction
- (Signal (Exception_Interrupts (J)), act'Unchecked_Access,
- old_act'Unchecked_Access);
+ (Signal (Exception_Interrupts (J)), act'Unchecked_Access,
+ old_act'Unchecked_Access);
pragma Assert (Result = 0);
end if;
end if;
end if;
-- Set SIGINT to unmasked state as long as it is not in "User" state.
- -- Check for Unreserve_All_Interrupts last
+ -- Check for Unreserve_All_Interrupts last.
if State (SIGINT) /= User then
Keep_Unmasked (SIGINT) := True;
end if;
-- Check all signals for state that requires keeping them unmasked and
- -- reserved
+ -- reserved.
for J in Interrupt_ID'Range loop
if State (J) = Default or else State (J) = Runtime then
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . L I N U X --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2008, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
+-- Boston, MA 02110-1301, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the alpha version of this package
+
+-- This package encapsulates cpu specific differences between implementations
+-- of GNU/Linux, in order to share s-osinte-linux.ads.
+
+-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
+-- Preelaborate. This package is designed to be a bottom-level (leaf) package.
+
+with Interfaces.C;
+
+package System.Linux is
+ pragma Preelaborate;
+
+ -----------
+ -- Errno --
+ -----------
+
+ EAGAIN : constant := 35;
+ EINTR : constant := 4;
+ EINVAL : constant := 22;
+ ENOMEM : constant := 12;
+ EPERM : constant := 1;
+ ETIMEDOUT : constant := 60;
+
+ -------------
+ -- Signals --
+ -------------
+
+ SIGHUP : constant := 1; -- hangup
+ SIGINT : constant := 2; -- interrupt (rubout)
+ SIGQUIT : constant := 3; -- quit (ASCD FS)
+ SIGILL : constant := 4; -- illegal instruction (not reset)
+ SIGTRAP : constant := 5; -- trace trap (not reset)
+ SIGIOT : constant := 6; -- IOT instruction
+ SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
+ SIGFPE : constant := 8; -- floating point exception
+ SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
+ SIGBUS : constant := 10; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+ SIGPIPE : constant := 13; -- write on a pipe with no one to read it
+ SIGALRM : constant := 14; -- alarm clock
+ SIGTERM : constant := 15; -- software termination signal from kill
+ SIGURG : constant := 16; -- urgent condition on IO channel
+ SIGSTOP : constant := 17; -- stop (cannot be caught or ignored)
+ SIGTSTP : constant := 18; -- user stop requested from tty
+ SIGCONT : constant := 19; -- stopped process has been continued
+ SIGCLD : constant := 20; -- alias for SIGCHLD
+ SIGCHLD : constant := 20; -- child status change
+ SIGTTIN : constant := 21; -- background tty read attempted
+ SIGTTOU : constant := 22; -- background tty write attempted
+ SIGIO : constant := 23; -- I/O now possible (4.2 BSD)
+ SIGPOLL : constant := 23; -- pollable event occurred
+ SIGXCPU : constant := 24; -- CPU time limit exceeded
+ SIGXFSZ : constant := 25; -- filesize limit exceeded
+ SIGVTALRM : constant := 26; -- virtual timer expired
+ SIGPROF : constant := 27; -- profiling timer expired
+ SIGWINCH : constant := 28; -- window size change
+ SIGPWR : constant := 29; -- power-fail restart
+ SIGUSR1 : constant := 30; -- user defined signal 1
+ SIGUSR2 : constant := 31; -- user defined signal 2
+
+ SIGLTHRRES : constant := 32; -- GNU/LinuxThreads restart signal
+ SIGLTHRCAN : constant := 33; -- GNU/LinuxThreads cancel signal
+ SIGLTHRDBG : constant := 34; -- GNU/LinuxThreads debugger signal
+
+ SIGADAABORT : constant := SIGABRT;
+ -- Change this if you want to use another signal for task abort.
+ -- SIGTERM might be a good one.
+
+ SIGUNUSED : constant := 0;
+ SIGSTKFLT : constant := 0;
+ SIGLOST : constant := 0;
+ -- These don't exist for Linux/Alpha. The constants are present
+ -- so that we can continue to use a-intnam-linux.ads.
+
+ -- struct_sigaction offsets
+
+ sa_mask_pos : constant := Standard'Address_Size / 8;
+ sa_flags_pos : constant := 128 + sa_mask_pos;
+
+ SA_SIGINFO : constant := 16#40#;
+ SA_ONSTACK : constant := 16#01#;
+
+ type pthread_mutex_t is record
+ dum0, dum1, dum2, dum3, dum4 : Interfaces.C.unsigned_long;
+ end record;
+ pragma Convention (C, pthread_mutex_t);
+
+end System.Linux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . L I N U X --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2008, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
+-- Boston, MA 02110-1301, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the hppa version of this package
+
+-- This package encapsulates cpu specific differences between implementations
+-- of GNU/Linux, in order to share s-osinte-linux.ads.
+
+-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
+-- Preelaborate. This package is designed to be a bottom-level (leaf) package.
+
+package System.Linux is
+ pragma Preelaborate;
+
+ -----------
+ -- Errno --
+ -----------
+
+ EAGAIN : constant := 11;
+ EINTR : constant := 4;
+ EINVAL : constant := 22;
+ ENOMEM : constant := 12;
+ EPERM : constant := 1;
+ ETIMEDOUT : constant := 238;
+
+ -------------
+ -- Signals --
+ -------------
+
+ SIGHUP : constant := 1; -- hangup
+ SIGINT : constant := 2; -- interrupt (rubout)
+ SIGQUIT : constant := 3; -- quit (ASCD FS)
+ SIGILL : constant := 4; -- illegal instruction (not reset)
+ SIGTRAP : constant := 5; -- trace trap (not reset)
+ SIGIOT : constant := 6; -- IOT instruction
+ SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
+ SIGEMT : constant := 7; -- EMT
+ SIGFPE : constant := 8; -- floating point exception
+ SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
+ SIGBUS : constant := 10; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+ SIGSYS : constant := 12; -- bad system call
+ SIGPIPE : constant := 13; -- write on a pipe with no one to read it
+ SIGALRM : constant := 14; -- alarm clock
+ SIGTERM : constant := 15; -- software termination signal from kill
+ SIGUSR1 : constant := 16; -- user defined signal 1
+ SIGUSR2 : constant := 17; -- user defined signal 2
+ SIGCLD : constant := 18; -- alias for SIGCHLD
+ SIGCHLD : constant := 18; -- child status change
+ SIGPWR : constant := 19; -- power-fail restart
+ SIGVTALRM : constant := 20; -- virtual timer expired
+ SIGPROF : constant := 21; -- profiling timer expired
+ SIGPOLL : constant := 22; -- pollable event occurred
+ SIGIO : constant := 22; -- I/O now possible (4.2 BSD)
+ SIGWINCH : constant := 23; -- window size change
+ SIGSTOP : constant := 24; -- stop (cannot be caught or ignored)
+ SIGTSTP : constant := 25; -- user stop requested from tty
+ SIGCONT : constant := 26; -- stopped process has been continued
+ SIGTTIN : constant := 27; -- background tty read attempted
+ SIGTTOU : constant := 28; -- background tty write attempted
+ SIGURG : constant := 29; -- urgent condition on IO channel
+ SIGLOST : constant := 30; -- File lock lost
+ SIGUNUSED : constant := 31; -- unused signal (GNU/Linux)
+ SIGXCPU : constant := 33; -- CPU time limit exceeded
+ SIGXFSZ : constant := 34; -- filesize limit exceeded
+ SIGSTKFLT : constant := 36; -- coprocessor stack fault (Linux)
+ SIGLTHRRES : constant := 37; -- GNU/LinuxThreads restart signal
+ SIGLTHRCAN : constant := 38; -- GNU/LinuxThreads cancel signal
+ SIGLTHRDBG : constant := 39; -- GNU/LinuxThreads debugger signal
+
+ -- struct_sigaction offsets
+
+ sa_flags_pos : constant := Standard'Address_Size / 8;
+ sa_mask_pos : constant := sa_flags_pos * 2;
+
+ SA_SIGINFO : constant := 16#10#;
+ SA_ONSTACK : constant := 16#01#;
+
+ type lock_array is array (1 .. 4) of int;
+ type atomic_lock_t is record
+ lock : lock_array;
+ end record;
+ pragma Convention (C, atomic_lock_t);
+ -- ??? Alignment should be 16 but this is larger than BIGGEST_ALIGNMENT.
+ -- This causes an erroneous pointer value to sometimes be passed to free
+ -- during deallocation. See PR ada/24533 for more details.
+ for atomic_lock_t'Alignment use 8;
+
+ type struct_pthread_fast_lock is record
+ spinlock : atomic_lock_t;
+ status : Long_Integer;
+ end record;
+ pragma Convention (C, struct_pthread_fast_lock);
+
+ type pthread_mutex_t is record
+ m_reserved : Integer;
+ m_count : Integer;
+ m_owner : System.Address;
+ m_kind : Integer;
+ m_lock : struct_pthread_fast_lock;
+ end record;
+ pragma Convention (C, pthread_mutex_t);
+
+end System.Linux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . L I N U X --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2008, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
+-- Boston, MA 02110-1301, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the default version of this package
+
+-- This package encapsulates cpu specific differences between implementations
+-- of GNU/Linux, in order to share s-osinte-linux.ads.
+
+-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
+-- Preelaborate. This package is designed to be a bottom-level (leaf) package
+
+package System.Linux is
+ pragma Preelaborate;
+
+ -----------
+ -- Errno --
+ -----------
+
+ EAGAIN : constant := 11;
+ EINTR : constant := 4;
+ EINVAL : constant := 22;
+ ENOMEM : constant := 12;
+ EPERM : constant := 1;
+ ETIMEDOUT : constant := 110;
+
+ -------------
+ -- Signals --
+ -------------
+
+ SIGHUP : constant := 1; -- hangup
+ SIGINT : constant := 2; -- interrupt (rubout)
+ SIGQUIT : constant := 3; -- quit (ASCD FS)
+ SIGILL : constant := 4; -- illegal instruction (not reset)
+ SIGTRAP : constant := 5; -- trace trap (not reset)
+ SIGIOT : constant := 6; -- IOT instruction
+ SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
+ SIGFPE : constant := 8; -- floating point exception
+ SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
+ SIGBUS : constant := 7; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+ SIGPIPE : constant := 13; -- write on a pipe with no one to read it
+ SIGALRM : constant := 14; -- alarm clock
+ SIGTERM : constant := 15; -- software termination signal from kill
+ SIGUSR1 : constant := 10; -- user defined signal 1
+ SIGUSR2 : constant := 12; -- user defined signal 2
+ SIGCLD : constant := 17; -- alias for SIGCHLD
+ SIGCHLD : constant := 17; -- child status change
+ SIGPWR : constant := 30; -- power-fail restart
+ SIGWINCH : constant := 28; -- window size change
+ SIGURG : constant := 23; -- urgent condition on IO channel
+ SIGPOLL : constant := 29; -- pollable event occurred
+ SIGIO : constant := 29; -- I/O now possible (4.2 BSD)
+ SIGLOST : constant := 29; -- File lock lost
+ SIGSTOP : constant := 19; -- stop (cannot be caught or ignored)
+ SIGTSTP : constant := 20; -- user stop requested from tty
+ SIGCONT : constant := 18; -- stopped process has been continued
+ SIGTTIN : constant := 21; -- background tty read attempted
+ SIGTTOU : constant := 22; -- background tty write attempted
+ SIGVTALRM : constant := 26; -- virtual timer expired
+ SIGPROF : constant := 27; -- profiling timer expired
+ SIGXCPU : constant := 24; -- CPU time limit exceeded
+ SIGXFSZ : constant := 25; -- filesize limit exceeded
+ SIGUNUSED : constant := 31; -- unused signal (GNU/Linux)
+ SIGSTKFLT : constant := 16; -- coprocessor stack fault (Linux)
+ SIGLTHRRES : constant := 32; -- GNU/LinuxThreads restart signal
+ SIGLTHRCAN : constant := 33; -- GNU/LinuxThreads cancel signal
+ SIGLTHRDBG : constant := 34; -- GNU/LinuxThreads debugger signal
+
+ -- struct_sigaction offsets
+
+ sa_mask_pos : constant := Standard'Address_Size / 8;
+ sa_flags_pos : constant := 128 + sa_mask_pos;
+
+ SA_SIGINFO : constant := 16#04#;
+ SA_ONSTACK : constant := 16#08000000#;
+
+ type struct_pthread_fast_lock is record
+ status : Long_Integer;
+ spinlock : Integer;
+ end record;
+ pragma Convention (C, struct_pthread_fast_lock);
+
+ type pthread_mutex_t is record
+ m_reserved : Integer;
+ m_count : Integer;
+ m_owner : System.Address;
+ m_kind : Integer;
+ m_lock : struct_pthread_fast_lock;
+ end record;
+ pragma Convention (C, pthread_mutex_t);
+
+end System.Linux;
pragma Convention (C, struct_sigaction);
type struct_sigaction_ptr is access all struct_sigaction;
- SA_SIGINFO : constant := 16#0100#;
+ SA_SIGINFO : constant := 16#0100#;
+ SA_ONSTACK : constant := 16#0001#;
SIG_BLOCK : constant := 0;
SIG_UNBLOCK : constant := 1;
-- Stack --
-----------
+ type stack_t is record
+ ss_sp : System.Address;
+ ss_size : size_t;
+ ss_flags : int;
+ end record;
+ pragma Convention (C, stack_t);
+
+ function sigaltstack
+ (ss : not null access stack_t;
+ oss : access stack_t) return int;
+ pragma Import (C, sigaltstack, "sigaltstack");
+
+ Alternate_Stack : aliased System.Address;
+ -- This is a dummy definition, never used (Alternate_Stack_Size is null)
+
+ Alternate_Stack_Size : constant := 0;
+ -- No alternate signal stack is used on this platform
+
Stack_Base_Available : constant Boolean := False;
-- Indicates wether the stack base is available on this target
PROT_WRITE : constant := 2;
PROT_EXEC : constant := 4;
PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC;
-
PROT_ON : constant := PROT_READ;
PROT_OFF : constant := PROT_ALL;
SIG_IGN : constant := 1;
SA_SIGINFO : constant := 16#0040#;
+ SA_ONSTACK : constant := 16#0001#;
function sigaction
(sig : Signal;
---------
function lwp_self return System.Address;
+ pragma Import (C, lwp_self, "pthread_self");
-- lwp_self does not exist on this thread library, revert to pthread_self
-- which is the closest approximation (with getpid). This function is
-- needed to share 7staprop.adb across POSIX-like targets.
- pragma Import (C, lwp_self, "pthread_self");
-------------
-- Threads --
-- Stack --
-----------
+ type stack_t is record
+ ss_sp : System.Address;
+ ss_size : size_t;
+ ss_flags : int;
+ end record;
+ pragma Convention (C, stack_t);
+
+ function sigaltstack
+ (ss : not null access stack_t;
+ oss : access stack_t) return int;
+ pragma Import (C, sigaltstack, "sigaltstack");
+
+ Alternate_Stack : aliased System.Address;
+ -- This is a dummy definition, never used (Alternate_Stack_Size is null)
+
+ Alternate_Stack_Size : constant := 0;
+ -- No alternate signal stack is used on this platform
+
Stack_Base_Available : constant Boolean := False;
- -- Indicates wether the stack base is available on this target.
- -- This allows us to share s-osinte.adb between all the FSU run time.
- -- Note that this value can only be true if pthread_t has a complete
- -- definition that corresponds exactly to the C header files.
+ -- Indicates wether the stack base is available on this target. This allows
+ -- us to share s-osinte.adb between all the FSU run time. Note that this
+ -- value can only be true if pthread_t has a complete definition that
+ -- corresponds exactly to the C header files.
function Get_Stack_Base (thread : pthread_t) return System.Address;
pragma Inline (Get_Stack_Base);
- -- returns the stack base of the specified thread.
- -- Only call this function when Stack_Base_Available is True.
+ -- returns the stack base of the specified thread. Only call this function
+ -- when Stack_Base_Available is True.
function Get_Page_Size return size_t;
function Get_Page_Size return System.Address;
pragma Import (C, Get_Page_Size, "getpagesize");
- -- returns the size of a page, or 0 if this is not relevant on this
- -- target
+ -- Returns the size of a page, or 0 if this is not relevant on this target
PROT_NONE : constant := 0;
PROT_READ : constant := 1;
PROT_ON : constant := PROT_NONE;
PROT_OFF : constant := PROT_ALL;
- function mprotect (addr : System.Address;
- len : size_t;
- prot : int) return int;
+ function mprotect
+ (addr : System.Address;
+ len : size_t;
+ prot : int) return int;
pragma Import (C, mprotect);
---------------------------------------
end record;
pragma Convention (C, siginfo_t);
- type stack_t is record
- ss_sp : System.Address;
- ss_size : int;
- ss_flags : int;
- end record;
- pragma Convention (C, stack_t);
-
type mcontext_t is new System.Address;
type ucontext_t is record
SIG_IGN : constant := 1;
SA_SIGINFO : constant := 16#0040#;
+ SA_ONSTACK : constant := 16#0001#;
function sigaction
(sig : Signal;
-- Stack --
-----------
+ type stack_t is record
+ ss_sp : System.Address;
+ ss_size : size_t;
+ ss_flags : int;
+ end record;
+ pragma Convention (C, stack_t);
+
+ function sigaltstack
+ (ss : not null access stack_t;
+ oss : access stack_t) return int;
+ pragma Import (C, sigaltstack, "sigaltstack");
+
+ Alternate_Stack : aliased System.Address;
+ -- This is a dummy definition, never used (Alternate_Stack_Size is null)
+
+ Alternate_Stack_Size : constant := 0;
+ -- No alternate signal stack is used on this platform
+
Stack_Base_Available : constant Boolean := False;
- -- Indicates wether the stack base is available on this target.
- -- This allows us to share s-osinte.adb between all the FSU run time.
- -- Note that this value can only be true if pthread_t has a complete
- -- definition that corresponds exactly to the C header files.
+ -- Indicates wether the stack base is available on this target. This allows
+ -- us to share s-osinte.adb between all the FSU run time. Note that this
+ -- value can only be true if pthread_t has a complete definition that
+ -- corresponds exactly to the C header files.
function Get_Stack_Base (thread : pthread_t) return Address;
pragma Inline (Get_Stack_Base);
- -- returns the stack base of the specified thread.
- -- Only call this function when Stack_Base_Available is True.
+ -- returns the stack base of the specified thread. Only call this function
+ -- when Stack_Base_Available is True.
function Get_Page_Size return size_t;
function Get_Page_Size return Address;
pragma Import (C, Get_Page_Size, "getpagesize");
- -- returns the size of a page, or 0 if this is not relevant on this
- -- target
+ -- returns the size of a page, or 0 if this is not relevant on this target
PROT_NONE : constant := 0;
PROT_READ : constant := 1;
PROT_WRITE : constant := 2;
PROT_EXEC : constant := 4;
PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC;
-
PROT_ON : constant := PROT_NONE;
PROT_OFF : constant := PROT_ALL;
- function mprotect
- (addr : Address; len : size_t; prot : int) return int;
+ function mprotect (addr : Address; len : size_t; prot : int) return int;
pragma Import (C, mprotect);
---------------------------------------
-- Nonstandard Thread Initialization --
---------------------------------------
- -- FSU_THREADS requires pthread_init, which is nonstandard and
- -- this should be invoked during the elaboration of s-taprop.adb
+ -- FSU_THREADS requires pthread_init, which is nonstandard and this should
+ -- be invoked during the elaboration of s-taprop.adb.
-- FreeBSD does not require this so we provide an empty Ada body
pragma Convention (C, struct_sigaction);
type struct_sigaction_ptr is access all struct_sigaction;
- SA_SIGINFO : constant := 16#10#;
+ SA_SIGINFO : constant := 16#10#;
+ SA_ONSTACK : constant := 16#01#;
SIG_BLOCK : constant := 0;
SIG_UNBLOCK : constant := 1;
-- Stack --
-----------
+ type stack_t is record
+ ss_sp : System.Address;
+ ss_flags : int;
+ ss_size : size_t;
+ end record;
+ pragma Convention (C, stack_t);
+
+ function sigaltstack
+ (ss : not null access stack_t;
+ oss : access stack_t) return int;
+ pragma Import (C, sigaltstack, "sigaltstack");
+
+ Alternate_Stack : aliased System.Address;
+ pragma Import (C, Alternate_Stack, "__gnat_alternate_stack");
+ -- The alternate signal stack for stack overflows
+
+ Alternate_Stack_Size : constant := 16 * 1024;
+ -- This must be in keeping with init.c:__gnat_alternate_stack
+
Stack_Base_Available : constant Boolean := False;
-- Indicates wether the stack base is available on this target
function Get_Stack_Base (thread : pthread_t) return Address;
pragma Inline (Get_Stack_Base);
- -- returns the stack base of the specified thread.
- -- Only call this function when Stack_Base_Available is True.
+ -- Returns the stack base of the specified thread. Only call this function
+ -- when Stack_Base_Available is True.
function Get_Page_Size return size_t;
function Get_Page_Size return Address;
pragma Import (C, Get_Page_Size, "getpagesize");
- -- returns the size of a page, or 0 if this is not relevant on this
- -- target
+ -- Returns the size of a page, or 0 if this is not relevant on this target
PROT_NONE : constant := 0;
PROT_READ : constant := 1;
PROT_WRITE : constant := 2;
PROT_EXEC : constant := 4;
PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC;
-
PROT_ON : constant := PROT_READ;
PROT_OFF : constant := PROT_ALL;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ I N T E R F A C E --
--- --
--- S p e c --
--- --
--- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2006, Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
--- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNARL; see file COPYING. If not, write --
--- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
--- Boston, MA 02110-1301, USA. --
--- --
--- As a special exception, if other files instantiate generics from this --
--- unit, or you link this unit with other files to produce an executable, --
--- this unit does not by itself cause the resulting executable to be --
--- covered by the GNU General Public License. This exception does not --
--- however invalidate any other reasons why the executable file might be --
--- covered by the GNU Public License. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is a GNU/Linux (GNU/LinuxThreads) version of this package
-
--- This package encapsulates all direct interfaces to OS services
--- that are needed by children of System.
-
--- PLEASE DO NOT add any with-clauses to this package or remove the pragma
--- Preelaborate. This package is designed to be a bottom-level (leaf) package.
-
-with Interfaces.C;
-with Unchecked_Conversion;
-
-package System.OS_Interface is
- pragma Preelaborate;
-
- pragma Linker_Options ("-lpthread");
-
- subtype int is Interfaces.C.int;
- subtype char is Interfaces.C.char;
- subtype short is Interfaces.C.short;
- subtype long is Interfaces.C.long;
- subtype unsigned is Interfaces.C.unsigned;
- subtype unsigned_short is Interfaces.C.unsigned_short;
- subtype unsigned_long is Interfaces.C.unsigned_long;
- subtype unsigned_char is Interfaces.C.unsigned_char;
- subtype plain_char is Interfaces.C.plain_char;
- subtype size_t is Interfaces.C.size_t;
-
- -----------
- -- Errno --
- -----------
-
- function errno return int;
- pragma Import (C, errno, "__get_errno");
-
- EAGAIN : constant := 35;
- EINTR : constant := 4;
- EINVAL : constant := 22;
- ENOMEM : constant := 12;
- EPERM : constant := 1;
- ETIMEDOUT : constant := 60;
-
- -------------
- -- Signals --
- -------------
-
- Max_Interrupt : constant := 63;
- type Signal is new int range 0 .. Max_Interrupt;
- for Signal'Size use int'Size;
-
- SIGHUP : constant := 1; -- hangup
- SIGINT : constant := 2; -- interrupt (rubout)
- SIGQUIT : constant := 3; -- quit (ASCD FS)
- SIGILL : constant := 4; -- illegal instruction (not reset)
- SIGTRAP : constant := 5; -- trace trap (not reset)
- SIGIOT : constant := 6; -- IOT instruction
- SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
- SIGFPE : constant := 8; -- floating point exception
- SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
- SIGBUS : constant := 10; -- bus error
- SIGSEGV : constant := 11; -- segmentation violation
- SIGPIPE : constant := 13; -- write on a pipe with no one to read it
- SIGALRM : constant := 14; -- alarm clock
- SIGTERM : constant := 15; -- software termination signal from kill
- SIGURG : constant := 16; -- urgent condition on IO channel
- SIGSTOP : constant := 17; -- stop (cannot be caught or ignored)
- SIGTSTP : constant := 18; -- user stop requested from tty
- SIGCONT : constant := 19; -- stopped process has been continued
- SIGCLD : constant := 20; -- alias for SIGCHLD
- SIGCHLD : constant := 20; -- child status change
- SIGTTIN : constant := 21; -- background tty read attempted
- SIGTTOU : constant := 22; -- background tty write attempted
- SIGIO : constant := 23; -- I/O now possible (4.2 BSD)
- SIGPOLL : constant := 23; -- pollable event occurred
- SIGXCPU : constant := 24; -- CPU time limit exceeded
- SIGXFSZ : constant := 25; -- filesize limit exceeded
- SIGVTALRM : constant := 26; -- virtual timer expired
- SIGPROF : constant := 27; -- profiling timer expired
- SIGWINCH : constant := 28; -- window size change
- SIGPWR : constant := 29; -- power-fail restart
- SIGUSR1 : constant := 30; -- user defined signal 1
- SIGUSR2 : constant := 31; -- user defined signal 2
-
- SIGLTHRRES : constant := 32; -- GNU/LinuxThreads restart signal
- SIGLTHRCAN : constant := 33; -- GNU/LinuxThreads cancel signal
- SIGLTHRDBG : constant := 34; -- GNU/LinuxThreads debugger signal
-
- SIGADAABORT : constant := SIGABRT;
- -- Change this if you want to use another signal for task abort.
- -- SIGTERM might be a good one.
-
- SIGUNUSED : constant := 0;
- SIGSTKFLT : constant := 0;
- SIGLOST : constant := 0;
- -- These don't exist for Linux/Alpha. The constants are present
- -- so that we can continue to use a-intnam-linux.ads.
-
- type Signal_Set is array (Natural range <>) of Signal;
-
- Unmasked : constant Signal_Set := (
- SIGTRAP,
- -- To enable debugging on multithreaded applications, mark SIGTRAP to
- -- be kept unmasked.
-
- SIGBUS,
-
- SIGTTIN, SIGTTOU, SIGTSTP,
- -- Keep these three signals unmasked so that background processes
- -- and IO behaves as normal "C" applications
-
- SIGPROF,
- -- To avoid confusing the profiler
-
- SIGKILL, SIGSTOP,
- -- These two signals actually cannot be masked;
- -- POSIX simply won't allow it.
-
- SIGLTHRRES, SIGLTHRCAN, SIGLTHRDBG);
- -- These three signals are used by GNU/LinuxThreads starting from
- -- glibc 2.1 (future 2.2).
-
- Reserved : constant Signal_Set := (SIGKILL, SIGSTOP);
-
- type sigset_t is private;
-
- function sigaddset (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigaddset, "sigaddset");
-
- function sigdelset (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigdelset, "sigdelset");
-
- function sigfillset (set : access sigset_t) return int;
- pragma Import (C, sigfillset, "sigfillset");
-
- function sigismember (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigismember, "sigismember");
-
- function sigemptyset (set : access sigset_t) return int;
- pragma Import (C, sigemptyset, "sigemptyset");
-
- type union_type_3 is new String (1 .. 116);
- type siginfo_t is record
- si_signo : int;
- si_code : int;
- si_errno : int;
- X_data : union_type_3;
- end record;
- pragma Convention (C, siginfo_t);
-
- type struct_sigaction is record
- sa_handler : System.Address;
- sa_mask : sigset_t;
- sa_flags : unsigned_long;
- end record;
- pragma Convention (C, struct_sigaction);
- type struct_sigaction_ptr is access all struct_sigaction;
-
- type Machine_State is record
- dummy : unsigned_long;
- end record;
- type Machine_State_Ptr is access all Machine_State;
-
- SA_SIGINFO : constant := 16#40#;
-
- SIG_BLOCK : constant := 0;
- SIG_UNBLOCK : constant := 1;
- SIG_SETMASK : constant := 2;
-
- SIG_DFL : constant := 0;
- SIG_IGN : constant := 1;
-
- function sigaction
- (sig : Signal;
- act : struct_sigaction_ptr;
- oact : struct_sigaction_ptr) return int;
- pragma Import (C, sigaction, "sigaction");
-
- ----------
- -- Time --
- ----------
-
- type timespec is private;
-
- function To_Duration (TS : timespec) return Duration;
- pragma Inline (To_Duration);
-
- function To_Timespec (D : Duration) return timespec;
- pragma Inline (To_Timespec);
-
- type struct_timeval is private;
-
- function To_Duration (TV : struct_timeval) return Duration;
- pragma Inline (To_Duration);
-
- function To_Timeval (D : Duration) return struct_timeval;
- pragma Inline (To_Timeval);
-
- function gettimeofday
- (tv : access struct_timeval;
- tz : System.Address := System.Null_Address) return int;
- pragma Import (C, gettimeofday, "gettimeofday");
-
- function sysconf (name : int) return long;
- pragma Import (C, sysconf);
-
- SC_CLK_TCK : constant := 2;
-
- -------------------------
- -- Priority Scheduling --
- -------------------------
-
- SCHED_OTHER : constant := 0;
- SCHED_FIFO : constant := 1;
- SCHED_RR : constant := 2;
-
- function To_Target_Priority
- (Prio : System.Any_Priority) return Interfaces.C.int;
- -- Maps System.Any_Priority to a POSIX priority.
-
- -------------
- -- Process --
- -------------
-
- type pid_t is private;
-
- function kill (pid : pid_t; sig : Signal) return int;
- pragma Import (C, kill, "kill");
-
- function getpid return pid_t;
- pragma Import (C, getpid, "getpid");
-
- -------------
- -- Threads --
- -------------
-
- type Thread_Body is access
- function (arg : System.Address) return System.Address;
-
- function Thread_Body_Access is new
- Unchecked_Conversion (System.Address, Thread_Body);
-
- type pthread_t is new unsigned_long;
- subtype Thread_Id is pthread_t;
-
- function To_pthread_t is new Unchecked_Conversion
- (unsigned_long, pthread_t);
-
- type pthread_mutex_t is limited private;
- type pthread_cond_t is limited private;
- type pthread_attr_t is limited private;
- type pthread_mutexattr_t is limited private;
- type pthread_condattr_t is limited private;
- type pthread_key_t is private;
-
- PTHREAD_CREATE_DETACHED : constant := 1;
-
- -----------
- -- Stack --
- -----------
-
- function Get_Stack_Base (thread : pthread_t) return Address;
- pragma Inline (Get_Stack_Base);
- -- This is a dummy procedure to share some GNULLI files
-
- ---------------------------------------
- -- Nonstandard Thread Initialization --
- ---------------------------------------
-
- procedure pthread_init;
- pragma Inline (pthread_init);
- -- This is a dummy procedure to share some GNULLI files
-
- -------------------------
- -- POSIX.1c Section 3 --
- -------------------------
-
- function sigwait (set : access sigset_t; sig : access Signal) return int;
- pragma Import (C, sigwait, "sigwait");
-
- function pthread_kill (thread : pthread_t; sig : Signal) return int;
- pragma Import (C, pthread_kill, "pthread_kill");
-
- function pthread_sigmask
- (how : int;
- set : access sigset_t;
- oset : access sigset_t) return int;
- pragma Import (C, pthread_sigmask, "pthread_sigmask");
-
- --------------------------
- -- POSIX.1c Section 11 --
- --------------------------
-
- function pthread_mutexattr_init
- (attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init");
-
- function pthread_mutexattr_destroy
- (attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy");
-
- function pthread_mutex_init
- (mutex : access pthread_mutex_t;
- attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutex_init, "pthread_mutex_init");
-
- function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy");
-
- function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock");
-
- function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock");
-
- function pthread_condattr_init
- (attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_condattr_init, "pthread_condattr_init");
-
- function pthread_condattr_destroy
- (attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy");
-
- function pthread_cond_init
- (cond : access pthread_cond_t;
- attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_cond_init, "pthread_cond_init");
-
- function pthread_cond_destroy (cond : access pthread_cond_t) return int;
- pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy");
-
- function pthread_cond_signal (cond : access pthread_cond_t) return int;
- pragma Import (C, pthread_cond_signal, "pthread_cond_signal");
-
- function pthread_cond_wait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_cond_wait, "pthread_cond_wait");
-
- function pthread_cond_timedwait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t;
- abstime : access timespec) return int;
- pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait");
-
- --------------------------
- -- POSIX.1c Section 13 --
- --------------------------
-
- type struct_sched_param is record
- sched_priority : int; -- scheduling priority
- end record;
- pragma Convention (C, struct_sched_param);
-
- function pthread_setschedparam
- (thread : pthread_t;
- policy : int;
- param : access struct_sched_param) return int;
- pragma Import (C, pthread_setschedparam, "pthread_setschedparam");
-
- function pthread_attr_setschedpolicy
- (attr : access pthread_attr_t;
- policy : int) return int;
- pragma Import
- (C, pthread_attr_setschedpolicy, "pthread_attr_setschedpolicy");
-
- function sched_yield return int;
- pragma Import (C, sched_yield, "sched_yield");
-
- ---------------------------
- -- P1003.1c - Section 16 --
- ---------------------------
-
- function pthread_attr_init
- (attributes : access pthread_attr_t) return int;
- pragma Import (C, pthread_attr_init, "pthread_attr_init");
-
- function pthread_attr_destroy
- (attributes : access pthread_attr_t) return int;
- pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy");
-
- function pthread_attr_setdetachstate
- (attr : access pthread_attr_t;
- detachstate : int) return int;
- pragma Import
- (C, pthread_attr_setdetachstate, "pthread_attr_setdetachstate");
-
- function pthread_attr_setstacksize
- (attr : access pthread_attr_t;
- stacksize : size_t) return int;
- pragma Import (C, pthread_attr_setstacksize, "pthread_attr_setstacksize");
-
- function pthread_create
- (thread : access pthread_t;
- attributes : access pthread_attr_t;
- start_routine : Thread_Body;
- arg : System.Address) return int;
- pragma Import (C, pthread_create, "pthread_create");
-
- procedure pthread_exit (status : System.Address);
- pragma Import (C, pthread_exit, "pthread_exit");
-
- function pthread_self return pthread_t;
- pragma Import (C, pthread_self, "pthread_self");
-
- --------------------------
- -- POSIX.1c Section 17 --
- --------------------------
-
- function pthread_setspecific
- (key : pthread_key_t;
- value : System.Address) return int;
- pragma Import (C, pthread_setspecific, "pthread_setspecific");
-
- function pthread_getspecific (key : pthread_key_t) return System.Address;
- pragma Import (C, pthread_getspecific, "pthread_getspecific");
-
- type destructor_pointer is access procedure (arg : System.Address);
-
- function pthread_key_create
- (key : access pthread_key_t;
- destructor : destructor_pointer) return int;
- pragma Import (C, pthread_key_create, "pthread_key_create");
-
-private
-
- type sigset_t is record
- dum0, dum1, dum2, dum3, dum4, dum5, dum6, dum7 : unsigned_long;
- dum8, dum9, dum10, dum11, dum12, dum13, dum14, dum15 : unsigned_long;
- end record;
- pragma Convention (C, sigset_t);
-
- type pid_t is new int;
-
- type time_t is new long;
-
- type timespec is record
- tv_sec : time_t;
- tv_nsec : long;
- end record;
- pragma Convention (C, timespec);
-
- type struct_timeval is record
- tv_sec : time_t;
- tv_usec : time_t;
- end record;
- pragma Convention (C, struct_timeval);
-
- type pthread_attr_t is record
- dum0, dum1, dum2, dum3, dum4, dum5, dum6 : unsigned_long;
- end record;
- pragma Convention (C, pthread_attr_t);
-
- type pthread_condattr_t is record
- dummy : int;
- end record;
- pragma Convention (C, pthread_condattr_t);
-
- type pthread_mutexattr_t is record
- mutexkind : int;
- end record;
- pragma Convention (C, pthread_mutexattr_t);
-
- type pthread_mutex_t is record
- dum0, dum1, dum2, dum3, dum4 : unsigned_long;
- end record;
- pragma Convention (C, pthread_mutex_t);
-
- type pthread_cond_t is record
- dum0, dum1, dum2, dum3, dum4, dum5 : unsigned_long;
- end record;
- pragma Convention (C, pthread_cond_t);
-
- type pthread_key_t is new unsigned;
-
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ I N T E R F A C E --
--- --
--- S p e c --
--- (GNU/Linux-HPPA Version) --
--- --
--- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2008, Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
--- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNARL; see file COPYING. If not, write --
--- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
--- Boston, MA 02110-1301, USA. --
--- --
--- As a special exception, if other files instantiate generics from this --
--- unit, or you link this unit with other files to produce an executable, --
--- this unit does not by itself cause the resulting executable to be --
--- covered by the GNU General Public License. This exception does not --
--- however invalidate any other reasons why the executable file might be --
--- covered by the GNU Public License. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is a GNU/Linux (GNU/LinuxThreads) version of this package
-
--- This package encapsulates all direct interfaces to OS services that are
--- needed by the tasking run-time (libgnarl).
-
--- PLEASE DO NOT add any with-clauses to this package or remove the pragma
--- Preelaborate. This package is designed to be a bottom-level (leaf) package.
-
-with Ada.Unchecked_Conversion;
-
-with Interfaces.C;
-
-package System.OS_Interface is
- pragma Preelaborate;
-
- pragma Linker_Options ("-lpthread");
-
- subtype int is Interfaces.C.int;
- subtype char is Interfaces.C.char;
- subtype short is Interfaces.C.short;
- subtype long is Interfaces.C.long;
- subtype unsigned is Interfaces.C.unsigned;
- subtype unsigned_short is Interfaces.C.unsigned_short;
- subtype unsigned_long is Interfaces.C.unsigned_long;
- subtype unsigned_char is Interfaces.C.unsigned_char;
- subtype plain_char is Interfaces.C.plain_char;
- subtype size_t is Interfaces.C.size_t;
-
- -----------
- -- Errno --
- -----------
-
- function errno return int;
- pragma Import (C, errno, "__get_errno");
-
- EAGAIN : constant := 11;
- EINTR : constant := 4;
- EINVAL : constant := 22;
- ENOMEM : constant := 12;
- EPERM : constant := 1;
- ETIMEDOUT : constant := 238;
-
- -------------
- -- Signals --
- -------------
-
- Max_Interrupt : constant := 63;
- type Signal is new int range 0 .. Max_Interrupt;
- for Signal'Size use int'Size;
-
- SIGHUP : constant := 1; -- hangup
- SIGINT : constant := 2; -- interrupt (rubout)
- SIGQUIT : constant := 3; -- quit (ASCD FS)
- SIGILL : constant := 4; -- illegal instruction (not reset)
- SIGTRAP : constant := 5; -- trace trap (not reset)
- SIGIOT : constant := 6; -- IOT instruction
- SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
- SIGEMT : constant := 7; -- EMT
- SIGFPE : constant := 8; -- floating point exception
- SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
- SIGBUS : constant := 10; -- bus error
- SIGSEGV : constant := 11; -- segmentation violation
- SIGSYS : constant := 12; -- bad system call
- SIGPIPE : constant := 13; -- write on a pipe with no one to read it
- SIGALRM : constant := 14; -- alarm clock
- SIGTERM : constant := 15; -- software termination signal from kill
- SIGUSR1 : constant := 16; -- user defined signal 1
- SIGUSR2 : constant := 17; -- user defined signal 2
- SIGCLD : constant := 18; -- alias for SIGCHLD
- SIGCHLD : constant := 18; -- child status change
- SIGPWR : constant := 19; -- power-fail restart
- SIGVTALRM : constant := 20; -- virtual timer expired
- SIGPROF : constant := 21; -- profiling timer expired
- SIGPOLL : constant := 22; -- pollable event occurred
- SIGIO : constant := 22; -- I/O now possible (4.2 BSD)
- SIGWINCH : constant := 23; -- window size change
- SIGSTOP : constant := 24; -- stop (cannot be caught or ignored)
- SIGTSTP : constant := 25; -- user stop requested from tty
- SIGCONT : constant := 26; -- stopped process has been continued
- SIGTTIN : constant := 27; -- background tty read attempted
- SIGTTOU : constant := 28; -- background tty write attempted
- SIGURG : constant := 29; -- urgent condition on IO channel
- SIGLOST : constant := 30; -- File lock lost
- SIGUNUSED : constant := 31; -- unused signal (GNU/Linux)
- SIGXCPU : constant := 33; -- CPU time limit exceeded
- SIGXFSZ : constant := 34; -- filesize limit exceeded
- SIGSTKFLT : constant := 36; -- coprocessor stack fault (Linux)
- SIGLTHRRES : constant := 37; -- GNU/LinuxThreads restart signal
- SIGLTHRCAN : constant := 38; -- GNU/LinuxThreads cancel signal
- SIGLTHRDBG : constant := 39; -- GNU/LinuxThreads debugger signal
-
- SIGADAABORT : constant := SIGABRT;
- -- Change this if you want to use another signal for task abort.
- -- SIGTERM might be a good one.
-
- type Signal_Set is array (Natural range <>) of Signal;
-
- Unmasked : constant Signal_Set := (
- SIGTRAP,
- -- To enable debugging on multithreaded applications, mark SIGTRAP to
- -- be kept unmasked.
-
- SIGBUS,
-
- SIGTTIN, SIGTTOU, SIGTSTP,
- -- Keep these three signals unmasked so that background processes
- -- and IO behaves as normal "C" applications
-
- SIGPROF,
- -- To avoid confusing the profiler
-
- SIGKILL, SIGSTOP,
- -- These two signals actually cannot be masked;
- -- POSIX simply won't allow it.
-
- SIGLTHRRES, SIGLTHRCAN, SIGLTHRDBG);
- -- These three signals are used by GNU/LinuxThreads starting from
- -- glibc 2.1 (future 2.2).
-
- Reserved : constant Signal_Set :=
- -- I am not sure why the following two signals are reserved.
- -- I guess they are not supported by this version of GNU/Linux.
- (SIGVTALRM, SIGUNUSED);
-
- type sigset_t is private;
-
- function sigaddset (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigaddset, "sigaddset");
-
- function sigdelset (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigdelset, "sigdelset");
-
- function sigfillset (set : access sigset_t) return int;
- pragma Import (C, sigfillset, "sigfillset");
-
- function sigismember (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigismember, "sigismember");
-
- function sigemptyset (set : access sigset_t) return int;
- pragma Import (C, sigemptyset, "sigemptyset");
-
- type union_type_3 is new String (1 .. 116);
- type siginfo_t is record
- si_signo : int;
- si_code : int;
- si_errno : int;
- X_data : union_type_3;
- end record;
- pragma Convention (C, siginfo_t);
-
- type struct_sigaction is record
- sa_handler : System.Address;
- sa_flags : unsigned_long;
- sa_mask : sigset_t;
- end record;
- pragma Convention (C, struct_sigaction);
- type struct_sigaction_ptr is access all struct_sigaction;
-
- type Machine_State is record
- eip : unsigned_long;
- ebx : unsigned_long;
- esp : unsigned_long;
- ebp : unsigned_long;
- esi : unsigned_long;
- edi : unsigned_long;
- end record;
- type Machine_State_Ptr is access all Machine_State;
-
- SA_SIGINFO : constant := 16;
-
- SIG_BLOCK : constant := 0;
- SIG_UNBLOCK : constant := 1;
- SIG_SETMASK : constant := 2;
-
- SIG_DFL : constant := 0;
- SIG_IGN : constant := 1;
-
- function sigaction
- (sig : Signal;
- act : struct_sigaction_ptr;
- oact : struct_sigaction_ptr) return int;
- pragma Import (C, sigaction, "sigaction");
-
- ----------
- -- Time --
- ----------
-
- type timespec is private;
-
- function To_Duration (TS : timespec) return Duration;
- pragma Inline (To_Duration);
-
- function To_Timespec (D : Duration) return timespec;
- pragma Inline (To_Timespec);
-
- type struct_timeval is private;
-
- function To_Duration (TV : struct_timeval) return Duration;
- pragma Inline (To_Duration);
-
- function To_Timeval (D : Duration) return struct_timeval;
- pragma Inline (To_Timeval);
-
- function gettimeofday
- (tv : access struct_timeval;
- tz : System.Address := System.Null_Address) return int;
- pragma Import (C, gettimeofday, "gettimeofday");
-
- function sysconf (name : int) return long;
- pragma Import (C, sysconf);
-
- SC_CLK_TCK : constant := 2;
- SC_NPROCESSORS_ONLN : constant := 84;
-
- -------------------------
- -- Priority Scheduling --
- -------------------------
-
- SCHED_OTHER : constant := 0;
- SCHED_FIFO : constant := 1;
- SCHED_RR : constant := 2;
-
- function To_Target_Priority
- (Prio : System.Any_Priority) return Interfaces.C.int;
- -- Maps System.Any_Priority to a POSIX priority
-
- -------------
- -- Process --
- -------------
-
- type pid_t is private;
-
- function kill (pid : pid_t; sig : Signal) return int;
- pragma Import (C, kill, "kill");
-
- function getpid return pid_t;
- pragma Import (C, getpid, "getpid");
-
- -------------
- -- Threads --
- -------------
-
- type Thread_Body is access
- function (arg : System.Address) return System.Address;
- pragma Convention (C, Thread_Body);
-
- function Thread_Body_Access is new
- Ada.Unchecked_Conversion (System.Address, Thread_Body);
-
- type pthread_t is new unsigned_long;
- subtype Thread_Id is pthread_t;
-
- function To_pthread_t is new Ada.Unchecked_Conversion
- (unsigned_long, pthread_t);
-
- type pthread_mutex_t is limited private;
- type pthread_cond_t is limited private;
- type pthread_attr_t is limited private;
- type pthread_mutexattr_t is limited private;
- type pthread_condattr_t is limited private;
- type pthread_key_t is private;
-
- PTHREAD_CREATE_DETACHED : constant := 1;
-
- -----------
- -- Stack --
- -----------
-
- function Get_Stack_Base (thread : pthread_t) return Address;
- pragma Inline (Get_Stack_Base);
- -- This is a dummy procedure to share some GNULLI files
-
- ---------------------------------------
- -- Nonstandard Thread Initialization --
- ---------------------------------------
-
- procedure pthread_init;
- pragma Inline (pthread_init);
- -- This is a dummy procedure to share some GNULLI files
-
- -------------------------
- -- POSIX.1c Section 3 --
- -------------------------
-
- function sigwait (set : access sigset_t; sig : access Signal) return int;
- pragma Import (C, sigwait, "sigwait");
-
- function pthread_kill (thread : pthread_t; sig : Signal) return int;
- pragma Import (C, pthread_kill, "pthread_kill");
-
- function pthread_sigmask
- (how : int;
- set : access sigset_t;
- oset : access sigset_t) return int;
- pragma Import (C, pthread_sigmask, "pthread_sigmask");
-
- --------------------------
- -- POSIX.1c Section 11 --
- --------------------------
-
- function pthread_mutexattr_init
- (attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init");
-
- function pthread_mutexattr_destroy
- (attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy");
-
- function pthread_mutex_init
- (mutex : access pthread_mutex_t;
- attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutex_init, "pthread_mutex_init");
-
- function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy");
-
- function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock");
-
- function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock");
-
- function pthread_condattr_init
- (attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_condattr_init, "pthread_condattr_init");
-
- function pthread_condattr_destroy
- (attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy");
-
- function pthread_cond_init
- (cond : access pthread_cond_t;
- attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_cond_init, "pthread_cond_init");
-
- function pthread_cond_destroy (cond : access pthread_cond_t) return int;
- pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy");
-
- function pthread_cond_signal (cond : access pthread_cond_t) return int;
- pragma Import (C, pthread_cond_signal, "pthread_cond_signal");
-
- function pthread_cond_wait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_cond_wait, "pthread_cond_wait");
-
- function pthread_cond_timedwait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t;
- abstime : access timespec) return int;
- pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait");
-
- --------------------------
- -- POSIX.1c Section 13 --
- --------------------------
-
- type struct_sched_param is record
- sched_priority : int; -- scheduling priority
- end record;
- pragma Convention (C, struct_sched_param);
-
- function pthread_setschedparam
- (thread : pthread_t;
- policy : int;
- param : access struct_sched_param) return int;
- pragma Import (C, pthread_setschedparam, "pthread_setschedparam");
-
- function pthread_attr_setschedpolicy
- (attr : access pthread_attr_t;
- policy : int) return int;
- pragma Import
- (C, pthread_attr_setschedpolicy, "pthread_attr_setschedpolicy");
-
- function sched_yield return int;
- pragma Import (C, sched_yield, "sched_yield");
-
- ---------------------------
- -- P1003.1c - Section 16 --
- ---------------------------
-
- function pthread_attr_init
- (attributes : access pthread_attr_t) return int;
- pragma Import (C, pthread_attr_init, "pthread_attr_init");
-
- function pthread_attr_destroy
- (attributes : access pthread_attr_t) return int;
- pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy");
-
- function pthread_attr_setdetachstate
- (attr : access pthread_attr_t;
- detachstate : int) return int;
- pragma Import
- (C, pthread_attr_setdetachstate, "pthread_attr_setdetachstate");
-
- function pthread_attr_setstacksize
- (attr : access pthread_attr_t;
- stacksize : size_t) return int;
- pragma Import (C, pthread_attr_setstacksize, "pthread_attr_setstacksize");
-
- function pthread_create
- (thread : access pthread_t;
- attributes : access pthread_attr_t;
- start_routine : Thread_Body;
- arg : System.Address) return int;
- pragma Import (C, pthread_create, "pthread_create");
-
- procedure pthread_exit (status : System.Address);
- pragma Import (C, pthread_exit, "pthread_exit");
-
- function pthread_self return pthread_t;
- pragma Import (C, pthread_self, "pthread_self");
-
- --------------------------
- -- POSIX.1c Section 17 --
- --------------------------
-
- function pthread_setspecific
- (key : pthread_key_t;
- value : System.Address) return int;
- pragma Import (C, pthread_setspecific, "pthread_setspecific");
-
- function pthread_getspecific (key : pthread_key_t) return System.Address;
- pragma Import (C, pthread_getspecific, "pthread_getspecific");
-
- type destructor_pointer is access procedure (arg : System.Address);
- pragma Convention (C, destructor_pointer);
-
- function pthread_key_create
- (key : access pthread_key_t;
- destructor : destructor_pointer) return int;
- pragma Import (C, pthread_key_create, "pthread_key_create");
-
- CPU_SETSIZE : constant := 1_024;
-
- type bit_field is array (1 .. CPU_SETSIZE) of Boolean;
- for bit_field'Size use CPU_SETSIZE;
- pragma Pack (bit_field);
- pragma Convention (C, bit_field);
-
- type cpu_set_t is record
- bits : bit_field;
- end record;
- pragma Convention (C, cpu_set_t);
-
- function pthread_setaffinity_np
- (thread : pthread_t;
- cpusetsize : size_t;
- cpuset : access cpu_set_t) return int;
- pragma Import (C, pthread_setaffinity_np, "__gnat_pthread_setaffinity_np");
-
-private
-
- type sigset_t is array (0 .. 31) of unsigned_long;
- pragma Convention (C, sigset_t);
-
- type pid_t is new int;
-
- type time_t is new long;
-
- type timespec is record
- tv_sec : time_t;
- tv_nsec : long;
- end record;
- pragma Convention (C, timespec);
-
- type struct_timeval is record
- tv_sec : time_t;
- tv_usec : time_t;
- end record;
- pragma Convention (C, struct_timeval);
-
- type pthread_attr_t is record
- detachstate : int;
- schedpolicy : int;
- schedparam : struct_sched_param;
- inheritsched : int;
- scope : int;
- guardsize : size_t;
- stackaddr_set : int;
- stackaddr : System.Address;
- stacksize : size_t;
- end record;
- pragma Convention (C, pthread_attr_t);
-
- type pthread_condattr_t is record
- dummy : int;
- end record;
- pragma Convention (C, pthread_condattr_t);
-
- type pthread_mutexattr_t is record
- mutexkind : int;
- end record;
- pragma Convention (C, pthread_mutexattr_t);
-
- type lock_array is array (1 .. 4) of int;
- type atomic_lock_t is record
- lock : lock_array;
- end record;
- pragma Convention (C, atomic_lock_t);
- -- ??? Alignment should be 16 but this is larger than BIGGEST_ALIGNMENT.
- -- This causes an erroneous pointer value to sometimes be passed to free
- -- during deallocation. See PR ada/24533 for more details.
- for atomic_lock_t'Alignment use 8;
-
- type struct_pthread_fast_lock is record
- spinlock : atomic_lock_t;
- status : long;
- end record;
- pragma Convention (C, struct_pthread_fast_lock);
-
- type pthread_mutex_t is record
- m_reserved : int;
- m_count : int;
- m_owner : System.Address;
- m_kind : int;
- m_lock : struct_pthread_fast_lock;
- end record;
- pragma Convention (C, pthread_mutex_t);
-
- type pthread_cond_t is array (0 .. 47) of unsigned_char;
- pragma Convention (C, pthread_cond_t);
-
- type pthread_key_t is new unsigned;
-
-end System.OS_Interface;
-- Preelaborate. This package is designed to be a bottom-level (leaf) package.
with Ada.Unchecked_Conversion;
-
with Interfaces.C;
+with System.Linux;
package System.OS_Interface is
pragma Preelaborate;
function errno return int;
pragma Import (C, errno, "__get_errno");
- EAGAIN : constant := 11;
- EINTR : constant := 4;
- EINVAL : constant := 22;
- ENOMEM : constant := 12;
- EPERM : constant := 1;
- ETIMEDOUT : constant := 110;
+ EAGAIN : constant := System.Linux.EAGAIN;
+ EINTR : constant := System.Linux.EINTR;
+ EINVAL : constant := System.Linux.EINVAL;
+ ENOMEM : constant := System.Linux.ENOMEM;
+ EPERM : constant := System.Linux.EPERM;
+ ETIMEDOUT : constant := System.Linux.ETIMEDOUT;
-------------
-- Signals --
type Signal is new int range 0 .. Max_Interrupt;
for Signal'Size use int'Size;
- SIGHUP : constant := 1; -- hangup
- SIGINT : constant := 2; -- interrupt (rubout)
- SIGQUIT : constant := 3; -- quit (ASCD FS)
- SIGILL : constant := 4; -- illegal instruction (not reset)
- SIGTRAP : constant := 5; -- trace trap (not reset)
- SIGIOT : constant := 6; -- IOT instruction
- SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
- SIGFPE : constant := 8; -- floating point exception
- SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
- SIGBUS : constant := 7; -- bus error
- SIGSEGV : constant := 11; -- segmentation violation
- SIGPIPE : constant := 13; -- write on a pipe with no one to read it
- SIGALRM : constant := 14; -- alarm clock
- SIGTERM : constant := 15; -- software termination signal from kill
- SIGUSR1 : constant := 10; -- user defined signal 1
- SIGUSR2 : constant := 12; -- user defined signal 2
- SIGCLD : constant := 17; -- alias for SIGCHLD
- SIGCHLD : constant := 17; -- child status change
- SIGPWR : constant := 30; -- power-fail restart
- SIGWINCH : constant := 28; -- window size change
- SIGURG : constant := 23; -- urgent condition on IO channel
- SIGPOLL : constant := 29; -- pollable event occurred
- SIGIO : constant := 29; -- I/O now possible (4.2 BSD)
- SIGLOST : constant := 29; -- File lock lost
- SIGSTOP : constant := 19; -- stop (cannot be caught or ignored)
- SIGTSTP : constant := 20; -- user stop requested from tty
- SIGCONT : constant := 18; -- stopped process has been continued
- SIGTTIN : constant := 21; -- background tty read attempted
- SIGTTOU : constant := 22; -- background tty write attempted
- SIGVTALRM : constant := 26; -- virtual timer expired
- SIGPROF : constant := 27; -- profiling timer expired
- SIGXCPU : constant := 24; -- CPU time limit exceeded
- SIGXFSZ : constant := 25; -- filesize limit exceeded
- SIGUNUSED : constant := 31; -- unused signal (GNU/Linux)
- SIGSTKFLT : constant := 16; -- coprocessor stack fault (Linux)
- SIGLTHRRES : constant := 32; -- GNU/LinuxThreads restart signal
- SIGLTHRCAN : constant := 33; -- GNU/LinuxThreads cancel signal
- SIGLTHRDBG : constant := 34; -- GNU/LinuxThreads debugger signal
+ SIGHUP : constant := System.Linux.SIGHUP;
+ SIGINT : constant := System.Linux.SIGINT;
+ SIGQUIT : constant := System.Linux.SIGQUIT;
+ SIGILL : constant := System.Linux.SIGILL;
+ SIGTRAP : constant := System.Linux.SIGTRAP;
+ SIGIOT : constant := System.Linux.SIGIOT;
+ SIGABRT : constant := System.Linux.SIGABRT;
+ SIGFPE : constant := System.Linux.SIGFPE;
+ SIGKILL : constant := System.Linux.SIGKILL;
+ SIGBUS : constant := System.Linux.SIGBUS;
+ SIGSEGV : constant := System.Linux.SIGSEGV;
+ SIGPIPE : constant := System.Linux.SIGPIPE;
+ SIGALRM : constant := System.Linux.SIGALRM;
+ SIGTERM : constant := System.Linux.SIGTERM;
+ SIGUSR1 : constant := System.Linux.SIGUSR1;
+ SIGUSR2 : constant := System.Linux.SIGUSR2;
+ SIGCLD : constant := System.Linux.SIGCLD;
+ SIGCHLD : constant := System.Linux.SIGCHLD;
+ SIGPWR : constant := System.Linux.SIGPWR;
+ SIGWINCH : constant := System.Linux.SIGWINCH;
+ SIGURG : constant := System.Linux.SIGURG;
+ SIGPOLL : constant := System.Linux.SIGPOLL;
+ SIGIO : constant := System.Linux.SIGIO;
+ SIGLOST : constant := System.Linux.SIGLOST;
+ SIGSTOP : constant := System.Linux.SIGSTOP;
+ SIGTSTP : constant := System.Linux.SIGTSTP;
+ SIGCONT : constant := System.Linux.SIGCONT;
+ SIGTTIN : constant := System.Linux.SIGTTIN;
+ SIGTTOU : constant := System.Linux.SIGTTOU;
+ SIGVTALRM : constant := System.Linux.SIGVTALRM;
+ SIGPROF : constant := System.Linux.SIGPROF;
+ SIGXCPU : constant := System.Linux.SIGXCPU;
+ SIGXFSZ : constant := System.Linux.SIGXFSZ;
+ SIGUNUSED : constant := System.Linux.SIGUNUSED;
+ SIGSTKFLT : constant := System.Linux.SIGSTKFLT;
+ SIGLTHRRES : constant := System.Linux.SIGLTHRRES;
+ SIGLTHRCAN : constant := System.Linux.SIGLTHRCAN;
+ SIGLTHRDBG : constant := System.Linux.SIGLTHRDBG;
SIGADAABORT : constant := SIGABRT;
-- Change this if you want to use another signal for task abort.
pragma Convention (C, siginfo_t);
type struct_sigaction is record
- sa_handler : System.Address;
- sa_mask : sigset_t;
- sa_flags : unsigned_long;
- sa_restorer : System.Address;
+ sa_handler : System.Address;
+ sa_mask : sigset_t;
+ sa_flags : Interfaces.C.unsigned_long;
+ sa_restorer : System.Address;
end record;
pragma Convention (C, struct_sigaction);
+
type struct_sigaction_ptr is access all struct_sigaction;
type Machine_State is record
end record;
type Machine_State_Ptr is access all Machine_State;
- SA_SIGINFO : constant := 16#04#;
+ SA_SIGINFO : constant := System.Linux.SA_SIGINFO;
+ SA_ONSTACK : constant := System.Linux.SA_ONSTACK;
SIG_BLOCK : constant := 0;
SIG_UNBLOCK : constant := 1;
-- Stack --
-----------
+ type stack_t is record
+ ss_sp : System.Address;
+ ss_flags : int;
+ ss_size : size_t;
+ end record;
+ pragma Convention (C, stack_t);
+
+ function sigaltstack
+ (ss : not null access stack_t;
+ oss : access stack_t) return int;
+ pragma Import (C, sigaltstack, "sigaltstack");
+
+ Alternate_Stack : aliased System.Address;
+ pragma Import (C, Alternate_Stack, "__gnat_alternate_stack");
+ -- The alternate signal stack for stack overflows
+
+ Alternate_Stack_Size : constant := 16 * 1024;
+ -- This must be in keeping with init.c:__gnat_alternate_stack
+
function Get_Stack_Base (thread : pthread_t) return Address;
pragma Inline (Get_Stack_Base);
-- This is a dummy procedure to share some GNULLI files
private
- type sigset_t is array (0 .. 127) of unsigned_char;
+ type sigset_t is array (0 .. 127) of Interfaces.C.unsigned_char;
pragma Convention (C, sigset_t);
- for sigset_t'Alignment use unsigned_long'Alignment;
+ for sigset_t'Alignment use Interfaces.C.unsigned_long'Alignment;
+
+ pragma Warnings (Off);
+ for struct_sigaction use record
+ sa_handler at 0 range 0 .. Standard'Address_Size - 1;
+ sa_mask at Linux.sa_mask_pos range 0 .. 1023;
+ sa_flags at Linux.sa_flags_pos range 0 .. Standard'Address_Size - 1;
+ end record;
+ -- We intentionally leave sa_restorer unspecified and let the compiler
+ -- append it after the last field, so disable corresponding warning.
+ pragma Warnings (On);
type pid_t is new int;
end record;
pragma Convention (C, pthread_mutexattr_t);
- type struct_pthread_fast_lock is record
- status : long;
- spinlock : int;
- end record;
- pragma Convention (C, struct_pthread_fast_lock);
-
- type pthread_mutex_t is record
- m_reserved : int;
- m_count : int;
- m_owner : System.Address;
- m_kind : int;
- m_lock : struct_pthread_fast_lock;
- end record;
- pragma Convention (C, pthread_mutex_t);
+ type pthread_mutex_t is new System.Linux.pthread_mutex_t;
type pthread_cond_t is array (0 .. 47) of unsigned_char;
pragma Convention (C, pthread_cond_t);
-- Stack --
-----------
+ Alternate_Stack_Size : constant := 0;
+ -- No alternate signal stack is used on this platform
+
Stack_Base_Available : constant Boolean := False;
-- Indicates wether the stack base is available on this target
pragma Convention (C, struct_sigaction);
type struct_sigaction_ptr is access all struct_sigaction;
- SA_SIGINFO : constant := 16#80#;
+ SA_SIGINFO : constant := 16#80#;
+
+ SA_ONSTACK : constant := 16#00#;
+ -- SA_ONSTACK is not defined on LynxOS, but it is refered to in the POSIX
+ -- implementation of System.Interrupt_Management. Therefore we define a
+ -- dummy value of zero here so that setting this flag is a nop.
SIG_BLOCK : constant := 0;
SIG_UNBLOCK : constant := 1;
-- Stack --
-----------
+ Alternate_Stack_Size : constant := 0;
+ -- No alternate signal stack is used on this platform
+
Stack_Base_Available : constant Boolean := False;
-- Indicates whether the stack base is available on this target
-- This is a NT (native) version of this package
-- This package encapsulates all direct interfaces to OS services
--- that are needed by the tasking run-time (libgnarl).
+-- that are needed by the tasking run-time (libgnarl). For non tasking
+-- oriented services consider declaring them into system-win32.
-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
-- Preelaborate. This package is designed to be a bottom-level (leaf) package.
-with Interfaces.C;
+with Ada.Unchecked_Conversion;
+with Interfaces.C;
with Interfaces.C.Strings;
-
-with Ada.Unchecked_Conversion;
+with System.Win32;
package System.OS_Interface is
pragma Preelaborate;
-- General Types --
-------------------
- type DWORD is new Interfaces.C.unsigned_long;
- type WORD is new Interfaces.C.unsigned_short;
-
- -- The LARGE_INTEGER type is actually a fixed point type
- -- that only can represent integers. The reason for this is
- -- easier conversion to Duration or other fixed point types.
- -- (See Operations.Clock)
-
- type LARGE_INTEGER is delta 1.0 range -2.0**63 .. 2.0**63 - 1.0;
-
subtype PSZ is Interfaces.C.Strings.chars_ptr;
- subtype PCHAR is Interfaces.C.Strings.chars_ptr;
-
- subtype PVOID is System.Address;
-
- Null_Void : constant PVOID := System.Null_Address;
- type PLONG is access all Interfaces.C.long;
- type PDWORD is access all DWORD;
- type BYTE is new Interfaces.C.unsigned_char;
- subtype CHAR is Interfaces.C.char;
-
- type BOOL is new Boolean;
- for BOOL'Size use Interfaces.C.unsigned_long'Size;
+ Null_Void : constant Win32.PVOID := System.Null_Address;
-------------------------
-- Handles for objects --
-------------------------
- type HANDLE is new Interfaces.C.long;
- type PHANDLE is access all HANDLE;
-
- subtype Thread_Id is HANDLE;
+ subtype Thread_Id is Win32.HANDLE;
-----------
-- Errno --
NO_ERROR : constant := 0;
FUNC_ERR : constant := -1;
- -----------
- -- Files --
- -----------
-
- type SECURITY_ATTRIBUTES is record
- nLength : DWORD;
- pSecurityDescriptor : PVOID;
- bInheritHandle : BOOL;
- end record;
-
- function CloseHandle (hObject : HANDLE) return BOOL;
- pragma Import (Stdcall, CloseHandle, "CloseHandle");
-
- ------------------------
- -- System Information --
- ------------------------
-
- type SYSTEM_INFO is record
- dwOemId : DWORD;
- dwPageSize : DWORD;
- lpMinimumApplicationAddress : PVOID;
- lpMaximumApplicationAddress : PVOID;
- dwActiveProcessorMask : DWORD;
- dwNumberOfProcessors : DWORD;
- dwProcessorType : DWORD;
- dwAllocationGranularity : DWORD;
- dwReserved : DWORD;
- end record;
-
- procedure GetSystemInfo (SI : access SYSTEM_INFO);
- pragma Import (Stdcall, GetSystemInfo, "GetSystemInfo");
-
-------------
-- Signals --
-------------
procedure kill (sig : Signal);
pragma Import (C, kill, "raise");
- ---------------------
- -- Time Management --
- ---------------------
-
- procedure Sleep (dwMilliseconds : DWORD);
- pragma Import (Stdcall, Sleep, External_Name => "Sleep");
-
- type SYSTEMTIME is record
- wYear : WORD;
- wMonth : WORD;
- wDayOfWeek : WORD;
- wDay : WORD;
- wHour : WORD;
- wMinute : WORD;
- wSecond : WORD;
- wMilliseconds : WORD;
- end record;
-
- procedure GetSystemTime (pSystemTime : access SYSTEMTIME);
- pragma Import (Stdcall, GetSystemTime, "GetSystemTime");
-
- procedure GetSystemTimeAsFileTime (lpFileTime : access Long_Long_Integer);
- pragma Import (Stdcall, GetSystemTimeAsFileTime, "GetSystemTimeAsFileTime");
-
- function SetSystemTime (pSystemTime : access SYSTEMTIME) return BOOL;
- pragma Import (Stdcall, SetSystemTime, "SetSystemTime");
-
- function FileTimeToSystemTime
- (lpFileTime : access Long_Long_Integer;
- lpSystemTime : access SYSTEMTIME) return BOOL;
- pragma Import (Stdcall, FileTimeToSystemTime, "FileTimeToSystemTime");
-
- function SystemTimeToFileTime
- (lpSystemTime : access SYSTEMTIME;
- lpFileTime : access Long_Long_Integer) return BOOL;
- pragma Import (Stdcall, SystemTimeToFileTime, "SystemTimeToFileTime");
-
- function FileTimeToLocalFileTime
- (lpFileTime : access Long_Long_Integer;
- lpLocalFileTime : access Long_Long_Integer) return BOOL;
- pragma Import (Stdcall, FileTimeToLocalFileTime, "FileTimeToLocalFileTime");
-
- function LocalFileTimeToFileTime
- (lpFileTime : access Long_Long_Integer;
- lpLocalFileTime : access Long_Long_Integer) return BOOL;
- pragma Import (Stdcall, LocalFileTimeToFileTime, "LocalFileTimeToFileTime");
-
- function QueryPerformanceCounter
- (lpPerformanceCount : access LARGE_INTEGER) return BOOL;
- pragma Import
- (Stdcall, QueryPerformanceCounter, "QueryPerformanceCounter");
-
- function QueryPerformanceFrequency
- (lpFrequency : access LARGE_INTEGER) return BOOL;
- pragma Import
- (Stdcall, QueryPerformanceFrequency, "QueryPerformanceFrequency");
-
-------------
-- Threads --
-------------
pragma Import (Stdcall, SwitchToThread, "SwitchToThread");
function GetThreadTimes
- (hThread : HANDLE;
+ (hThread : Win32.HANDLE;
lpCreationTime : access Long_Long_Integer;
lpExitTime : access Long_Long_Integer;
lpKernelTime : access Long_Long_Integer;
- lpUserTime : access Long_Long_Integer) return BOOL;
+ lpUserTime : access Long_Long_Integer) return Win32.BOOL;
pragma Import (Stdcall, GetThreadTimes, "GetThreadTimes");
-----------------------
type CRITICAL_SECTION is private;
- procedure InitializeCriticalSection
- (pCriticalSection : access CRITICAL_SECTION);
- pragma Import
- (Stdcall, InitializeCriticalSection, "InitializeCriticalSection");
-
- procedure EnterCriticalSection
- (pCriticalSection : access CRITICAL_SECTION);
- pragma Import (Stdcall, EnterCriticalSection, "EnterCriticalSection");
-
- procedure LeaveCriticalSection
- (pCriticalSection : access CRITICAL_SECTION);
- pragma Import (Stdcall, LeaveCriticalSection, "LeaveCriticalSection");
-
- procedure DeleteCriticalSection
- (pCriticalSection : access CRITICAL_SECTION);
- pragma Import (Stdcall, DeleteCriticalSection, "DeleteCriticalSection");
-
-------------------------------------------------------------
-- Thread Creation, Activation, Suspension And Termination --
-------------------------------------------------------------
- subtype ProcessorId is DWORD;
-
type PTHREAD_START_ROUTINE is access function
- (pThreadParameter : PVOID) return DWORD;
+ (pThreadParameter : Win32.PVOID) return Win32.DWORD;
pragma Convention (Stdcall, PTHREAD_START_ROUTINE);
function To_PTHREAD_START_ROUTINE is new
Ada.Unchecked_Conversion (System.Address, PTHREAD_START_ROUTINE);
function CreateThread
- (pThreadAttributes : access SECURITY_ATTRIBUTES;
- dwStackSize : DWORD;
+ (pThreadAttributes : access Win32.SECURITY_ATTRIBUTES;
+ dwStackSize : Win32.DWORD;
pStartAddress : PTHREAD_START_ROUTINE;
- pParameter : PVOID;
- dwCreationFlags : DWORD;
- pThreadId : PDWORD) return HANDLE;
+ pParameter : Win32.PVOID;
+ dwCreationFlags : Win32.DWORD;
+ pThreadId : access Win32.DWORD) return Win32.HANDLE;
pragma Import (Stdcall, CreateThread, "CreateThread");
function BeginThreadEx
- (pThreadAttributes : access SECURITY_ATTRIBUTES;
- dwStackSize : DWORD;
+ (pThreadAttributes : access Win32.SECURITY_ATTRIBUTES;
+ dwStackSize : Win32.DWORD;
pStartAddress : PTHREAD_START_ROUTINE;
- pParameter : PVOID;
- dwCreationFlags : DWORD;
- pThreadId : PDWORD) return HANDLE;
+ pParameter : Win32.PVOID;
+ dwCreationFlags : Win32.DWORD;
+ pThreadId : not null access Win32.DWORD) return Win32.HANDLE;
pragma Import (C, BeginThreadEx, "_beginthreadex");
Debug_Process : constant := 16#00000001#;
Stack_Size_Param_Is_A_Reservation : constant := 16#00010000#;
function GetExitCodeThread
- (hThread : HANDLE;
- pExitCode : PDWORD) return BOOL;
+ (hThread : Win32.HANDLE;
+ pExitCode : not null access Win32.DWORD) return Win32.BOOL;
pragma Import (Stdcall, GetExitCodeThread, "GetExitCodeThread");
- function ResumeThread (hThread : HANDLE) return DWORD;
+ function ResumeThread (hThread : Win32.HANDLE) return Win32.DWORD;
pragma Import (Stdcall, ResumeThread, "ResumeThread");
- function SuspendThread (hThread : HANDLE) return DWORD;
+ function SuspendThread (hThread : Win32.HANDLE) return Win32.DWORD;
pragma Import (Stdcall, SuspendThread, "SuspendThread");
- procedure ExitThread (dwExitCode : DWORD);
+ procedure ExitThread (dwExitCode : Win32.DWORD);
pragma Import (Stdcall, ExitThread, "ExitThread");
- procedure EndThreadEx (dwExitCode : DWORD);
+ procedure EndThreadEx (dwExitCode : Win32.DWORD);
pragma Import (C, EndThreadEx, "_endthreadex");
function TerminateThread
- (hThread : HANDLE;
- dwExitCode : DWORD) return BOOL;
+ (hThread : Win32.HANDLE;
+ dwExitCode : Win32.DWORD) return Win32.BOOL;
pragma Import (Stdcall, TerminateThread, "TerminateThread");
- function GetCurrentThread return HANDLE;
+ function GetCurrentThread return Win32.HANDLE;
pragma Import (Stdcall, GetCurrentThread, "GetCurrentThread");
- function GetCurrentProcess return HANDLE;
+ function GetCurrentProcess return Win32.HANDLE;
pragma Import (Stdcall, GetCurrentProcess, "GetCurrentProcess");
- function GetCurrentThreadId return DWORD;
+ function GetCurrentThreadId return Win32.DWORD;
pragma Import (Stdcall, GetCurrentThreadId, "GetCurrentThreadId");
- function TlsAlloc return DWORD;
+ function TlsAlloc return Win32.DWORD;
pragma Import (Stdcall, TlsAlloc, "TlsAlloc");
- function TlsGetValue (dwTlsIndex : DWORD) return PVOID;
+ function TlsGetValue (dwTlsIndex : Win32.DWORD) return Win32.PVOID;
pragma Import (Stdcall, TlsGetValue, "TlsGetValue");
- function TlsSetValue (dwTlsIndex : DWORD; pTlsValue : PVOID) return BOOL;
+ function TlsSetValue
+ (dwTlsIndex : Win32.DWORD; pTlsValue : Win32.PVOID) return Win32.BOOL;
pragma Import (Stdcall, TlsSetValue, "TlsSetValue");
- function TlsFree (dwTlsIndex : DWORD) return BOOL;
+ function TlsFree (dwTlsIndex : Win32.DWORD) return Win32.BOOL;
pragma Import (Stdcall, TlsFree, "TlsFree");
- TLS_Nothing : constant := DWORD'Last;
+ TLS_Nothing : constant := Win32.DWORD'Last;
procedure ExitProcess (uExitCode : Interfaces.C.unsigned);
pragma Import (Stdcall, ExitProcess, "ExitProcess");
function WaitForSingleObject
- (hHandle : HANDLE;
- dwMilliseconds : DWORD) return DWORD;
+ (hHandle : Win32.HANDLE;
+ dwMilliseconds : Win32.DWORD) return Win32.DWORD;
pragma Import (Stdcall, WaitForSingleObject, "WaitForSingleObject");
function WaitForSingleObjectEx
- (hHandle : HANDLE;
- dwMilliseconds : DWORD;
- fAlertable : BOOL) return DWORD;
+ (hHandle : Win32.HANDLE;
+ dwMilliseconds : Win32.DWORD;
+ fAlertable : Win32.BOOL) return Win32.DWORD;
pragma Import (Stdcall, WaitForSingleObjectEx, "WaitForSingleObjectEx");
- function SetThreadIdealProcessor
- (hThread : HANDLE;
- dwIdealProcessor : ProcessorId) return DWORD;
- pragma Import (Stdcall, SetThreadIdealProcessor, "SetThreadIdealProcessor");
-
- Wait_Infinite : constant := DWORD'Last;
+ Wait_Infinite : constant := Win32.DWORD'Last;
WAIT_TIMEOUT : constant := 16#0000_0102#;
WAIT_FAILED : constant := 16#FFFF_FFFF#;
------------------------------------
function CreateSemaphore
- (pSemaphoreAttributes : access SECURITY_ATTRIBUTES;
+ (pSemaphoreAttributes : access Win32.SECURITY_ATTRIBUTES;
lInitialCount : Interfaces.C.long;
lMaximumCount : Interfaces.C.long;
- pName : PSZ) return HANDLE;
+ pName : PSZ) return Win32.HANDLE;
pragma Import (Stdcall, CreateSemaphore, "CreateSemaphoreA");
function OpenSemaphore
- (dwDesiredAccess : DWORD;
- bInheritHandle : BOOL;
- pName : PSZ) return HANDLE;
+ (dwDesiredAccess : Win32.DWORD;
+ bInheritHandle : Win32.BOOL;
+ pName : PSZ) return Win32.HANDLE;
pragma Import (Stdcall, OpenSemaphore, "OpenSemaphoreA");
function ReleaseSemaphore
- (hSemaphore : HANDLE;
+ (hSemaphore : Win32.HANDLE;
lReleaseCount : Interfaces.C.long;
- pPreviousCount : PLONG) return BOOL;
+ pPreviousCount : access Win32.LONG) return Win32.BOOL;
pragma Import (Stdcall, ReleaseSemaphore, "ReleaseSemaphore");
function CreateEvent
- (pEventAttributes : access SECURITY_ATTRIBUTES;
- bManualReset : BOOL;
- bInitialState : BOOL;
- pName : PSZ) return HANDLE;
+ (pEventAttributes : access Win32.SECURITY_ATTRIBUTES;
+ bManualReset : Win32.BOOL;
+ bInitialState : Win32.BOOL;
+ pName : PSZ) return Win32.HANDLE;
pragma Import (Stdcall, CreateEvent, "CreateEventA");
function OpenEvent
- (dwDesiredAccess : DWORD;
- bInheritHandle : BOOL;
- pName : PSZ) return HANDLE;
+ (dwDesiredAccess : Win32.DWORD;
+ bInheritHandle : Win32.BOOL;
+ pName : PSZ) return Win32.HANDLE;
pragma Import (Stdcall, OpenEvent, "OpenEventA");
- function SetEvent (hEvent : HANDLE) return BOOL;
+ function SetEvent (hEvent : Win32.HANDLE) return Win32.BOOL;
pragma Import (Stdcall, SetEvent, "SetEvent");
- function ResetEvent (hEvent : HANDLE) return BOOL;
+ function ResetEvent (hEvent : Win32.HANDLE) return Win32.BOOL;
pragma Import (Stdcall, ResetEvent, "ResetEvent");
- function PulseEvent (hEvent : HANDLE) return BOOL;
+ function PulseEvent (hEvent : Win32.HANDLE) return Win32.BOOL;
pragma Import (Stdcall, PulseEvent, "PulseEvent");
function CreateMutex
- (pMutexAttributes : access SECURITY_ATTRIBUTES;
- bInitialOwner : BOOL;
- pName : PSZ) return HANDLE;
+ (pMutexAttributes : access Win32.SECURITY_ATTRIBUTES;
+ bInitialOwner : Win32.BOOL;
+ pName : PSZ) return Win32.HANDLE;
pragma Import (Stdcall, CreateMutex, "CreateMutexA");
function OpenMutex
- (dwDesiredAccess : DWORD;
- bInheritHandle : BOOL;
- pName : PSZ) return HANDLE;
+ (dwDesiredAccess : Win32.DWORD;
+ bInheritHandle : Win32.BOOL;
+ pName : PSZ) return Win32.HANDLE;
pragma Import (Stdcall, OpenMutex, "OpenMutexA");
- function ReleaseMutex (hMutex : HANDLE) return BOOL;
+ function ReleaseMutex (hMutex : Win32.HANDLE) return Win32.BOOL;
pragma Import (Stdcall, ReleaseMutex, "ReleaseMutex");
---------------------------------------------------
-----------------
function SetThreadPriority
- (hThread : HANDLE;
- nPriority : Interfaces.C.int) return BOOL;
+ (hThread : Win32.HANDLE;
+ nPriority : Interfaces.C.int) return Win32.BOOL;
pragma Import (Stdcall, SetThreadPriority, "SetThreadPriority");
- function GetThreadPriority (hThread : HANDLE) return Interfaces.C.int;
+ function GetThreadPriority (hThread : Win32.HANDLE) return Interfaces.C.int;
pragma Import (Stdcall, GetThreadPriority, "GetThreadPriority");
function SetPriorityClass
- (hProcess : HANDLE;
- dwPriorityClass : DWORD) return BOOL;
+ (hProcess : Win32.HANDLE;
+ dwPriorityClass : Win32.DWORD) return Win32.BOOL;
pragma Import (Stdcall, SetPriorityClass, "SetPriorityClass");
procedure SetThreadPriorityBoost
- (hThread : HANDLE;
- DisablePriorityBoost : BOOL);
+ (hThread : Win32.HANDLE;
+ DisablePriorityBoost : Win32.BOOL);
pragma Import (Stdcall, SetThreadPriorityBoost, "SetThreadPriorityBoost");
Normal_Priority_Class : constant := 16#00000020#;
Thread_Priority_Time_Critical : constant := 15;
Thread_Priority_Error_Return : constant := Interfaces.C.long'Last;
- function GetLastError return DWORD;
- pragma Import (Stdcall, GetLastError, "GetLastError");
-
private
type sigset_t is new Interfaces.C.unsigned_long;
type CRITICAL_SECTION is record
- DebugInfo : System.Address;
- -- The following three fields control entering and
- -- exiting the critical section for the resource
+ DebugInfo : System.Address;
+
LockCount : Long_Integer;
RecursionCount : Long_Integer;
- OwningThread : HANDLE;
- LockSemaphore : HANDLE;
- Reserved : DWORD;
+ OwningThread : Win32.HANDLE;
+ -- The above three fields control entering and exiting the critical
+ -- section for the resource.
+
+ LockSemaphore : Win32.HANDLE;
+ Reserved : Win32.DWORD;
end record;
end System.OS_Interface;
type struct_sigaction_ptr is access all struct_sigaction;
SA_SIGINFO : constant := 16#0008#;
+ SA_ONSTACK : constant := 16#0001#;
SIG_BLOCK : constant := 1;
SIG_UNBLOCK : constant := 2;
-- Stack --
-----------
+ type stack_t is record
+ ss_sp : System.Address;
+ ss_size : size_t;
+ ss_flags : int;
+ end record;
+ pragma Convention (C, stack_t);
+
+ function sigaltstack
+ (ss : not null access stack_t;
+ oss : access stack_t) return int;
+ pragma Import (C, sigaltstack, "sigaltstack");
+
+ Alternate_Stack : aliased System.Address;
+ -- This is a dummy definition, never used (Alternate_Stack_Size is null)
+
+ Alternate_Stack_Size : constant := 0;
+ -- No alternate signal stack is used on this platform
+
Stack_Base_Available : constant Boolean := False;
-- Indicates whether the stack base is available on this target
function Get_Stack_Base (thread : pthread_t) return Address;
pragma Inline (Get_Stack_Base);
- -- returns the stack base of the specified thread.
- -- Only call this function when Stack_Base_Available is True.
+ -- Returns the stack base of the specified thread. Only call this function
+ -- when Stack_Base_Available is True.
function Get_Page_Size return size_t;
function Get_Page_Size return Address;
pragma Import (C, Get_Page_Size, "getpagesize");
- -- returns the size of a page, or 0 if this is not relevant on this
- -- target
+ -- Returns the size of a page, or 0 if this is not relevant on this target
PROT_NONE : constant := 0;
PROT_READ : constant := 1;
PROT_WRITE : constant := 2;
PROT_EXEC : constant := 4;
PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC;
-
PROT_ON : constant := PROT_READ;
PROT_OFF : constant := PROT_ALL;
SA_NODEFER : constant := 8;
SA_SIGINFO : constant := 16#40#;
+ SA_ONSTACK : constant := 16#01#;
function sigaction
(sig : Signal;
with System.Tasking.Debug;
with System.Interrupt_Management;
with System.OS_Primitives;
-with System.Storage_Elements;
with System.Stack_Checking.Operations;
with System.Soft_Links;
use System.OS_Interface;
use System.Parameters;
use System.OS_Primitives;
- use System.Storage_Elements;
use System.Task_Info;
+ Use_Alternate_Stack : constant Boolean := Alternate_Stack_Size /= 0;
+ -- Whether to use an alternate signal stack for stack overflows
+
----------------
-- Local Data --
----------------
function To_pthread_t is new Ada.Unchecked_Conversion
(unsigned_long, System.OS_Interface.pthread_t);
- procedure Get_Stack_Attributes
- (T : Task_Id;
- ISP : out System.Address;
- Size : out Storage_Offset);
- -- Fill ISP and Size with the Initial Stack Pointer value and the
- -- thread stack size for task T.
-
-------------------
-- Abort_Handler --
-------------------
return T.Common.Current_Priority;
end Get_Priority;
- --------------------------
- -- Get_Stack_Attributes --
- --------------------------
-
- procedure Get_Stack_Attributes
- (T : Task_Id;
- ISP : out System.Address;
- Size : out Storage_Offset)
- is
- function pthread_getattr_np
- (thread : pthread_t;
- attr : System.Address) return Interfaces.C.int;
- pragma Import (C, pthread_getattr_np, "pthread_getattr_np");
-
- function pthread_attr_getstack
- (attr : System.Address;
- base : System.Address;
- size : System.Address) return Interfaces.C.int;
- pragma Import (C, pthread_attr_getstack, "pthread_attr_getstack");
-
- Result : Interfaces.C.int;
-
- Attributes : aliased pthread_attr_t;
- Stack_Base : aliased System.Address;
- Stack_Size : aliased Storage_Offset;
-
- begin
- Result :=
- pthread_getattr_np
- (T.Common.LL.Thread, Attributes'Address);
- pragma Assert (Result = 0);
-
- Result :=
- pthread_attr_getstack
- (Attributes'Address, Stack_Base'Address, Stack_Size'Address);
- pragma Assert (Result = 0);
-
- Result := pthread_attr_destroy (Attributes'Access);
- pragma Assert (Result = 0);
-
- ISP := Stack_Base + Stack_Size;
- Size := Stack_Size;
- end Get_Stack_Attributes;
-
----------------
-- Enter_Task --
----------------
procedure Enter_Task (Self_ID : Task_Id) is
begin
if Self_ID.Common.Task_Info /= null
- and then
- Self_ID.Common.Task_Info.CPU_Affinity = No_CPU
+ and then Self_ID.Common.Task_Info.CPU_Affinity = No_CPU
then
raise Invalid_CPU_Number;
end if;
Unlock_RTS;
- -- Determine where the task stack starts, how large it is, and let the
- -- stack checking engine know about it.
-
- declare
- Initial_SP : System.Address;
- Stack_Size : Storage_Offset;
- begin
- Get_Stack_Attributes (Self_ID, Initial_SP, Stack_Size);
- System.Stack_Checking.Operations.Notify_Stack_Attributes
- (Initial_SP, Stack_Size);
- end;
+ if Use_Alternate_Stack then
+ declare
+ Stack : aliased stack_t;
+ Result : Interfaces.C.int;
+ begin
+ Stack.ss_sp := Self_ID.Common.Task_Alternate_Stack;
+ Stack.ss_size := Alternate_Stack_Size;
+ Stack.ss_flags := 0;
+ Result := sigaltstack (Stack'Access, null);
+ pragma Assert (Result = 0);
+ end;
+ end if;
end Enter_Task;
--------------
Priority : System.Any_Priority;
Succeeded : out Boolean)
is
- Attributes : aliased pthread_attr_t;
- Result : Interfaces.C.int;
+ Attributes : aliased pthread_attr_t;
+ Adjusted_Stack_Size : Interfaces.C.size_t;
+ Result : Interfaces.C.int;
begin
+ Adjusted_Stack_Size :=
+ Interfaces.C.size_t (Stack_Size + Alternate_Stack_Size);
+
Result := pthread_attr_init (Attributes'Access);
pragma Assert (Result = 0 or else Result = ENOMEM);
Result :=
pthread_attr_setstacksize
- (Attributes'Access, Interfaces.C.size_t (Stack_Size));
+ (Attributes'Access, Adjusted_Stack_Size);
pragma Assert (Result = 0);
Result :=
Attributes'Access,
Thread_Body_Access (Wrapper),
To_Address (T));
- pragma Assert (Result = 0 or else Result = EAGAIN);
+ pragma Assert
+ (Result = 0 or else Result = EAGAIN or else Result = ENOMEM);
if Result /= 0 then
Succeeded := False;
pragma Assert (Result = 0);
SSL.Abort_Undefer.all;
- end
- if;
+ end if;
end Suspend_Until_True;
----------------
old_act : aliased struct_sigaction;
Tmp_Set : aliased sigset_t;
Result : Interfaces.C.int;
+ -- Whether to use an alternate signal stack for stack overflows
function State
(Int : System.Interrupt_Management.Interrupt_ID) return Character;
Specific.Initialize (Environment_Task);
+ if Use_Alternate_Stack then
+ Environment_Task.Common.Task_Alternate_Stack :=
+ Alternate_Stack'Address;
+ end if;
+
Enter_Task (Environment_Task);
-- Install the abort-signal handler
with System.OS_Primitives;
with System.Task_Info;
with System.Interrupt_Management;
+with System.Win32.Ext;
with System.Soft_Links;
-- We use System.Soft_Links instead of System.Tasking.Initialization because
use System.Parameters;
use System.OS_Primitives;
use System.Task_Info;
+ use System.Win32;
+ use System.Win32.Ext;
pragma Link_With ("-Xlinker --stack=0x200000,0x1000");
-- Change the default stack size (2 MB) for tasking programs on Windows.
-- Also note that under Windows XP, we use a Windows XP extension to
-- specify the stack size on a per task basis, as done under other OSes.
+ ---------------------
+ -- Local Functions --
+ ---------------------
+
+ procedure InitializeCriticalSection (pCriticalSection : access RTS_Lock);
+ procedure InitializeCriticalSection
+ (pCriticalSection : access CRITICAL_SECTION);
+ pragma Import
+ (Stdcall, InitializeCriticalSection, "InitializeCriticalSection");
+
+ procedure EnterCriticalSection (pCriticalSection : access RTS_Lock);
+ procedure EnterCriticalSection
+ (pCriticalSection : access CRITICAL_SECTION);
+ pragma Import (Stdcall, EnterCriticalSection, "EnterCriticalSection");
+
+ procedure LeaveCriticalSection (pCriticalSection : access RTS_Lock);
+ procedure LeaveCriticalSection (pCriticalSection : access CRITICAL_SECTION);
+ pragma Import (Stdcall, LeaveCriticalSection, "LeaveCriticalSection");
+
+ procedure DeleteCriticalSection (pCriticalSection : access RTS_Lock);
+ procedure DeleteCriticalSection
+ (pCriticalSection : access CRITICAL_SECTION);
+ pragma Import (Stdcall, DeleteCriticalSection, "DeleteCriticalSection");
+
----------------
-- Local Data --
----------------
Succeeded : BOOL;
begin
Succeeded := TlsSetValue (TlsIndex, To_Address (Self_Id));
- pragma Assert (Succeeded = True);
+ pragma Assert (Succeeded = Win32.TRUE);
end Set;
end Specific;
procedure Initialize_Cond (Cond : not null access Condition_Variable) is
hEvent : HANDLE;
begin
- hEvent := CreateEvent (null, True, False, Null_Ptr);
+ hEvent := CreateEvent (null, Win32.TRUE, Win32.FALSE, Null_Ptr);
pragma Assert (hEvent /= 0);
Cond.all := Condition_Variable (hEvent);
end Initialize_Cond;
Result : BOOL;
begin
Result := CloseHandle (HANDLE (Cond.all));
- pragma Assert (Result = True);
+ pragma Assert (Result = Win32.TRUE);
end Finalize_Cond;
-----------------
Result : BOOL;
begin
Result := SetEvent (HANDLE (Cond.all));
- pragma Assert (Result = True);
+ pragma Assert (Result = Win32.TRUE);
end Cond_Signal;
---------------
-- Must reset Cond BEFORE L is unlocked
Result_Bool := ResetEvent (HANDLE (Cond.all));
- pragma Assert (Result_Bool = True);
+ pragma Assert (Result_Bool = Win32.TRUE);
Unlock (L, Global_Lock => True);
-- No problem if we are interrupted here: if the condition is signaled,
-- Must reset Cond BEFORE L is unlocked
Result := ResetEvent (HANDLE (Cond.all));
- pragma Assert (Result = True);
+ pragma Assert (Result = Win32.TRUE);
Unlock (L, Global_Lock => True);
-- No problem if we are interrupted here: if the condition is signaled,
if Timed_Out then
Result := SetEvent (HANDLE (Cond.all));
- pragma Assert (Result = True);
+ pragma Assert (Result = Win32.TRUE);
end if;
Status := Integer (Wait_Result);
is
pragma Unreferenced (Level);
begin
- InitializeCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access);
+ InitializeCriticalSection (L);
end Initialize_Lock;
-------------------
procedure Finalize_Lock (L : not null access RTS_Lock) is
begin
- DeleteCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access);
+ DeleteCriticalSection (L);
end Finalize_Lock;
----------------
is
begin
if not Single_Lock or else Global_Lock then
- EnterCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access);
+ EnterCriticalSection (L);
end if;
end Write_Lock;
procedure Write_Lock (T : Task_Id) is
begin
if not Single_Lock then
- EnterCriticalSection
- (CRITICAL_SECTION (T.Common.LL.L)'Unrestricted_Access);
+ EnterCriticalSection (T.Common.LL.L'Access);
end if;
end Write_Lock;
(L : not null access RTS_Lock; Global_Lock : Boolean := False) is
begin
if not Single_Lock or else Global_Lock then
- LeaveCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access);
+ LeaveCriticalSection (L);
end if;
end Unlock;
procedure Unlock (T : Task_Id) is
begin
if not Single_Lock then
- LeaveCriticalSection
- (CRITICAL_SECTION (T.Common.LL.L)'Unrestricted_Access);
+ LeaveCriticalSection (T.Common.LL.L'Access);
end if;
end Unlock;
begin
Res := SetThreadPriority
(T.Common.LL.Thread, Interfaces.C.int (Underlying_Priorities (Prio)));
- pragma Assert (Res = True);
+ pragma Assert (Res = Win32.TRUE);
if Dispatching_Policy = 'F' or else Get_Policy (Prio) = 'F' then
hTask : HANDLE;
TaskId : aliased DWORD;
- pTaskParameter : System.OS_Interface.PVOID;
+ pTaskParameter : Win32.PVOID;
Result : DWORD;
Entry_Point : PTHREAD_START_ROUTINE;
-- boost. A priority boost is temporarily given by the system to a
-- thread when it is taken out of a wait state.
- SetThreadPriorityBoost (hTask, DisablePriorityBoost => True);
+ SetThreadPriorityBoost (hTask, DisablePriorityBoost => Win32.TRUE);
end if;
-- Step 4: Handle Task_Info
Result := WaitForSingleObject (T.Common.LL.Thread, Wait_Infinite);
pragma Assert (Result /= WAIT_FAILED);
Succeeded := CloseHandle (T.Common.LL.Thread);
- pragma Assert (Succeeded = True);
+ pragma Assert (Succeeded = Win32.TRUE);
end if;
Free (Self_ID);
-- Initialize internal condition variable
- S.CV := CreateEvent (null, True, False, Null_Ptr);
+ S.CV := CreateEvent (null, Win32.TRUE, Win32.FALSE, Null_Ptr);
pragma Assert (S.CV /= 0);
end Initialize;
-- Destroy internal condition variable
Result := CloseHandle (S.CV);
- pragma Assert (Result = True);
+ pragma Assert (Result = Win32.TRUE);
end Finalize;
-------------------
S.State := False;
Result := SetEvent (S.CV);
- pragma Assert (Result = True);
+ pragma Assert (Result = Win32.TRUE);
else
S.State := True;
end if;
-- Must reset CV BEFORE L is unlocked
Result_Bool := ResetEvent (S.CV);
- pragma Assert (Result_Bool = True);
+ pragma Assert (Result_Bool = Win32.TRUE);
LeaveCriticalSection (S.L'Access);
use System.Parameters;
use System.OS_Primitives;
+ Use_Alternate_Stack : constant Boolean := Alternate_Stack_Size /= 0;
+ -- Whether to use an alternate signal stack for stack overflows
+
----------------
-- Local Data --
----------------
end loop;
Unlock_RTS;
+
+ if Use_Alternate_Stack then
+ declare
+ Stack : aliased stack_t;
+ Result : Interfaces.C.int;
+ begin
+ Stack.ss_sp := Self_ID.Common.Task_Alternate_Stack;
+ Stack.ss_size := Alternate_Stack_Size;
+ Stack.ss_flags := 0;
+ Result := sigaltstack (Stack'Access, null);
+ pragma Assert (Result = 0);
+ end;
+ end if;
end Enter_Task;
--------------
use System.Task_Info;
begin
- Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size);
+ Adjusted_Stack_Size :=
+ Interfaces.C.size_t (Stack_Size + Alternate_Stack_Size);
if Stack_Base_Available then
Specific.Initialize (Environment_Task);
+ if Use_Alternate_Stack then
+ Environment_Task.Common.Task_Alternate_Stack :=
+ Alternate_Stack'Address;
+ end if;
+
Enter_Task (Environment_Task);
-- Install the abort-signal handler
type Ada_Task_Control_Block;
type Task_Id is access all Ada_Task_Control_Block;
+ for Task_Id'Size use System.Task_Primitives.Task_Address_Size;
Null_Task : constant Task_Id;
-- from the run-time system.
function To_Task_Id is
- new Ada.Unchecked_Conversion (System.Address, Task_Id);
+ new Ada.Unchecked_Conversion
+ (System.Task_Primitives.Task_Address, Task_Id);
function To_Address is
- new Ada.Unchecked_Conversion (Task_Id, System.Address);
+ new Ada.Unchecked_Conversion
+ (Task_Id, System.Task_Primitives.Task_Address);
-----------------------
-- Enumeration types --
-- Abnormal means that the task terminates because it is being aborted
-- handled_Exception means that the task terminates because of exception
- -- raised by by the execution of its task_body.
+ -- raised by the execution of its task_body.
type Termination_Handler is access protected procedure
(Cause : Cause_Of_Termination;
-- Activator writes it, once, before Self starts executing. Thereafter,
-- Self only reads it.
+ Task_Alternate_Stack : System.Address;
+ -- The address of the alternate signal stack for this task, if any
+ --
+ -- Protection: Only accessed by Self
+
Task_Entry_Point : Task_Procedure_Access;
-- Information needed to call the procedure containing the code for
-- the body of this task.
------------------------------------
type Access_Address is access all System.Address;
- -- Comment on what this is used for ???
+ -- Anonymous pointer used to implement task attributes (see s-tataat.adb
+ -- and a-tasatt.adb)
pragma No_Strict_Aliasing (Access_Address);
-- This type is used in contexts where aliasing may be an issue (see
-- A component of this type is guaranteed to be included in the
-- Ada_Task_Control_Block.
+ subtype Task_Address is System.Address;
+ -- In some versions of Task_Primitives, notably for VMS, Task_Address is
+ -- the short version of address defined in System.Aux_DEC. To avoid
+ -- dragging Aux_DEC into tasking packages a tasking specific subtype is
+ -- defined here.
+
+ Task_Address_Size : constant := Standard'Address_Size;
+ -- The size of Task_Address
+
+ Alternate_Stack_Size : constant := 0;
+ -- No alternate signal stack is used on this platform
+
private
type Lock is record
L : aliased System.OS_Interface.pthread_mutex_t;
-- A component of this type is guaranteed to be included in the
-- Ada_Task_Control_Block.
+ subtype Task_Address is System.Address;
+ -- In some versions of Task_Primitives, notably for VMS, Task_Address is
+ -- the short version of address defined in System.Aux_DEC. To avoid
+ -- dragging Aux_DEC into tasking packages a tasking specific subtype is
+ -- defined here.
+
+ Task_Address_Size : constant := Standard'Address_Size;
+ -- The size of Task_Address
+
+ Alternate_Stack_Size : constant := 0;
+ -- No alternate signal stack is used on this platform
+
private
type Lock is record
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ P R I M I T I V E S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1991-1994, Florida State University --
+-- Copyright (C) 1995-2008, AdaCore --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
+-- Boston, MA 02110-1301, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a POSIX-like version of this package where no alternate stack
+-- is needed for stack checking.
+
+-- Note: this file can only be used for POSIX compliant systems
+
+pragma Polling (Off);
+-- Turn off polling, we do not want ATC polling to take place during tasking
+-- operations. It causes infinite loops and other problems.
+
+with System.OS_Interface;
+
+package System.Task_Primitives is
+ pragma Preelaborate;
+
+ type Lock is limited private;
+ -- Should be used for implementation of protected objects
+
+ type RTS_Lock is limited private;
+ -- Should be used inside the runtime system. The difference between Lock
+ -- and the RTS_Lock is that the later one serves only as a semaphore so
+ -- that do not check for ceiling violations.
+
+ type Suspension_Object is limited private;
+ -- Should be used for the implementation of Ada.Synchronous_Task_Control
+
+ type Task_Body_Access is access procedure;
+ -- Pointer to the task body's entry point (or possibly a wrapper declared
+ -- local to the GNARL).
+
+ type Private_Data is limited private;
+ -- Any information that the GNULLI needs maintained on a per-task basis.
+ -- A component of this type is guaranteed to be included in the
+ -- Ada_Task_Control_Block.
+
+ subtype Task_Address is System.Address;
+ -- In some versions of Task_Primitives, notably for VMS, Task_Address is
+ -- the short version of address defined in System.Aux_DEC. To avoid
+ -- dragging Aux_DEC into tasking packages a tasking specific subtype is
+ -- defined here.
+
+ Task_Address_Size : constant := Standard'Address_Size;
+ -- The size of Task_Address
+
+ Alternate_Stack_Size : constant := 0;
+ -- No alternate signal stack is used on this platform
+
+private
+
+ type Lock is new System.OS_Interface.pthread_mutex_t;
+ type RTS_Lock is new System.OS_Interface.pthread_mutex_t;
+
+ type Suspension_Object is record
+ State : Boolean;
+ pragma Atomic (State);
+ -- Boolean that indicates whether the object is open. This field is
+ -- marked Atomic to ensure that we can read its value without locking
+ -- the access to the Suspension_Object.
+
+ Waiting : Boolean;
+ -- Flag showing if there is a task already suspended on this object
+
+ L : aliased System.OS_Interface.pthread_mutex_t;
+ -- Protection for ensuring mutual exclusion on the Suspension_Object
+
+ CV : aliased System.OS_Interface.pthread_cond_t;
+ -- Condition variable used to queue threads until condition is signaled
+ end record;
+
+ type Private_Data is record
+ Thread : aliased System.OS_Interface.pthread_t;
+ pragma Atomic (Thread);
+ -- Thread field may be updated by two different threads of control.
+ -- (See, Enter_Task and Create_Task in s-taprop.adb). They put the same
+ -- value (thr_self value). We do not want to use lock on those
+ -- operations and the only thing we have to make sure is that they are
+ -- updated in atomic fashion.
+
+ LWP : aliased System.Address;
+ -- The purpose of this field is to provide a better tasking support on
+ -- gdb. The order of the two first fields (Thread and LWP) is important.
+ -- On targets where lwp is not relevant, this is equivalent to Thread.
+
+ CV : aliased System.OS_Interface.pthread_cond_t;
+ -- Should be commented ??? (in all versions of taspri)
+
+ L : aliased RTS_Lock;
+ -- Protection for all components is lock L
+ end record;
+
+end System.Task_Primitives;
-- A component of this type is guaranteed to be included in the
-- Ada_Task_Control_Block.
+ subtype Task_Address is System.Address;
+ -- In some versions of Task_Primitives, notably for VMS, Task_Address is
+ -- the short version of address defined in System.Aux_DEC. To avoid
+ -- dragging Aux_DEC into tasking packages a tasking specific subtype is
+ -- defined here.
+
+ Task_Address_Size : constant := Standard'Address_Size;
+ -- The size of Task_Address
+
+ Alternate_Stack_Size : constant := 0;
+ -- No alternate signal stack is used on this platform
+
private
type Private_Task_Serial_Number is mod 2 ** 64;
-- Any information that the GNULLI needs maintained on a per-task basis.
-- A component of this type is guaranteed to be included
+ subtype Task_Address is System.Address;
+ -- In some versions of Task_Primitives, notably for VMS, Task_Address is
+ -- the short version of address defined in System.Aux_DEC. To avoid
+ -- dragging Aux_DEC into tasking packages a tasking specific subtype is
+ -- defined here.
+
+ Task_Address_Size : constant := Standard'Address_Size;
+ -- The size of Task_Address
+
+ Alternate_Stack_Size : constant := 0;
+ -- No alternate signal stack is used on this platform
+
private
type Lock is record
with System.Tasking.Debug;
with System.Address_Image;
+with System.Task_Primitives;
with System.Task_Primitives.Operations;
with System.Tasking.Utilities;
with System.Tasking.Queuing;
-- For tasks created by an allocator that fails, due to an exception, it is
-- called from Expunge_Unactivated_Tasks.
--
- -- It is also called from Ada.Unchecked_Deallocation, for objects that are
- -- or contain tasks.
- --
-- Different code is used at master completion, in Terminate_Dependents,
-- due to a need for tighter synchronization with the master.
Initialization.Undefer_Abort_Nestable (Self_ID);
- -- ???
- -- Why do we need to allow for nested deferral here?
+ -- ??? Why do we need to allow for nested deferral here?
if Runtime_Traces then
Send_Trace_Info (T_Activate);
-- called to create a new task.
procedure Create_Task
- (Priority : Integer;
- Size : System.Parameters.Size_Type;
- Task_Info : System.Task_Info.Task_Info_Type;
- Num_Entries : Task_Entry_Index;
- Master : Master_Level;
- State : Task_Procedure_Access;
- Discriminants : System.Address;
- Elaborated : Access_Boolean;
- Chain : in out Activation_Chain;
- Task_Image : String;
- Created_Task : out Task_Id)
+ (Priority : Integer;
+ Size : System.Parameters.Size_Type;
+ Task_Info : System.Task_Info.Task_Info_Type;
+ Relative_Deadline : Ada.Real_Time.Time_Span;
+ Num_Entries : Task_Entry_Index;
+ Master : Master_Level;
+ State : Task_Procedure_Access;
+ Discriminants : System.Address;
+ Elaborated : Access_Boolean;
+ Chain : in out Activation_Chain;
+ Task_Image : String;
+ Created_Task : out Task_Id)
is
T, P : Task_Id;
Self_ID : constant Task_Id := STPO.Self;
Base_Priority : System.Any_Priority;
Len : Natural;
+ pragma Unreferenced (Relative_Deadline);
+ -- EDF scheduling is not supported by any of the target platforms so
+ -- this parameter is not passed any further.
+
begin
-- If Master is greater than the current master, it means that Master
-- has already awaited its dependent tasks. This raises Program_Error,
Unlock_RTS;
end if;
- -- We need to explicitely wait for the task to be terminated here
+ -- We need to explicitly wait for the task to be terminated here
-- because on true concurrent system, we may end this procedure before
-- the tasks are really terminated.
Initialization.Task_Lock (Self_Id);
Lock_RTS;
+ Initialization.Finalize_Attributes_Link.all (T);
Initialization.Remove_From_All_Tasks_List (T);
Unlock_RTS;
-- Task_Wrapper --
------------------
- -- The task wrapper is a procedure that is called first for each task
- -- task body, and which in turn calls the compiler-generated task body
- -- procedure. The wrapper's main job is to do initialization for the task.
- -- It also has some locally declared objects that server as per-task local
- -- data. Task finalization is done by Complete_Task, which is called from
- -- an at-end handler that the compiler generates.
+ -- The task wrapper is a procedure that is called first for each task body
+ -- and which in turn calls the compiler-generated task body procedure.
+ -- The wrapper's main job is to do initialization for the task. It also
+ -- has some locally declared objects that serve as per-task local data.
+ -- Task finalization is done by Complete_Task, which is called from an
+ -- at-end handler that the compiler generates.
procedure Task_Wrapper (Self_ID : Task_Id) is
use type SSE.Storage_Offset;
Bottom_Of_Stack : aliased Integer;
+ Task_Alternate_Stack :
+ aliased SSE.Storage_Array (1 .. Alternate_Stack_Size);
+ -- The alternate signal stack for this task, if any
+
+ Use_Alternate_Stack : constant Boolean := Alternate_Stack_Size /= 0;
+ -- Whether to use above alternate signal stack for stack overflows
+
Secondary_Stack_Size :
constant SSE.Storage_Offset :=
Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size *
-- Why are warnings being turned off here???
Secondary_Stack_Address : System.Address := Secondary_Stack'Address;
+ -- Address of secondary stack. In the fixed secondary stack case, this
+ -- value is not modified, causing a warning, hence the bracketing with
+ -- Warnings (Off/On). But why is so much *more* bracketed???
Small_Overflow_Guard : constant := 12 * 1024;
-- Note: this used to be 4K, but was changed to 12K, since smaller
-- Size of the overflow guard, used by dynamic stack usage analysis
pragma Warnings (On);
- -- Address of secondary stack. In the fixed secondary stack case, this
- -- value is not modified, causing a warning, hence the bracketing with
- -- Warnings (Off/On). But why is so much *more* bracketed ???
SEH_Table : aliased SSE.Storage_Array (1 .. 8);
-- Structured Exception Registration table (2 words)
Size := Size - Natural (Secondary_Stack_Size);
end if;
+ if Use_Alternate_Stack then
+ Self_ID.Common.Task_Alternate_Stack := Task_Alternate_Stack'Address;
+ end if;
+
if System.Stack_Usage.Is_Enabled then
STPO.Lock_RTS;
Initialize_Analyzer (Self_ID.Common.Analyzer,
use System.Standard_Library;
function To_Address is new
- Ada.Unchecked_Conversion (Task_Id, System.Address);
+ Ada.Unchecked_Conversion
+ (Task_Id, System.Task_Primitives.Task_Address);
function Tailored_Exception_Information
(E : Exception_Occurrence) return String;
with System.Task_Info;
with System.Parameters;
+with Ada.Real_Time;
+
package System.Tasking.Stages is
pragma Elaborate_Body;
-- _init.discr := discr;
-- _init._task_id := null;
-- create_task (unspecified_priority, tZ,
- -- unspecified_task_info, 0, _master,
- -- task_procedure_access!(tB'address),
+ -- unspecified_task_info, ada__real_time__time_span_zero, 0,
+ -- _master, task_procedure_access!(tB'address),
-- _init'address, tE'unchecked_access, _chain, _task_id, _init.
-- _task_id);
-- return;
-- now in order to wake up the activator (the environment task).
procedure Create_Task
- (Priority : Integer;
- Size : System.Parameters.Size_Type;
- Task_Info : System.Task_Info.Task_Info_Type;
- Num_Entries : Task_Entry_Index;
- Master : Master_Level;
- State : Task_Procedure_Access;
- Discriminants : System.Address;
- Elaborated : Access_Boolean;
- Chain : in out Activation_Chain;
- Task_Image : String;
- Created_Task : out Task_Id);
+ (Priority : Integer;
+ Size : System.Parameters.Size_Type;
+ Task_Info : System.Task_Info.Task_Info_Type;
+ Relative_Deadline : Ada.Real_Time.Time_Span;
+ Num_Entries : Task_Entry_Index;
+ Master : Master_Level;
+ State : Task_Procedure_Access;
+ Discriminants : System.Address;
+ Elaborated : Access_Boolean;
+ Chain : in out Activation_Chain;
+ Task_Image : String;
+ Created_Task : out Task_Id);
-- Compiler interface only. Do not call from within the RTS.
-- This must be called to create a new task.
--
-- Size is the stack size of the task to create
-- Task_Info is the task info associated with the created task, or
-- Unspecified_Task_Info if none.
+ -- Relative_Deadline is the relative deadline associated with the created
+ -- task by means of a pragma Relative_Deadline, or 0.0 if none.
-- State is the compiler generated task's procedure body
-- Discriminants is a pointer to a limited record whose discriminants
-- are those of the task to create. This parameter should be passed as
-- S p e c --
-- (GNU-Linux/x86 Version) --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
Preallocated_Stacks : constant Boolean := False;
Signed_Zeros : constant Boolean := True;
Stack_Check_Default : constant Boolean := False;
- Stack_Check_Probes : constant Boolean := False;
+ Stack_Check_Probes : constant Boolean := True;
Stack_Check_Limits : constant Boolean := False;
Support_64_Bit_Divides : constant Boolean := True;
Support_Aggregates : constant Boolean := True;
-- S p e c --
-- (GNU-Linux/x86-64 Version) --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
Preallocated_Stacks : constant Boolean := False;
Signed_Zeros : constant Boolean := True;
Stack_Check_Default : constant Boolean := False;
- Stack_Check_Probes : constant Boolean := False;
+ Stack_Check_Probes : constant Boolean := True;
Stack_Check_Limits : constant Boolean := False;
Support_64_Bit_Divides : constant Boolean := True;
Support_Aggregates : constant Boolean := True;
projects / gcc.git / commitdiff