From 8d9a1ba7bbd5bf5b7f5cfe1c88dd38d70ac54bbc Mon Sep 17 00:00:00 2001 From: Pierre-Marie de Rodat Date: Wed, 8 Nov 2017 17:32:18 +0000 Subject: [PATCH] [multiple changes] 2017-11-08 Piotr Trojanek * lib-xref.ads, lib-xref-spark_specific.adb (Traverse_Compilation_Unit): Move declaration to package body. 2017-11-08 Hristian Kirtchev * exp_spark.adb (Expand_SPARK_N_Object_Renaming_Declaration): Obtain the type of the renaming from its defining entity, rather then the subtype mark as there may not be a subtype mark. 2017-11-08 Jerome Lambourg * adaint.c, s-oscons-tmplt.c, init.c, libgnat/system-qnx-aarch64.ads, libgnarl/a-intnam__qnx.ads, libgnarl/s-intman__qnx.adb, libgnarl/s-osinte__qnx.ads, libgnarl/s-qnx.ads, libgnarl/s-taprop__qnx.adb, s-oscons-tmplt.c, sigtramp-qnx.c, terminals.c: Initial port of GNAT for aarch64-qnx 2017-11-08 Elisa Barboni * exp_util.adb (Find_DIC_Type): Move... * sem_util.ads, sem_util.adb (Find_DIC_Type): ... here. 2017-11-08 Justin Squirek * sem_res.adb (Resolve_Allocator): Add info messages corresponding to the owner and corresponding coextension. 2017-11-08 Ed Schonberg * sem_aggr.adb (Resolve_Delta_Aggregate): Divide into the following separate procedures. (Resolve_Delta_Array_Aggregate): Previous code form Resolve_Delta_Aggregate. (Resolve_Delta_Record_Aggregate): Extend previous code to cover latest ARG decisions on the legality rules for delta aggregates for records: in the case of a variant record, components from different variants cannot be specified in the delta aggregate, and this must be checked statically. From-SVN: r254547 --- gcc/ada/ChangeLog | 41 + gcc/ada/adaint.c | 4 +- gcc/ada/exp_spark.adb | 2 +- gcc/ada/exp_util.adb | 65 - gcc/ada/init.c | 100 +- gcc/ada/lib-xref-spark_specific.adb | 6 + gcc/ada/lib-xref.ads | 6 - gcc/ada/libgnarl/a-intnam__qnx.ads | 146 +++ gcc/ada/libgnarl/s-intman__qnx.adb | 298 +++++ gcc/ada/libgnarl/s-osinte__qnx.ads | 619 ++++++++++ gcc/ada/libgnarl/s-qnx.ads | 122 ++ gcc/ada/libgnarl/s-taprop__qnx.adb | 1546 ++++++++++++++++++++++++ gcc/ada/libgnat/system-qnx-aarch64.ads | 157 +++ gcc/ada/s-oscons-tmplt.c | 9 +- gcc/ada/sem_aggr.adb | 340 ++++-- gcc/ada/sem_res.adb | 32 + gcc/ada/sem_util.adb | 60 + gcc/ada/sem_util.ads | 5 + gcc/ada/sigtramp-qnx.c | 301 +++++ gcc/ada/terminals.c | 4 +- 20 files changed, 3683 insertions(+), 180 deletions(-) create mode 100644 gcc/ada/libgnarl/a-intnam__qnx.ads create mode 100644 gcc/ada/libgnarl/s-intman__qnx.adb create mode 100644 gcc/ada/libgnarl/s-osinte__qnx.ads create mode 100644 gcc/ada/libgnarl/s-qnx.ads create mode 100644 gcc/ada/libgnarl/s-taprop__qnx.adb create mode 100644 gcc/ada/libgnat/system-qnx-aarch64.ads create mode 100644 gcc/ada/sigtramp-qnx.c diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 51aa930e0f4..ce7872b3ef4 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,44 @@ +2017-11-08 Piotr Trojanek + + * lib-xref.ads, lib-xref-spark_specific.adb + (Traverse_Compilation_Unit): Move declaration to package body. + +2017-11-08 Hristian Kirtchev + + * exp_spark.adb (Expand_SPARK_N_Object_Renaming_Declaration): Obtain + the type of the renaming from its defining entity, rather then the + subtype mark as there may not be a subtype mark. + +2017-11-08 Jerome Lambourg + + * adaint.c, s-oscons-tmplt.c, init.c, libgnat/system-qnx-aarch64.ads, + libgnarl/a-intnam__qnx.ads, libgnarl/s-intman__qnx.adb, + libgnarl/s-osinte__qnx.ads, libgnarl/s-qnx.ads, + libgnarl/s-taprop__qnx.adb, s-oscons-tmplt.c, sigtramp-qnx.c, + terminals.c: Initial port of GNAT for aarch64-qnx + +2017-11-08 Elisa Barboni + + * exp_util.adb (Find_DIC_Type): Move... + * sem_util.ads, sem_util.adb (Find_DIC_Type): ... here. + +2017-11-08 Justin Squirek + + * sem_res.adb (Resolve_Allocator): Add info messages corresponding to + the owner and corresponding coextension. + +2017-11-08 Ed Schonberg + + * sem_aggr.adb (Resolve_Delta_Aggregate): Divide into the + following separate procedures. + (Resolve_Delta_Array_Aggregate): Previous code form + Resolve_Delta_Aggregate. + (Resolve_Delta_Record_Aggregate): Extend previous code to cover latest + ARG decisions on the legality rules for delta aggregates for records: + in the case of a variant record, components from different variants + cannot be specified in the delta aggregate, and this must be checked + statically. + 2017-11-08 Piotr Trojanek * spark_xrefs.ads (SPARK_Scope_Record): Remove File_Num component. diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index 10325b0f1d0..cb0f4bb93b0 100644 --- a/gcc/ada/adaint.c +++ b/gcc/ada/adaint.c @@ -1012,7 +1012,7 @@ __gnat_open_new_temp (char *path, int fmode) #if (defined (__FreeBSD__) || defined (__NetBSD__) || defined (__OpenBSD__) \ || defined (__linux__) || defined (__GLIBC__) || defined (__ANDROID__) \ - || defined (__DragonFly__)) && !defined (__vxworks) + || defined (__DragonFly__) || defined (__QNX__)) && !defined (__vxworks) return mkstemp (path); #elif defined (__Lynx__) mktemp (path); @@ -1185,7 +1185,7 @@ __gnat_tmp_name (char *tmp_filename) #elif defined (__linux__) || defined (__FreeBSD__) || defined (__NetBSD__) \ || defined (__OpenBSD__) || defined (__GLIBC__) || defined (__ANDROID__) \ - || defined (__DragonFly__) + || defined (__DragonFly__) || defined (__QNX__) #define MAX_SAFE_PATH 1000 char *tmpdir = getenv ("TMPDIR"); diff --git a/gcc/ada/exp_spark.adb b/gcc/ada/exp_spark.adb index 5386fa6578b..43ca12f7940 100644 --- a/gcc/ada/exp_spark.adb +++ b/gcc/ada/exp_spark.adb @@ -349,7 +349,7 @@ package body Exp_SPARK is Loc : constant Source_Ptr := Sloc (N); Obj_Id : constant Entity_Id := Defining_Entity (N); Nam : constant Node_Id := Name (N); - Typ : constant Entity_Id := Etype (Subtype_Mark (N)); + Typ : constant Entity_Id := Etype (Obj_Id); begin -- Transform a renaming of the form diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index e9522e44e0d..d5e8e09c941 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -165,11 +165,6 @@ package body Exp_Util is -- Force evaluation of bounds of a slice, which may be given by a range -- or by a subtype indication with or without a constraint. - function Find_DIC_Type (Typ : Entity_Id) return Entity_Id; - -- Subsidiary to all Build_DIC_Procedure_xxx routines. Find the type which - -- defines the Default_Initial_Condition pragma of type Typ. This is either - -- Typ itself or a parent type when the pragma is inherited. - function Make_CW_Equivalent_Type (T : Entity_Id; E : Node_Id) return Entity_Id; @@ -5389,66 +5384,6 @@ package body Exp_Util is return TSS (Utyp, TSS_Finalize_Address); end Finalize_Address; - ------------------- - -- Find_DIC_Type -- - ------------------- - - function Find_DIC_Type (Typ : Entity_Id) return Entity_Id is - Curr_Typ : Entity_Id; - -- The current type being examined in the parent hierarchy traversal - - DIC_Typ : Entity_Id; - -- The type which carries the DIC pragma. This variable denotes the - -- partial view when private types are involved. - - Par_Typ : Entity_Id; - -- The parent type of the current type. This variable denotes the full - -- view when private types are involved. - - begin - -- The input type defines its own DIC pragma, therefore it is the owner - - if Has_Own_DIC (Typ) then - DIC_Typ := Typ; - - -- Otherwise the DIC pragma is inherited from a parent type - - else - pragma Assert (Has_Inherited_DIC (Typ)); - - -- Climb the parent chain - - Curr_Typ := Typ; - loop - -- Inspect the parent type. Do not consider subtypes as they - -- inherit the DIC attributes from their base types. - - DIC_Typ := Base_Type (Etype (Curr_Typ)); - - -- Look at the full view of a private type because the type may - -- have a hidden parent introduced in the full view. - - Par_Typ := DIC_Typ; - - if Is_Private_Type (Par_Typ) - and then Present (Full_View (Par_Typ)) - then - Par_Typ := Full_View (Par_Typ); - end if; - - -- Stop the climb once the nearest parent type which defines a DIC - -- pragma of its own is encountered or when the root of the parent - -- chain is reached. - - exit when Has_Own_DIC (DIC_Typ) or else Curr_Typ = Par_Typ; - - Curr_Typ := Par_Typ; - end loop; - end if; - - return DIC_Typ; - end Find_DIC_Type; - ------------------------ -- Find_Interface_ADT -- ------------------------ diff --git a/gcc/ada/init.c b/gcc/ada/init.c index 4071bb461e7..e1cf4fa660e 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -2516,6 +2516,104 @@ __gnat_install_handler (void) __gnat_handler_installed = 1; } +#elif defined(__QNX__) + +/***************/ +/* QNX Section */ +/***************/ + +#include +#include +#include +#include "sigtramp.h" + +void +__gnat_map_signal (int sig, + siginfo_t *si ATTRIBUTE_UNUSED, + void *mcontext ATTRIBUTE_UNUSED) +{ + 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); +} + +static void +__gnat_error_handler (int sig, siginfo_t *si, void *ucontext) +{ + __gnat_sigtramp (sig, (void *) si, (void *) ucontext, + (__sigtramphandler_t *)&__gnat_map_signal); +} + +void +__gnat_install_handler (void) +{ + struct sigaction act; + int err; + + act.sa_handler = __gnat_error_handler; + act.sa_flags = SA_NODEFER | SA_SIGINFO; + sigemptyset (&act.sa_mask); + + /* Do not install handlers if interrupt state is "System" */ + if (__gnat_get_interrupt_state (SIGFPE) != 's') { + err = sigaction (SIGFPE, &act, NULL); + if (err == -1) { + err = errno; + perror ("error while attaching SIGFPE"); + perror (strerror (err)); + } + } + if (__gnat_get_interrupt_state (SIGILL) != 's') { + sigaction (SIGILL, &act, NULL); + if (err == -1) { + err = errno; + perror ("error while attaching SIGFPE"); + perror (strerror (err)); + } + } + if (__gnat_get_interrupt_state (SIGSEGV) != 's') { + sigaction (SIGSEGV, &act, NULL); + if (err == -1) { + err = errno; + perror ("error while attaching SIGFPE"); + perror (strerror (err)); + } + } + if (__gnat_get_interrupt_state (SIGBUS) != 's') { + sigaction (SIGBUS, &act, NULL); + if (err == -1) { + err = errno; + perror ("error while attaching SIGFPE"); + perror (strerror (err)); + } + } + __gnat_handler_installed = 1; +} + #elif defined (__DJGPP__) void @@ -2648,7 +2746,7 @@ __gnat_install_handler (void) #if defined (_WIN32) || defined (__INTERIX) \ || defined (__Lynx__) || defined(__NetBSD__) || defined(__FreeBSD__) \ - || defined (__OpenBSD__) || defined (__DragonFly__) + || defined (__OpenBSD__) || defined (__DragonFly__) || defined(__QNX__) #define HAVE_GNAT_INIT_FLOAT diff --git a/gcc/ada/lib-xref-spark_specific.adb b/gcc/ada/lib-xref-spark_specific.adb index df0c5bbe188..48bb91da3db 100644 --- a/gcc/ada/lib-xref-spark_specific.adb +++ b/gcc/ada/lib-xref-spark_specific.adb @@ -96,6 +96,12 @@ package body SPARK_Specific is function Entity_Hash (E : Entity_Id) return Entity_Hashed_Range; -- Hash function for hash table + generic + with procedure Process (N : Node_Id) is <>; + procedure Traverse_Compilation_Unit (CU : Node_Id); + -- Call Process on all declarations within compilation unit CU. Bodies + -- of stubs are also traversed, but generic declarations are ignored. + -------------------- -- Add_SPARK_File -- -------------------- diff --git a/gcc/ada/lib-xref.ads b/gcc/ada/lib-xref.ads index 85b42efe084..a01e9d3f3fb 100644 --- a/gcc/ada/lib-xref.ads +++ b/gcc/ada/lib-xref.ads @@ -645,12 +645,6 @@ package Lib.Xref is -- files and scopes) and from shared cross-references. Fill in the -- tables in library package called SPARK_Xrefs. - generic - with procedure Process (N : Node_Id) is <>; - procedure Traverse_Compilation_Unit (CU : Node_Id); - -- Call Process on all declarations within compilation unit CU. Bodies - -- of stubs are also traversed, but generic declarations are ignored. - end SPARK_Specific; ----------------- diff --git a/gcc/ada/libgnarl/a-intnam__qnx.ads b/gcc/ada/libgnarl/a-intnam__qnx.ads new file mode 100644 index 00000000000..ab45b381863 --- /dev/null +++ b/gcc/ada/libgnarl/a-intnam__qnx.ads @@ -0,0 +1,146 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . I N T E R R U P T S . N A M E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-2017, 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 3, or (at your option) any later ver- -- +-- sion. GNAT 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a QNX version of this package + +-- The pragma Unreserve_All_Interrupts affects the following signal(s): + +-- SIGINT: made available for Ada handler + +-- This target-dependent package spec contains names of interrupts +-- supported by the local system. + +with System.OS_Interface; + +package Ada.Interrupts.Names is + + -- All identifiers in this unit are implementation defined + + pragma Implementation_Defined; + + -- Beware that the mapping of names to signals may be many-to-one. There + -- may be aliases. Also, for all signal names that are not supported on the + -- current system the value of the corresponding constant will be zero. + + SIGHUP : constant Interrupt_ID := + System.OS_Interface.SIGHUP; -- hangup + + SIGINT : constant Interrupt_ID := + System.OS_Interface.SIGINT; -- interrupt (rubout) + + SIGQUIT : constant Interrupt_ID := + System.OS_Interface.SIGQUIT; -- quit (ASCD FS) + + SIGILL : constant Interrupt_ID := + System.OS_Interface.SIGILL; -- illegal instruction (not reset) + + SIGTRAP : constant Interrupt_ID := + System.OS_Interface.SIGTRAP; -- trace trap (not reset) + + SIGIOT : constant Interrupt_ID := + System.OS_Interface.SIGIOT; -- IOT instruction + + SIGABRT : constant Interrupt_ID := -- used by abort, + System.OS_Interface.SIGABRT; -- replace SIGIOT in the future + + SIGFPE : constant Interrupt_ID := + System.OS_Interface.SIGFPE; -- floating point exception + + SIGKILL : constant Interrupt_ID := + System.OS_Interface.SIGKILL; -- kill (cannot be caught or ignored) + + SIGBUS : constant Interrupt_ID := + System.OS_Interface.SIGBUS; -- bus error + + SIGSEGV : constant Interrupt_ID := + System.OS_Interface.SIGSEGV; -- segmentation violation + + SIGPIPE : constant Interrupt_ID := -- write on a pipe with + System.OS_Interface.SIGPIPE; -- no one to read it + + SIGALRM : constant Interrupt_ID := + System.OS_Interface.SIGALRM; -- alarm clock + + SIGTERM : constant Interrupt_ID := + System.OS_Interface.SIGTERM; -- software termination signal from kill + + SIGUSR1 : constant Interrupt_ID := + System.OS_Interface.SIGUSR1; -- user defined signal 1 + + SIGUSR2 : constant Interrupt_ID := + System.OS_Interface.SIGUSR2; -- user defined signal 2 + + SIGCLD : constant Interrupt_ID := + System.OS_Interface.SIGCLD; -- child status change + + SIGCHLD : constant Interrupt_ID := + System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD + + SIGWINCH : constant Interrupt_ID := + System.OS_Interface.SIGWINCH; -- window size change + + SIGURG : constant Interrupt_ID := + System.OS_Interface.SIGURG; -- urgent condition on IO channel + + SIGPOLL : constant Interrupt_ID := + System.OS_Interface.SIGPOLL; -- pollable event occurred + + SIGIO : constant Interrupt_ID := -- input/output possible, + System.OS_Interface.SIGIO; -- SIGPOLL alias (Solaris) + + SIGSTOP : constant Interrupt_ID := + System.OS_Interface.SIGSTOP; -- stop (cannot be caught or ignored) + + SIGTSTP : constant Interrupt_ID := + System.OS_Interface.SIGTSTP; -- user stop requested from tty + + SIGCONT : constant Interrupt_ID := + System.OS_Interface.SIGCONT; -- stopped process has been continued + + SIGTTIN : constant Interrupt_ID := + System.OS_Interface.SIGTTIN; -- background tty read attempted + + SIGTTOU : constant Interrupt_ID := + System.OS_Interface.SIGTTOU; -- background tty write attempted + + SIGVTALRM : constant Interrupt_ID := + System.OS_Interface.SIGVTALRM; -- virtual timer expired + + SIGPROF : constant Interrupt_ID := + System.OS_Interface.SIGPROF; -- profiling timer expired + + SIGXCPU : constant Interrupt_ID := + System.OS_Interface.SIGXCPU; -- CPU time limit exceeded + + SIGXFSZ : constant Interrupt_ID := + System.OS_Interface.SIGXFSZ; -- filesize limit exceeded + +end Ada.Interrupts.Names; diff --git a/gcc/ada/libgnarl/s-intman__qnx.adb b/gcc/ada/libgnarl/s-intman__qnx.adb new file mode 100644 index 00000000000..ae33d69fae3 --- /dev/null +++ b/gcc/ada/libgnarl/s-intman__qnx.adb @@ -0,0 +1,298 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, 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 3, or (at your option) any later ver- -- +-- sion. GNAT 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the QNX/Neutrino threads version of this package + +-- Make a careful study of all signals available under the OS, to see which +-- need to be reserved, kept always unmasked, or kept always unmasked. Be on +-- the lookout for special signals that may be used by the thread library. + +-- Since this is a multi target file, the signal <-> exception mapping +-- is simple minded. If you need a more precise and target specific +-- signal handling, create a new s-intman.adb that will fit your needs. + +-- This file assumes that: + +-- SIGFPE, SIGILL, SIGSEGV and SIGBUS exist. They are mapped as follows: +-- SIGPFE => Constraint_Error +-- SIGILL => Program_Error +-- SIGSEGV => Storage_Error +-- SIGBUS => Storage_Error + +-- SIGINT exists and will be kept unmasked unless the pragma +-- Unreserve_All_Interrupts is specified anywhere in the application. + +-- System.OS_Interface contains the following: +-- SIGADAABORT: the signal that will be used to abort tasks. +-- Unmasked: the OS specific set of signals that should be unmasked in +-- all the threads. SIGADAABORT is unmasked by +-- default +-- Reserved: the OS specific set of signals that are reserved. + +with System.Task_Primitives; + +package body System.Interrupt_Management is + + use Interfaces.C; + use System.OS_Interface; + + type Interrupt_List is array (Interrupt_ID range <>) of Interrupt_ID; + Exception_Interrupts : constant Interrupt_List := + (SIGFPE, SIGILL, SIGSEGV, SIGBUS); + + Unreserve_All_Interrupts : Interfaces.C.int; + pragma Import + (C, Unreserve_All_Interrupts, "__gl_unreserve_all_interrupts"); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Signal_Trampoline + (signo : Signal; + siginfo : System.Address; + ucontext : System.Address; + handler : System.Address); + pragma Import (C, Signal_Trampoline, "__gnat_sigtramp"); + -- Pass the real handler to a speical function that handles unwinding by + -- skipping over the kernel signal frame (which doesn't contain any unwind + -- information). + + procedure Map_Signal + (signo : Signal; + siginfo : System.Address; + ucontext : System.Address); + pragma Import (C, Map_Signal, "__gnat_map_signal"); + + function State (Int : Interrupt_ID) return Character; + pragma Import (C, State, "__gnat_get_interrupt_state"); + -- Get interrupt state. Defined in init.c The input argument is the + -- interrupt number, and the result is one of the following: + + User : constant Character := 'u'; + Runtime : constant Character := 'r'; + Default : constant Character := 's'; + -- '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 (use "default" + -- system handler) + + procedure Notify_Exception + (signo : Signal; + siginfo : System.Address; + ucontext : System.Address); + -- This function identifies the Ada exception to be raised using the + -- information when the system received a synchronous signal. Since this + -- function is machine and OS dependent, different code has to be provided + -- for different target. + + ---------------------- + -- Notify_Exception -- + ---------------------- + + Signal_Mask : aliased sigset_t; + -- The set of signals handled by Notify_Exception + + procedure Notify_Exception + (signo : Signal; + siginfo : System.Address; + ucontext : System.Address) + is + Result : Interfaces.C.int; + + begin + -- With the __builtin_longjmp, the signal mask is not restored, so we + -- need to restore it explicitly. + + Result := pthread_sigmask (SIG_UNBLOCK, Signal_Mask'Access, null); + pragma Assert (Result = 0); + + -- Perform the necessary context adjustments prior to a raise + -- from a signal handler. + + Adjust_Context_For_Raise (signo, ucontext); + + -- Check that treatment of exception propagation here is consistent with + -- treatment of the abort signal in System.Task_Primitives.Operations. + + Signal_Trampoline (signo, siginfo, ucontext, Map_Signal'Address); + end Notify_Exception; + + ---------------- + -- Initialize -- + ---------------- + + Initialized : Boolean := False; + + procedure Initialize is + act : aliased struct_sigaction; + 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; + end if; + + Initialized := True; + + -- Need to call pthread_init very early because it is doing signal + -- initializations. + + pthread_init; + + Abort_Task_Interrupt := SIGADAABORT; + + act.sa_handler := Notify_Exception'Address; + + -- 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 + -- ZCX propagation scheme needs. + + -- Most man pages for sigaction mention that sa_sigaction should be set + -- instead of sa_handler when SA_SIGINFO is on. In practice, the two + -- fields are actually union'ed and located at the same offset. + + -- On some targets, we set sa_flags to SA_NODEFER so that during the + -- handler execution we do not change the Signal_Mask to be masked for + -- the Signal. + + -- This is a temporary fix to the problem that the Signal_Mask is not + -- restored after the exception (longjmp) from the handler. The right + -- 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 explicitly the mask + -- in the exception handler. + + Result := sigemptyset (Signal_Mask'Access); + pragma Assert (Result = 0); + + -- Add signals that map to Ada exceptions to the mask + + for J in Exception_Interrupts'Range loop + if State (Exception_Interrupts (J)) /= Default then + Result := + sigaddset (Signal_Mask'Access, Signal (Exception_Interrupts (J))); + pragma Assert (Result = 0); + end if; + end loop; + + act.sa_mask := Signal_Mask; + + pragma Assert (Keep_Unmasked = (Interrupt_ID'Range => False)); + pragma Assert (Reserve = (Interrupt_ID'Range => False)); + + -- Process state of exception signals + + for J in Exception_Interrupts'Range loop + if State (Exception_Interrupts (J)) /= User then + Keep_Unmasked (Exception_Interrupts (J)) := True; + 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); + pragma Assert (Result = 0); + end if; + end if; + end loop; + + if State (Abort_Task_Interrupt) /= User then + Keep_Unmasked (Abort_Task_Interrupt) := True; + Reserve (Abort_Task_Interrupt) := True; + end if; + + -- Set SIGINT to unmasked state as long as it is not in "User" state. + -- Check for Unreserve_All_Interrupts last. + + if State (SIGINT) /= User then + Keep_Unmasked (SIGINT) := True; + Reserve (SIGINT) := True; + end if; + + -- Check all signals for state that requires keeping them unmasked and + -- reserved. + + for J in Interrupt_ID'Range loop + if State (J) = Default or else State (J) = Runtime then + Keep_Unmasked (J) := True; + Reserve (J) := True; + end if; + end loop; + + -- Add the set of signals that must always be unmasked for this target + + for J in Unmasked'Range loop + Keep_Unmasked (Interrupt_ID (Unmasked (J))) := True; + Reserve (Interrupt_ID (Unmasked (J))) := True; + end loop; + + -- Add target-specific reserved signals + + if Reserved'Length > 0 then + for J in Reserved'Range loop + Reserve (Interrupt_ID (Reserved (J))) := True; + end loop; + end if; + + -- Process pragma Unreserve_All_Interrupts. This overrides any settings + -- due to pragma Interrupt_State: + + if Unreserve_All_Interrupts /= 0 then + Keep_Unmasked (SIGINT) := False; + Reserve (SIGINT) := False; + end if; + + -- We do not really have Signal 0. We just use this value to identify + -- non-existent signals (see s-intnam.ads). Therefore, Signal should not + -- be used in all signal related operations hence mark it as reserved. + + Reserve (0) := True; + end Initialize; + +end System.Interrupt_Management; diff --git a/gcc/ada/libgnarl/s-osinte__qnx.ads b/gcc/ada/libgnarl/s-osinte__qnx.ads new file mode 100644 index 00000000000..70478dfed10 --- /dev/null +++ b/gcc/ada/libgnarl/s-osinte__qnx.ads @@ -0,0 +1,619 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT 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) 1995-2017, 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- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a QNX/Neutrino 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; +with System.OS_Constants; + +package System.OS_Interface is + pragma Preelaborate; + + 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"); + + EPERM : constant := 1; + EINTR : constant := 4; + EAGAIN : constant := 11; + ENOMEM : constant := 12; + EINVAL : constant := 22; + ETIMEDOUT : constant := 260; + + ------------- + -- Signals -- + ------------- + + Max_Interrupt : constant := 64; + type Signal is new int range 0 .. Max_Interrupt; + for Signal'Size use int'Size; + + SIGHUP : constant := 1; + SIGINT : constant := 2; + SIGQUIT : constant := 3; + SIGILL : constant := 4; + SIGTRAP : constant := 5; + SIGIOT : constant := 6; + SIGABRT : constant := 6; + SIGDEADLK : constant := 7; + SIGFPE : constant := 8; + SIGKILL : constant := 9; + SIGBUS : constant := 10; + SIGSEGV : constant := 11; + SIGSYS : constant := 12; + SIGPIPE : constant := 13; + SIGALRM : constant := 14; + SIGTERM : constant := 15; + SIGUSR1 : constant := 16; + SIGUSR2 : constant := 17; + SIGCLD : constant := 18; + SIGCHLD : constant := 18; + SIGPWR : constant := 19; + SIGWINCH : constant := 20; + SIGURG : constant := 21; + SIGPOLL : constant := 22; + SIGIO : constant := 22; + SIGSTOP : constant := 23; + SIGTSTP : constant := 24; + SIGCONT : constant := 25; + SIGTTIN : constant := 26; + SIGTTOU : constant := 27; + SIGVTALRM : constant := 28; + SIGPROF : constant := 29; + SIGXCPU : constant := 30; + SIGXFSZ : constant := 31; + + SIGRTMIN : constant := 41; + SITRTMAX : constant := 56; + + SIGSELECT : constant := 57; + SIGPHOTON : constant := 58; + + SIGADAABORT : constant := SIGABRT; + -- Change this 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 can't be masked (POSIX won't allow it) + + Reserved : constant Signal_Set := (SIGKILL, SIGSTOP, SIGSEGV); + + 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 : Interfaces.C.int; + sa_mask : sigset_t; + end record; + pragma Convention (C, struct_sigaction); + + type struct_sigaction_ptr is access all struct_sigaction; + + SIG_BLOCK : constant := 0; + SIG_UNBLOCK : constant := 1; + SIG_SETMASK : constant := 2; + SIG_PENDING : constant := 5; + + SA_NOCLDSTOP : constant := 16#0001#; + SA_SIGINFO : constant := 16#0002#; + SA_RESETHAND : constant := 16#0004#; + SA_ONSTACK : constant := 16#0008#; + SA_NODEFER : constant := 16#0010#; + SA_NOCLDWAIT : constant := 16#0020#; + + SS_ONSTACK : constant := 1; + SS_DISABLE : 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 -- + ---------- + + Time_Slice_Supported : constant Boolean := True; + -- Indicates whether time slicing is supported + + type timespec is private; + + type clockid_t is new int; + + function clock_gettime + (clock_id : clockid_t; tp : access timespec) return int; + pragma Import (C, clock_gettime, "clock_gettime"); + + function clock_getres + (clock_id : clockid_t; + res : access timespec) return int; + pragma Import (C, clock_getres, "clock_getres"); + + function To_Duration (TS : timespec) return Duration; + pragma Inline (To_Duration); + + function To_Timespec (D : Duration) return timespec; + pragma Inline (To_Timespec); + + 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 + with Inline_Always; + -- 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; + + PTHREAD_SCOPE_PROCESS : constant := 1; + PTHREAD_SCOPE_SYSTEM : constant := 0; + + -- Read/Write lock not supported on Android. + + subtype pthread_rwlock_t is pthread_mutex_t; + subtype pthread_rwlockattr_t is pthread_mutexattr_t; + + ----------- + -- 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; + -- Dummy definition: alternate stack not available due to missing + -- sigaltstack + + Alternate_Stack_Size : constant := 0; + -- This must be in keeping with init.c:__gnat_alternate_stack + + Stack_Base_Available : constant Boolean := False; + -- Indicates whether the stack base is available on this target + + function Get_Stack_Base (thread : pthread_t) return System.Address + with Inline_Always; + -- This is a dummy procedure to share some GNULLI files + + function Get_Page_Size return int; + pragma Import (C, Get_Page_Size, "getpagesize"); + -- Returns the size of a page + + 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; + + function mprotect (addr : Address; len : size_t; prot : int) return int; + pragma Import (C, mprotect); + + --------------------------------------- + -- Nonstandard Thread Initialization -- + --------------------------------------- + + procedure pthread_init with Inline_Always; + + ------------------------- + -- 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, "sigprocmask"); + -- pthread_sigmask maybe be broken due to mismatch between sigset_t and + -- kernel_sigset_t, substitute sigprocmask temporarily. ??? + -- 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"); + + Relative_Timed_Wait : constant Boolean := False; + -- pthread_cond_timedwait requires an absolute delay time + + -------------------------- + -- POSIX.1c Section 13 -- + -------------------------- + + PTHREAD_PRIO_PROTECT : constant := 0; + PTHREAD_PRIO_INHERIT : constant := 1; + + function pthread_mutexattr_setprotocol + (attr : access pthread_mutexattr_t; + protocol : int) return int is (0); + + function pthread_mutexattr_setprioceiling + (attr : access pthread_mutexattr_t; + prioceiling : int) return int is (0); + + 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_setscope + (attr : access pthread_attr_t; + scope : int) return int; + pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope"); + + 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"); + + function lwp_self return System.Address; + pragma Import (C, lwp_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; + -- Size of the cpu_set_t mask on most linux systems (SUSE 11 uses 4_096). + -- This is kept for backward compatibility (System.Task_Info uses it), but + -- the run-time library does no longer rely on static masks, using + -- dynamically allocated masks instead. + + 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); + + type cpu_set_t_ptr is access all cpu_set_t; + -- In the run-time library we use this pointer because the size of type + -- cpu_set_t varies depending on the glibc version. Hence, objects of type + -- cpu_set_t are allocated dynamically using the number of processors + -- available in the target machine (value obtained at execution time). + + function CPU_ALLOC (count : size_t) return cpu_set_t_ptr; + pragma Import (C, CPU_ALLOC, "__gnat_cpu_alloc"); + -- Wrapper around the CPU_ALLOC C macro + + function CPU_ALLOC_SIZE (count : size_t) return size_t; + pragma Import (C, CPU_ALLOC_SIZE, "__gnat_cpu_alloc_size"); + -- Wrapper around the CPU_ALLOC_SIZE C macro + + procedure CPU_FREE (cpuset : cpu_set_t_ptr); + pragma Import (C, CPU_FREE, "__gnat_cpu_free"); + -- Wrapper around the CPU_FREE C macro + + procedure CPU_ZERO (count : size_t; cpuset : cpu_set_t_ptr); + pragma Import (C, CPU_ZERO, "__gnat_cpu_zero"); + -- Wrapper around the CPU_ZERO_S C macro + + procedure CPU_SET (cpu : int; count : size_t; cpuset : cpu_set_t_ptr); + pragma Import (C, CPU_SET, "__gnat_cpu_set"); + -- Wrapper around the CPU_SET_S C macro + +private + + type sigset_t is new Interfaces.C.unsigned_long; + pragma Convention (C, sigset_t); + for sigset_t'Alignment use Interfaces.C.unsigned_long'Alignment; + + 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 unsigned_long_long_t is mod 2 ** 64; + -- Local type only used to get the alignment of this type below + + subtype char_array is Interfaces.C.char_array; + + type pthread_attr_t is record + Data : char_array (1 .. OS_Constants.PTHREAD_ATTR_SIZE); + end record; + pragma Convention (C, pthread_attr_t); + for pthread_attr_t'Alignment use Interfaces.C.unsigned_long'Alignment; + + type pthread_condattr_t is record + Data : char_array (1 .. OS_Constants.PTHREAD_CONDATTR_SIZE); + end record; + pragma Convention (C, pthread_condattr_t); + for pthread_condattr_t'Alignment use Interfaces.C.int'Alignment; + + type pthread_mutexattr_t is record + Data : char_array (1 .. OS_Constants.PTHREAD_MUTEXATTR_SIZE); + end record; + pragma Convention (C, pthread_mutexattr_t); + for pthread_mutexattr_t'Alignment use Interfaces.C.int'Alignment; + + type pthread_mutex_t is record + Data : char_array (1 .. OS_Constants.PTHREAD_MUTEX_SIZE); + end record; + pragma Convention (C, pthread_mutex_t); + for pthread_mutex_t'Alignment use Interfaces.C.unsigned_long'Alignment; + + type pthread_cond_t is record + Data : char_array (1 .. OS_Constants.PTHREAD_COND_SIZE); + end record; + pragma Convention (C, pthread_cond_t); + for pthread_cond_t'Alignment use unsigned_long_long_t'Alignment; + + type pthread_key_t is new unsigned; + +end System.OS_Interface; diff --git a/gcc/ada/libgnarl/s-qnx.ads b/gcc/ada/libgnarl/s-qnx.ads new file mode 100644 index 00000000000..2097f778624 --- /dev/null +++ b/gcc/ada/libgnarl/s-qnx.ads @@ -0,0 +1,122 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . Q N X -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2017, 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 3, or (at your option) any later ver- -- +-- sion. GNAT 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- -- +------------------------------------------------------------------------------ + +-- This is the default version of this package + +-- This package encapsulates cpu specific differences between implementations +-- of QNX, 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.QNX is + pragma Preelaborate; + + ---------- + -- Time -- + ---------- + + subtype long is Interfaces.C.long; + subtype suseconds_t is Interfaces.C.long; + subtype time_t is Interfaces.C.long; + subtype clockid_t is Interfaces.C.int; + + type timespec is record + tv_sec : time_t; + tv_nsec : long; + end record; + pragma Convention (C, timespec); + + type timeval is record + tv_sec : time_t; + tv_usec : suseconds_t; + end record; + pragma Convention (C, timeval); + + ----------- + -- 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 + SIGEMT : constant := 7; -- EMT instruction + SIGDEADLK : constant := 7; -- Mutex deadlock + SIGFPE : constant := 8; -- floating point exception + SIGKILL : constant := 9; -- kill (cannot be caught or ignored) + 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 := 16; -- user defined signal 1 + SIGUSR2 : constant := 17; -- user defined signal 2 + SIGCHLD : constant := 18; -- child status change + SIGCLD : constant := 18; -- alias for SIGCHLD + SIGPWR : constant := 19; -- power-fail restart + SIGWINCH : constant := 20; -- window size change + SIGURG : constant := 21; -- urgent condition on IO channel + SIGPOLL : constant := 22; -- pollable event occurred + SIGIO : constant := 22; -- I/O now possible (4.2 BSD) + SIGSTOP : constant := 23; -- stop (cannot be caught or ignored) + SIGTSTP : constant := 24; -- user stop requested from tty + SIGCONT : constant := 25; -- stopped process has been continued + SIGTTIN : constant := 26; -- background tty read attempted + SIGTTOU : constant := 27; -- background tty write attempted + SIGVTALRM : constant := 28; -- virtual timer expired + SIGPROF : constant := 29; -- profiling timer expired + SIGXCPU : constant := 30; -- CPU time limit exceeded + SIGXFSZ : constant := 31; -- filesize limit exceeded + + -- struct_sigaction offsets + + sa_handler_pos : constant := 0; + 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#; + +end System.QNX; diff --git a/gcc/ada/libgnarl/s-taprop__qnx.adb b/gcc/ada/libgnarl/s-taprop__qnx.adb new file mode 100644 index 00000000000..85ebed799bd --- /dev/null +++ b/gcc/ada/libgnarl/s-taprop__qnx.adb @@ -0,0 +1,1546 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 . O P E R A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, 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 3, or (at your option) any later ver- -- +-- sion. GNAT 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the QNX/Neutrino version of this package + +-- This package contains all the GNULL primitives that interface directly with +-- the underlying OS. + +-- Note: this file can only be used for POSIX compliant systems that implement +-- SCHED_FIFO and Ceiling Locking correctly. + +-- For configurations where SCHED_FIFO and priority ceiling are not a +-- requirement, this file can also be used (e.g AiX threads) + +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 Ada.Unchecked_Conversion; + +with Interfaces.C; + +with System.Tasking.Debug; +with System.Interrupt_Management; +with System.OS_Constants; +with System.OS_Primitives; +with System.Task_Info; + +with System.Soft_Links; +-- We use System.Soft_Links instead of System.Tasking.Initialization +-- because the later is a higher level package that we shouldn't depend on. +-- For example when using the restricted run time, it is replaced by +-- System.Tasking.Restricted.Stages. + +package body System.Task_Primitives.Operations is + + package OSC renames System.OS_Constants; + package SSL renames System.Soft_Links; + + use System.Tasking.Debug; + use System.Tasking; + use Interfaces.C; + use System.OS_Interface; + use System.Parameters; + use System.OS_Primitives; + + ---------------- + -- Local Data -- + ---------------- + + -- The followings are logically constants, but need to be initialized + -- at run time. + + Single_RTS_Lock : aliased RTS_Lock; + -- This is a lock to allow only one thread of control in the RTS at + -- a time; it is used to execute in mutual exclusion from all other tasks. + -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List + + Environment_Task_Id : Task_Id; + -- A variable to hold Task_Id for the environment task + + Unblocked_Signal_Mask : aliased sigset_t; + -- The set of signals that should be unblocked in all tasks + + -- The followings are internal configuration constants needed + + Next_Serial_Number : Task_Serial_Number := 100; + -- We start at 100 (reserve some special values for using in error checks) + + Time_Slice_Val : Integer; + pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); + + Dispatching_Policy : Character; + pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); + + Locking_Policy : Character; + pragma Import (C, Locking_Policy, "__gl_locking_policy"); + + Foreign_Task_Elaborated : aliased Boolean := True; + -- Used to identified fake tasks (i.e., non-Ada Threads) + + Use_Alternate_Stack : constant Boolean := Alternate_Stack_Size /= 0; + -- Whether to use an alternate signal stack for stack overflows + + Abort_Handler_Installed : Boolean := False; + -- True if a handler for the abort signal is installed + + -------------------- + -- Local Packages -- + -------------------- + + package Specific is + + procedure Initialize (Environment_Task : Task_Id); + pragma Inline (Initialize); + -- Initialize various data needed by this package + + function Is_Valid_Task return Boolean; + pragma Inline (Is_Valid_Task); + -- Does executing thread have a TCB? + + procedure Set (Self_Id : Task_Id); + pragma Inline (Set); + -- Set the self id for the current task + + function Self return Task_Id; + pragma Inline (Self); + -- Return a pointer to the Ada Task Control Block of the calling task + + end Specific; + + package body Specific is separate; + -- The body of this package is target specific + + ---------------------------------- + -- ATCB allocation/deallocation -- + ---------------------------------- + + package body ATCB_Allocation is separate; + -- The body of this package is shared across several targets + + --------------------------------- + -- Support for foreign threads -- + --------------------------------- + + function Register_Foreign_Thread + (Thread : Thread_Id; + Sec_Stack_Size : Size_Type := Unspecified_Size) return Task_Id; + -- Allocate and initialize a new ATCB for the current Thread. The size of + -- the secondary stack can be optionally specified. + + function Register_Foreign_Thread + (Thread : Thread_Id; + Sec_Stack_Size : Size_Type := Unspecified_Size) + return Task_Id is separate; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Abort_Handler (Sig : Signal); + -- Signal handler used to implement asynchronous abort. + -- See also comment before body, below. + + function To_Address is + new Ada.Unchecked_Conversion (Task_Id, System.Address); + + function GNAT_pthread_condattr_setup + (attr : access pthread_condattr_t) return int; + pragma Import (C, + GNAT_pthread_condattr_setup, "__gnat_pthread_condattr_setup"); + + procedure Compute_Deadline + (Time : Duration; + Mode : ST.Delay_Modes; + Check_Time : out Duration; + Abs_Time : out Duration; + Rel_Time : out Duration); + -- Helper for Timed_Sleep and Timed_Delay: given a deadline specified by + -- Time and Mode, compute the current clock reading (Check_Time), and the + -- target absolute and relative clock readings (Abs_Time, Rel_Time). The + -- epoch for Time depends on Mode; the epoch for Check_Time and Abs_Time + -- is always that of CLOCK_RT_Ada. + + ------------------- + -- Abort_Handler -- + ------------------- + + -- Target-dependent binding of inter-thread Abort signal to the raising of + -- the Abort_Signal exception. + + -- The technical issues and alternatives here are essentially the + -- same as for raising exceptions in response to other signals + -- (e.g. Storage_Error). See code and comments in the package body + -- System.Interrupt_Management. + + -- Some implementations may not allow an exception to be propagated out of + -- a handler, and others might leave the signal or interrupt that invoked + -- this handler masked after the exceptional return to the application + -- code. + + -- GNAT exceptions are originally implemented using setjmp()/longjmp(). On + -- most UNIX systems, this will allow transfer out of a signal handler, + -- which is usually the only mechanism available for implementing + -- asynchronous handlers of this kind. However, some systems do not + -- restore the signal mask on longjmp(), leaving the abort signal masked. + + procedure Abort_Handler (Sig : Signal) is + pragma Unreferenced (Sig); + + T : constant Task_Id := Self; + Old_Set : aliased sigset_t; + + Result : Interfaces.C.int; + pragma Warnings (Off, Result); + + begin + -- It's not safe to raise an exception when using GCC ZCX mechanism. + -- Note that we still need to install a signal handler, since in some + -- cases (e.g. shutdown of the Server_Task in System.Interrupts) we + -- need to send the Abort signal to a task. + + if ZCX_By_Default then + return; + end if; + + if T.Deferral_Level = 0 + and then T.Pending_ATC_Level < T.ATC_Nesting_Level and then + not T.Aborting + then + T.Aborting := True; + + -- Make sure signals used for RTS internal purpose are unmasked + + Result := pthread_sigmask (SIG_UNBLOCK, + Unblocked_Signal_Mask'Access, Old_Set'Access); + pragma Assert (Result = 0); + + raise Standard'Abort_Signal; + end if; + end Abort_Handler; + + ---------------------- + -- Compute_Deadline -- + ---------------------- + + procedure Compute_Deadline + (Time : Duration; + Mode : ST.Delay_Modes; + Check_Time : out Duration; + Abs_Time : out Duration; + Rel_Time : out Duration) + is + begin + Check_Time := Monotonic_Clock; + + -- Relative deadline + + if Mode = Relative then + Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time; + + if Relative_Timed_Wait then + Rel_Time := Duration'Min (Max_Sensible_Delay, Time); + end if; + + pragma Warnings (Off); + -- Comparison "OSC.CLOCK_RT_Ada = OSC.CLOCK_REALTIME" is compile + -- time known. + + -- Absolute deadline specified using the tasking clock (CLOCK_RT_Ada) + + elsif Mode = Absolute_RT + or else OSC.CLOCK_RT_Ada = OSC.CLOCK_REALTIME + then + pragma Warnings (On); + Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); + + if Relative_Timed_Wait then + Rel_Time := Duration'Min (Max_Sensible_Delay, Time - Check_Time); + end if; + + -- Absolute deadline specified using the calendar clock, in the + -- case where it is not the same as the tasking clock: compensate for + -- difference between clock epochs (Base_Time - Base_Cal_Time). + + else + declare + Cal_Check_Time : constant Duration := OS_Primitives.Clock; + RT_Time : constant Duration := + Time + Check_Time - Cal_Check_Time; + + begin + Abs_Time := + Duration'Min (Check_Time + Max_Sensible_Delay, RT_Time); + + if Relative_Timed_Wait then + Rel_Time := + Duration'Min (Max_Sensible_Delay, RT_Time - Check_Time); + end if; + end; + end if; + end Compute_Deadline; + + ----------------- + -- Stack_Guard -- + ----------------- + + procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is + Stack_Base : constant Address := Get_Stack_Base (T.Common.LL.Thread); + Page_Size : Address; + Res : Interfaces.C.int; + + begin + if Stack_Base_Available then + + -- Compute the guard page address + + Page_Size := Address (Get_Page_Size); + Res := + mprotect + (Stack_Base - (Stack_Base mod Page_Size) + Page_Size, + size_t (Page_Size), + prot => (if On then PROT_ON else PROT_OFF)); + pragma Assert (Res = 0); + end if; + end Stack_Guard; + + -------------------- + -- Get_Thread_Id -- + -------------------- + + function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is + begin + return T.Common.LL.Thread; + end Get_Thread_Id; + + ---------- + -- Self -- + ---------- + + function Self return Task_Id renames Specific.Self; + + --------------------- + -- Initialize_Lock -- + --------------------- + + -- Note: mutexes and cond_variables needed per-task basis are initialized + -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such + -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any + -- status change of RTS. Therefore raising Storage_Error in the following + -- routines should be able to be handled safely. + + procedure Initialize_Lock + (Prio : System.Any_Priority; + L : not null access Lock) + is + Attributes : aliased pthread_mutexattr_t; + Result : Interfaces.C.int; + + begin + Result := pthread_mutexattr_init (Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error; + end if; + + if Locking_Policy = 'C' then + Result := pthread_mutexattr_setprotocol + (Attributes'Access, PTHREAD_PRIO_PROTECT); + pragma Assert (Result = 0); + + Result := pthread_mutexattr_setprioceiling + (Attributes'Access, Interfaces.C.int (Prio)); + pragma Assert (Result = 0); + + elsif Locking_Policy = 'I' then + Result := pthread_mutexattr_setprotocol + (Attributes'Access, PTHREAD_PRIO_INHERIT); + pragma Assert (Result = 0); + end if; + + Result := pthread_mutex_init (L.WO'Access, Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + Result := pthread_mutexattr_destroy (Attributes'Access); + raise Storage_Error; + end if; + + Result := pthread_mutexattr_destroy (Attributes'Access); + pragma Assert (Result = 0); + end Initialize_Lock; + + procedure Initialize_Lock + (L : not null access RTS_Lock; Level : Lock_Level) + is + pragma Unreferenced (Level); + + Attributes : aliased pthread_mutexattr_t; + Result : Interfaces.C.int; + + begin + Result := pthread_mutexattr_init (Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error; + end if; + + if Locking_Policy = 'C' then + Result := pthread_mutexattr_setprotocol + (Attributes'Access, PTHREAD_PRIO_PROTECT); + pragma Assert (Result = 0); + + Result := pthread_mutexattr_setprioceiling + (Attributes'Access, Interfaces.C.int (System.Any_Priority'Last)); + pragma Assert (Result = 0); + + elsif Locking_Policy = 'I' then + Result := pthread_mutexattr_setprotocol + (Attributes'Access, PTHREAD_PRIO_INHERIT); + pragma Assert (Result = 0); + end if; + + Result := pthread_mutex_init (L, Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + Result := pthread_mutexattr_destroy (Attributes'Access); + raise Storage_Error; + end if; + + Result := pthread_mutexattr_destroy (Attributes'Access); + pragma Assert (Result = 0); + end Initialize_Lock; + + ------------------- + -- Finalize_Lock -- + ------------------- + + procedure Finalize_Lock (L : not null access Lock) is + Result : Interfaces.C.int; + begin + Result := pthread_mutex_destroy (L.WO'Access); + pragma Assert (Result = 0); + end Finalize_Lock; + + procedure Finalize_Lock (L : not null access RTS_Lock) is + Result : Interfaces.C.int; + begin + Result := pthread_mutex_destroy (L); + pragma Assert (Result = 0); + end Finalize_Lock; + + ---------------- + -- Write_Lock -- + ---------------- + + procedure Write_Lock + (L : not null access Lock; Ceiling_Violation : out Boolean) + is + Result : Interfaces.C.int; + + begin + Result := pthread_mutex_lock (L.WO'Access); + + -- The cause of EINVAL is a priority ceiling violation + + Ceiling_Violation := Result = EINVAL; + pragma Assert (Result = 0 or else Ceiling_Violation); + end Write_Lock; + + procedure Write_Lock + (L : not null access RTS_Lock; + Global_Lock : Boolean := False) + is + Result : Interfaces.C.int; + begin + if not Single_Lock or else Global_Lock then + Result := pthread_mutex_lock (L); + pragma Assert (Result = 0); + end if; + end Write_Lock; + + procedure Write_Lock (T : Task_Id) is + Result : Interfaces.C.int; + begin + if not Single_Lock then + Result := pthread_mutex_lock (T.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + end Write_Lock; + + --------------- + -- Read_Lock -- + --------------- + + procedure Read_Lock + (L : not null access Lock; Ceiling_Violation : out Boolean) is + begin + Write_Lock (L, Ceiling_Violation); + end Read_Lock; + + ------------ + -- Unlock -- + ------------ + + procedure Unlock (L : not null access Lock) is + Result : Interfaces.C.int; + begin + Result := pthread_mutex_unlock (L.WO'Access); + pragma Assert (Result = 0); + end Unlock; + + procedure Unlock + (L : not null access RTS_Lock; Global_Lock : Boolean := False) + is + Result : Interfaces.C.int; + begin + if not Single_Lock or else Global_Lock then + Result := pthread_mutex_unlock (L); + pragma Assert (Result = 0); + end if; + end Unlock; + + procedure Unlock (T : Task_Id) is + Result : Interfaces.C.int; + begin + if not Single_Lock then + Result := pthread_mutex_unlock (T.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + end Unlock; + + ----------------- + -- Set_Ceiling -- + ----------------- + + -- Dynamic priority ceilings are not supported by the underlying system + + procedure Set_Ceiling + (L : not null access Lock; + Prio : System.Any_Priority) + is + pragma Unreferenced (L, Prio); + begin + null; + end Set_Ceiling; + + ----------- + -- Sleep -- + ----------- + + procedure Sleep + (Self_ID : Task_Id; + Reason : System.Tasking.Task_States) + is + pragma Unreferenced (Reason); + + Result : Interfaces.C.int; + + begin + Result := + pthread_cond_wait + (cond => Self_ID.Common.LL.CV'Access, + mutex => (if Single_Lock + then Single_RTS_Lock'Access + else Self_ID.Common.LL.L'Access)); + + -- EINTR is not considered a failure + + pragma Assert (Result = 0 or else Result = EINTR); + end Sleep; + + ----------------- + -- Timed_Sleep -- + ----------------- + + -- This is for use within the run-time system, so abort is + -- assumed to be already deferred, and the caller should be + -- holding its own ATCB lock. + + procedure Timed_Sleep + (Self_ID : Task_Id; + Time : Duration; + Mode : ST.Delay_Modes; + Reason : Task_States; + Timedout : out Boolean; + Yielded : out Boolean) + is + pragma Unreferenced (Reason); + + Base_Time : Duration; + Check_Time : Duration; + Abs_Time : Duration; + Rel_Time : Duration; + + Request : aliased timespec; + Result : Interfaces.C.int; + + begin + Timedout := True; + Yielded := False; + + Compute_Deadline + (Time => Time, + Mode => Mode, + Check_Time => Check_Time, + Abs_Time => Abs_Time, + Rel_Time => Rel_Time); + Base_Time := Check_Time; + + if Abs_Time > Check_Time then + Request := + To_Timespec (if Relative_Timed_Wait then Rel_Time else Abs_Time); + + loop + exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; + + Result := + pthread_cond_timedwait + (cond => Self_ID.Common.LL.CV'Access, + mutex => (if Single_Lock + then Single_RTS_Lock'Access + else Self_ID.Common.LL.L'Access), + abstime => Request'Access); + + Check_Time := Monotonic_Clock; + exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; + + if Result = 0 or Result = EINTR then + + -- Somebody may have called Wakeup for us + + Timedout := False; + exit; + end if; + + pragma Assert (Result = ETIMEDOUT); + end loop; + end if; + end Timed_Sleep; + + ----------------- + -- Timed_Delay -- + ----------------- + + -- This is for use in implementing delay statements, so we assume the + -- caller is abort-deferred but is holding no locks. + + procedure Timed_Delay + (Self_ID : Task_Id; + Time : Duration; + Mode : ST.Delay_Modes) + is + Base_Time : Duration; + Check_Time : Duration; + Abs_Time : Duration; + Rel_Time : Duration; + Request : aliased timespec; + + Result : Interfaces.C.int; + pragma Warnings (Off, Result); + + begin + if Single_Lock then + Lock_RTS; + end if; + + Write_Lock (Self_ID); + + Compute_Deadline + (Time => Time, + Mode => Mode, + Check_Time => Check_Time, + Abs_Time => Abs_Time, + Rel_Time => Rel_Time); + Base_Time := Check_Time; + + if Abs_Time > Check_Time then + Request := + To_Timespec (if Relative_Timed_Wait then Rel_Time else Abs_Time); + Self_ID.Common.State := Delay_Sleep; + + loop + exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; + + Result := + pthread_cond_timedwait + (cond => Self_ID.Common.LL.CV'Access, + mutex => (if Single_Lock + then Single_RTS_Lock'Access + else Self_ID.Common.LL.L'Access), + abstime => Request'Access); + + Check_Time := Monotonic_Clock; + exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; + + pragma Assert (Result = 0 + or else Result = ETIMEDOUT + or else Result = EINTR); + end loop; + + Self_ID.Common.State := Runnable; + end if; + + Unlock (Self_ID); + + if Single_Lock then + Unlock_RTS; + end if; + + Result := sched_yield; + end Timed_Delay; + + --------------------- + -- Monotonic_Clock -- + --------------------- + + function Monotonic_Clock return Duration is + TS : aliased timespec; + Result : Interfaces.C.int; + begin + Result := clock_gettime + (clock_id => OSC.CLOCK_RT_Ada, tp => TS'Unchecked_Access); + pragma Assert (Result = 0); + return To_Duration (TS); + end Monotonic_Clock; + + ------------------- + -- RT_Resolution -- + ------------------- + + function RT_Resolution return Duration is + TS : aliased timespec; + Result : Interfaces.C.int; + begin + Result := clock_getres (OSC.CLOCK_REALTIME, TS'Unchecked_Access); + pragma Assert (Result = 0); + + return To_Duration (TS); + end RT_Resolution; + + ------------ + -- Wakeup -- + ------------ + + procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is + pragma Unreferenced (Reason); + Result : Interfaces.C.int; + begin + Result := pthread_cond_signal (T.Common.LL.CV'Access); + pragma Assert (Result = 0); + end Wakeup; + + ----------- + -- Yield -- + ----------- + + procedure Yield (Do_Yield : Boolean := True) is + Result : Interfaces.C.int; + pragma Unreferenced (Result); + begin + if Do_Yield then + Result := sched_yield; + end if; + end Yield; + + ------------------ + -- Set_Priority -- + ------------------ + + procedure Set_Priority + (T : Task_Id; + Prio : System.Any_Priority; + Loss_Of_Inheritance : Boolean := False) + is + pragma Unreferenced (Loss_Of_Inheritance); + + Result : Interfaces.C.int; + Param : aliased struct_sched_param; + + function Get_Policy (Prio : System.Any_Priority) return Character; + pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching"); + -- Get priority specific dispatching policy + + Priority_Specific_Policy : constant Character := Get_Policy (Prio); + -- Upper case first character of the policy name corresponding to the + -- task as set by a Priority_Specific_Dispatching pragma. + + begin + T.Common.Current_Priority := Prio; + Param.sched_priority := To_Target_Priority (Prio); + + if Time_Slice_Supported + and then (Dispatching_Policy = 'R' + or else Priority_Specific_Policy = 'R' + or else Time_Slice_Val > 0) + then + Result := pthread_setschedparam + (T.Common.LL.Thread, SCHED_RR, Param'Access); + + elsif Dispatching_Policy = 'F' + or else Priority_Specific_Policy = 'F' + or else Time_Slice_Val = 0 + then + Result := pthread_setschedparam + (T.Common.LL.Thread, SCHED_FIFO, Param'Access); + + else + Result := pthread_setschedparam + (T.Common.LL.Thread, SCHED_OTHER, Param'Access); + end if; + + pragma Assert (Result = 0); + end Set_Priority; + + ------------------ + -- Get_Priority -- + ------------------ + + function Get_Priority (T : Task_Id) return System.Any_Priority is + begin + return T.Common.Current_Priority; + end Get_Priority; + + ---------------- + -- Enter_Task -- + ---------------- + + procedure Enter_Task (Self_ID : Task_Id) is + begin + Self_ID.Common.LL.Thread := pthread_self; + Self_ID.Common.LL.LWP := lwp_self; + + Specific.Set (Self_ID); + + 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; + + ------------------- + -- Is_Valid_Task -- + ------------------- + + function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task; + + ----------------------------- + -- Register_Foreign_Thread -- + ----------------------------- + + function Register_Foreign_Thread return Task_Id is + begin + if Is_Valid_Task then + return Self; + else + return Register_Foreign_Thread (pthread_self); + end if; + end Register_Foreign_Thread; + + -------------------- + -- Initialize_TCB -- + -------------------- + + procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is + Mutex_Attr : aliased pthread_mutexattr_t; + Result : Interfaces.C.int; + Cond_Attr : aliased pthread_condattr_t; + + begin + -- Give the task a unique serial number + + Self_ID.Serial_Number := Next_Serial_Number; + Next_Serial_Number := Next_Serial_Number + 1; + pragma Assert (Next_Serial_Number /= 0); + + if not Single_Lock then + Result := pthread_mutexattr_init (Mutex_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = 0 then + if Locking_Policy = 'C' then + Result := + pthread_mutexattr_setprotocol + (Mutex_Attr'Access, + PTHREAD_PRIO_PROTECT); + pragma Assert (Result = 0); + + Result := + pthread_mutexattr_setprioceiling + (Mutex_Attr'Access, + Interfaces.C.int (System.Any_Priority'Last)); + pragma Assert (Result = 0); + + elsif Locking_Policy = 'I' then + Result := + pthread_mutexattr_setprotocol + (Mutex_Attr'Access, + PTHREAD_PRIO_INHERIT); + pragma Assert (Result = 0); + end if; + + Result := + pthread_mutex_init + (Self_ID.Common.LL.L'Access, + Mutex_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + end if; + + if Result /= 0 then + Succeeded := False; + return; + end if; + + Result := pthread_mutexattr_destroy (Mutex_Attr'Access); + pragma Assert (Result = 0); + end if; + + Result := pthread_condattr_init (Cond_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = 0 then + Result := GNAT_pthread_condattr_setup (Cond_Attr'Access); + pragma Assert (Result = 0); + + Result := + pthread_cond_init + (Self_ID.Common.LL.CV'Access, Cond_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + end if; + + if Result = 0 then + Succeeded := True; + else + if not Single_Lock then + Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + + Succeeded := False; + end if; + + Result := pthread_condattr_destroy (Cond_Attr'Access); + pragma Assert (Result = 0); + end Initialize_TCB; + + ----------------- + -- Create_Task -- + ----------------- + + procedure Create_Task + (T : Task_Id; + Wrapper : System.Address; + Stack_Size : System.Parameters.Size_Type; + Priority : System.Any_Priority; + Succeeded : out Boolean) + is + Attributes : aliased pthread_attr_t; + Adjusted_Stack_Size : Interfaces.C.size_t; + Page_Size : constant Interfaces.C.size_t := + Interfaces.C.size_t (Get_Page_Size); + Result : Interfaces.C.int; + + function Thread_Body_Access is new + Ada.Unchecked_Conversion (System.Address, Thread_Body); + + use System.Task_Info; + + begin + Adjusted_Stack_Size := + Interfaces.C.size_t (Stack_Size + Alternate_Stack_Size); + + if Stack_Base_Available then + + -- If Stack Checking is supported then allocate 2 additional pages: + + -- In the worst case, stack is allocated at something like + -- N * Get_Page_Size - epsilon, we need to add the size for 2 pages + -- to be sure the effective stack size is greater than what + -- has been asked. + + Adjusted_Stack_Size := Adjusted_Stack_Size + 2 * Page_Size; + end if; + + -- Round stack size as this is required by some OSes (Darwin) + + Adjusted_Stack_Size := Adjusted_Stack_Size + Page_Size - 1; + Adjusted_Stack_Size := + Adjusted_Stack_Size - Adjusted_Stack_Size mod Page_Size; + + Result := pthread_attr_init (Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result /= 0 then + Succeeded := False; + return; + end if; + + Result := + pthread_attr_setdetachstate + (Attributes'Access, PTHREAD_CREATE_DETACHED); + pragma Assert (Result = 0); + + Result := + pthread_attr_setstacksize + (Attributes'Access, Adjusted_Stack_Size); + pragma Assert (Result = 0); + + if T.Common.Task_Info /= Default_Scope then + case T.Common.Task_Info is + when System.Task_Info.Process_Scope => + Result := + pthread_attr_setscope + (Attributes'Access, PTHREAD_SCOPE_PROCESS); + + when System.Task_Info.System_Scope => + Result := + pthread_attr_setscope + (Attributes'Access, PTHREAD_SCOPE_SYSTEM); + + when System.Task_Info.Default_Scope => + Result := 0; + end case; + + pragma Assert (Result = 0); + end if; + + -- Since the initial signal mask of a thread is inherited from the + -- creator, and the Environment task has all its signals masked, we + -- do not need to manipulate caller's signal mask at this point. + -- All tasks in RTS will have All_Tasks_Mask initially. + + -- Note: the use of Unrestricted_Access in the following call is needed + -- because otherwise we have an error of getting a access-to-volatile + -- value which points to a non-volatile object. But in this case it is + -- safe to do this, since we know we have no problems with aliasing and + -- Unrestricted_Access bypasses this check. + + Result := pthread_create + (T.Common.LL.Thread'Unrestricted_Access, + Attributes'Access, + Thread_Body_Access (Wrapper), + To_Address (T)); + pragma Assert (Result = 0 or else Result = EAGAIN); + + Succeeded := Result = 0; + + Result := pthread_attr_destroy (Attributes'Access); + pragma Assert (Result = 0); + + if Succeeded then + Set_Priority (T, Priority); + end if; + end Create_Task; + + ------------------ + -- Finalize_TCB -- + ------------------ + + procedure Finalize_TCB (T : Task_Id) is + Result : Interfaces.C.int; + + begin + if not Single_Lock then + Result := pthread_mutex_destroy (T.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + + Result := pthread_cond_destroy (T.Common.LL.CV'Access); + pragma Assert (Result = 0); + + if T.Known_Tasks_Index /= -1 then + Known_Tasks (T.Known_Tasks_Index) := null; + end if; + + ATCB_Allocation.Free_ATCB (T); + end Finalize_TCB; + + --------------- + -- Exit_Task -- + --------------- + + procedure Exit_Task is + begin + -- Mark this task as unknown, so that if Self is called, it won't + -- return a dangling pointer. + + Specific.Set (null); + end Exit_Task; + + ---------------- + -- Abort_Task -- + ---------------- + + procedure Abort_Task (T : Task_Id) is + Result : Interfaces.C.int; + begin + if Abort_Handler_Installed then + Result := + pthread_kill + (T.Common.LL.Thread, + Signal (System.Interrupt_Management.Abort_Task_Interrupt)); + pragma Assert (Result = 0); + end if; + end Abort_Task; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (S : in out Suspension_Object) is + Mutex_Attr : aliased pthread_mutexattr_t; + Cond_Attr : aliased pthread_condattr_t; + Result : Interfaces.C.int; + + begin + -- Initialize internal state (always to False (RM D.10 (6))) + + S.State := False; + S.Waiting := False; + + -- Initialize internal mutex + + Result := pthread_mutexattr_init (Mutex_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error; + end if; + + Result := pthread_mutex_init (S.L'Access, Mutex_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + Result := pthread_mutexattr_destroy (Mutex_Attr'Access); + pragma Assert (Result = 0); + + raise Storage_Error; + end if; + + Result := pthread_mutexattr_destroy (Mutex_Attr'Access); + pragma Assert (Result = 0); + + -- Initialize internal condition variable + + Result := pthread_condattr_init (Cond_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result /= 0 then + Result := pthread_mutex_destroy (S.L'Access); + pragma Assert (Result = 0); + + -- Storage_Error is propagated as intended if the allocation of the + -- underlying OS entities fails. + + raise Storage_Error; + + else + Result := GNAT_pthread_condattr_setup (Cond_Attr'Access); + pragma Assert (Result = 0); + end if; + + Result := pthread_cond_init (S.CV'Access, Cond_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result /= 0 then + Result := pthread_mutex_destroy (S.L'Access); + pragma Assert (Result = 0); + + Result := pthread_condattr_destroy (Cond_Attr'Access); + pragma Assert (Result = 0); + + -- Storage_Error is propagated as intended if the allocation of the + -- underlying OS entities fails. + + raise Storage_Error; + end if; + + Result := pthread_condattr_destroy (Cond_Attr'Access); + pragma Assert (Result = 0); + end Initialize; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (S : in out Suspension_Object) is + Result : Interfaces.C.int; + + begin + -- Destroy internal mutex + + Result := pthread_mutex_destroy (S.L'Access); + pragma Assert (Result = 0); + + -- Destroy internal condition variable + + Result := pthread_cond_destroy (S.CV'Access); + pragma Assert (Result = 0); + end Finalize; + + ------------------- + -- Current_State -- + ------------------- + + function Current_State (S : Suspension_Object) return Boolean is + begin + -- We do not want to use lock on this read operation. State is marked + -- as Atomic so that we ensure that the value retrieved is correct. + + return S.State; + end Current_State; + + --------------- + -- Set_False -- + --------------- + + procedure Set_False (S : in out Suspension_Object) is + Result : Interfaces.C.int; + + begin + SSL.Abort_Defer.all; + + Result := pthread_mutex_lock (S.L'Access); + pragma Assert (Result = 0); + + S.State := False; + + Result := pthread_mutex_unlock (S.L'Access); + pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; + end Set_False; + + -------------- + -- Set_True -- + -------------- + + procedure Set_True (S : in out Suspension_Object) is + Result : Interfaces.C.int; + + begin + SSL.Abort_Defer.all; + + Result := pthread_mutex_lock (S.L'Access); + pragma Assert (Result = 0); + + -- If there is already a task waiting on this suspension object then + -- we resume it, leaving the state of the suspension object to False, + -- as it is specified in (RM D.10(9)). Otherwise, it just leaves + -- the state to True. + + if S.Waiting then + S.Waiting := False; + S.State := False; + + Result := pthread_cond_signal (S.CV'Access); + pragma Assert (Result = 0); + + else + S.State := True; + end if; + + Result := pthread_mutex_unlock (S.L'Access); + pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; + end Set_True; + + ------------------------ + -- Suspend_Until_True -- + ------------------------ + + procedure Suspend_Until_True (S : in out Suspension_Object) is + Result : Interfaces.C.int; + + begin + SSL.Abort_Defer.all; + + Result := pthread_mutex_lock (S.L'Access); + pragma Assert (Result = 0); + + if S.Waiting then + + -- Program_Error must be raised upon calling Suspend_Until_True + -- if another task is already waiting on that suspension object + -- (RM D.10(10)). + + Result := pthread_mutex_unlock (S.L'Access); + pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; + + raise Program_Error; + + else + -- Suspend the task if the state is False. Otherwise, the task + -- continues its execution, and the state of the suspension object + -- is set to False (ARM D.10 par. 9). + + if S.State then + S.State := False; + else + S.Waiting := True; + + loop + -- Loop in case pthread_cond_wait returns earlier than expected + -- (e.g. in case of EINTR caused by a signal). + + Result := pthread_cond_wait (S.CV'Access, S.L'Access); + pragma Assert (Result = 0 or else Result = EINTR); + + exit when not S.Waiting; + end loop; + end if; + + Result := pthread_mutex_unlock (S.L'Access); + pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; + end if; + end Suspend_Until_True; + + ---------------- + -- Check_Exit -- + ---------------- + + -- Dummy version + + function Check_Exit (Self_ID : ST.Task_Id) return Boolean is + pragma Unreferenced (Self_ID); + begin + return True; + end Check_Exit; + + -------------------- + -- Check_No_Locks -- + -------------------- + + function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is + pragma Unreferenced (Self_ID); + begin + return True; + end Check_No_Locks; + + ---------------------- + -- Environment_Task -- + ---------------------- + + function Environment_Task return Task_Id is + begin + return Environment_Task_Id; + end Environment_Task; + + -------------- + -- Lock_RTS -- + -------------- + + procedure Lock_RTS is + begin + Write_Lock (Single_RTS_Lock'Access, Global_Lock => True); + end Lock_RTS; + + ---------------- + -- Unlock_RTS -- + ---------------- + + procedure Unlock_RTS is + begin + Unlock (Single_RTS_Lock'Access, Global_Lock => True); + end Unlock_RTS; + + ------------------ + -- Suspend_Task -- + ------------------ + + function Suspend_Task + (T : ST.Task_Id; + Thread_Self : Thread_Id) return Boolean + is + begin + if T.Common.LL.Thread /= Thread_Self then + return pthread_kill (T.Common.LL.Thread, SIGSTOP) = 0; + else + return True; + end if; + end Suspend_Task; + + ----------------- + -- Resume_Task -- + ----------------- + + function Resume_Task + (T : ST.Task_Id; + Thread_Self : Thread_Id) return Boolean + is + begin + if T.Common.LL.Thread /= Thread_Self then + return pthread_kill (T.Common.LL.Thread, SIGCONT) = 0; + else + return True; + end if; + end Resume_Task; + + -------------------- + -- Stop_All_Tasks -- + -------------------- + + procedure Stop_All_Tasks is + begin + null; + end Stop_All_Tasks; + + --------------- + -- Stop_Task -- + --------------- + + function Stop_Task (T : ST.Task_Id) return Boolean is + pragma Unreferenced (T); + begin + return False; + end Stop_Task; + + ------------------- + -- Continue_Task -- + ------------------- + + function Continue_Task (T : ST.Task_Id) return Boolean is + pragma Unreferenced (T); + begin + return False; + end Continue_Task; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Environment_Task : Task_Id) is + act : aliased struct_sigaction; + old_act : aliased struct_sigaction; + Tmp_Set : aliased sigset_t; + Result : Interfaces.C.int; + + function State + (Int : System.Interrupt_Management.Interrupt_ID) return Character; + pragma Import (C, State, "__gnat_get_interrupt_state"); + -- Get interrupt state. Defined in a-init.c + -- The input argument is the interrupt number, + -- and the result is one of the following: + + Default : constant Character := 's'; + -- '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 (use "default" + -- system handler) + + begin + Environment_Task_Id := Environment_Task; + + Interrupt_Management.Initialize; + + -- Prepare the set of signals that should unblocked in all tasks + + Result := sigemptyset (Unblocked_Signal_Mask'Access); + pragma Assert (Result = 0); + + for J in Interrupt_Management.Interrupt_ID loop + if System.Interrupt_Management.Keep_Unmasked (J) then + Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J)); + pragma Assert (Result = 0); + end if; + end loop; + + -- Initialize the lock used to synchronize chain of all ATCBs + + Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); + + Specific.Initialize (Environment_Task); + + if Use_Alternate_Stack then + Environment_Task.Common.Task_Alternate_Stack := + Alternate_Stack'Address; + end if; + + -- Make environment task known here because it doesn't go through + -- Activate_Tasks, which does it for all other tasks. + + Known_Tasks (Known_Tasks'First) := Environment_Task; + Environment_Task.Known_Tasks_Index := Known_Tasks'First; + + Enter_Task (Environment_Task); + + if State + (System.Interrupt_Management.Abort_Task_Interrupt) /= Default + then + act.sa_flags := 0; + act.sa_handler := Abort_Handler'Address; + + Result := sigemptyset (Tmp_Set'Access); + pragma Assert (Result = 0); + act.sa_mask := Tmp_Set; + + Result := + sigaction + (Signal (System.Interrupt_Management.Abort_Task_Interrupt), + act'Unchecked_Access, + old_act'Unchecked_Access); + pragma Assert (Result = 0); + Abort_Handler_Installed := True; + end if; + end Initialize; + + ----------------------- + -- Set_Task_Affinity -- + ----------------------- + + procedure Set_Task_Affinity (T : ST.Task_Id) is + pragma Unreferenced (T); + + begin + -- Setting task affinity is not supported by the underlying system + + null; + end Set_Task_Affinity; + +end System.Task_Primitives.Operations; diff --git a/gcc/ada/libgnat/system-qnx-aarch64.ads b/gcc/ada/libgnat/system-qnx-aarch64.ads new file mode 100644 index 00000000000..421311d8531 --- /dev/null +++ b/gcc/ada/libgnat/system-qnx-aarch64.ads @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (QNX/Aarch64 Version) -- +-- -- +-- Copyright (C) 1992-2017, 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 -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- 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- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package System is + pragma Pure; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + pragma No_Elaboration_Code_All; + -- Allow the use of that restriction in units that WITH this unit + + type Name is (SYSTEM_NAME_GNAT); + System_Name : constant Name := SYSTEM_NAME_GNAT; + + -- System-Dependent Named Numbers + + Min_Int : constant := Long_Long_Integer'First; + Max_Int : constant := Long_Long_Integer'Last; + + Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; + + Max_Base_Digits : constant := Long_Long_Float'Digits; + Max_Digits : constant := Long_Long_Float'Digits; + + Max_Mantissa : constant := 63; + Fine_Delta : constant := 2.0 ** (-Max_Mantissa); + + Tick : constant := 0.000_001; + + -- Storage-related Declarations + + type Address is private; + pragma Preelaborable_Initialization (Address); + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := Standard'Word_Size; + Memory_Size : constant := 2 ** Long_Integer'Size; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := + Bit_Order'Val (Standard'Default_Bit_Order); + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + -- 0 .. 98 corresponds to the system priority range 1 .. 99. + -- + -- If the scheduling policy is SCHED_FIFO or SCHED_RR the runtime makes use + -- of the entire range provided by the system. + -- + -- If the scheduling policy is SCHED_OTHER the only valid system priority + -- is 1 and other values are simply ignored. + + Max_Priority : constant Positive := 97; + Max_Interrupt_Priority : constant Positive := 98; + + subtype Any_Priority is Integer range 0 .. 98; + subtype Priority is Any_Priority range 0 .. 97; + subtype Interrupt_Priority is Any_Priority range 98 .. 98; + + Default_Priority : constant Priority := 48; + +private + + type Address is mod Memory_Size; + Null_Address : constant Address := 0; + + -------------------------------------- + -- System Implementation Parameters -- + -------------------------------------- + + -- These parameters provide information about the target that is used + -- by the compiler. They are in the private part of System, where they + -- can be accessed using the special circuitry in the Targparm unit + -- whose source should be consulted for more detailed descriptions + -- of the individual switch values. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; + Command_Line_Args : constant Boolean := True; + Configurable_Run_Time : constant Boolean := False; + Denorm : constant Boolean := True; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : constant Boolean := False; + Support_Aggregates : constant Boolean := True; + Support_Atomic_Primitives : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + Frontend_Exceptions : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + +end System; diff --git a/gcc/ada/s-oscons-tmplt.c b/gcc/ada/s-oscons-tmplt.c index 444ad6072d4..95eadfc8854 100644 --- a/gcc/ada/s-oscons-tmplt.c +++ b/gcc/ada/s-oscons-tmplt.c @@ -157,7 +157,8 @@ pragma Style_Checks ("M32766"); # include <_types.h> #endif -#if defined (__linux__) || defined (__ANDROID__) || defined (__rtems__) +#if defined (__linux__) || defined (__ANDROID__) || defined (__QNX__) \ + || defined (__rtems__) # include # include #endif @@ -1191,7 +1192,7 @@ CND(MSG_WAITALL, "Wait for full reception") #endif CND(MSG_NOSIGNAL, "No SIGPIPE on send") -#if defined (__linux__) || defined (__ANDROID__) +#if defined (__linux__) || defined (__ANDROID__) || defined (__QNX__) # define MSG_Forced_Flags "MSG_NOSIGNAL" #else # define MSG_Forced_Flags "0" @@ -1361,7 +1362,7 @@ CND(SIZEOF_struct_hostent, "struct hostent") #define SIZEOF_struct_servent (sizeof (struct servent)) CND(SIZEOF_struct_servent, "struct servent") -#if defined (__linux__) || defined (__ANDROID__) +#if defined (__linux__) || defined (__ANDROID__) || defined (__QNX__) #define SIZEOF_sigset (sizeof (sigset_t)) CND(SIZEOF_sigset, "sigset") #endif @@ -1464,7 +1465,7 @@ CNS(CLOCK_RT_Ada, "") #endif #if defined (__APPLE__) || defined (__linux__) || defined (__ANDROID__) \ - || defined (__rtems__) || defined (DUMMY) + || defined (__QNX__) || defined (__rtems__) || defined (DUMMY) /* -- Sizes of pthread data types diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 6c29b38b93a..62b59341069 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -418,6 +418,13 @@ package body Sem_Aggr is -- array of characters is expected. This procedure simply rewrites the -- string as an aggregate, prior to resolution. + --------------------------------- + -- Delta aggregate processing -- + --------------------------------- + + procedure Resolve_Delta_Array_Aggregate (N : Node_Id; Typ : Entity_Id); + procedure Resolve_Delta_Record_Aggregate (N : Node_Id; Typ : Entity_Id); + ------------------------ -- Array_Aggr_Subtype -- ------------------------ @@ -2759,143 +2766,278 @@ package body Sem_Aggr is procedure Resolve_Delta_Aggregate (N : Node_Id; Typ : Entity_Id) is Base : constant Node_Id := Expression (N); + + begin + if not Is_Composite_Type (Typ) then + Error_Msg_N ("not a composite type", N); + end if; + + Analyze_And_Resolve (Base, Typ); + + if Is_Array_Type (Typ) then + Resolve_Delta_Array_Aggregate (N, Typ); + else + Resolve_Delta_Record_Aggregate (N, Typ); + end if; + + Set_Etype (N, Typ); + end Resolve_Delta_Aggregate; + + ----------------------------------- + -- Resolve_Delta_Array_Aggregate -- + ----------------------------------- + + procedure Resolve_Delta_Array_Aggregate (N : Node_Id; Typ : Entity_Id) is Deltas : constant List_Id := Component_Associations (N); + Assoc : Node_Id; + Choice : Node_Id; + Index_Type : Entity_Id; - function Get_Component_Type (Nam : Node_Id) return Entity_Id; + begin + Index_Type := Etype (First_Index (Typ)); + Assoc := First (Deltas); + while Present (Assoc) loop + if Nkind (Assoc) = N_Iterated_Component_Association then + Choice := First (Choice_List (Assoc)); + while Present (Choice) loop + if Nkind (Choice) = N_Others_Choice then + Error_Msg_N + ("others not allowed in delta aggregate", Choice); - ------------------------ - -- Get_Component_Type -- - ------------------------ + else + Analyze_And_Resolve (Choice, Index_Type); + end if; - function Get_Component_Type (Nam : Node_Id) return Entity_Id is - Comp : Entity_Id; + Next (Choice); + end loop; - begin - Comp := First_Entity (Typ); + declare + Id : constant Entity_Id := Defining_Identifier (Assoc); + Ent : constant Entity_Id := + New_Internal_Entity + (E_Loop, Current_Scope, Sloc (Assoc), 'L'); - while Present (Comp) loop - if Chars (Comp) = Chars (Nam) then - if Ekind (Comp) = E_Discriminant then - Error_Msg_N ("delta cannot apply to discriminant", Nam); + begin + Set_Etype (Ent, Standard_Void_Type); + Set_Parent (Ent, Assoc); + + if No (Scope (Id)) then + Enter_Name (Id); + Set_Etype (Id, Index_Type); + Set_Ekind (Id, E_Variable); + Set_Scope (Id, Ent); end if; - return Etype (Comp); - end if; + Push_Scope (Ent); + Analyze_And_Resolve + (New_Copy_Tree (Expression (Assoc)), Component_Type (Typ)); + End_Scope; + end; - Comp := Next_Entity (Comp); - end loop; + else + Choice := First (Choice_List (Assoc)); + while Present (Choice) loop + if Nkind (Choice) = N_Others_Choice then + Error_Msg_N + ("others not allowed in delta aggregate", Choice); - Error_Msg_NE ("type& has no component with this name", Nam, Typ); - return Any_Type; - end Get_Component_Type; + else + Analyze (Choice); + if Is_Entity_Name (Choice) + and then Is_Type (Entity (Choice)) + then + -- Choice covers a range of values. + if Base_Type (Entity (Choice)) /= + Base_Type (Index_Type) + then + Error_Msg_NE + ("choice does mat match index type of", + Choice, Typ); + end if; + else + Resolve (Choice, Index_Type); + end if; + end if; - -- Local variables + Next (Choice); + end loop; + + Analyze_And_Resolve (Expression (Assoc), Component_Type (Typ)); + end if; + + Next (Assoc); + end loop; + end Resolve_Delta_Array_Aggregate; + ------------------------------------ + -- Resolve_Delta_Record_Aggregate -- + ------------------------------------ + + procedure Resolve_Delta_Record_Aggregate (N : Node_Id; Typ : Entity_Id) is + Deltas : constant List_Id := Component_Associations (N); Assoc : Node_Id; Choice : Node_Id; Comp_Type : Entity_Id; - Index_Type : Entity_Id; - -- Start of processing for Resolve_Delta_Aggregate + -- Variables used to verify that discriminant-dependent components + -- appear in the same variant. - begin - if not Is_Composite_Type (Typ) then - Error_Msg_N ("not a composite type", N); - end if; + Variant : Node_Id; + Comp_Ref : Entity_Id; - Analyze_And_Resolve (Base, Typ); + procedure Check_Variant (Id : Entity_Id); + -- If a given component of the delta aggregate appears in a variant + -- part, verify that it is within the same variant as that of previous + -- specified variant components of the delta. - if Is_Array_Type (Typ) then - Index_Type := Etype (First_Index (Typ)); - Assoc := First (Deltas); - while Present (Assoc) loop - if Nkind (Assoc) = N_Iterated_Component_Association then - Choice := First (Choice_List (Assoc)); - while Present (Choice) loop - if Nkind (Choice) = N_Others_Choice then - Error_Msg_N - ("others not allowed in delta aggregate", Choice); + function Nested_In (V1, V2 : Node_Id) return Boolean; + -- Determine whether variant V1 is within variant V2. - else - Analyze_And_Resolve (Choice, Index_Type); - end if; + function Get_Component_Type (Nam : Node_Id) return Entity_Id; + -- Locate component with a given name and return its type. If none + -- found report error. - Next (Choice); - end loop; + function Variant_Depth (N : Node_Id) return Integer; + -- Determine the distance of a variant to the enclosing type + -- declaration. + + -------------------- + -- Check_Variant -- + -------------------- + + procedure Check_Variant (Id : Entity_Id) is + Comp : Entity_Id; + Comp_Variant : Node_Id; + + begin + if not Has_Discriminants (Typ) then + return; + end if; + + Comp := First_Entity (Typ); + while Present (Comp) loop + exit when Chars (Comp) = Chars (Id); + Next_Component (Comp); + end loop; + -- Find the variant, if any, whose component list includes the + -- component declaration. + + Comp_Variant := Parent (Parent (List_Containing (Parent (Comp)))); + if Nkind (Comp_Variant) = N_Variant then + if No (Variant) then + Variant := Comp_Variant; + Comp_Ref := Comp; + + elsif Variant /= Comp_Variant then declare - Id : constant Entity_Id := Defining_Identifier (Assoc); - Ent : constant Entity_Id := - New_Internal_Entity - (E_Loop, Current_Scope, Sloc (Assoc), 'L'); + D1 : constant Integer := Variant_Depth (Variant); + D2 : constant Integer := Variant_Depth (Comp_Variant); begin - Set_Etype (Ent, Standard_Void_Type); - Set_Parent (Ent, Assoc); - - if No (Scope (Id)) then - Enter_Name (Id); - Set_Etype (Id, Index_Type); - Set_Ekind (Id, E_Variable); - Set_Scope (Id, Ent); - end if; + if D1 = D2 + or else + (D1 > D2 and then not Nested_In (Variant, Comp_Variant)) + or else + (D2 > D1 and then not Nested_In (Comp_Variant, Variant)) + then + Error_Msg_Node_2 := Comp_Ref; + Error_Msg_NE + ("& and & appear in different variants", Id, Comp); + + -- Otherwise retain the deeper variant for subsequent tests - Push_Scope (Ent); - Analyze_And_Resolve - (New_Copy_Tree (Expression (Assoc)), Component_Type (Typ)); - End_Scope; + elsif D2 > D1 then + Variant := Comp_Variant; + end if; end; + end if; + end if; + end Check_Variant; - else - Choice := First (Choice_List (Assoc)); - while Present (Choice) loop - if Nkind (Choice) = N_Others_Choice then - Error_Msg_N - ("others not allowed in delta aggregate", Choice); + --------------- + -- Nested_In -- + --------------- - else - Analyze (Choice); - if Is_Entity_Name (Choice) - and then Is_Type (Entity (Choice)) - then - -- Choice covers a range of values. - if Base_Type (Entity (Choice)) /= - Base_Type (Index_Type) - then - Error_Msg_NE - ("choice does mat match index type of", - Choice, Typ); - end if; - else - Resolve (Choice, Index_Type); - end if; - end if; + function Nested_In (V1, V2 : Node_Id) return Boolean is + Par : Node_Id; + begin + Par := Parent (V1); + while Nkind (Par) /= N_Full_Type_Declaration loop + if Par = V2 then + return True; + end if; + Par := Parent (Par); + end loop; - Next (Choice); - end loop; + return False; + end Nested_In; - Analyze_And_Resolve (Expression (Assoc), Component_Type (Typ)); + ------------------- + -- Variant_Depth -- + ------------------- + + function Variant_Depth (N : Node_Id) return Integer is + Depth : Integer; + Par : Node_Id; + begin + Depth := 0; + Par := Parent (N); + while Nkind (Par) /= N_Full_Type_Declaration loop + Depth := Depth + 1; + Par := Parent (Par); + end loop; + + return Depth; + end Variant_Depth; + + ------------------------ + -- Get_Component_Type -- + ------------------------ + + function Get_Component_Type (Nam : Node_Id) return Entity_Id is + Comp : Entity_Id; + + begin + Comp := First_Entity (Typ); + + while Present (Comp) loop + if Chars (Comp) = Chars (Nam) then + if Ekind (Comp) = E_Discriminant then + Error_Msg_N ("delta cannot apply to discriminant", Nam); + end if; + + return Etype (Comp); end if; - Next (Assoc); + Comp := Next_Entity (Comp); end loop; - else - Assoc := First (Deltas); - while Present (Assoc) loop - Choice := First (Choice_List (Assoc)); - while Present (Choice) loop - Comp_Type := Get_Component_Type (Choice); - Next (Choice); - end loop; + Error_Msg_NE ("type& has no component with this name", Nam, Typ); + return Any_Type; + end Get_Component_Type; - Analyze_And_Resolve (Expression (Assoc), Comp_Type); - Next (Assoc); + -- Start of processing for Resolve_Delta_Record_Aggregate + + begin + Variant := Empty; + Assoc := First (Deltas); + + while Present (Assoc) loop + Choice := First (Choice_List (Assoc)); + while Present (Choice) loop + Comp_Type := Get_Component_Type (Choice); + if Comp_Type /= Any_Type then + Check_Variant (Choice); + end if; + + Next (Choice); end loop; - end if; - Set_Etype (N, Typ); - end Resolve_Delta_Aggregate; + Analyze_And_Resolve (Expression (Assoc), Comp_Type); + Next (Assoc); + end loop; + end Resolve_Delta_Record_Aggregate; --------------------------------- -- Resolve_Extension_Aggregate -- diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index afa2e8e966c..214fb8ec3b7 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -5143,6 +5143,38 @@ package body Sem_Res is if not Is_Static_Coextension (N) then Set_Is_Dynamic_Coextension (N); + + -- ??? We currently do not handle finalization and deallocation + -- of coextensions properly so let's at least warn the user + -- about it. + + if Is_Controlled_Active (Desig_T) then + if Is_Controlled_Active + (Defining_Identifier + (Parent (Associated_Node_For_Itype (Typ)))) + then + Error_Msg_N + ("info: coextension will not be finalized when its " + & "associated owner is finalized", N); + else + Error_Msg_N + ("info: coextension will not be finalized when its " + & "associated owner is deallocated", N); + end if; + else + if Is_Controlled_Active + (Defining_Identifier + (Parent (Associated_Node_For_Itype (Typ)))) + then + Error_Msg_N + ("info: coextension will not be deallocated when its " + & "associated owner is finalized", N); + else + Error_Msg_N + ("info: coextension will not be deallocated when its " + & "associated owner is deallocated", N); + end if; + end if; end if; -- Cleanup for potential static coextensions diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 175f5e7c969..317792a963d 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -7841,6 +7841,66 @@ package body Sem_Util is raise Program_Error; end Find_Corresponding_Discriminant; + ------------------- + -- Find_DIC_Type -- + ------------------- + + function Find_DIC_Type (Typ : Entity_Id) return Entity_Id is + Curr_Typ : Entity_Id; + -- The current type being examined in the parent hierarchy traversal + + DIC_Typ : Entity_Id; + -- The type which carries the DIC pragma. This variable denotes the + -- partial view when private types are involved. + + Par_Typ : Entity_Id; + -- The parent type of the current type. This variable denotes the full + -- view when private types are involved. + + begin + -- The input type defines its own DIC pragma, therefore it is the owner + + if Has_Own_DIC (Typ) then + DIC_Typ := Typ; + + -- Otherwise the DIC pragma is inherited from a parent type + + else + pragma Assert (Has_Inherited_DIC (Typ)); + + -- Climb the parent chain + + Curr_Typ := Typ; + loop + -- Inspect the parent type. Do not consider subtypes as they + -- inherit the DIC attributes from their base types. + + DIC_Typ := Base_Type (Etype (Curr_Typ)); + + -- Look at the full view of a private type because the type may + -- have a hidden parent introduced in the full view. + + Par_Typ := DIC_Typ; + + if Is_Private_Type (Par_Typ) + and then Present (Full_View (Par_Typ)) + then + Par_Typ := Full_View (Par_Typ); + end if; + + -- Stop the climb once the nearest parent type which defines a DIC + -- pragma of its own is encountered or when the root of the parent + -- chain is reached. + + exit when Has_Own_DIC (DIC_Typ) or else Curr_Typ = Par_Typ; + + Curr_Typ := Par_Typ; + end loop; + end if; + + return DIC_Typ; + end Find_DIC_Type; + ---------------------------------- -- Find_Enclosing_Iterator_Loop -- ---------------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index f0e06e4a4e6..9aaa1160ed7 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -769,6 +769,11 @@ package Sem_Util is -- analyzed. Subsequent uses of this id on a different type denotes the -- discriminant at the same position in this new type. + function Find_DIC_Type (Typ : Entity_Id) return Entity_Id; + -- Subsidiary to all Build_DIC_Procedure_xxx routines. Find the type which + -- defines the Default_Initial_Condition pragma of type Typ. This is either + -- Typ itself or a parent type when the pragma is inherited. + function Find_Enclosing_Iterator_Loop (Id : Entity_Id) return Entity_Id; -- Find the nearest iterator loop which encloses arbitrary entity Id. If -- such a loop exists, return the entity of its identifier (E_Loop scope), diff --git a/gcc/ada/sigtramp-qnx.c b/gcc/ada/sigtramp-qnx.c new file mode 100644 index 00000000000..60c98e1935b --- /dev/null +++ b/gcc/ada/sigtramp-qnx.c @@ -0,0 +1,301 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * S I G T R A M P * + * * + * Asm Implementation File * + * * + * Copyright (C) 2017, 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- * + * ware Foundation; either version 3, or (at your option) any later ver- * + * sion. GNAT 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. * + * * + * As a special exception under Section 7 of GPL version 3, you are granted * + * additional permissions described in the GCC Runtime Library Exception, * + * version 3.1, as published by the Free Software Foundation. * + * * + * In particular, you can freely distribute your programs built with the * + * GNAT Pro compiler, including any required library run-time units, using * + * any licensing terms of your choosing. See the AdaCore Software License * + * for full details. * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * Extensive contributions were provided by Ada Core Technologies Inc. * + * * + ****************************************************************************/ + +/********************************************** + * QNX version of the __gnat_sigtramp service * + **********************************************/ + +#include + +#include "sigtramp.h" +/* See sigtramp.h for a general explanation of functionality. */ + +extern void __gnat_sigtramp_common + (int signo, void *siginfo, void *sigcontext, + __sigtramphandler_t * handler); + +void __gnat_sigtramp (int signo, void *si, void *sc, + __sigtramphandler_t * handler) + __attribute__((optimize(2))); + +void __gnat_sigtramp (int signo, void *si, void *ucontext, + __sigtramphandler_t * handler) +{ + struct sigcontext *mcontext = &((ucontext_t *) ucontext)->uc_mcontext; + + __gnat_sigtramp_common (signo, si, mcontext, handler); +} + +/* asm string construction helpers. */ + +#define STR(TEXT) #TEXT +/* stringify expanded TEXT, surrounding it with double quotes. */ + +#define S(E) STR(E) +/* stringify E, which will resolve as text but may contain macros + still to be expanded. */ + +/* asm (TEXT) outputs TEXT. These facilitate the output of + multiline contents: */ +#define TAB(S) "\t" S +#define CR(S) S "\n" + +#undef TCR +#define TCR(S) TAB(CR(S)) + +/* Trampoline body block + --------------------- */ + +#ifdef __x86_64__ +/***************************************** + * x86-64 * + *****************************************/ + +#define COMMON_CFI(REG) \ + ".cfi_offset " S(REGNO_##REG) "," S(REG_##REG) + +// CFI register numbers +#define REGNO_RAX 0 +#define REGNO_RDX 1 +#define REGNO_RCX 2 +#define REGNO_RBX 3 +#define REGNO_RSI 4 +#define REGNO_RDI 5 +#define REGNO_RBP 6 +#define REGNO_RSP 7 +#define REGNO_R8 8 +#define REGNO_R9 9 +#define REGNO_R10 10 +#define REGNO_R11 11 +#define REGNO_R12 12 +#define REGNO_R13 13 +#define REGNO_R14 14 +#define REGNO_R15 15 +#define REGNO_RPC 16 /* aka %rip */ + +// Registers offset from the regset structure +#define REG_RDI 0x00 +#define REG_RSI 0x08 +#define REG_RDX 0x10 +#define REG_R10 0x18 +#define REG_R8 0x20 +#define REG_R9 0x28 +#define REG_RAX 0x30 +#define REG_RBX 0x38 +#define REG_RBP 0x40 +#define REG_RCX 0x48 +#define REG_R11 0x50 +#define REG_R12 0x58 +#define REG_R13 0x60 +#define REG_R14 0x68 +#define REG_R15 0x70 +#define REG_RPC 0x78 /* RIP */ +#define REG_RSP 0x90 + +#define CFI_COMMON_REGS \ +CR("# CFI for common registers\n") \ +TCR(COMMON_CFI(RSP)) \ +TCR(COMMON_CFI(R15)) \ +TCR(COMMON_CFI(R14)) \ +TCR(COMMON_CFI(R13)) \ +TCR(COMMON_CFI(R12)) \ +TCR(COMMON_CFI(R11)) \ +TCR(COMMON_CFI(RCX)) \ +TCR(COMMON_CFI(RBP)) \ +TCR(COMMON_CFI(RBX)) \ +TCR(COMMON_CFI(RAX)) \ +TCR(COMMON_CFI(R9)) \ +TCR(COMMON_CFI(R8)) \ +TCR(COMMON_CFI(R10)) \ +TCR(COMMON_CFI(RSI)) \ +TCR(COMMON_CFI(RDI)) \ +TCR(COMMON_CFI(RDX)) \ +TCR(COMMON_CFI(RPC)) \ +TCR(".cfi_return_column " S(REGNO_RPC)) + +#define SIGTRAMP_BODY \ +TCR(".cfi_def_cfa 15, 0") \ +CFI_COMMON_REGS \ +CR("") \ +TCR("# Allocate frame and save the non-volatile") \ +TCR("# registers we're going to modify") \ +TCR("subq $8, %rsp") \ +TCR("# Setup CFA_REG = context, which we'll retrieve as our CFA value") \ +TCR("movq %rdx, %r15") \ +TCR("# Call the real handler. The signo, siginfo and sigcontext") \ +TCR("# arguments are the same as those we received") \ +TCR("call *%rcx") \ +TCR("# This part should never be executed") \ +TCR("addq $8, %rsp") \ +TCR("ret") +#endif + +#ifdef __aarch64__ +/***************************************** + * Aarch64 * + *****************************************/ + +#define UC_MCONTEXT_SS 16 + +#define CFA_REG 19 +#define BASE_REG 20 + +#define DW_CFA_def_cfa 0x0c +#define DW_CFA_expression 0x10 + +#define DW_OP_breg(n) 0x70+(n) + +#define REG_REGNO_GR(n) n +#define REG_REGNO_PC 30 + +/* The first byte of the SLEB128 value of the offset. */ +#define REG_OFFSET_GR(n) (UC_MCONTEXT_SS + n * 8) +#define REG_OFFSET_LONG_GR(n) (UC_MCONTEXT_SS + n * 8 + 128) +#define REG_OFFSET_LONG128_GR(n) (UC_MCONTEXT_SS + (n - 16) * 8 + 128) +#define REG_OFFSET_LONG256_GR(n) (UC_MCONTEXT_SS + (n - 32) * 8 + 128) + +#define REG_OFFSET_LONG256_PC REG_OFFSET_LONG256_GR(32) + +#define CFI_DEF_CFA \ + TCR(".cfi_def_cfa " S(CFA_REG) ", 0") + +/* We need 4 variants depending on the offset: 0+, 64+, 128+, 256+. */ +#define COMMON_CFI(REG) \ + ".cfi_escape " S(DW_CFA_expression) "," S(REG_REGNO_##REG) ",2," \ + S(DW_OP_breg(BASE_REG)) "," S(REG_OFFSET_##REG) + +#define COMMON_LONG_CFI(REG) \ + ".cfi_escape " S(DW_CFA_expression) "," S(REG_REGNO_##REG) ",3," \ + S(DW_OP_breg(BASE_REG)) "," S(REG_OFFSET_LONG_##REG) ",0" + +#define COMMON_LONG128_CFI(REG) \ + ".cfi_escape " S(DW_CFA_expression) "," S(REG_REGNO_##REG) ",3," \ + S(DW_OP_breg(BASE_REG)) "," S(REG_OFFSET_LONG128_##REG) ",1" + +#define COMMON_LONG256_CFI(REG) \ + ".cfi_escape " S(DW_CFA_expression) "," S(REG_REGNO_##REG) ",3," \ + S(DW_OP_breg(BASE_REG)) "," S(REG_OFFSET_LONG256_##REG) ",2" + +#define CFI_COMMON_REGS \ + CR("# CFI for common registers\n") \ + TCR(COMMON_CFI(GR(0))) \ + TCR(COMMON_CFI(GR(1))) \ + TCR(COMMON_CFI(GR(2))) \ + TCR(COMMON_CFI(GR(3))) \ + TCR(COMMON_CFI(GR(4))) \ + TCR(COMMON_CFI(GR(5))) \ + TCR(COMMON_LONG_CFI(GR(6))) \ + TCR(COMMON_LONG_CFI(GR(7))) \ + TCR(COMMON_LONG_CFI(GR(8))) \ + TCR(COMMON_LONG_CFI(GR(9))) \ + TCR(COMMON_LONG_CFI(GR(10))) \ + TCR(COMMON_LONG_CFI(GR(11))) \ + TCR(COMMON_LONG_CFI(GR(12))) \ + TCR(COMMON_LONG_CFI(GR(13))) \ + TCR(COMMON_LONG128_CFI(GR(14))) \ + TCR(COMMON_LONG128_CFI(GR(15))) \ + TCR(COMMON_LONG128_CFI(GR(16))) \ + TCR(COMMON_LONG128_CFI(GR(17))) \ + TCR(COMMON_LONG128_CFI(GR(18))) \ + TCR(COMMON_LONG128_CFI(GR(19))) \ + TCR(COMMON_LONG128_CFI(GR(20))) \ + TCR(COMMON_LONG128_CFI(GR(21))) \ + TCR(COMMON_LONG128_CFI(GR(22))) \ + TCR(COMMON_LONG128_CFI(GR(23))) \ + TCR(COMMON_LONG128_CFI(GR(24))) \ + TCR(COMMON_LONG128_CFI(GR(25))) \ + TCR(COMMON_LONG128_CFI(GR(26))) \ + TCR(COMMON_LONG128_CFI(GR(27))) \ + TCR(COMMON_LONG128_CFI(GR(28))) \ + TCR(COMMON_LONG128_CFI(GR(29))) \ + TCR(COMMON_LONG256_CFI(PC)) + +#define SIGTRAMP_BODY \ + CFI_DEF_CFA \ + CFI_COMMON_REGS \ + TCR("# Push FP and LR on stack") \ + TCR("stp x29, x30, [sp, #-32]!") \ + TCR("stp x" S(CFA_REG) ", x" S(BASE_REG) ", [sp, #16]") \ + TCR("mov x29, sp") \ + TCR("# Load the saved value of the stack pointer as CFA") \ + TCR("ldr x" S(CFA_REG) ", [x2, #" S(REG_OFFSET_GR(31)) "]") \ + TCR("# Use x" S(BASE_REG) " as base register for the CFI") \ + TCR("mov x" S(BASE_REG) ", x2") \ + TCR("# Call the handler") \ + TCR("blr x3") \ + TCR("# Release our frame and return (should never get here!).") \ + TCR("ldp x" S(CFA_REG) ", x" S(BASE_REG)" , [sp, #16]") \ + TCR("ldp x29, x30, [sp], 32") \ + TCR("ret") + +#endif /* AARCH64 */ + +/* Symbol definition block + ----------------------- */ + +#if defined (__x86_64__) || defined (__aarch64__) +#define FUNC_ALIGN TCR(".p2align 4,,15") +#else +#define FUNC_ALIGN +#endif + +#define SIGTRAMP_START(SYM) \ +CR("# " S(SYM) " cfi trampoline") \ +TCR(".type " S(SYM) ", @function") \ +CR("") \ +FUNC_ALIGN \ +CR(S(SYM) ":") \ +TCR(".cfi_startproc") \ +TCR(".cfi_signal_frame") + +/* Symbol termination block + ------------------------ */ + +#define SIGTRAMP_END(SYM) \ +CR(".cfi_endproc") \ +TCR(".size " S(SYM) ", .-" S(SYM)) + +/*---------------------------- + -- And now, the real code -- + ---------------------------- */ + +/* Text section start. The compiler isn't aware of that switch. */ + +asm (".text\n" + TCR(".align 2")); + +/* sigtramp stub for common registers. */ + +#define TRAMP_COMMON __gnat_sigtramp_common + +asm (SIGTRAMP_START(TRAMP_COMMON)); +asm (SIGTRAMP_BODY); +asm (SIGTRAMP_END(TRAMP_COMMON)); diff --git a/gcc/ada/terminals.c b/gcc/ada/terminals.c index 9133a3bd88c..9f300514ced 100644 --- a/gcc/ada/terminals.c +++ b/gcc/ada/terminals.c @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * Copyright (C) 2008-2016, AdaCore * + * Copyright (C) 2008-2017, AdaCore * * * * 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- * @@ -1111,7 +1111,7 @@ __gnat_setup_winsize (void *desc, int rows, int columns) /* On some system termio is either absent or including it will disable termios (HP-UX) */ #if !defined (__hpux__) && !defined (BSD) && !defined (__APPLE__) \ - && !defined (__rtems__) + && !defined (__rtems__) && !defined (__QNXNTO__) # include #endif -- 2.30.2