public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc r12-4303] [Ada] RTEMS: use hardware interrupts instead of signals for interrupt handling
@ 2021-10-11 13:39 Pierre-Marie de Rodat
0 siblings, 0 replies; only message in thread
From: Pierre-Marie de Rodat @ 2021-10-11 13:39 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:9d615a4b6e8b9e0cf1cd862a69d6ad1a7788f396
commit r12-4303-g9d615a4b6e8b9e0cf1cd862a69d6ad1a7788f396
Author: Patrick Bernardi <bernardi@adacore.com>
Date: Mon Oct 4 17:37:50 2021 -0400
[Ada] RTEMS: use hardware interrupts instead of signals for interrupt handling
gcc/ada/
* Makefile.rtl (VxWorks): Rename s-inmaop__vxworks.adb to
s-inmaop__hwint.adb.
(RTEMS): Use s-inmaop__hwint.adb, s-intman__rtems.adb/s,
s-taprop__rtems.adb.
* libgnarl/a-intnam__rtems.ads: Remove signals definitions and
replace with Hardware_Interrupts.
* libgnarl/s-inmaop__vxworks.adb: Rename as...
* libgnarl/s-inmaop__hwint.adb: ... this.
* libgnarl/s-interr__hwint.adb: Remove unnecessary comments.
* libgnarl/s-intman__rtems.ads, libgnarl/s-intman__rtems.adb:
New files.
* libgnarl/s-osinte__rtems.adb: Add RTEMS API bindings.
(Binary_Semaphore_Create, Binary_Semaphore_Delete,
Binary_Semaphore_Obtain, Binary_Semaphore_Release,
Binary_Semaphore_Flush, Interrupt_Connect,
Interrupt_Number_To_Vector): New functions.
* libgnarl/s-osinte__rtems.ads (Num_HW_Interrupts, Signal):
Removed.
(NSIG, Interrupt_Range): New.
(Binary_Semaphore_Create, Binary_Semaphore_Delete,
Binary_Semaphore_Obtain, Binary_Semaphore_Release,
Binary_Semaphore_Flush, Interrupt_Connect,
Interrupt_Number_To_Vector): Remove Import pragma.
* libgnarl/s-taprop__rtems.adb: New file.
Diff:
---
gcc/ada/Makefile.rtl | 13 +-
gcc/ada/libgnarl/a-intnam__rtems.ads | 74 +-
.../{s-inmaop__vxworks.adb => s-inmaop__hwint.adb} | 7 +-
gcc/ada/libgnarl/s-interr__hwint.adb | 36 +-
gcc/ada/libgnarl/s-intman__rtems.adb | 93 ++
gcc/ada/libgnarl/s-intman__rtems.ads | 99 ++
gcc/ada/libgnarl/s-osinte__rtems.adb | 150 +++
gcc/ada/libgnarl/s-osinte__rtems.ads | 65 +-
gcc/ada/libgnarl/s-taprop__rtems.adb | 1347 ++++++++++++++++++++
9 files changed, 1732 insertions(+), 152 deletions(-)
diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl
index 75d172518d0..7fef5171311 100644
--- a/gcc/ada/Makefile.rtl
+++ b/gcc/ada/Makefile.rtl
@@ -1084,7 +1084,7 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworks vxworksspe vxworks7% vxworks7spe
a-nuaufl.ads<libgnat/a-nuaufl__wraplf.ads \
a-nashfl.ads<libgnat/a-nashfl__wraplf.ads \
s-dorepr.adb<libgnat/s-dorepr__fma.adb \
- s-inmaop.adb<libgnarl/s-inmaop__vxworks.adb \
+ s-inmaop.adb<libgnarl/s-inmaop__hwint.adb \
s-intman.ads<libgnarl/s-intman__vxworks.ads \
s-intman.adb<libgnarl/s-intman__vxworks.adb \
s-osinte.ads<libgnarl/s-osinte__vxworks.ads \
@@ -1207,7 +1207,7 @@ ifeq ($(strip $(filter-out %86 x86_64 wrs vxworks vxworks7%,$(target_cpu) $(targ
a-nashfl.ads<libgnat/a-nashfl__wraplf.ads \
s-osinte.adb<libgnarl/s-osinte__vxworks.adb \
s-osinte.ads<libgnarl/s-osinte__vxworks.ads \
- s-inmaop.adb<libgnarl/s-inmaop__vxworks.adb \
+ s-inmaop.adb<libgnarl/s-inmaop__hwint.adb \
s-intman.ads<libgnarl/s-intman__vxworks.ads \
s-intman.adb<libgnarl/s-intman__vxworks.adb \
s-osprim.adb<libgnat/s-osprim__posix.adb \
@@ -1351,7 +1351,7 @@ ifeq ($(strip $(filter-out aarch64 arm% coff wrs vx%,$(target_cpu) $(target_vend
a-naliop.ads<libgnat/a-naliop__nolibm.ads \
a-nuaufl.ads<libgnat/a-nuaufl__wraplf.ads \
a-nashfl.ads<libgnat/a-nashfl__wraplf.ads \
- s-inmaop.adb<libgnarl/s-inmaop__vxworks.adb \
+ s-inmaop.adb<libgnarl/s-inmaop__hwint.adb \
s-interr.adb<libgnarl/s-interr__vxworks.adb \
s-intman.ads<libgnarl/s-intman__vxworks.ads \
s-intman.adb<libgnarl/s-intman__vxworks.adb \
@@ -2047,14 +2047,15 @@ ifeq ($(strip $(filter-out rtems%,$(target_os))),)
LIBGNAT_TARGET_PAIRS = \
system.ads<libgnat/system-rtems.ads \
a-intnam.ads<libgnarl/a-intnam__rtems.ads \
- s-inmaop.adb<libgnarl/s-inmaop__posix.adb \
- s-intman.adb<libgnarl/s-intman__posix.adb \
+ s-inmaop.adb<libgnarl/s-inmaop__hwint.adb \
+ s-intman.adb<libgnarl/s-intman__rtems.adb \
+ s-intman.ads<libgnarl/s-intman__rtems.ads \
s-osinte.adb<libgnarl/s-osinte__rtems.adb \
s-osinte.ads<libgnarl/s-osinte__rtems.ads \
s-osprim.adb<libgnat/s-osprim__rtems.adb \
s-parame.adb<libgnat/s-parame__rtems.adb \
s-parame.ads<libgnat/s-parame__posix2008.ads \
- s-taprop.adb<libgnarl/s-taprop__posix.adb \
+ s-taprop.adb<libgnarl/s-taprop__rtems.adb \
s-taspri.ads<libgnarl/s-taspri__posix.ads \
s-tpopsp.adb<libgnarl/s-tpopsp__tls.adb \
s-interr.adb<libgnarl/s-interr__hwint.adb
diff --git a/gcc/ada/libgnarl/a-intnam__rtems.ads b/gcc/ada/libgnarl/a-intnam__rtems.ads
index 89618f64075..4654f00bbe7 100644
--- a/gcc/ada/libgnarl/a-intnam__rtems.ads
+++ b/gcc/ada/libgnarl/a-intnam__rtems.ads
@@ -34,81 +34,17 @@
------------------------------------------------------------------------------
-- This is a RTEMS version of this package
---
--- The following signals are reserved by the run time:
---
--- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGABRT, SIGINT,
--- SIGALRM, SIGEMT, SIGKILL
---
--- The pragma Unreserve_All_Interrupts affects the following signal(s):
---
--- SIGINT: made available for Ada handlers
-
--- This target-dependent package spec contains names of interrupts
--- supported by the local system.
with System.OS_Interface;
--- used for names of interrupts
package Ada.Interrupts.Names is
- -- 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
-
- SIGEMT : constant Interrupt_ID :=
- System.OS_Interface.SIGEMT; -- EMT instruction
-
- 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
-
- SIGSYS : constant Interrupt_ID :=
- System.OS_Interface.SIGSYS; -- bad argument to system call
-
- 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
+ -- All identifiers in this unit are implementation defined
- SIGUSR1 : constant Interrupt_ID :=
- System.OS_Interface.SIGUSR1; -- user defined signal 1
+ pragma Implementation_Defined;
- SIGUSR2 : constant Interrupt_ID :=
- System.OS_Interface.SIGUSR2; -- user defined signal 2
+ subtype Hardware_Interrupts is Interrupt_ID
+ range Interrupt_ID'First .. System.OS_Interface.Max_HW_Interrupt;
+ -- Range of values that can be used for hardware interrupts
end Ada.Interrupts.Names;
diff --git a/gcc/ada/libgnarl/s-inmaop__vxworks.adb b/gcc/ada/libgnarl/s-inmaop__hwint.adb
similarity index 97%
rename from gcc/ada/libgnarl/s-inmaop__vxworks.adb
rename to gcc/ada/libgnarl/s-inmaop__hwint.adb
index 8496c82a534..52a92ac1bee 100644
--- a/gcc/ada/libgnarl/s-inmaop__vxworks.adb
+++ b/gcc/ada/libgnarl/s-inmaop__hwint.adb
@@ -30,9 +30,10 @@
-- --
------------------------------------------------------------------------------
--- This is a VxWorks version of this package. Many operations are null as this
--- package supports the use of Ada interrupt handling facilities for signals,
--- while those facilities are used for hardware interrupts on these targets.
+-- This is a hardware interrupt version of this package. Many operations are
+-- null as this package supports the use of Ada interrupt handling facilities
+-- for signals, while those facilities are used for hardware interrupts on
+-- these targets.
with Ada.Exceptions;
diff --git a/gcc/ada/libgnarl/s-interr__hwint.adb b/gcc/ada/libgnarl/s-interr__hwint.adb
index be6b55908c8..5f801749c45 100644
--- a/gcc/ada/libgnarl/s-interr__hwint.adb
+++ b/gcc/ada/libgnarl/s-interr__hwint.adb
@@ -29,29 +29,15 @@
-- --
------------------------------------------------------------------------------
--- Invariants:
-
--- All user-handlable signals are masked at all times in all tasks/threads
--- except possibly for the Interrupt_Manager task.
-
--- When a user task wants to have the effect of masking/unmasking an signal,
--- it must call Block_Interrupt/Unblock_Interrupt, which will have the effect
--- of unmasking/masking the signal in the Interrupt_Manager task. These
--- comments do not apply to vectored hardware interrupts, which may be masked
--- or unmasked using routined interfaced to the relevant embedded RTOS system
--- calls.
+-- This is reasonably generic version of this package, supporting vectored
+-- hardware interrupts using non-RTOS specific adapter routines which should
+-- easily implemented on any RTOS capable of supporting GNAT.
--- Once we associate a Signal_Server_Task with an signal, the task never goes
--- away, and we never remove the association. On the other hand, it is more
--- convenient to terminate an associated Interrupt_Server_Task for a vectored
--- hardware interrupt (since we use a binary semaphore for synchronization
--- with the umbrella handler).
+-- Invariants:
--- There is no more than one signal per Signal_Server_Task and no more than
--- one Signal_Server_Task per signal. The same relation holds for hardware
--- interrupts and Interrupt_Server_Task's at any given time. That is, only
--- one non-terminated Interrupt_Server_Task exists for a give interrupt at
--- any time.
+-- There is no more than one interrupt per Interrupt_Server_Task and no more
+-- than one Interrupt_Server_Task per interrupt. If an interrupt handler is
+-- detached, the corresponding Interrupt_Server_Task is terminated.
-- Within this package, the lock L is used to protect the various status
-- tables. If there is a Server_Task associated with a signal or interrupt,
@@ -59,10 +45,6 @@
-- status between Interrupt_Manager and Server_Task. Protection among service
-- requests are ensured via user calls to the Interrupt_Manager entries.
--- This is reasonably generic version of this package, supporting vectored
--- hardware interrupts using non-RTOS specific adapter routines which should
--- easily implemented on any RTOS capable of supporting GNAT.
-
with Ada.Unchecked_Conversion;
with Ada.Task_Identification;
@@ -151,13 +133,13 @@ package body System.Interrupts is
(others => (null, Static => False));
pragma Volatile_Components (User_Handler);
-- Holds the protected procedure handler (if any) and its Static
- -- information for each interrupt or signal. A handler is static iff it
+ -- information for each interrupt. A handler is static if and only if it
-- is specified through the pragma Attach_Handler.
User_Entry : array (Interrupt_ID) of Entry_Assoc :=
(others => (T => Null_Task, E => Null_Task_Entry));
pragma Volatile_Components (User_Entry);
- -- Holds the task and entry index (if any) for each interrupt / signal
+ -- Holds the task and entry index (if any) for each interrupt
-- Type and Head, Tail of the list containing Registered Interrupt
-- Handlers. These definitions are used to register the handlers
diff --git a/gcc/ada/libgnarl/s-intman__rtems.adb b/gcc/ada/libgnarl/s-intman__rtems.adb
new file mode 100644
index 00000000000..dedc67c4a60
--- /dev/null
+++ b/gcc/ada/libgnarl/s-intman__rtems.adb
@@ -0,0 +1,93 @@
+------------------------------------------------------------------------------
+-- --
+-- 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-2021, 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the RTEMS version of this package
+
+-- It is simpler than other versions because the Ada interrupt handling
+-- mechanisms are used for hardware interrupts rather than signals.
+
+package body System.Interrupt_Management is
+
+ use System.OS_Interface;
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ 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
+ -- hardware interrupt number, and the result is one of the following:
+
+ 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)
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ Initialized : Boolean := False;
+ -- Set to True once Initialize is called, further calls have no effect
+
+ procedure Initialize is
+
+ begin
+ if Initialized then
+ return;
+ end if;
+
+ Initialized := True;
+
+ -- Set the signal used to signal an abort to another task as defined in
+ -- System.OS_Interface.
+
+ Abort_Task_Interrupt := SIGADAABORT;
+
+ -- Initialize hardware interrupt handling
+
+ pragma Assert (Reserve = (Interrupt_ID'Range => False));
+
+ -- Check all interrupts for state that requires keeping them reserved
+
+ for J in Interrupt_ID'Range loop
+ if State (J) = Default or else State (J) = Runtime then
+ Reserve (J) := True;
+ end if;
+ end loop;
+
+ end Initialize;
+
+end System.Interrupt_Management;
diff --git a/gcc/ada/libgnarl/s-intman__rtems.ads b/gcc/ada/libgnarl/s-intman__rtems.ads
new file mode 100644
index 00000000000..f3d53ecfbcb
--- /dev/null
+++ b/gcc/ada/libgnarl/s-intman__rtems.ads
@@ -0,0 +1,99 @@
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-2021, 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the RTEMS version of this package
+
+-- This package encapsulates and centralizes information about all
+-- uses of interrupts (or signals), including the target-dependent
+-- mapping of interrupts (or signals) to exceptions.
+
+-- Unlike the original design, System.Interrupt_Management can only
+-- be used for tasking systems.
+
+-- PLEASE DO NOT put any subprogram declarations with arguments of
+-- type Interrupt_ID into the visible part of this package. The type
+-- Interrupt_ID is used to derive the type in Ada.Interrupts, and
+-- adding more operations to that type would be illegal according
+-- to the Ada Reference Manual. This is the reason why the signals
+-- sets are implemented using visible arrays rather than functions.
+
+with System.OS_Interface;
+
+with Interfaces.C;
+
+package System.Interrupt_Management is
+ pragma Preelaborate;
+
+ type Interrupt_Mask is limited private;
+
+ type Interrupt_ID is new Interfaces.C.int
+ range 0 .. System.OS_Interface.Max_Interrupt;
+
+ type Interrupt_Set is array (Interrupt_ID) of Boolean;
+
+ subtype Signal_ID is Interrupt_ID range 0 .. System.OS_Interface.NSIG - 1;
+
+ type Signal_Set is array (Signal_ID) of Boolean;
+
+ -- The following objects serve as constants, but are initialized in the
+ -- body to aid portability. This permits us to use more portable names for
+ -- interrupts, where distinct names may map to the same interrupt ID
+ -- value.
+
+ -- For example, suppose SIGRARE is a signal that is not defined on all
+ -- systems, but is always reserved when it is defined. If we have the
+ -- convention that ID zero is not used for any "real" signals, and SIGRARE
+ -- = 0 when SIGRARE is not one of the locally supported signals, we can
+ -- write:
+ -- Reserved (SIGRARE) := True;
+ -- and the initialization code will be portable.
+
+ Abort_Task_Interrupt : Signal_ID;
+ -- The signal that is used to implement task abort if an interrupt is used
+ -- for that purpose. This is one of the reserved signals.
+
+ Reserve : Interrupt_Set := (others => False);
+ -- Reserve (I) is true iff the interrupt I is one that cannot be permitted
+ -- to be attached to a user handler. The possible reasons are many. For
+ -- example, it may be mapped to an exception used to implement task abort,
+ -- or used to implement time delays.
+
+ procedure Initialize;
+ -- Initialize the various variables defined in this package. This procedure
+ -- must be called before accessing any object from this package and can be
+ -- called multiple times (only the first call has any effect).
+
+private
+ type Interrupt_Mask is new System.OS_Interface.sigset_t;
+ -- In some implementation Interrupt_Mask can be represented as a linked
+ -- list.
+
+end System.Interrupt_Management;
diff --git a/gcc/ada/libgnarl/s-osinte__rtems.adb b/gcc/ada/libgnarl/s-osinte__rtems.adb
index cd977d0e403..96883afcf25 100644
--- a/gcc/ada/libgnarl/s-osinte__rtems.adb
+++ b/gcc/ada/libgnarl/s-osinte__rtems.adb
@@ -44,6 +44,54 @@ with Interfaces.C; use Interfaces.C;
package body System.OS_Interface is
+ ---------------
+ -- RTEMS API --
+ ---------------
+
+ type RTEMS_Attributes is new unsigned;
+
+ RTEMS_SIMPLE_BINARY_SEMAPHORE : constant := 16#00000020#;
+ RTEMS_FIFO : constant := 16#00000000#;
+
+ type RTEMS_Interval is new unsigned;
+
+ RTEMS_NO_TIMEOUT : constant := 0;
+
+ type RTEMS_Options is new unsigned;
+
+ RTEMS_WAIT : constant := 16#00000000#;
+ RTEMS_INTERRUPT_UNIQUE : constant := 16#00000001#;
+
+ type RTEMS_Name is new unsigned;
+
+ function RTEMS_Build_Name (C1, C2, C3, C4 : Character) return RTEMS_Name
+ with Import, External_Name => "rtems_build_name", Convention => C;
+
+ function RTEMS_Semaphore_Create
+ (Name : RTEMS_Name;
+ Count : unsigned;
+ Attributes : RTEMS_Attributes;
+ Priority_Ceiling : unsigned;
+ Semaphore : out Binary_Semaphore_Id) return int
+ with Import, External_Name => "rtems_semaphore_create", Convention => C;
+
+ function RTEMS_Semaphore_Delete (Semaphore : Binary_Semaphore_Id) return int
+ with Import, External_Name => "rtems_semaphore_delete", Convention => C;
+
+ function RTEMS_Semaphore_Flush (Semaphore : Binary_Semaphore_Id)
+ return int
+ with Import, External_Name => "rtems_semaphore_flush", Convention => C;
+
+ function RTEMS_Semaphore_Obtain
+ (Semaphore : Binary_Semaphore_Id;
+ Options : RTEMS_Options;
+ Timeout : RTEMS_Interval) return int
+ with Import, External_Name => "rtems_semaphore_obtain", Convention => C;
+
+ function RTEMS_Semaphore_Release (Semaphore : Binary_Semaphore_Id)
+ return int
+ with Import, External_Name => "rtems_semaphore_release", Convention => C;
+
-----------------
-- To_Duration --
-----------------
@@ -85,6 +133,108 @@ package body System.OS_Interface is
tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
end To_Timespec;
+ -----------------------------
+ -- Binary_Semaphore_Create --
+ -----------------------------
+
+ function Binary_Semaphore_Create return Binary_Semaphore_Id is
+ Semaphore : Binary_Semaphore_Id;
+ Status : int;
+ begin
+ Status :=
+ RTEMS_Semaphore_Create
+ (Name => RTEMS_Build_Name ('G', 'N', 'A', 'T'),
+ Count => 0,
+ Attributes => RTEMS_SIMPLE_BINARY_SEMAPHORE or RTEMS_FIFO,
+ Priority_Ceiling => 0,
+ Semaphore => Semaphore);
+
+ pragma Assert (Status = 0);
+
+ return Semaphore;
+ end Binary_Semaphore_Create;
+
+ -----------------------------
+ -- Binary_Semaphore_Delete --
+ -----------------------------
+
+ function Binary_Semaphore_Delete (ID : Binary_Semaphore_Id)
+ return int is
+ begin
+ return RTEMS_Semaphore_Delete (ID);
+ end Binary_Semaphore_Delete;
+
+ -----------------------------
+ -- Binary_Semaphore_Obtain --
+ -----------------------------
+
+ function Binary_Semaphore_Obtain (ID : Binary_Semaphore_Id)
+ return int is
+ begin
+ return RTEMS_Semaphore_Obtain (ID, RTEMS_WAIT, RTEMS_NO_TIMEOUT);
+ end Binary_Semaphore_Obtain;
+
+ ------------------------------
+ -- Binary_Semaphore_Release --
+ ------------------------------
+
+ function Binary_Semaphore_Release (ID : Binary_Semaphore_Id)
+ return int is
+ begin
+ return RTEMS_Semaphore_Release (ID);
+ end Binary_Semaphore_Release;
+
+ ----------------------------
+ -- Binary_Semaphore_Flush --
+ ----------------------------
+
+ function Binary_Semaphore_Flush (ID : Binary_Semaphore_Id) return int is
+ begin
+ return RTEMS_Semaphore_Flush (ID);
+ end Binary_Semaphore_Flush;
+
+ -----------------------
+ -- Interrupt_Connect --
+ -----------------------
+
+ function Interrupt_Connect
+ (Vector : Interrupt_Vector;
+ Handler : Interrupt_Handler;
+ Parameter : System.Address := System.Null_Address) return int
+ is
+ function RTEMS_Interrupt_Handler_Install
+ (Vector : Interrupt_Vector;
+ Info : char_array;
+ Options : RTEMS_Options;
+ Handler : Interrupt_Handler;
+ Parameter : System.Address) return int
+ with Import,
+ External_Name => "rtems_interrupt_handler_install",
+ Convention => C;
+
+ Info_String : constant char_array := To_C ("GNAT Interrupt Handler");
+ -- Handler name that is registered with RTEMS
+ begin
+ return
+ RTEMS_Interrupt_Handler_Install
+ (Vector => Vector,
+ Info => Info_String,
+ Options => RTEMS_INTERRUPT_UNIQUE,
+ Handler => Handler,
+ Parameter => Parameter);
+ end Interrupt_Connect;
+
+ --------------------------------
+ -- Interrupt_Number_To_Vector --
+ --------------------------------
+
+ function Interrupt_Number_To_Vector (intNum : int)
+ return Interrupt_Vector
+ is
+ begin
+ return Interrupt_Vector (intNum);
+ end Interrupt_Number_To_Vector;
+
------------------
-- pthread_init --
------------------
diff --git a/gcc/ada/libgnarl/s-osinte__rtems.ads b/gcc/ada/libgnarl/s-osinte__rtems.ads
index ffbfc3aa6fb..5743a6aa468 100644
--- a/gcc/ada/libgnarl/s-osinte__rtems.ads
+++ b/gcc/ada/libgnarl/s-osinte__rtems.ads
@@ -85,18 +85,20 @@ package System.OS_Interface is
ENOMEM : constant := System.OS_Constants.ENOMEM;
ETIMEDOUT : constant := System.OS_Constants.ETIMEDOUT;
- -------------
- -- Signals --
- -------------
+ ----------------------------
+ -- Signals and Interrupts --
+ ----------------------------
- Num_HW_Interrupts : constant := 256;
+ NSIG : constant := 64;
+ -- Number of signals on the target OS
+ type Signal is new int range 0 .. Interfaces.C."-" (NSIG, 1);
- Max_HW_Interrupt : constant := Num_HW_Interrupts - 1;
+ Max_HW_Interrupt : constant := 255;
type HW_Interrupt is new int range 0 .. Max_HW_Interrupt;
Max_Interrupt : constant := Max_HW_Interrupt;
-
- type Signal is new int range 0 .. Max_Interrupt;
+ subtype Interrupt_Range is Natural range 0 .. Max_HW_Interrupt;
+ -- For s-interr
SIGXCPU : constant := 0; -- XCPU
SIGHUP : constant := 1; -- hangup
@@ -546,34 +548,19 @@ package System.OS_Interface is
type Binary_Semaphore_Id is new rtems_id;
function Binary_Semaphore_Create return Binary_Semaphore_Id;
- pragma Import (
- C,
- Binary_Semaphore_Create,
- "__gnat_binary_semaphore_create");
+ pragma Inline (Binary_Semaphore_Create);
function Binary_Semaphore_Delete (ID : Binary_Semaphore_Id) return int;
- pragma Import (
- C,
- Binary_Semaphore_Delete,
- "__gnat_binary_semaphore_delete");
+ pragma Inline (Binary_Semaphore_Delete);
function Binary_Semaphore_Obtain (ID : Binary_Semaphore_Id) return int;
- pragma Import (
- C,
- Binary_Semaphore_Obtain,
- "__gnat_binary_semaphore_obtain");
+ pragma Inline (Binary_Semaphore_Obtain);
function Binary_Semaphore_Release (ID : Binary_Semaphore_Id) return int;
- pragma Import (
- C,
- Binary_Semaphore_Release,
- "__gnat_binary_semaphore_release");
+ pragma Inline (Binary_Semaphore_Release);
function Binary_Semaphore_Flush (ID : Binary_Semaphore_Id) return int;
- pragma Import (
- C,
- Binary_Semaphore_Flush,
- "__gnat_binary_semaphore_flush");
+ pragma Inline (Binary_Semaphore_Flush);
------------------------------------------------------------
-- Hardware Interrupt Wrappers to Support Interrupt Tasks --
@@ -581,36 +568,20 @@ package System.OS_Interface is
type Interrupt_Handler is access procedure (parameter : System.Address);
pragma Convention (C, Interrupt_Handler);
+
type Interrupt_Vector is new System.Address;
function Interrupt_Connect
- (vector : Interrupt_Vector;
- handler : Interrupt_Handler;
- parameter : System.Address := System.Null_Address) return int;
- pragma Import (C, Interrupt_Connect, "__gnat_interrupt_connect");
+ (Vector : Interrupt_Vector;
+ Handler : Interrupt_Handler;
+ Parameter : System.Address := System.Null_Address) return int;
-- Use this to set up an user handler. The routine installs a
-- a user handler which is invoked after RTEMS has saved enough
-- context for a high-level language routine to be safely invoked.
- function Interrupt_Vector_Get
- (Vector : Interrupt_Vector) return Interrupt_Handler;
- pragma Import (C, Interrupt_Vector_Get, "__gnat_interrupt_get");
- -- Use this to get the existing handler for later restoral.
-
- procedure Interrupt_Vector_Set
- (Vector : Interrupt_Vector;
- Handler : Interrupt_Handler);
- pragma Import (C, Interrupt_Vector_Set, "__gnat_interrupt_set");
- -- Use this to restore a handler obtained using Interrupt_Vector_Get.
-
function Interrupt_Number_To_Vector (intNum : int) return Interrupt_Vector;
-- Convert a logical interrupt number to the hardware interrupt vector
-- number used to connect the interrupt.
- pragma Import (
- C,
- Interrupt_Number_To_Vector,
- "__gnat_interrupt_number_to_vector"
- );
private
diff --git a/gcc/ada/libgnarl/s-taprop__rtems.adb b/gcc/ada/libgnarl/s-taprop__rtems.adb
new file mode 100644
index 00000000000..9153032337f
--- /dev/null
+++ b/gcc/ada/libgnarl/s-taprop__rtems.adb
@@ -0,0 +1,1347 @@
+------------------------------------------------------------------------------
+-- --
+-- 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-2021, 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the RTEMS version of this package
+
+-- This package contains all the GNULL primitives that interface directly with
+-- the underlying OS.
+
+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 to protect All_Tasks_List
+
+ Environment_Task_Id : Task_Id;
+ -- A variable to hold Task_Id for the environment task
+
+ Locking_Policy : constant Character;
+ pragma Import (C, Locking_Policy, "__gl_locking_policy");
+ -- Value of the pragma Locking_Policy:
+ -- 'C' for Ceiling_Locking
+ -- 'I' for Inherit_Locking
+ -- ' ' for none.
+
+ -- The followings are internal configuration constants needed
+
+ Next_Serial_Number : Task_Serial_Number := 100;
+ -- We start at 100, to reserve some special values for
+ -- using in error checking.
+
+ Time_Slice_Val : constant Integer;
+ pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
+
+ Dispatching_Policy : constant Character;
+ pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_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
+
+ package Monotonic is
+
+ function Monotonic_Clock return Duration;
+ pragma Inline (Monotonic_Clock);
+ -- Returns an absolute time, represented as an offset relative to some
+ -- unspecified starting point, typically system boot time. This clock
+ -- is not affected by discontinuous jumps in the system time.
+
+ function RT_Resolution return Duration;
+ pragma Inline (RT_Resolution);
+ -- Returns resolution of the underlying clock used to implement RT_Clock
+
+ procedure Timed_Sleep
+ (Self_ID : ST.Task_Id;
+ Time : Duration;
+ Mode : ST.Delay_Modes;
+ Reason : System.Tasking.Task_States;
+ Timedout : out Boolean;
+ Yielded : out Boolean);
+ -- Combination of Sleep (above) and Timed_Delay
+
+ procedure Timed_Delay
+ (Self_ID : ST.Task_Id;
+ Time : Duration;
+ Mode : ST.Delay_Modes);
+ -- Implement the semantics of the delay statement.
+ -- The caller should be abort-deferred and should not hold any locks.
+
+ end Monotonic;
+
+ package body Monotonic is separate;
+
+ ----------------------------------
+ -- 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");
+
+ -------------------
+ -- 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;
+ Unblocked_Mask : 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 := sigemptyset (Unblocked_Mask'Access);
+ pragma Assert (Result = 0);
+ Result :=
+ sigaddset
+ (Unblocked_Mask'Access,
+ Signal (Interrupt_Management.Abort_Task_Interrupt));
+ pragma Assert (Result = 0);
+ Result := sigaddset (Unblocked_Mask'Access, SIGBUS);
+ pragma Assert (Result = 0);
+ Result := sigaddset (Unblocked_Mask'Access, SIGFPE);
+ pragma Assert (Result = 0);
+ Result := sigaddset (Unblocked_Mask'Access, SIGILL);
+ pragma Assert (Result = 0);
+ Result := sigaddset (Unblocked_Mask'Access, SIGSEGV);
+ pragma Assert (Result = 0);
+
+ Result :=
+ pthread_sigmask
+ (SIG_UNBLOCK,
+ Unblocked_Mask'Access,
+ Old_Set'Access);
+ pragma Assert (Result = 0);
+
+ raise Standard'Abort_Signal;
+ end if;
+ end Abort_Handler;
+
+ -----------------
+ -- 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) is
+ Result : Interfaces.C.int;
+ begin
+ Result := pthread_mutex_lock (L);
+ pragma Assert (Result = 0);
+ end Write_Lock;
+
+ procedure Write_Lock (T : Task_Id) is
+ Result : Interfaces.C.int;
+ begin
+ Result := pthread_mutex_lock (T.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ 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) is
+ Result : Interfaces.C.int;
+ begin
+ Result := pthread_mutex_unlock (L);
+ pragma Assert (Result = 0);
+ end Unlock;
+
+ procedure Unlock (T : Task_Id) is
+ Result : Interfaces.C.int;
+ begin
+ Result := pthread_mutex_unlock (T.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ 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 => 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) renames Monotonic.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) renames Monotonic.Timed_Delay;
+
+ ---------------------
+ -- Monotonic_Clock --
+ ---------------------
+
+ function Monotonic_Clock return Duration renames Monotonic.Monotonic_Clock;
+
+ -------------------
+ -- RT_Resolution --
+ -------------------
+
+ function RT_Resolution return Duration renames Monotonic.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);
+
+ 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);
+
+ 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
+ Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ 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
+ Result := pthread_mutex_destroy (T.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+
+ 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);
+ end Lock_RTS;
+
+ ----------------
+ -- Unlock_RTS --
+ ----------------
+
+ procedure Unlock_RTS is
+ begin
+ Unlock (Single_RTS_Lock'Access);
+ end Unlock_RTS;
+
+ ------------------
+ -- Suspend_Task --
+ ------------------
+
+ function Suspend_Task
+ (T : ST.Task_Id;
+ Thread_Self : Thread_Id) return Boolean
+ is
+ pragma Unreferenced (T, Thread_Self);
+ begin
+ return False;
+ end Suspend_Task;
+
+ -----------------
+ -- Resume_Task --
+ -----------------
+
+ function Resume_Task
+ (T : ST.Task_Id;
+ Thread_Self : Thread_Id) return Boolean
+ is
+ pragma Unreferenced (T, Thread_Self);
+ begin
+ return False;
+ 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;
+
+ -- 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;
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2021-10-11 13:39 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2021-10-11 13:39 [gcc r12-4303] [Ada] RTEMS: use hardware interrupts instead of signals for interrupt handling Pierre-Marie de Rodat
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).